FS/FS/cust_pkg.pm

   1 package FS::cust_pkg;
   2 use base qw( FS::cust_pkg::Search FS::cust_pkg::API
   3              FS::otaker_Mixin FS::cust_main_Mixin FS::Sales_Mixin
   4              FS::contact_Mixin FS::location_Mixin
   5              FS::m2m_Common FS::option_Common
   6            );
   7
   8 use strict;
   9 use Carp qw(cluck);
  10 use Scalar::Util qw( blessed );
  11 use List::Util qw(min max);
  12 use Tie::IxHash;
  13 use Time::Local qw( timelocal timelocal_nocheck );
  14 use MIME::Entity;
  15 use FS::UID qw( dbh driver_name );
  16 use FS::Misc qw( send_email );
  17 use FS::Record qw( qsearch qsearchs fields );
  18 use FS::CurrentUser;
  19 use FS::cust_svc;
  20 use FS::part_pkg;
  21 use FS::cust_main;
  22 use FS::contact;
  23 use FS::cust_location;
  24 use FS::pkg_svc;
  25 use FS::cust_bill_pkg;
  26 use FS::cust_pkg_detail;
  27 use FS::cust_pkg_usage;
  28 use FS::cdr_cust_pkg_usage;
  29 use FS::cust_event;
  30 use FS::h_cust_svc;
  31 use FS::reg_code;
  32 use FS::part_svc;
  33 use FS::cust_pkg_reason;
  34 use FS::reason;
  35 use FS::cust_pkg_usageprice;
  36 use FS::cust_pkg_discount;
  37 use FS::discount;
  38 use FS::sales;
  39 # for modify_charge
  40 use FS::cust_credit;
  41
  42 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
  43 # setup }
  44 # because they load configuration by setting FS::UID::callback (see TODO)
  45 use FS::svc_acct;
  46 use FS::svc_domain;
  47 use FS::svc_www;
  48 use FS::svc_forward;
  49
  50 # for sending cancel emails in sub cancel
  51 use FS::Conf;
  52
  53 our ($disable_agentcheck, $DEBUG, $me, $import) = (0, 0, '[FS::cust_pkg]', 0);
  54
  55 our $upgrade = 0; #go away after setup+start dates cleaned up for old customers
  56
  57 sub _cache {
  58   my $self = shift;
  59   my ( $hashref, $cache ) = @_;
  60   #if ( $hashref->{'pkgpart'} ) {
  61   if ( $hashref->{'pkg'} ) {
  62     # #@{ $self->{'_pkgnum'} } = ();
  63     # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
  64     # $self->{'_pkgpart'} = $subcache;
  65     # #push @{ $self->{'_pkgnum'} },
  66     #   FS::part_pkg->new_or_cached($hashref, $subcache);
  67     $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
  68   }
  69   if ( exists $hashref->{'svcnum'} ) {
  70     #@{ $self->{'_pkgnum'} } = ();
  71     my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
  72     $self->{'_svcnum'} = $subcache;
  73     #push @{ $self->{'_pkgnum'} },
  74     FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
  75   }
  76 }
  77
  78 =head1 NAME
  79
  80 FS::cust_pkg - Object methods for cust_pkg objects
  81
  82 =head1 SYNOPSIS
  83
  84   use FS::cust_pkg;
  85
  86   $record = new FS::cust_pkg \%hash;
  87   $record = new FS::cust_pkg { 'column' => 'value' };
  88
  89   $error = $record->insert;
  90
  91   $error = $new_record->replace($old_record);
  92
  93   $error = $record->delete;
  94
  95   $error = $record->check;
  96
  97   $error = $record->cancel;
  98
  99   $error = $record->suspend;
 100
 101   $error = $record->unsuspend;
 102
 103   $part_pkg = $record->part_pkg;
 104
 105   @labels = $record->labels;
 106
 107   $seconds = $record->seconds_since($timestamp);
 108
 109   #bulk cancel+order... perhaps slightly deprecated, only used by the bulk
 110   # cancel+order in the web UI and nowhere else (edit/process/cust_pkg.cgi)
 111   $error = FS::cust_pkg::order( $custnum, \@pkgparts );
 112   $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
 113
 114 =head1 DESCRIPTION
 115
 116 An FS::cust_pkg object represents a customer billing item.  FS::cust_pkg
 117 inherits from FS::Record.  The following fields are currently supported:
 118
 119 =over 4
 120
 121 =item pkgnum
 122
 123 Primary key (assigned automatically for new billing items)
 124
 125 =item custnum
 126
 127 Customer (see L<FS::cust_main>)
 128
 129 =item pkgpart
 130
 131 Billing item definition (see L<FS::part_pkg>)
 132
 133 =item locationnum
 134
 135 Optional link to package location (see L<FS::location>)
 136
 137 =item order_date
 138
 139 date package was ordered (also remains same on changes)
 140
 141 =item start_date
 142
 143 date
 144
 145 =item setup
 146
 147 date
 148
 149 =item bill
 150
 151 date (next bill date)
 152
 153 =item last_bill
 154
 155 last bill date
 156
 157 =item adjourn
 158
 159 date
 160
 161 =item susp
 162
 163 date
 164
 165 =item expire
 166
 167 date
 168
 169 =item contract_end
 170
 171 date
 172
 173 =item cancel
 174
 175 date
 176
 177 =item usernum
 178
 179 order taker (see L<FS::access_user>)
 180
 181 =item manual_flag
 182
 183 If this field is set to 1, disables the automatic
 184 unsuspension of this package when using the B<unsuspendauto> config option.
 185
 186 =item quantity
 187
 188 If not set, defaults to 1
 189
 190 =item change_date
 191
 192 Date of change from previous package
 193
 194 =item change_pkgnum
 195
 196 Previous pkgnum
 197
 198 =item change_pkgpart
 199
 200 Previous pkgpart
 201
 202 =item change_locationnum
 203
 204 Previous locationnum
 205
 206 =item waive_setup
 207
 208 =item main_pkgnum
 209
 210 The pkgnum of the package that this package is supplemental to, if any.
 211
 212 =item pkglinknum
 213
 214 The package link (L<FS::part_pkg_link>) that defines this supplemental
 215 package, if it is one.
 216
 217 =item change_to_pkgnum
 218
 219 The pkgnum of the package this one will be "changed to" in the future
 220 (on its expiration date).
 221
 222 =back
 223
 224 Note: setup, last_bill, bill, adjourn, susp, expire, cancel and change_date
 225 are specified as UNIX timestamps; see L<perlfunc/"time">.  Also see
 226 L<Time::Local> and L<Date::Parse> for conversion functions.
 227
 228 =head1 METHODS
 229
 230 =over 4
 231
 232 =item new HASHREF
 233
 234 Create a new billing item.  To add the item to the database, see L<"insert">.
 235
 236 =cut
 237
 238 sub table { 'cust_pkg'; }
 239 sub cust_linked { $_[0]->cust_main_custnum || $_[0]->custnum }
 240 sub cust_unlinked_msg {
 241   my $self = shift;
 242   "WARNING: can't find cust_main.custnum ". $self->custnum.
 243   ' (cust_pkg.pkgnum '. $self->pkgnum. ')';
 244 }
 245
 246 =item set_initial_timers
 247
 248 If required by the package definition, sets any automatic expire, adjourn,
 249 or contract_end timers to some number of months after the start date
 250 (or setup date, if the package has already been setup). If the package has
 251 a delayed setup fee after a period of "free days", will also set the
 252 start date to the end of that period.
 253
 254 If the package has an automatic transfer rule (C<change_to_pkgnum>), then
 255 this will also order the package and set its start date.
 256
 257 =cut
 258
 259 sub set_initial_timers {
 260   my $self = shift;
 261   my $part_pkg = $self->part_pkg;
 262   my $start = $self->start_date || $self->setup || time;
 263
 264   foreach my $action ( qw(expire adjourn contract_end) ) {
 265     my $months = $part_pkg->get("${action}_months");
 266     if($months and !$self->get($action)) {
 267       $self->set($action, $part_pkg->add_freq($start, $months) );
 268     }
 269   }
 270
 271   # if this package has an expire date and a change_to_pkgpart, set automatic
 272   # package transfer
 273   # (but don't call change_later, as that would call $self->replace, and we're
 274   # probably in the middle of $self->insert right now)
 275   if ( $part_pkg->expire_months and $part_pkg->change_to_pkgpart ) {
 276     if ( $self->change_to_pkgnum ) {
 277       # this can happen if a package is ordered on hold, scheduled for a
 278       # future change _while on hold_, and then released from hold, causing
 279       # the automatic transfer to schedule.
 280       #
 281       # what's correct behavior in that case? I think it's to disallow
 282       # future-changing an on-hold package that has an automatic transfer.
 283       # but if we DO get into this situation, let the manual package change
 284       # win.
 285       warn "pkgnum ".$self->pkgnum.": manual future package change blocks ".
 286            "automatic transfer.\n";
 287     } else {
 288       my $change_to = FS::cust_pkg->new( {
 289           start_date  => $self->get('expire'),
 290           pkgpart     => $part_pkg->change_to_pkgpart,
 291           map { $_ => $self->get($_) }
 292             qw( custnum locationnum quantity refnum salesnum contract_end )
 293       } );
 294       my $error = $change_to->insert;
 295
 296       return $error if $error;
 297       $self->set('change_to_pkgnum', $change_to->pkgnum);
 298     }
 299   }
 300
 301   # if this package has "free days" and delayed setup fee, then
 302   # set start date that many days in the future.
 303   # (this should have been set in the UI, but enforce it here)
 304   if ( $part_pkg->option('free_days',1)
 305        && $part_pkg->option('delay_setup',1)
 306      )
 307   {
 308     $self->start_date( $part_pkg->default_start_date );
 309   }
 310
 311   '';
 312 }
 313
 314 =item insert [ OPTION => VALUE ... ]
 315
 316 Adds this billing item to the database ("Orders" the item).  If there is an
 317 error, returns the error, otherwise returns false.
 318
 319 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
 320 will be used to look up the package definition and agent restrictions will be
 321 ignored.
 322
 323 If the additional field I<refnum> is defined, an FS::pkg_referral record will
 324 be created and inserted.  Multiple FS::pkg_referral records can be created by
 325 setting I<refnum> to an array reference of refnums or a hash reference with
 326 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
 327 record will be created corresponding to cust_main.refnum.
 328
 329 If the additional field I<cust_pkg_usageprice> is defined, it will be treated
 330 as an arrayref of FS::cust_pkg_usageprice objects, which will be inserted.
 331 (Note that this field cannot be set with a usual ->cust_pkg_usageprice method.
 332 It can be set as part of the hash when creating the object, or with the B<set>
 333 method.)
 334
 335 The following options are available:
 336
 337 =over 4
 338
 339 =item change
 340
 341 If set true, supresses actions that should only be taken for new package
 342 orders.  (Currently this includes: intro periods when delay_setup is on,
 343 auto-adding a 1st start date, auto-adding expiration/adjourn/contract_end dates)
 344
 345 =item options
 346
 347 cust_pkg_option records will be created
 348
 349 =item ticket_subject
 350
 351 a ticket will be added to this customer with this subject
 352
 353 =item ticket_queue
 354
 355 an optional queue name for ticket additions
 356
 357 =item allow_pkgpart
 358
 359 Don't check the legality of the package definition.  This should be used
 360 when performing a package change that doesn't change the pkgpart (i.e.
 361 a location change).
 362
 363 =back
 364
 365 =cut
 366
 367 sub insert {
 368   my( $self, %options ) = @_;
 369
 370   my $oldAutoCommit = $FS::UID::AutoCommit;
 371   local $FS::UID::AutoCommit = 0;
 372   my $dbh = dbh;
 373
 374   my $error;
 375   $error = $self->check_pkgpart unless $options{'allow_pkgpart'};
 376
 377   my $part_pkg = $self->part_pkg;
 378
 379   if ( ! $import && ! $options{'change'} ) {
 380
 381     # set order date to now
 382     $self->order_date(time) unless ($import && $self->order_date);
 383
 384     # if the package def says to start only on the first of the month:
 385     if ( $part_pkg->option('start_1st', 1) && !$self->start_date ) {
 386       my ($sec,$min,$hour,$mday,$mon,$year) = (localtime(time) )[0,1,2,3,4,5];
 387       $mon += 1 unless $mday == 1;
 388       until ( $mon < 12 ) { $mon -= 12; $year++; }
 389       $self->start_date( timelocal_nocheck(0,0,0,1,$mon,$year) );
 390     }
 391
 392     if ($self->susp eq 'now' or $part_pkg->start_on_hold) {
 393       # if the package was ordered on hold:
 394       # - suspend it
 395       # - don't set the start date (it will be started manually)
 396       $self->set('susp', $self->order_date);
 397       $self->set('start_date', '');
 398     } else {
 399       # set expire/adjourn/contract_end timers, and free days, if appropriate
 400       # and automatic package transfer, which can fail, so capture the result
 401       $error = $self->set_initial_timers;
 402     }
 403   } # else this is a package change, and shouldn't have "new package" behavior
 404
 405   $error ||= $self->SUPER::insert($options{options} ? %{$options{options}} : ());
 406   if ( $error ) {
 407     $dbh->rollback if $oldAutoCommit;
 408     return $error;
 409   }
 410
 411   $self->refnum($self->cust_main->refnum) unless $self->refnum;
 412   $self->refnum( [ $self->refnum ] ) unless ref($self->refnum);
 413   $self->process_m2m( 'link_table'   => 'pkg_referral',
 414                       'target_table' => 'part_referral',
 415                       'params'       => $self->refnum,
 416                     );
 417
 418   if ( $self->hashref->{cust_pkg_usageprice} ) {
 419     for my $cust_pkg_usageprice ( @{ $self->hashref->{cust_pkg_usageprice} } ) {
 420       $cust_pkg_usageprice->pkgnum( $self->pkgnum );
 421       my $error = $cust_pkg_usageprice->insert;
 422       if ( $error ) {
 423         $dbh->rollback if $oldAutoCommit;
 424         return $error;
 425       }
 426     }
 427   }
 428
 429   if ( $self->discountnum ) {
 430     my $error = $self->insert_discount();
 431     if ( $error ) {
 432       $dbh->rollback if $oldAutoCommit;
 433       return $error;
 434     }
 435   }
 436
 437   my $conf = new FS::Conf;
 438
 439   if ( ! $import && $conf->config('ticket_system') && $options{ticket_subject} ) {
 440
 441     #this init stuff is still inefficient, but at least its limited to
 442     # the small number (any?) folks using ticket emailing on pkg order
 443
 444     #eval '
 445     #  use lib ( "/opt/rt3/local/lib", "/opt/rt3/lib" );
 446     #  use RT;
 447     #';
 448     #die $@ if $@;
 449     #
 450     #RT::LoadConfig();
 451     #RT::Init();
 452     use FS::TicketSystem;
 453     FS::TicketSystem->init();
 454
 455     my $q = new RT::Queue($RT::SystemUser);
 456     $q->Load($options{ticket_queue}) if $options{ticket_queue};
 457     my $t = new RT::Ticket($RT::SystemUser);
 458     my $mime = new MIME::Entity;
 459     $mime->build( Type => 'text/plain', Data => $options{ticket_subject} );
 460     $t->Create( $options{ticket_queue} ? (Queue => $q) : (),
 461                 Subject => $options{ticket_subject},
 462                 MIMEObj => $mime,
 463               );
 464     $t->AddLink( Type   => 'MemberOf',
 465                  Target => 'freeside://freeside/cust_main/'. $self->custnum,
 466                );
 467   }
 468
 469   if (! $import && $conf->config('welcome_letter') && $self->cust_main->num_pkgs == 1) {
 470     my $queue = new FS::queue {
 471       'job'     => 'FS::cust_main::queueable_print',
 472     };
 473     $error = $queue->insert(
 474       'custnum'  => $self->custnum,
 475       'template' => 'welcome_letter',
 476     );
 477
 478     if ($error) {
 479       warn "can't send welcome letter: $error";
 480     }
 481
 482   }
 483
 484   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 485   '';
 486
 487 }
 488
 489 =item delete
 490
 491 This method now works but you probably shouldn't use it.
 492
 493 You don't want to delete packages, because there would then be no record
 494 the customer ever purchased the package.  Instead, see the cancel method and
 495 hide cancelled packages.
 496
 497 =cut
 498
 499 # this is still used internally to abort future package changes, so it
 500 # does need to work
 501
 502 sub delete {
 503   my $self = shift;
 504
 505   # The following foreign keys to cust_pkg are not cleaned up here, and will
 506   # cause package deletion to fail:
 507   #
 508   # cust_credit.pkgnum and commission_pkgnum (and cust_credit_void)
 509   # cust_credit_bill.pkgnum
 510   # cust_pay_pending.pkgnum
 511   # cust_pay.pkgnum (and cust_pay_void)
 512   # cust_bill_pay.pkgnum (wtf, shouldn't reference pkgnum)
 513   # cust_pkg_usage.pkgnum
 514   # cust_pkg.uncancel_pkgnum, change_pkgnum, main_pkgnum, and change_to_pkgnum
 515
 516   # cust_svc is handled by canceling the package before deleting it
 517   # cust_pkg_option is handled via option_Common
 518
 519   my $oldAutoCommit = $FS::UID::AutoCommit;
 520   local $FS::UID::AutoCommit = 0;
 521   my $dbh = dbh;
 522
 523   foreach my $cust_pkg_discount ($self->cust_pkg_discount) {
 524     my $error = $cust_pkg_discount->delete;
 525     if ( $error ) {
 526       $dbh->rollback if $oldAutoCommit;
 527       return $error;
 528     }
 529   }
 530   #cust_bill_pkg_discount?
 531
 532   foreach my $cust_pkg_detail ($self->cust_pkg_detail) {
 533     my $error = $cust_pkg_detail->delete;
 534     if ( $error ) {
 535       $dbh->rollback if $oldAutoCommit;
 536       return $error;
 537     }
 538   }
 539
 540   foreach my $cust_pkg_reason (
 541     qsearchs( {
 542                 'table' => 'cust_pkg_reason',
 543                 'hashref' => { 'pkgnum' => $self->pkgnum },
 544               }
 545             )
 546   ) {
 547     my $error = $cust_pkg_reason->delete;
 548     if ( $error ) {
 549       $dbh->rollback if $oldAutoCommit;
 550       return $error;
 551     }
 552   }
 553
 554   foreach my $pkg_referral ( $self->pkg_referral ) {
 555     my $error = $pkg_referral->delete;
 556     if ( $error ) {
 557       $dbh->rollback if $oldAutoCommit;
 558       return $error;
 559     }
 560   }
 561
 562   my $error = $self->SUPER::delete(@_);
 563   if ( $error ) {
 564     $dbh->rollback if $oldAutoCommit;
 565     return $error;
 566   }
 567
 568   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 569
 570   '';
 571
 572 }
 573
 574 =item replace [ OLD_RECORD ] [ HASHREF | OPTION => VALUE ... ]
 575
 576 Replaces the OLD_RECORD with this one in the database.  If there is an error,
 577 returns the error, otherwise returns false.
 578
 579 Currently, custnum, setup, bill, adjourn, susp, expire, and cancel may be changed.
 580
 581 Changing pkgpart may have disasterous effects.  See the order subroutine.
 582
 583 setup and bill are normally updated by calling the bill method of a customer
 584 object (see L<FS::cust_main>).
 585
 586 suspend is normally updated by the suspend and unsuspend methods.
 587
 588 cancel is normally updated by the cancel method (and also the order subroutine
 589 in some cases).
 590
 591 Available options are:
 592
 593 =over 4
 594
 595 =item reason
 596
 597 can be set to a cancellation reason (see L<FS:reason>), either a reasonnum of an existing reason, or passing a hashref will create a new reason.  The hashref should have the following keys: typenum - Reason type (see L<FS::reason_type>, reason - Text of the new reason.
 598
 599 =item reason_otaker
 600
 601 the access_user (see L<FS::access_user>) providing the reason
 602
 603 =item options
 604
 605 hashref of keys and values - cust_pkg_option records will be created, updated or removed as appopriate
 606
 607 =back
 608
 609 =cut
 610
 611 sub replace {
 612   my $new = shift;
 613
 614   my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
 615               ? shift
 616               : $new->replace_old;
 617
 618   my $options =
 619     ( ref($_[0]) eq 'HASH' )
 620       ? shift
 621       : { @_ };
 622
 623   #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
 624   #return "Can't change otaker!" if $old->otaker ne $new->otaker;
 625
 626   #allow this *sigh*
 627   #return "Can't change setup once it exists!"
 628   #  if $old->getfield('setup') &&
 629   #     $old->getfield('setup') != $new->getfield('setup');
 630
 631   #some logic for bill, susp, cancel?
 632
 633   local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
 634
 635   my $oldAutoCommit = $FS::UID::AutoCommit;
 636   local $FS::UID::AutoCommit = 0;
 637   my $dbh = dbh;
 638
 639   foreach my $method ( qw(adjourn expire) ) {  # How many reasons?
 640     if ($options->{'reason'} && $new->$method && $old->$method ne $new->$method) {
 641       my $error = $new->insert_reason(
 642         'reason'        => $options->{'reason'},
 643         'date'          => $new->$method,
 644         'action'        => $method,
 645         'reason_otaker' => $options->{'reason_otaker'},
 646       );
 647       if ( $error ) {
 648         dbh->rollback if $oldAutoCommit;
 649         return "Error inserting cust_pkg_reason: $error";
 650       }
 651     }
 652   }
 653
 654   #save off and freeze RADIUS attributes for any associated svc_acct records
 655   my @svc_acct = ();
 656   if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
 657
 658                 #also check for specific exports?
 659                 # to avoid spurious modify export events
 660     @svc_acct = map  { $_->svc_x }
 661                 grep { $_->part_svc->svcdb eq 'svc_acct' }
 662                      $old->cust_svc;
 663
 664     $_->snapshot foreach @svc_acct;
 665
 666   }
 667
 668   my $error =  $new->export_pkg_change($old)
 669             || $new->SUPER::replace( $old,
 670                                      $options->{options}
 671                                        ? $options->{options}
 672                                        : ()
 673                                    );
 674   if ( $error ) {
 675     $dbh->rollback if $oldAutoCommit;
 676     return $error;
 677   }
 678
 679   #for prepaid packages,
 680   #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
 681   foreach my $old_svc_acct ( @svc_acct ) {
 682     my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
 683     my $s_error =
 684       $new_svc_acct->replace( $old_svc_acct,
 685                               'depend_jobnum' => $options->{depend_jobnum},
 686                             );
 687     if ( $s_error ) {
 688       $dbh->rollback if $oldAutoCommit;
 689       return $s_error;
 690     }
 691   }
 692
 693   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 694   '';
 695
 696 }
 697
 698 =item check
 699
 700 Checks all fields to make sure this is a valid billing item.  If there is an
 701 error, returns the error, otherwise returns false.  Called by the insert and
 702 replace methods.
 703
 704 =cut
 705
 706 sub check {
 707   my $self = shift;
 708
 709   if ( !$self->locationnum or $self->locationnum == -1 ) {
 710     $self->set('locationnum', $self->cust_main->ship_locationnum);
 711   }
 712
 713   my $error =
 714     $self->ut_numbern('pkgnum')
 715     || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
 716     || $self->ut_numbern('pkgpart')
 717     || $self->ut_foreign_keyn('contactnum',  'contact',       'contactnum' )
 718     || $self->ut_foreign_keyn('locationnum', 'cust_location', 'locationnum')
 719     || $self->ut_foreign_keyn('salesnum', 'sales', 'salesnum')
 720     || $self->ut_numbern('quantity')
 721     || $self->ut_numbern('start_date')
 722     || $self->ut_numbern('setup')
 723     || $self->ut_numbern('bill')
 724     || $self->ut_numbern('susp')
 725     || $self->ut_numbern('cancel')
 726     || $self->ut_numbern('adjourn')
 727     || $self->ut_numbern('resume')
 728     || $self->ut_numbern('expire')
 729     || $self->ut_numbern('dundate')
 730     || $self->ut_flag('no_auto', [ '', 'Y' ])
 731     || $self->ut_flag('waive_setup', [ '', 'Y' ])
 732     || $self->ut_flag('separate_bill')
 733     || $self->ut_textn('agent_pkgid')
 734     || $self->ut_enum('recur_show_zero', [ '', 'Y', 'N', ])
 735     || $self->ut_enum('setup_show_zero', [ '', 'Y', 'N', ])
 736     || $self->ut_foreign_keyn('main_pkgnum', 'cust_pkg', 'pkgnum')
 737     || $self->ut_foreign_keyn('pkglinknum', 'part_pkg_link', 'pkglinknum')
 738     || $self->ut_foreign_keyn('change_to_pkgnum', 'cust_pkg', 'pkgnum')
 739   ;
 740   return $error if $error;
 741
 742   return "A package with both start date (future start) and setup date (already started) will never bill"
 743     if $self->start_date && $self->setup && ! $upgrade;
 744
 745   return "A future unsuspend date can only be set for a package with a suspend date"
 746     if $self->resume and !$self->susp and !$self->adjourn;
 747
 748   $self->usernum($FS::CurrentUser::CurrentUser->usernum) unless $self->usernum;
 749
 750   if ( $self->dbdef_table->column('manual_flag') ) {
 751     $self->manual_flag('') if $self->manual_flag eq ' ';
 752     $self->manual_flag =~ /^([01]?)$/
 753       or return "Illegal manual_flag ". $self->manual_flag;
 754     $self->manual_flag($1);
 755   }
 756
 757   $self->SUPER::check;
 758 }
 759
 760 =item check_pkgpart
 761
 762 Check the pkgpart to make sure it's allowed with the reg_code and/or
 763 promo_code of the package (if present) and with the customer's agent.
 764 Called from C<insert>, unless we are doing a package change that doesn't
 765 affect pkgpart.
 766
 767 =cut
 768
 769 sub check_pkgpart {
 770   my $self = shift;
 771
 772   # my $error = $self->ut_numbern('pkgpart'); # already done
 773
 774   my $error;
 775   if ( $self->reg_code ) {
 776
 777     unless ( grep { $self->pkgpart == $_->pkgpart }
 778              map  { $_->reg_code_pkg }
 779              qsearchs( 'reg_code', { 'code'     => $self->reg_code,
 780                                      'agentnum' => $self->cust_main->agentnum })
 781            ) {
 782       return "Unknown registration code";
 783     }
 784
 785   } elsif ( $self->promo_code ) {
 786
 787     my $promo_part_pkg =
 788       qsearchs('part_pkg', {
 789         'pkgpart'    => $self->pkgpart,
 790         'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
 791       } );
 792     return 'Unknown promotional code' unless $promo_part_pkg;
 793
 794   } else {
 795
 796     unless ( $disable_agentcheck ) {
 797       my $agent =
 798         qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
 799       return "agent ". $agent->agentnum. ':'. $agent->agent.
 800              " can't purchase pkgpart ". $self->pkgpart
 801         unless $agent->pkgpart_hashref->{ $self->pkgpart }
 802             || $agent->agentnum == $self->part_pkg->agentnum;
 803     }
 804
 805     $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
 806     return $error if $error;
 807
 808   }
 809
 810   '';
 811
 812 }
 813
 814 =item cancel [ OPTION => VALUE ... ]
 815
 816 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
 817 in this package, then cancels the package itself (sets the cancel field to
 818 now).
 819
 820 Available options are:
 821
 822 =over 4
 823
 824 =item quiet - can be set true to supress email cancellation notices.
 825
 826 =item time -  can be set to cancel the package based on a specific future or
 827 historical date.  Using time ensures that the remaining amount is calculated
 828 correctly.  Note however that this is an immediate cancel and just changes
 829 the date.  You are PROBABLY looking to expire the account instead of using
 830 this.
 831
 832 =item reason - can be set to a cancellation reason (see L<FS:reason>),
 833 either a reasonnum of an existing reason, or passing a hashref will create
 834 a new reason.  The hashref should have the following keys: typenum - Reason
 835 type (see L<FS::reason_type>, reason - Text of the new reason.
 836
 837 =item date - can be set to a unix style timestamp to specify when to
 838 cancel (expire)
 839
 840 =item nobill - can be set true to skip billing if it might otherwise be done.
 841
 842 =item unused_credit - can be set to 1 to credit the remaining time, or 0 to
 843 not credit it.  This must be set (by change()) when changing the package
 844 to a different pkgpart or location, and probably shouldn't be in any other
 845 case.  If it's not set, the 'unused_credit_cancel' part_pkg option will
 846 be used.
 847
 848 =item no_delay_cancel - prevents delay_cancel behavior
 849 no matter what other options say, for use when changing packages (or any
 850 other time you're really sure you want an immediate cancel)
 851
 852 =back
 853
 854 If there is an error, returns the error, otherwise returns false.
 855
 856 =cut
 857
 858 #NOT DOCUMENTING - this should only be used when calling recursively
 859 #=item delay_cancel - for internal use, to allow proper handling of
 860 #supplemental packages when the main package is flagged to suspend
 861 #before cancelling, probably shouldn't be used otherwise (set the
 862 #corresponding package option instead)
 863
 864 sub cancel {
 865   my( $self, %options ) = @_;
 866   my $error;
 867
 868   # supplemental packages can now be separately canceled, though the UI
 869   # shouldn't permit it
 870   #
 871   ## pass all suspend/cancel actions to the main package
 872   ## (unless the pkglinknum has been removed, then the link is defunct and
 873   ## this package can be canceled on its own)
 874   #if ( $self->main_pkgnum and $self->pkglinknum and !$options{'from_main'} ) {
 875   #  return $self->main_pkg->cancel(%options);
 876   #}
 877
 878   my $conf = new FS::Conf;
 879
 880   warn "cust_pkg::cancel called with options".
 881        join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
 882     if $DEBUG;
 883
 884   my $oldAutoCommit = $FS::UID::AutoCommit;
 885   local $FS::UID::AutoCommit = 0;
 886   my $dbh = dbh;
 887
 888   my $old = $self->select_for_update;
 889
 890   if ( $old->get('cancel') || $self->get('cancel') ) {
 891     dbh->rollback if $oldAutoCommit;
 892     return "";  # no error
 893   }
 894
 895   # XXX possibly set cancel_time to the expire date?
 896   my $cancel_time = $options{'time'} || time;
 897   my $date = $options{'date'} if $options{'date'}; # expire/cancel later
 898   $date = '' if ($date && $date <= $cancel_time);      # complain instead?
 899
 900   my $delay_cancel = $options{'no_delay_cancel'} ? 0 : $options{'delay_cancel'};
 901   if ( !$date && $self->part_pkg->option('delay_cancel',1)
 902        && (($self->status eq 'active') || ($self->status eq 'suspended'))
 903        && !$options{'no_delay_cancel'}
 904   ) {
 905     my $expdays = $conf->config('part_pkg-delay_cancel-days') || 1;
 906     my $expsecs = 60*60*24*$expdays;
 907     my $suspfor = $self->susp ? $cancel_time - $self->susp : 0;
 908     $expsecs = $expsecs - $suspfor if $suspfor;
 909     unless ($expsecs <= 0) { #if it's already been suspended long enough, don't re-suspend
 910       $delay_cancel = 1;
 911       $date = $cancel_time + $expsecs;
 912     }
 913   }
 914
 915   #race condition: usage could be ongoing until unprovisioned
 916   #resolved by performing a change package instead (which unprovisions) and
 917   #later cancelling
 918   if ( !$options{nobill} && !$date ) {
 919     # && $conf->exists('bill_usage_on_cancel') ) { #calc_cancel checks this
 920       my $copy = $self->new({$self->hash});
 921       my $error =
 922         $copy->cust_main->bill( 'pkg_list' => [ $copy ],
 923                                 'cancel'   => 1,
 924                                 'time'     => $cancel_time );
 925       warn "Error billing during cancel, custnum ".
 926         #$self->cust_main->custnum. ": $error"
 927         ": $error"
 928         if $error;
 929   }
 930
 931   if ( $options{'reason'} ) {
 932     $error = $self->insert_reason( 'reason' => $options{'reason'},
 933                                    'action' => $date ? 'expire' : 'cancel',
 934                                    'date'   => $date ? $date : $cancel_time,
 935                                    'reason_otaker' => $options{'reason_otaker'},
 936                                  );
 937     if ( $error ) {
 938       dbh->rollback if $oldAutoCommit;
 939       return "Error inserting cust_pkg_reason: $error";
 940     }
 941   }
 942
 943   my %svc_cancel_opt = ();
 944   $svc_cancel_opt{'date'} = $date if $date;
 945   foreach my $cust_svc (
 946     #schwartz
 947     map  { $_->[0] }
 948     sort { $a->[1] <=> $b->[1] }
 949     map  { [ $_, $_->svc_x ? $_->svc_x->table_info->{'cancel_weight'} : -1 ]; }
 950     qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 951   ) {
 952     my $part_svc = $cust_svc->part_svc;
 953     next if ( defined($part_svc) and $part_svc->preserve );
 954     my $error = $cust_svc->cancel( %svc_cancel_opt );
 955
 956     if ( $error ) {
 957       $dbh->rollback if $oldAutoCommit;
 958       return 'Error '. ($svc_cancel_opt{'date'} ? 'expiring' : 'canceling' ).
 959              " cust_svc: $error";
 960     }
 961   }
 962
 963   unless ($date) {
 964     # credit remaining time if appropriate
 965     my $do_credit;
 966     if ( exists($options{'unused_credit'}) ) {
 967       $do_credit = $options{'unused_credit'};
 968     }
 969     else {
 970       $do_credit = $self->part_pkg->option('unused_credit_cancel', 1);
 971     }
 972     if ( $do_credit ) {
 973       my $error = $self->credit_remaining('cancel', $cancel_time);
 974       if ($error) {
 975         $dbh->rollback if $oldAutoCommit;
 976         return $error;
 977       }
 978     }
 979   } #unless $date
 980
 981   my %hash = $self->hash;
 982   if ( $date ) {
 983     $hash{'expire'} = $date;
 984     if ($delay_cancel) {
 985       # just to be sure these are clear
 986       $hash{'adjourn'} = undef;
 987       $hash{'resume'} = undef;
 988     }
 989   } else {
 990     $hash{'cancel'} = $cancel_time;
 991   }
 992   $hash{'change_custnum'} = $options{'change_custnum'};
 993
 994   # if this is a supplemental package that's lost its part_pkg_link, and it's
 995   # being canceled for real, unlink it completely
 996   if ( !$date and ! $self->pkglinknum ) {
 997     $hash{main_pkgnum} = '';
 998   }
 999
1000   # if there is a future package change scheduled, unlink from it (like
1001   # abort_change) first, then delete it.
1002   $hash{'change_to_pkgnum'} = '';
1003
1004   # save the package state
1005   my $new = new FS::cust_pkg ( \%hash );
1006   $error = $new->replace( $self, options => { $self->options } );
1007
1008   if ( $self->change_to_pkgnum ) {
1009     my $change_to = FS::cust_pkg->by_key($self->change_to_pkgnum);
1010     $error ||= $change_to->cancel('no_delay_cancel' => 1) || $change_to->delete;
1011   }
1012   if ( $error ) {
1013     $dbh->rollback if $oldAutoCommit;
1014     return $error;
1015   }
1016
1017   foreach my $supp_pkg ( $self->supplemental_pkgs ) {
1018     $error = $supp_pkg->cancel(%options,
1019       'from_main' => 1,
1020       'date' => $date, #in case it got changed by delay_cancel
1021       'delay_cancel' => $delay_cancel,
1022     );
1023     if ( $error ) {
1024       $dbh->rollback if $oldAutoCommit;
1025       return "canceling supplemental pkg#".$supp_pkg->pkgnum.": $error";
1026     }
1027   }
1028
1029   if ($delay_cancel && !$options{'from_main'}) {
1030     $error = $new->suspend(
1031       'from_cancel' => 1,
1032       'time'        => $cancel_time
1033     );
1034   }
1035
1036   unless ($date) {
1037     foreach my $usage ( $self->cust_pkg_usage ) {
1038       $error = $usage->delete;
1039       if ( $error ) {
1040         $dbh->rollback if $oldAutoCommit;
1041         return "deleting usage pools: $error";
1042       }
1043     }
1044   }
1045
1046   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1047   return '' if $date; #no errors
1048
1049   my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
1050   if ( !$options{'quiet'} &&
1051         $conf->exists('emailcancel', $self->cust_main->agentnum) &&
1052         @invoicing_list ) {
1053     my $msgnum = $conf->config('cancel_msgnum', $self->cust_main->agentnum);
1054     my $error = '';
1055     if ( $msgnum ) {
1056       my $msg_template = qsearchs('msg_template', { msgnum => $msgnum });
1057       $error = $msg_template->send( 'cust_main' => $self->cust_main,
1058                                     'object'    => $self );
1059     }
1060     else {
1061       $error = send_email(
1062         'from'    => $conf->invoice_from_full( $self->cust_main->agentnum ),
1063         'to'      => \@invoicing_list,
1064         'subject' => ( $conf->config('cancelsubject') || 'Cancellation Notice' ),
1065         'body'    => [ map "$_\n", $conf->config('cancelmessage') ],
1066         'custnum' => $self->custnum,
1067         'msgtype' => '', #admin?
1068       );
1069     }
1070     #should this do something on errors?
1071   }
1072
1073   ''; #no errors
1074
1075 }
1076
1077 =item cancel_if_expired [ NOW_TIMESTAMP ]
1078
1079 Cancels this package if its expire date has been reached.
1080
1081 =cut
1082
1083 sub cancel_if_expired {
1084   my $self = shift;
1085   my $time = shift || time;
1086   return '' unless $self->expire && $self->expire <= $time;
1087   my $error = $self->cancel;
1088   if ( $error ) {
1089     return "Error cancelling expired pkg ". $self->pkgnum. " for custnum ".
1090            $self->custnum. ": $error";
1091   }
1092   '';
1093 }
1094
1095 =item uncancel
1096
1097 "Un-cancels" this package: Orders a new package with the same custnum, pkgpart,
1098 locationnum, (other fields?).  Attempts to re-provision cancelled services
1099 using history information (errors at this stage are not fatal).
1100
1101 cust_pkg: pass a scalar reference, will be filled in with the new cust_pkg object
1102
1103 svc_fatal: service provisioning errors are fatal
1104
1105 svc_errors: pass an array reference, will be filled in with any provisioning errors
1106
1107 main_pkgnum: link the package as a supplemental package of this one.  For
1108 internal use only.
1109
1110 =cut
1111
1112 sub uncancel {
1113   my( $self, %options ) = @_;
1114
1115   #in case you try do do $uncancel-date = $cust_pkg->uncacel
1116   return '' unless $self->get('cancel');
1117
1118   if ( $self->main_pkgnum and !$options{'main_pkgnum'} ) {
1119     return $self->main_pkg->uncancel(%options);
1120   }
1121
1122   ##
1123   # Transaction-alize
1124   ##
1125
1126   my $oldAutoCommit = $FS::UID::AutoCommit;
1127   local $FS::UID::AutoCommit = 0;
1128   my $dbh = dbh;
1129
1130   ##
1131   # insert the new package
1132   ##
1133
1134   my $cust_pkg = new FS::cust_pkg {
1135     last_bill       => ( $options{'last_bill'} || $self->get('last_bill') ),
1136     bill            => ( $options{'bill'}      || $self->get('bill')      ),
1137     uncancel        => time,
1138     uncancel_pkgnum => $self->pkgnum,
1139     main_pkgnum     => ($options{'main_pkgnum'} || ''),
1140     map { $_ => $self->get($_) } qw(
1141       custnum pkgpart locationnum
1142       setup
1143       susp adjourn resume expire start_date contract_end dundate
1144       change_date change_pkgpart change_locationnum
1145       manual_flag no_auto separate_bill quantity agent_pkgid
1146       recur_show_zero setup_show_zero
1147     ),
1148   };
1149
1150   my $error = $cust_pkg->insert(
1151     'change' => 1, #supresses any referral credit to a referring customer
1152     'allow_pkgpart' => 1, # allow this even if the package def is disabled
1153   );
1154   if ($error) {
1155     $dbh->rollback if $oldAutoCommit;
1156     return $error;
1157   }
1158
1159   ##
1160   # insert services
1161   ##
1162
1163   #find historical services within this timeframe before the package cancel
1164   # (incompatible with "time" option to cust_pkg->cancel?)
1165   my $fuzz = 2 * 60; #2 minutes?  too much?   (might catch separate unprovision)
1166                      #            too little? (unprovisioing export delay?)
1167   my($end, $start) = ( $self->get('cancel'), $self->get('cancel') - $fuzz );
1168   my @h_cust_svc = $self->h_cust_svc( $end, $start );
1169
1170   my @svc_errors;
1171   foreach my $h_cust_svc (@h_cust_svc) {
1172     my $h_svc_x = $h_cust_svc->h_svc_x( $end, $start );
1173     #next unless $h_svc_x; #should this happen?
1174     (my $table = $h_svc_x->table) =~ s/^h_//;
1175     require "FS/$table.pm";
1176     my $class = "FS::$table";
1177     my $svc_x = $class->new( {
1178       'pkgnum'  => $cust_pkg->pkgnum,
1179       'svcpart' => $h_cust_svc->svcpart,
1180       map { $_ => $h_svc_x->get($_) } fields($table)
1181     } );
1182
1183     # radius_usergroup
1184     if ( $h_svc_x->isa('FS::h_svc_Radius_Mixin') ) {
1185       $svc_x->usergroup( [ $h_svc_x->h_usergroup($end, $start) ] );
1186     }
1187
1188     my $svc_error = $svc_x->insert;
1189     if ( $svc_error ) {
1190       if ( $options{svc_fatal} ) {
1191         $dbh->rollback if $oldAutoCommit;
1192         return $svc_error;
1193       } else {
1194         # if we've failed to insert the svc_x object, svc_Common->insert
1195         # will have removed the cust_svc already.  if not, then both records
1196         # were inserted but we failed for some other reason (export, most
1197         # likely).  in that case, report the error and delete the records.
1198         push @svc_errors, $svc_error;
1199         my $cust_svc = qsearchs('cust_svc', { 'svcnum' => $svc_x->svcnum });
1200         if ( $cust_svc ) {
1201           # except if export_insert failed, export_delete probably won't be
1202           # much better
1203           local $FS::svc_Common::noexport_hack = 1;
1204           my $cleanup_error = $svc_x->delete; # also deletes cust_svc
1205           if ( $cleanup_error ) { # and if THAT fails, then run away
1206             $dbh->rollback if $oldAutoCommit;
1207             return $cleanup_error;
1208           }
1209         }
1210       } # svc_fatal
1211     } # svc_error
1212   } #foreach $h_cust_svc
1213
1214   #these are pretty rare, but should handle them
1215   # - dsl_device (mac addresses)
1216   # - phone_device (mac addresses)
1217   # - dsl_note (ikano notes)
1218   # - domain_record (i.e. restore DNS information w/domains)
1219   # - inventory_item(?) (inventory w/un-cancelling service?)
1220   # - nas (svc_broaband nas stuff)
1221   #this stuff is unused in the wild afaik
1222   # - mailinglistmember
1223   # - router.svcnum?
1224   # - svc_domain.parent_svcnum?
1225   # - acct_snarf (ancient mail fetching config)
1226   # - cgp_rule (communigate)
1227   # - cust_svc_option (used by our Tron stuff)
1228   # - acct_rt_transaction (used by our time worked stuff)
1229
1230   ##
1231   # also move over any services that didn't unprovision at cancellation
1232   ##
1233
1234   foreach my $cust_svc ( qsearch('cust_svc', { pkgnum => $self->pkgnum } ) ) {
1235     $cust_svc->pkgnum( $cust_pkg->pkgnum );
1236     my $error = $cust_svc->replace;
1237     if ( $error ) {
1238       $dbh->rollback if $oldAutoCommit;
1239       return $error;
1240     }
1241   }
1242
1243   ##
1244   # Uncancel any supplemental packages, and make them supplemental to the
1245   # new one.
1246   ##
1247
1248   foreach my $supp_pkg ( $self->supplemental_pkgs ) {
1249     my $new_pkg;
1250     $error = $supp_pkg->uncancel(%options, 'main_pkgnum' => $cust_pkg->pkgnum);
1251     if ( $error ) {
1252       $dbh->rollback if $oldAutoCommit;
1253       return "canceling supplemental pkg#".$supp_pkg->pkgnum.": $error";
1254     }
1255   }
1256
1257   ##
1258   # Finish
1259   ##
1260
1261   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1262
1263   ${ $options{cust_pkg} }   = $cust_pkg   if ref($options{cust_pkg});
1264   @{ $options{svc_errors} } = @svc_errors if ref($options{svc_errors});
1265
1266   '';
1267 }
1268
1269 =item unexpire
1270
1271 Cancels any pending expiration (sets the expire field to null).
1272
1273 If there is an error, returns the error, otherwise returns false.
1274
1275 =cut
1276
1277 sub unexpire {
1278   my( $self, %options ) = @_;
1279   my $error;
1280
1281   my $oldAutoCommit = $FS::UID::AutoCommit;
1282   local $FS::UID::AutoCommit = 0;
1283   my $dbh = dbh;
1284
1285   my $old = $self->select_for_update;
1286
1287   my $pkgnum = $old->pkgnum;
1288   if ( $old->get('cancel') || $self->get('cancel') ) {
1289     dbh->rollback if $oldAutoCommit;
1290     return "Can't unexpire cancelled package $pkgnum";
1291     # or at least it's pointless
1292   }
1293
1294   unless ( $old->get('expire') && $self->get('expire') ) {
1295     dbh->rollback if $oldAutoCommit;
1296     return "";  # no error
1297   }
1298
1299   my %hash = $self->hash;
1300   $hash{'expire'} = '';
1301   my $new = new FS::cust_pkg ( \%hash );
1302   $error = $new->replace( $self, options => { $self->options } );
1303   if ( $error ) {
1304     $dbh->rollback if $oldAutoCommit;
1305     return $error;
1306   }
1307
1308   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1309
1310   ''; #no errors
1311
1312 }
1313
1314 =item suspend [ OPTION => VALUE ... ]
1315
1316 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
1317 package, then suspends the package itself (sets the susp field to now).
1318
1319 Available options are:
1320
1321 =over 4
1322
1323 =item reason - can be set to a cancellation reason (see L<FS:reason>),
1324 either a reasonnum of an existing reason, or passing a hashref will create
1325 a new reason.  The hashref should have the following keys:
1326 - typenum - Reason type (see L<FS::reason_type>
1327 - reason - Text of the new reason.
1328
1329 =item date - can be set to a unix style timestamp to specify when to
1330 suspend (adjourn)
1331
1332 =item time - can be set to override the current time, for calculation
1333 of final invoices or unused-time credits
1334
1335 =item resume_date - can be set to a time when the package should be
1336 unsuspended.  This may be more convenient than calling C<unsuspend()>
1337 separately.
1338
1339 =item from_main - allows a supplemental package to be suspended, rather
1340 than redirecting the method call to its main package.  For internal use.
1341
1342 =item from_cancel - used when suspending from the cancel method, forces
1343 this to skip everything besides basic suspension.  For internal use.
1344
1345 =back
1346
1347 If there is an error, returns the error, otherwise returns false.
1348
1349 =cut
1350
1351 sub suspend {
1352   my( $self, %options ) = @_;
1353   my $error;
1354
1355   # supplemental packages still can't be separately suspended, but silently
1356   # exit instead of failing or passing the action to the main package (so
1357   # that the "Suspend customer" action doesn't trip over the supplemental
1358   # packages and die)
1359
1360   if ( $self->main_pkgnum and !$options{'from_main'} ) {
1361     return;
1362   }
1363
1364   my $oldAutoCommit = $FS::UID::AutoCommit;
1365   local $FS::UID::AutoCommit = 0;
1366   my $dbh = dbh;
1367
1368   my $old = $self->select_for_update;
1369
1370   my $pkgnum = $old->pkgnum;
1371   if ( $old->get('cancel') || $self->get('cancel') ) {
1372     dbh->rollback if $oldAutoCommit;
1373     return "Can't suspend cancelled package $pkgnum";
1374   }
1375
1376   if ( $old->get('susp') || $self->get('susp') ) {
1377     dbh->rollback if $oldAutoCommit;
1378     return "";  # no error                     # complain on adjourn?
1379   }
1380
1381   my $suspend_time = $options{'time'} || time;
1382   my $date = $options{date} if $options{date}; # adjourn/suspend later
1383   $date = '' if ($date && $date <= $suspend_time); # complain instead?
1384
1385   if ( $date && $old->get('expire') && $old->get('expire') < $date ) {
1386     dbh->rollback if $oldAutoCommit;
1387     return "Package $pkgnum expires before it would be suspended.";
1388   }
1389
1390   # some false laziness with sub cancel
1391   if ( !$options{nobill} && !$date && !$options{'from_cancel'} &&
1392        $self->part_pkg->option('bill_suspend_as_cancel',1) ) {
1393     # kind of a kludge--'bill_suspend_as_cancel' to avoid having to
1394     # make the entire cust_main->bill path recognize 'suspend' and
1395     # 'cancel' separately.
1396     warn "Billing $pkgnum on suspension (at $suspend_time)\n" if $DEBUG;
1397     my $copy = $self->new({$self->hash});
1398     my $error =
1399       $copy->cust_main->bill( 'pkg_list' => [ $copy ],
1400                               'cancel'   => 1,
1401                               'time'     => $suspend_time );
1402     warn "Error billing during suspend, custnum ".
1403       #$self->cust_main->custnum. ": $error"
1404       ": $error"
1405       if $error;
1406   }
1407
1408   my $cust_pkg_reason;
1409   if ( $options{'reason'} ) {
1410     $error = $self->insert_reason( 'reason' => $options{'reason'},
1411                                    'action' => $date ? 'adjourn' : 'suspend',
1412                                    'date'   => $date ? $date : $suspend_time,
1413                                    'reason_otaker' => $options{'reason_otaker'},
1414                                  );
1415     if ( $error ) {
1416       dbh->rollback if $oldAutoCommit;
1417       return "Error inserting cust_pkg_reason: $error";
1418     }
1419     $cust_pkg_reason = qsearchs('cust_pkg_reason', {
1420         'date'    => $date ? $date : $suspend_time,
1421         'action'  => $date ? 'A' : 'S',
1422         'pkgnum'  => $self->pkgnum,
1423     });
1424   }
1425
1426   # if a reasonnum was passed, get the actual reason object so we can check
1427   # unused_credit
1428   # (passing a reason hashref is still allowed, but it can't be used with
1429   # the fancy behavioral options.)
1430
1431   my $reason;
1432   if ($options{'reason'} =~ /^\d+$/) {
1433     $reason = FS::reason->by_key($options{'reason'});
1434   }
1435
1436   my %hash = $self->hash;
1437   if ( $date ) {
1438     $hash{'adjourn'} = $date;
1439   } else {
1440     $hash{'susp'} = $suspend_time;
1441   }
1442
1443   my $resume_date = $options{'resume_date'} || 0;
1444   if ( $resume_date > ($date || $suspend_time) ) {
1445     $hash{'resume'} = $resume_date;
1446   }
1447
1448   $options{options} ||= {};
1449
1450   my $new = new FS::cust_pkg ( \%hash );
1451   $error = $new->replace( $self, options => { $self->options,
1452                                               %{ $options{options} },
1453                                             }
1454                         );
1455   if ( $error ) {
1456     $dbh->rollback if $oldAutoCommit;
1457     return $error;
1458   }
1459
1460   unless ( $date ) { # then we are suspending now
1461
1462     unless ($options{'from_cancel'}) {
1463       # credit remaining time if appropriate
1464       # (if required by the package def, or the suspend reason)
1465       my $unused_credit = $self->part_pkg->option('unused_credit_suspend',1)
1466                           || ( defined($reason) && $reason->unused_credit );
1467
1468       if ( $unused_credit ) {
1469         warn "crediting unused time on pkg#".$self->pkgnum."\n" if $DEBUG;
1470         my $error = $self->credit_remaining('suspend', $suspend_time);
1471         if ($error) {
1472           $dbh->rollback if $oldAutoCommit;
1473           return $error;
1474         }
1475       }
1476     }
1477
1478     my @cust_svc = qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } );
1479
1480     #attempt ordering ala cust_svc_suspend_cascade (without infinite-looping
1481     # on the circular dep case)
1482     #  (this is too simple for multi-level deps, we need to use something
1483     #   to resolve the DAG properly when possible)
1484     my %svcpart = ();
1485     $svcpart{$_->svcpart} = 0 foreach @cust_svc;
1486     foreach my $svcpart ( keys %svcpart ) {
1487       foreach my $part_svc_link (
1488         FS::part_svc_link->by_agentnum($self->cust_main->agentnum,
1489                                          src_svcpart => $svcpart,
1490                                          link_type => 'cust_svc_suspend_cascade'
1491                                       )
1492       ) {
1493         $svcpart{$part_svc_link->dst_svcpart} = max(
1494           $svcpart{$part_svc_link->dst_svcpart},
1495           $svcpart{$part_svc_link->src_svcpart} + 1
1496         );
1497       }
1498     }
1499     @cust_svc = sort { $svcpart{ $a->svcpart } <=> $svcpart{ $b->svcpart } }
1500                   @cust_svc;
1501
1502     my @labels = ();
1503     foreach my $cust_svc ( @cust_svc ) {
1504       $cust_svc->suspend( 'labels_arrayref' => \@labels );
1505     }
1506
1507     # suspension fees: if there is a feepart, and it's not an unsuspend fee,
1508     # and this is not a suspend-before-cancel
1509     if ( $cust_pkg_reason ) {
1510       my $reason_obj = $cust_pkg_reason->reason;
1511       if ( $reason_obj->feepart and
1512            ! $reason_obj->fee_on_unsuspend and
1513            ! $options{'from_cancel'} ) {
1514
1515         # register the need to charge a fee, cust_main->bill will do the rest
1516         warn "registering suspend fee: pkgnum ".$self->pkgnum.", feepart ".$reason->feepart."\n"
1517           if $DEBUG;
1518         my $cust_pkg_reason_fee = FS::cust_pkg_reason_fee->new({
1519             'pkgreasonnum'  => $cust_pkg_reason->num,
1520             'pkgnum'        => $self->pkgnum,
1521             'feepart'       => $reason->feepart,
1522             'nextbill'      => $reason->fee_hold,
1523         });
1524         $error ||= $cust_pkg_reason_fee->insert;
1525       }
1526     }
1527
1528     my $conf = new FS::Conf;
1529     if ( $conf->config('suspend_email_admin') && !$options{'from_cancel'} ) {
1530
1531       my $error = send_email(
1532         'from'    => $conf->config('invoice_from', $self->cust_main->agentnum),
1533                                    #invoice_from ??? well as good as any
1534         'to'      => $conf->config('suspend_email_admin'),
1535         'subject' => 'FREESIDE NOTIFICATION: Customer package suspended',
1536         'body'    => [
1537           "This is an automatic message from your Freeside installation\n",
1538           "informing you that the following customer package has been suspended:\n",
1539           "\n",
1540           'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
1541           'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
1542           ( map { "Service : $_\n" } @labels ),
1543         ],
1544         'custnum' => $self->custnum,
1545         'msgtype' => 'admin'
1546       );
1547
1548       if ( $error ) {
1549         warn "WARNING: can't send suspension admin email (suspending anyway): ".
1550              "$error\n";
1551       }
1552
1553     }
1554
1555   }
1556
1557   foreach my $supp_pkg ( $self->supplemental_pkgs ) {
1558     $error = $supp_pkg->suspend(%options, 'from_main' => 1);
1559     if ( $error ) {
1560       $dbh->rollback if $oldAutoCommit;
1561       return "suspending supplemental pkg#".$supp_pkg->pkgnum.": $error";
1562     }
1563   }
1564
1565   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1566
1567   ''; #no errors
1568 }
1569
1570 =item credit_remaining MODE TIME
1571
1572 Generate a credit for this package for the time remaining in the current
1573 billing period.  MODE is either "suspend" or "cancel" (determines the
1574 credit type).  TIME is the time of suspension/cancellation.  Both arguments
1575 are mandatory.
1576
1577 =cut
1578
1579 # Implementation note:
1580 #
1581 # If you pkgpart-change a package that has been billed, and it's set to give
1582 # credit on package change, then this method gets called and then the new
1583 # package will have no last_bill date. Therefore the customer will be credited
1584 # only once (per billing period) even if there are multiple package changes.
1585 #
1586 # If you location-change a package that has been billed, this method will NOT
1587 # be called and the new package WILL have the last bill date of the old
1588 # package.
1589 #
1590 # If the new package is then canceled within the same billing cycle,
1591 # credit_remaining needs to run calc_remain on the OLD package to determine
1592 # the amount of unused time to credit.
1593
1594 sub credit_remaining {
1595   # Add a credit for remaining service
1596   my ($self, $mode, $time) = @_;
1597   die 'credit_remaining requires suspend or cancel'
1598     unless $mode eq 'suspend' or $mode eq 'cancel';
1599   die 'no suspend/cancel time' unless $time > 0;
1600
1601   my $conf = FS::Conf->new;
1602   my $reason_type = $conf->config($mode.'_credit_type');
1603
1604   my $last_bill = $self->getfield('last_bill') || 0;
1605   my $next_bill = $self->getfield('bill') || 0;
1606   if ( $last_bill > 0         # the package has been billed
1607       and $next_bill > 0      # the package has a next bill date
1608       and $next_bill >= $time # which is in the future
1609   ) {
1610     my @cust_credit_source_bill_pkg = ();
1611     my $remaining_value = 0;
1612
1613     my $remain_pkg = $self;
1614     $remaining_value = $remain_pkg->calc_remain(
1615       'time' => $time,
1616       'cust_credit_source_bill_pkg' => \@cust_credit_source_bill_pkg,
1617     );
1618
1619     # we may have to walk back past some package changes to get to the
1620     # one that actually has unused time
1621     while ( $remaining_value == 0 ) {
1622       if ( $remain_pkg->change_pkgnum ) {
1623         $remain_pkg = FS::cust_pkg->by_key($remain_pkg->change_pkgnum);
1624       } else {
1625         # the package has really never been billed
1626         return;
1627       }
1628       $remaining_value = $remain_pkg->calc_remain(
1629         'time' => $time,
1630         'cust_credit_source_bill_pkg' => \@cust_credit_source_bill_pkg,
1631       );
1632     }
1633
1634     if ( $remaining_value > 0 ) {
1635       warn "Crediting for $remaining_value on package ".$self->pkgnum."\n"
1636         if $DEBUG;
1637       my $error = $self->cust_main->credit(
1638         $remaining_value,
1639         'Credit for unused time on '. $self->part_pkg->pkg,
1640         'reason_type' => $reason_type,
1641         'cust_credit_source_bill_pkg' => \@cust_credit_source_bill_pkg,
1642       );
1643       return "Error crediting customer \$$remaining_value for unused time".
1644         " on ". $self->part_pkg->pkg. ": $error"
1645         if $error;
1646     } #if $remaining_value
1647   } #if $last_bill, etc.
1648   '';
1649 }
1650
1651 =item unsuspend [ OPTION => VALUE ... ]
1652
1653 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
1654 package, then unsuspends the package itself (clears the susp field and the
1655 adjourn field if it is in the past).  If the suspend reason includes an
1656 unsuspension package, that package will be ordered.
1657
1658 Available options are:
1659
1660 =over 4
1661
1662 =item date
1663
1664 Can be set to a date to unsuspend the package in the future (the 'resume'
1665 field).
1666
1667 =item adjust_next_bill
1668
1669 Can be set true to adjust the next bill date forward by
1670 the amount of time the account was inactive.  This was set true by default
1671 in the past (from 1.4.2 and 1.5.0pre6 through 1.7.0), but now needs to be
1672 explicitly requested with this option or in the price plan.
1673
1674 =back
1675
1676 If there is an error, returns the error, otherwise returns false.
1677
1678 =cut
1679
1680 sub unsuspend {
1681   my( $self, %opt ) = @_;
1682   my $error;
1683
1684   # pass all suspend/cancel actions to the main package
1685   if ( $self->main_pkgnum and !$opt{'from_main'} ) {
1686     return $self->main_pkg->unsuspend(%opt);
1687   }
1688
1689   my $oldAutoCommit = $FS::UID::AutoCommit;
1690   local $FS::UID::AutoCommit = 0;
1691   my $dbh = dbh;
1692
1693   my $old = $self->select_for_update;
1694
1695   my $pkgnum = $old->pkgnum;
1696   if ( $old->get('cancel') || $self->get('cancel') ) {
1697     $dbh->rollback if $oldAutoCommit;
1698     return "Can't unsuspend cancelled package $pkgnum";
1699   }
1700
1701   unless ( $old->get('susp') && $self->get('susp') ) {
1702     $dbh->rollback if $oldAutoCommit;
1703     return "";  # no error                     # complain instead?
1704   }
1705
1706   # handle the case of setting a future unsuspend (resume) date
1707   # and do not continue to actually unsuspend the package
1708   my $date = $opt{'date'};
1709   if ( $date and $date > time ) { # return an error if $date <= time?
1710
1711     if ( $old->get('expire') && $old->get('expire') < $date ) {
1712       $dbh->rollback if $oldAutoCommit;
1713       return "Package $pkgnum expires before it would be unsuspended.";
1714     }
1715
1716     my $new = new FS::cust_pkg { $self->hash };
1717     $new->set('resume', $date);
1718     $error = $new->replace($self, options => $self->options);
1719
1720     if ( $error ) {
1721       $dbh->rollback if $oldAutoCommit;
1722       return $error;
1723     }
1724     else {
1725       $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1726       return '';
1727     }
1728
1729   } #if $date
1730
1731   if (!$self->setup) {
1732     # then this package is being released from on-hold status
1733     $error = $self->set_initial_timers;
1734     if ( $error ) {
1735       $dbh->rollback if $oldAutoCommit;
1736       return $error;
1737     }
1738   }
1739
1740   my @labels = ();
1741
1742   foreach my $cust_svc (
1743     qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
1744   ) {
1745     my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
1746
1747     $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
1748       $dbh->rollback if $oldAutoCommit;
1749       return "Illegal svcdb value in part_svc!";
1750     };
1751     my $svcdb = $1;
1752     require "FS/$svcdb.pm";
1753
1754     my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
1755     if ($svc) {
1756       $error = $svc->unsuspend;
1757       if ( $error ) {
1758         $dbh->rollback if $oldAutoCommit;
1759         return $error;
1760       }
1761       my( $label, $value ) = $cust_svc->label;
1762       push @labels, "$label: $value";
1763     }
1764
1765   }
1766
1767   my $cust_pkg_reason = $self->last_cust_pkg_reason('susp');
1768   my $reason = $cust_pkg_reason ? $cust_pkg_reason->reason : '';
1769
1770   my %hash = $self->hash;
1771   my $inactive = time - $hash{'susp'};
1772
1773   my $conf = new FS::Conf;
1774
1775   #adjust the next bill date forward
1776   # increment next bill date if certain conditions are met:
1777   # - it was due to be billed at some point
1778   # - either the global or local config says to do this
1779   my $adjust_bill = 0;
1780   if (
1781        $inactive > 0
1782     && ( $hash{'bill'} || $hash{'setup'} )
1783     && (    $opt{'adjust_next_bill'}
1784          || $conf->exists('unsuspend-always_adjust_next_bill_date')
1785          || $self->part_pkg->option('unsuspend_adjust_bill', 1)
1786        )
1787   ) {
1788     $adjust_bill = 1;
1789   }
1790
1791   # but not if:
1792   # - the package billed during suspension
1793   # - or it was ordered on hold
1794   # - or the customer was credited for the unused time
1795
1796   if ( $self->option('suspend_bill',1)
1797       or ( $self->part_pkg->option('suspend_bill',1)
1798            and ! $self->option('no_suspend_bill',1)
1799          )
1800       or $hash{'order_date'} == $hash{'susp'}
1801   ) {
1802     $adjust_bill = 0;
1803   }
1804
1805   if ( $adjust_bill ) {
1806     if (    $self->part_pkg->option('unused_credit_suspend')
1807          or ( ref($reason) and $reason->unused_credit ) ) {
1808       # then the customer was credited for the unused time before suspending,
1809       # so their next bill should be immediate
1810       $hash{'bill'} = time;
1811     } else {
1812       # add the length of time suspended to the bill date
1813       $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive;
1814     }
1815   }
1816
1817   $hash{'susp'} = '';
1818   $hash{'adjourn'} = '' if $hash{'adjourn'} and $hash{'adjourn'} < time;
1819   $hash{'resume'} = '' if !$hash{'adjourn'};
1820   my $new = new FS::cust_pkg ( \%hash );
1821   $error = $new->replace( $self, options => { $self->options } );
1822   if ( $error ) {
1823     $dbh->rollback if $oldAutoCommit;
1824     return $error;
1825   }
1826
1827   my $unsusp_pkg;
1828
1829   if ( $reason ) {
1830     if ( $reason->unsuspend_pkgpart ) {
1831       warn "Suspend reason '".$reason->reason."' uses deprecated unsuspend_pkgpart feature.\n";
1832       my $part_pkg = FS::part_pkg->by_key($reason->unsuspend_pkgpart)
1833         or $error = "Unsuspend package definition ".$reason->unsuspend_pkgpart.
1834                     " not found.";
1835       my $start_date = $self->cust_main->next_bill_date
1836         if $reason->unsuspend_hold;
1837
1838       if ( $part_pkg ) {
1839         $unsusp_pkg = FS::cust_pkg->new({
1840             'custnum'     => $self->custnum,
1841             'pkgpart'     => $reason->unsuspend_pkgpart,
1842             'start_date'  => $start_date,
1843             'locationnum' => $self->locationnum,
1844             # discount? probably not...
1845         });
1846
1847         $error ||= $self->cust_main->order_pkg( 'cust_pkg' => $unsusp_pkg );
1848       }
1849     }
1850     # new way, using fees
1851     if ( $reason->feepart and $reason->fee_on_unsuspend ) {
1852       # register the need to charge a fee, cust_main->bill will do the rest
1853       warn "registering unsuspend fee: pkgnum ".$self->pkgnum.", feepart ".$reason->feepart."\n"
1854         if $DEBUG;
1855       my $cust_pkg_reason_fee = FS::cust_pkg_reason_fee->new({
1856           'pkgreasonnum'  => $cust_pkg_reason->num,
1857           'pkgnum'        => $self->pkgnum,
1858           'feepart'       => $reason->feepart,
1859           'nextbill'      => $reason->fee_hold,
1860       });
1861       $error ||= $cust_pkg_reason_fee->insert;
1862     }
1863
1864     if ( $error ) {
1865       $dbh->rollback if $oldAutoCommit;
1866       return $error;
1867     }
1868   }
1869
1870   if ( $conf->config('unsuspend_email_admin') ) {
1871
1872     my $error = send_email(
1873       'from'    => $conf->config('invoice_from', $self->cust_main->agentnum),
1874                                  #invoice_from ??? well as good as any
1875       'to'      => $conf->config('unsuspend_email_admin'),
1876       'subject' => 'FREESIDE NOTIFICATION: Customer package unsuspended',       'body'    => [
1877         "This is an automatic message from your Freeside installation\n",
1878         "informing you that the following customer package has been unsuspended:\n",
1879         "\n",
1880         'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
1881         'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
1882         ( map { "Service : $_\n" } @labels ),
1883         ($unsusp_pkg ?
1884           "An unsuspension fee was charged: ".
1885             $unsusp_pkg->part_pkg->pkg_comment."\n"
1886           : ''
1887         ),
1888       ],
1889       'custnum' => $self->custnum,
1890       'msgtype' => 'admin',
1891     );
1892
1893     if ( $error ) {
1894       warn "WARNING: can't send unsuspension admin email (unsuspending anyway): ".
1895            "$error\n";
1896     }
1897
1898   }
1899
1900   foreach my $supp_pkg ( $self->supplemental_pkgs ) {
1901     $error = $supp_pkg->unsuspend(%opt, 'from_main' => 1);
1902     if ( $error ) {
1903       $dbh->rollback if $oldAutoCommit;
1904       return "unsuspending supplemental pkg#".$supp_pkg->pkgnum.": $error";
1905     }
1906   }
1907
1908   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1909
1910   ''; #no errors
1911 }
1912
1913 =item unadjourn
1914
1915 Cancels any pending suspension (sets the adjourn field to null).
1916
1917 If there is an error, returns the error, otherwise returns false.
1918
1919 =cut
1920
1921 sub unadjourn {
1922   my( $self, %options ) = @_;
1923   my $error;
1924
1925   my $oldAutoCommit = $FS::UID::AutoCommit;
1926   local $FS::UID::AutoCommit = 0;
1927   my $dbh = dbh;
1928
1929   my $old = $self->select_for_update;
1930
1931   my $pkgnum = $old->pkgnum;
1932   if ( $old->get('cancel') || $self->get('cancel') ) {
1933     dbh->rollback if $oldAutoCommit;
1934     return "Can't unadjourn cancelled package $pkgnum";
1935     # or at least it's pointless
1936   }
1937
1938   if ( $old->get('susp') || $self->get('susp') ) {
1939     dbh->rollback if $oldAutoCommit;
1940     return "Can't unadjourn suspended package $pkgnum";
1941     # perhaps this is arbitrary
1942   }
1943
1944   unless ( $old->get('adjourn') && $self->get('adjourn') ) {
1945     dbh->rollback if $oldAutoCommit;
1946     return "";  # no error
1947   }
1948
1949   my %hash = $self->hash;
1950   $hash{'adjourn'} = '';
1951   $hash{'resume'}  = '';
1952   my $new = new FS::cust_pkg ( \%hash );
1953   $error = $new->replace( $self, options => { $self->options } );
1954   if ( $error ) {
1955     $dbh->rollback if $oldAutoCommit;
1956     return $error;
1957   }
1958
1959   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1960
1961   ''; #no errors
1962
1963 }
1964
1965
1966 =item change HASHREF | OPTION => VALUE ...
1967
1968 Changes this package: cancels it and creates a new one, with a different
1969 pkgpart or locationnum or both.  All services are transferred to the new
1970 package (no change will be made if this is not possible).
1971
1972 Options may be passed as a list of key/value pairs or as a hash reference.
1973 Options are:
1974
1975 =over 4
1976
1977 =item locationnum
1978
1979 New locationnum, to change the location for this package.
1980
1981 =item cust_location
1982
1983 New FS::cust_location object, to create a new location and assign it
1984 to this package.
1985
1986 =item cust_main
1987
1988 New FS::cust_main object, to create a new customer and assign the new package
1989 to it.
1990
1991 =item pkgpart
1992
1993 New pkgpart (see L<FS::part_pkg>).
1994
1995 =item refnum
1996
1997 New refnum (see L<FS::part_referral>).
1998
1999 =item quantity
2000
2001 New quantity; if unspecified, the new package will have the same quantity
2002 as the old.
2003
2004 =item cust_pkg
2005
2006 "New" (existing) FS::cust_pkg object.  The package's services and other
2007 attributes will be transferred to this package.
2008
2009 =item keep_dates
2010
2011 Set to true to transfer billing dates (start_date, setup, last_bill, bill,
2012 susp, adjourn, cancel, expire, and contract_end) to the new package.
2013
2014 =item unprotect_svcs
2015
2016 Normally, change() will rollback and return an error if some services
2017 can't be transferred (also see the I<cust_pkg-change_svcpart> config option).
2018 If unprotect_svcs is true, this method will transfer as many services as
2019 it can and then unconditionally cancel the old package.
2020
2021 =item contract_end
2022
2023 If specified, sets this value for the contract_end date on the new package
2024 (without regard for keep_dates or the usual date-preservation behavior.)
2025 Will throw an error if defined but false;  the UI doesn't allow editing
2026 this unless it already exists, making removal impossible to undo.
2027
2028 =back
2029
2030 At least one of locationnum, cust_location, pkgpart, refnum, cust_main, or
2031 cust_pkg must be specified (otherwise, what's the point?)
2032
2033 Returns either the new FS::cust_pkg object or a scalar error.
2034
2035 For example:
2036
2037   my $err_or_new_cust_pkg = $old_cust_pkg->change
2038
2039 =cut
2040
2041 #used by change and change_later
2042 #didn't put with documented check methods because it depends on change-specific opts
2043 #and it also possibly edits the value of opts
2044 sub _check_change {
2045   my $self = shift;
2046   my $opt = shift;
2047   if ( defined($opt->{'contract_end'}) ) {
2048     my $current_contract_end = $self->get('contract_end');
2049     unless ($opt->{'contract_end'}) {
2050       if ($current_contract_end) {
2051         return "Cannot remove contract end date when changing packages";
2052       } else {
2053         #shouldn't even pass this option if there's not a current value
2054         #but can be handled gracefully if the option is empty
2055         warn "Contract end date passed unexpectedly";
2056         delete $opt->{'contract_end'};
2057         return '';
2058       }
2059     }
2060     unless ($current_contract_end) {
2061       #option shouldn't be passed, throw error if it's non-empty
2062       return "Cannot add contract end date when changing packages " . $self->pkgnum;
2063     }
2064   }
2065   return '';
2066 }
2067
2068 #some false laziness w/order
2069 sub change {
2070   my $self = shift;
2071   my $opt = ref($_[0]) ? shift : { @_ };
2072
2073   my $conf = new FS::Conf;
2074
2075   # handle contract_end on cust_pkg same as passed option
2076   if ( $opt->{'cust_pkg'} ) {
2077     $opt->{'contract_end'} = $opt->{'cust_pkg'}->contract_end;
2078     delete $opt->{'contract_end'} unless $opt->{'contract_end'};
2079   }
2080
2081   # check contract_end, prevent adding/removing
2082   my $error = $self->_check_change($opt);
2083   return $error if $error;
2084
2085   # Transactionize this whole mess
2086   my $oldAutoCommit = $FS::UID::AutoCommit;
2087   local $FS::UID::AutoCommit = 0;
2088   my $dbh = dbh;
2089
2090   if ( $opt->{'cust_location'} ) {
2091     $error = $opt->{'cust_location'}->find_or_insert;
2092     if ( $error ) {
2093       $dbh->rollback if $oldAutoCommit;
2094       return "creating location record: $error";
2095     }
2096     $opt->{'locationnum'} = $opt->{'cust_location'}->locationnum;
2097   }
2098
2099   # Before going any further here: if the package is still in the pre-setup
2100   # state, it's safe to modify it in place. No need to charge/credit for
2101   # partial period, transfer services, transfer usage pools, copy invoice
2102   # details, or change any dates.
2103   if ( ! $self->setup and ! $opt->{cust_pkg} and ! $opt->{cust_main} ) {
2104     foreach ( qw( locationnum pkgpart quantity refnum salesnum ) ) {
2105       if ( length($opt->{$_}) ) {
2106         $self->set($_, $opt->{$_});
2107       }
2108     }
2109     # almost. if the new pkgpart specifies start/adjourn/expire timers,
2110     # apply those.
2111     if ( $opt->{'pkgpart'} and $opt->{'pkgpart'} != $self->pkgpart ) {
2112       $error ||= $self->set_initial_timers;
2113     }
2114     # but if contract_end was explicitly specified, that overrides all else
2115     $self->set('contract_end', $opt->{'contract_end'})
2116       if $opt->{'contract_end'};
2117     $error ||= $self->replace;
2118     if ( $error ) {
2119       $dbh->rollback if $oldAutoCommit;
2120       return "modifying package: $error";
2121     } else {
2122       $dbh->commit if $oldAutoCommit;
2123       return $self;
2124     }
2125   }
2126
2127   my %hash = ();
2128
2129   my $time = time;
2130
2131   $hash{'setup'} = $time if $self->setup;
2132
2133   $hash{'change_date'} = $time;
2134   $hash{"change_$_"}  = $self->$_()
2135     foreach qw( pkgnum pkgpart locationnum );
2136
2137   if ( $opt->{'cust_pkg'} ) {
2138     # treat changing to a package with a different pkgpart as a
2139     # pkgpart change (because it is)
2140     $opt->{'pkgpart'} = $opt->{'cust_pkg'}->pkgpart;
2141   }
2142
2143   # whether to override pkgpart checking on the new package
2144   my $same_pkgpart = 1;
2145   if ( $opt->{'pkgpart'} and ( $opt->{'pkgpart'} != $self->pkgpart ) ) {
2146     $same_pkgpart = 0;
2147   }
2148
2149   my $unused_credit = 0;
2150   my $keep_dates = $opt->{'keep_dates'};
2151
2152   # Special case.  If the pkgpart is changing, and the customer is
2153   # going to be credited for remaining time, don't keep setup, bill,
2154   # or last_bill dates, and DO pass the flag to cancel() to credit
2155   # the customer.
2156   if ( $opt->{'pkgpart'}
2157        and $opt->{'pkgpart'} != $self->pkgpart
2158        and $self->part_pkg->option('unused_credit_change', 1) ) {
2159     $unused_credit = 1;
2160     $keep_dates = 0;
2161     $hash{$_} = '' foreach qw(setup bill last_bill);
2162   }
2163
2164   if ( $keep_dates ) {
2165     foreach my $date ( qw(setup bill last_bill) ) {
2166       $hash{$date} = $self->getfield($date);
2167     }
2168   }
2169   # always keep the following dates
2170   foreach my $date (qw(order_date susp adjourn cancel expire resume
2171                     start_date contract_end)) {
2172     $hash{$date} = $self->getfield($date);
2173   }
2174   # but if contract_end was explicitly specified, that overrides all else
2175   $hash{'contract_end'} = $opt->{'contract_end'}
2176     if $opt->{'contract_end'};
2177
2178   # allow $opt->{'locationnum'} = '' to specifically set it to null
2179   # (i.e. customer default location)
2180   $opt->{'locationnum'} = $self->locationnum if !exists($opt->{'locationnum'});
2181
2182   # usually this doesn't matter.  the two cases where it does are:
2183   # 1. unused_credit_change + pkgpart change + setup fee on the new package
2184   # and
2185   # 2. (more importantly) changing a package before it's billed
2186   $hash{'waive_setup'} = $self->waive_setup;
2187
2188   # if this package is scheduled for a future package change, preserve that
2189   $hash{'change_to_pkgnum'} = $self->change_to_pkgnum;
2190
2191   my $custnum = $self->custnum;
2192   if ( $opt->{cust_main} ) {
2193     my $cust_main = $opt->{cust_main};
2194     unless ( $cust_main->custnum ) {
2195       my $error = $cust_main->insert( @{ $opt->{cust_main_insert_args}||[] } );
2196       if ( $error ) {
2197         $dbh->rollback if $oldAutoCommit;
2198         return "inserting customer record: $error";
2199       }
2200     }
2201     $custnum = $cust_main->custnum;
2202   }
2203
2204   $hash{'contactnum'} = $opt->{'contactnum'} if $opt->{'contactnum'};
2205
2206   my $cust_pkg;
2207   if ( $opt->{'cust_pkg'} ) {
2208     # The target package already exists; update it to show that it was
2209     # changed from this package.
2210     $cust_pkg = $opt->{'cust_pkg'};
2211
2212     # follow all the above rules for date changes, etc.
2213     foreach (keys %hash) {
2214       $cust_pkg->set($_, $hash{$_});
2215     }
2216     # except those that implement the future package change behavior
2217     foreach (qw(change_to_pkgnum start_date expire)) {
2218       $cust_pkg->set($_, '');
2219     }
2220
2221     $error = $cust_pkg->replace;
2222
2223   } else {
2224     # Create the new package.
2225     $cust_pkg = new FS::cust_pkg {
2226       custnum     => $custnum,
2227       locationnum => $opt->{'locationnum'},
2228       ( map {  $_ => ( $opt->{$_} || $self->$_() )  }
2229           qw( pkgpart quantity refnum salesnum )
2230       ),
2231       %hash,
2232     };
2233     $error = $cust_pkg->insert( 'change' => 1,
2234                                 'allow_pkgpart' => $same_pkgpart );
2235   }
2236   if ($error) {
2237     $dbh->rollback if $oldAutoCommit;
2238     return "inserting new package: $error";
2239   }
2240
2241   # Transfer services and cancel old package.
2242   # Enforce service limits only if this is a pkgpart change.
2243   local $FS::cust_svc::ignore_quantity;
2244   $FS::cust_svc::ignore_quantity = 1 if $same_pkgpart;
2245   $error = $self->transfer($cust_pkg);
2246   if ($error and $error == 0) {
2247     # $old_pkg->transfer failed.
2248     $dbh->rollback if $oldAutoCommit;
2249     return "transferring $error";
2250   }
2251
2252   if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
2253     warn "trying transfer again with change_svcpart option\n" if $DEBUG;
2254     $error = $self->transfer($cust_pkg, 'change_svcpart'=>1 );
2255     if ($error and $error == 0) {
2256       # $old_pkg->transfer failed.
2257       $dbh->rollback if $oldAutoCommit;
2258       return "converting $error";
2259     }
2260   }
2261
2262   # We set unprotect_svcs when executing a "future package change".  It's
2263   # not a user-interactive operation, so returning an error means the
2264   # package change will just fail.  Rather than have that happen, we'll
2265   # let leftover services be deleted.
2266   if ($error > 0 and !$opt->{'unprotect_svcs'}) {
2267     # Transfers were successful, but we still had services left on the old
2268     # package.  We can't change the package under this circumstances, so abort.
2269     $dbh->rollback if $oldAutoCommit;
2270     return "unable to transfer all services";
2271   }
2272
2273   #reset usage if changing pkgpart
2274   # AND usage rollover is off (otherwise adds twice, now and at package bill)
2275   if ($self->pkgpart != $cust_pkg->pkgpart) {
2276     my $part_pkg = $cust_pkg->part_pkg;
2277     $error = $part_pkg->reset_usage($cust_pkg, $part_pkg->is_prepaid
2278                                                  ? ()
2279                                                  : ( 'null' => 1 )
2280                                    )
2281       if $part_pkg->can('reset_usage') && ! $part_pkg->option('usage_rollover',1);
2282
2283     if ($error) {
2284       $dbh->rollback if $oldAutoCommit;
2285       return "setting usage values: $error";
2286     }
2287   } else {
2288     # if NOT changing pkgpart, transfer any usage pools over
2289     foreach my $usage ($self->cust_pkg_usage) {
2290       $usage->set('pkgnum', $cust_pkg->pkgnum);
2291       $error = $usage->replace;
2292       if ( $error ) {
2293         $dbh->rollback if $oldAutoCommit;
2294         return "transferring usage pools: $error";
2295       }
2296     }
2297   }
2298
2299   # transfer usage pricing add-ons, if we're not changing pkgpart
2300   if ( $same_pkgpart ) {
2301     foreach my $old_cust_pkg_usageprice ($self->cust_pkg_usageprice) {
2302       my $new_cust_pkg_usageprice = new FS::cust_pkg_usageprice {
2303         'pkgnum'         => $cust_pkg->pkgnum,
2304         'usagepricepart' => $old_cust_pkg_usageprice->usagepricepart,
2305         'quantity'       => $old_cust_pkg_usageprice->quantity,
2306       };
2307       $error = $new_cust_pkg_usageprice->insert;
2308       if ( $error ) {
2309         $dbh->rollback if $oldAutoCommit;
2310         return "Error transferring usage pricing add-on: $error";
2311       }
2312     }
2313   }
2314
2315   # transfer discounts, if we're not changing pkgpart
2316   if ( $same_pkgpart ) {
2317     foreach my $old_discount ($self->cust_pkg_discount_active) {
2318       # don't remove the old discount, we may still need to bill that package.
2319       my $new_discount = new FS::cust_pkg_discount {
2320         'pkgnum'      => $cust_pkg->pkgnum,
2321         'discountnum' => $old_discount->discountnum,
2322         'months_used' => $old_discount->months_used,
2323       };
2324       $error = $new_discount->insert;
2325       if ( $error ) {
2326         $dbh->rollback if $oldAutoCommit;
2327         return "transferring discounts: $error";
2328       }
2329     }
2330   }
2331
2332   # transfer (copy) invoice details
2333   foreach my $detail ($self->cust_pkg_detail) {
2334     my $new_detail = FS::cust_pkg_detail->new({ $detail->hash });
2335     $new_detail->set('pkgdetailnum', '');
2336     $new_detail->set('pkgnum', $cust_pkg->pkgnum);
2337     $error = $new_detail->insert;
2338     if ( $error ) {
2339       $dbh->rollback if $oldAutoCommit;
2340       return "transferring package notes: $error";
2341     }
2342   }
2343
2344   my @new_supp_pkgs;
2345
2346   if ( !$opt->{'cust_pkg'} ) {
2347     # Order any supplemental packages.
2348     my $part_pkg = $cust_pkg->part_pkg;
2349     my @old_supp_pkgs = $self->supplemental_pkgs;
2350     foreach my $link ($part_pkg->supp_part_pkg_link) {
2351       my $old;
2352       foreach (@old_supp_pkgs) {
2353         if ($_->pkgpart == $link->dst_pkgpart) {
2354           $old = $_;
2355           $_->pkgpart(0); # so that it can't match more than once
2356         }
2357         last if $old;
2358       }
2359       # false laziness with FS::cust_main::Packages::order_pkg
2360       my $new = FS::cust_pkg->new({
2361           pkgpart       => $link->dst_pkgpart,
2362           pkglinknum    => $link->pkglinknum,
2363           custnum       => $custnum,
2364           main_pkgnum   => $cust_pkg->pkgnum,
2365           locationnum   => $cust_pkg->locationnum,
2366           start_date    => $cust_pkg->start_date,
2367           order_date    => $cust_pkg->order_date,
2368           expire        => $cust_pkg->expire,
2369           adjourn       => $cust_pkg->adjourn,
2370           contract_end  => $cust_pkg->contract_end,
2371           refnum        => $cust_pkg->refnum,
2372           discountnum   => $cust_pkg->discountnum,
2373           waive_setup   => $cust_pkg->waive_setup,
2374       });
2375       if ( $old and $opt->{'keep_dates'} ) {
2376         foreach (qw(setup bill last_bill)) {
2377           $new->set($_, $old->get($_));
2378         }
2379       }
2380       $error = $new->insert( allow_pkgpart => $same_pkgpart );
2381       # transfer services
2382       if ( $old ) {
2383         $error ||= $old->transfer($new);
2384       }
2385       if ( $error and $error > 0 ) {
2386         # no reason why this should ever fail, but still...
2387         $error = "Unable to transfer all services from supplemental package ".
2388           $old->pkgnum;
2389       }
2390       if ( $error ) {
2391         $dbh->rollback if $oldAutoCommit;
2392         return $error;
2393       }
2394       push @new_supp_pkgs, $new;
2395     }
2396   } # if !$opt->{'cust_pkg'}
2397     # because if there is one, then supplemental packages would already
2398     # have been created for it.
2399
2400   #Good to go, cancel old package.  Notify 'cancel' of whether to credit
2401   #remaining time.
2402   #Don't allow billing the package (preceding period packages and/or
2403   #outstanding usage) if we are keeping dates (i.e. location changing),
2404   #because the new package will be billed for the same date range.
2405   #Supplemental packages are also canceled here.
2406
2407   # during scheduled changes, avoid canceling the package we just
2408   # changed to (duh)
2409   $self->set('change_to_pkgnum' => '');
2410
2411   $error = $self->cancel(
2412     quiet          => 1,
2413     unused_credit  => $unused_credit,
2414     nobill         => $keep_dates,
2415     change_custnum => ( $self->custnum != $custnum ? $custnum : '' ),
2416     no_delay_cancel => 1,
2417   );
2418   if ($error) {
2419     $dbh->rollback if $oldAutoCommit;
2420     return "canceling old package: $error";
2421   }
2422
2423   if ( $conf->exists('cust_pkg-change_pkgpart-bill_now') ) {
2424     #$self->cust_main
2425     my $error = $cust_pkg->cust_main->bill(
2426       'pkg_list' => [ $cust_pkg, @new_supp_pkgs ]
2427     );
2428     if ( $error ) {
2429       $dbh->rollback if $oldAutoCommit;
2430       return "billing new package: $error";
2431     }
2432   }
2433
2434   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2435
2436   $cust_pkg;
2437
2438 }
2439
2440 =item change_later OPTION => VALUE...
2441
2442 Schedule a package change for a later date.  This actually orders the new
2443 package immediately, but sets its start date for a future date, and sets
2444 the current package to expire on the same date.
2445
2446 If the package is already scheduled for a change, this can be called with
2447 'start_date' to change the scheduled date, or with pkgpart and/or
2448 locationnum to modify the package change.  To cancel the scheduled change
2449 entirely, see C<abort_change>.
2450
2451 Options include:
2452
2453 =over 4
2454
2455 =item start_date
2456
2457 The date for the package change.  Required, and must be in the future.
2458
2459 =item pkgpart
2460
2461 =item locationnum
2462
2463 =item quantity
2464
2465 =item contract_end
2466
2467 The pkgpart, locationnum, quantity and optional contract_end of the new
2468 package, with the same meaning as in C<change>.
2469
2470 =back
2471
2472 =cut
2473
2474 sub change_later {
2475   my $self = shift;
2476   my $opt = ref($_[0]) ? shift : { @_ };
2477
2478   # check contract_end, prevent adding/removing
2479   my $error = $self->_check_change($opt);
2480   return $error if $error;
2481
2482   my $oldAutoCommit = $FS::UID::AutoCommit;
2483   local $FS::UID::AutoCommit = 0;
2484   my $dbh = dbh;
2485
2486   my $cust_main = $self->cust_main;
2487
2488   my $date = delete $opt->{'start_date'} or return 'start_date required';
2489
2490   if ( $date <= time ) {
2491     $dbh->rollback if $oldAutoCommit;
2492     return "start_date $date is in the past";
2493   }
2494
2495   if ( $self->change_to_pkgnum ) {
2496     my $change_to = FS::cust_pkg->by_key($self->change_to_pkgnum);
2497     my $new_pkgpart = $opt->{'pkgpart'}
2498         if $opt->{'pkgpart'} and $opt->{'pkgpart'} != $change_to->pkgpart;
2499     my $new_locationnum = $opt->{'locationnum'}
2500         if $opt->{'locationnum'} and $opt->{'locationnum'} != $change_to->locationnum;
2501     my $new_quantity = $opt->{'quantity'}
2502         if $opt->{'quantity'} and $opt->{'quantity'} != $change_to->quantity;
2503     my $new_contract_end = $opt->{'contract_end'}
2504         if $opt->{'contract_end'} and $opt->{'contract_end'} != $change_to->contract_end;
2505     if ( $new_pkgpart or $new_locationnum or $new_quantity or $new_contract_end ) {
2506       # it hasn't been billed yet, so in principle we could just edit
2507       # it in place (w/o a package change), but that's bad form.
2508       # So change the package according to the new options...
2509       my $err_or_pkg = $change_to->change(%$opt);
2510       if ( ref $err_or_pkg ) {
2511         # Then set that package up for a future start.
2512         $self->set('change_to_pkgnum', $err_or_pkg->pkgnum);
2513         $self->set('expire', $date); # in case it's different
2514         $err_or_pkg->set('start_date', $date);
2515         $err_or_pkg->set('change_date', '');
2516         $err_or_pkg->set('change_pkgnum', '');
2517
2518         $error = $self->replace       ||
2519                  $err_or_pkg->replace ||
2520                  #because change() might've edited existing scheduled change in place
2521                  (($err_or_pkg->pkgnum == $change_to->pkgnum) ? '' :
2522                   $change_to->cancel('no_delay_cancel' => 1) ||
2523                   $change_to->delete);
2524       } else {
2525         $error = $err_or_pkg;
2526       }
2527     } else { # change the start date only.
2528       $self->set('expire', $date);
2529       $change_to->set('start_date', $date);
2530       $error = $self->replace || $change_to->replace;
2531     }
2532     if ( $error ) {
2533       $dbh->rollback if $oldAutoCommit;
2534       return $error;
2535     } else {
2536       $dbh->commit if $oldAutoCommit;
2537       return '';
2538     }
2539   } # if $self->change_to_pkgnum
2540
2541   my $new_pkgpart = $opt->{'pkgpart'}
2542       if $opt->{'pkgpart'} and $opt->{'pkgpart'} != $self->pkgpart;
2543   my $new_locationnum = $opt->{'locationnum'}
2544       if $opt->{'locationnum'} and $opt->{'locationnum'} != $self->locationnum;
2545   my $new_quantity = $opt->{'quantity'}
2546       if $opt->{'quantity'} and $opt->{'quantity'} != $self->quantity;
2547   my $new_contract_end = $opt->{'contract_end'}
2548       if $opt->{'contract_end'} and $opt->{'contract_end'} != $self->contract_end;
2549
2550   return '' unless $new_pkgpart or $new_locationnum or $new_quantity or $new_contract_end; # wouldn't do anything
2551
2552   # allow $opt->{'locationnum'} = '' to specifically set it to null
2553   # (i.e. customer default location)
2554   $opt->{'locationnum'} = $self->locationnum if !exists($opt->{'locationnum'});
2555
2556   my $new = FS::cust_pkg->new( {
2557     custnum     => $self->custnum,
2558     locationnum => $opt->{'locationnum'},
2559     start_date  => $date,
2560     map   {  $_ => ( $opt->{$_} || $self->$_() )  }
2561       qw( pkgpart quantity refnum salesnum contract_end )
2562   } );
2563   $error = $new->insert('change' => 1,
2564                         'allow_pkgpart' => ($new_pkgpart ? 0 : 1));
2565   if ( !$error ) {
2566     $self->set('change_to_pkgnum', $new->pkgnum);
2567     $self->set('expire', $date);
2568     $error = $self->replace;
2569   }
2570   if ( $error ) {
2571     $dbh->rollback if $oldAutoCommit;
2572   } else {
2573     $dbh->commit if $oldAutoCommit;
2574   }
2575
2576   $error;
2577 }
2578
2579 =item abort_change
2580
2581 Cancels a future package change scheduled by C<change_later>.
2582
2583 =cut
2584
2585 sub abort_change {
2586   my $self = shift;
2587   my $oldAutoCommit = $FS::UID::AutoCommit;
2588   local $FS::UID::AutoCommit = 0;
2589
2590   my $pkgnum = $self->change_to_pkgnum;
2591   my $change_to = FS::cust_pkg->by_key($pkgnum) if $pkgnum;
2592   my $error;
2593   $self->set('change_to_pkgnum', '');
2594   $self->set('expire', '');
2595   $error = $self->replace;
2596   if ( $change_to ) {
2597     $error ||= $change_to->cancel || $change_to->delete;
2598   }
2599
2600   if ( $oldAutoCommit ) {
2601     if ( $error ) {
2602       dbh->rollback;
2603     } else {
2604       dbh->commit;
2605     }
2606   }
2607
2608   return $error;
2609 }
2610
2611 =item set_quantity QUANTITY
2612
2613 Change the package's quantity field.  This is one of the few package properties
2614 that can safely be changed without canceling and reordering the package
2615 (because it doesn't affect tax eligibility).  Returns an error or an
2616 empty string.
2617
2618 =cut
2619
2620 sub set_quantity {
2621   my $self = shift;
2622   $self = $self->replace_old; # just to make sure
2623   $self->quantity(shift);
2624   $self->replace;
2625 }
2626
2627 =item set_salesnum SALESNUM
2628
2629 Change the package's salesnum (sales person) field.  This is one of the few
2630 package properties that can safely be changed without canceling and reordering
2631 the package (because it doesn't affect tax eligibility).  Returns an error or
2632 an empty string.
2633
2634 =cut
2635
2636 sub set_salesnum {
2637   my $self = shift;
2638   $self = $self->replace_old; # just to make sure
2639   $self->salesnum(shift);
2640   $self->replace;
2641   # XXX this should probably reassign any credit that's already been given
2642 }
2643
2644 =item modify_charge OPTIONS
2645
2646 Change the properties of a one-time charge.  The following properties can
2647 be changed this way:
2648 - pkg: the package description
2649 - classnum: the package class
2650 - additional: arrayref of additional invoice details to add to this package
2651
2652 and, I<if the charge has not yet been billed>:
2653 - start_date: the date when it will be billed
2654 - amount: the setup fee to be charged
2655 - quantity: the multiplier for the setup fee
2656 - separate_bill: whether to put the charge on a separate invoice
2657
2658 If you pass 'adjust_commission' => 1, and the classnum changes, and there are
2659 commission credits linked to this charge, they will be recalculated.
2660
2661 =cut
2662
2663 sub modify_charge {
2664   my $self = shift;
2665   my %opt = @_;
2666   my $part_pkg = $self->part_pkg;
2667   my $pkgnum = $self->pkgnum;
2668
2669   my $dbh = dbh;
2670   my $oldAutoCommit = $FS::UID::AutoCommit;
2671   local $FS::UID::AutoCommit = 0;
2672
2673   return "Can't use modify_charge except on one-time charges"
2674     unless $part_pkg->freq eq '0';
2675
2676   if ( length($opt{'pkg'}) and $part_pkg->pkg ne $opt{'pkg'} ) {
2677     $part_pkg->set('pkg', $opt{'pkg'});
2678   }
2679
2680   my %pkg_opt = $part_pkg->options;
2681   my $pkg_opt_modified = 0;
2682
2683   $opt{'additional'} ||= [];
2684   my $i;
2685   my @old_additional;
2686   foreach (grep /^additional/, keys %pkg_opt) {
2687     ($i) = ($_ =~ /^additional_info(\d+)$/);
2688     $old_additional[$i] = $pkg_opt{$_} if $i;
2689     delete $pkg_opt{$_};
2690   }
2691
2692   for ( $i = 0; exists($opt{'additional'}->[$i]); $i++ ) {
2693     $pkg_opt{ "additional_info$i" } = $opt{'additional'}->[$i];
2694     if (!exists($old_additional[$i])
2695         or $old_additional[$i] ne $opt{'additional'}->[$i])
2696     {
2697       $pkg_opt_modified = 1;
2698     }
2699   }
2700   $pkg_opt_modified = 1 if (scalar(@old_additional) - 1) != $i;
2701   $pkg_opt{'additional_count'} = $i if $i > 0;
2702
2703   my $old_classnum;
2704   if ( exists($opt{'classnum'}) and $part_pkg->classnum ne $opt{'classnum'} )
2705   {
2706     # remember it
2707     $old_classnum = $part_pkg->classnum;
2708     $part_pkg->set('classnum', $opt{'classnum'});
2709   }
2710
2711   if ( !$self->get('setup') ) {
2712     # not yet billed, so allow amount, setup_cost, quantity, start_date,
2713     # and separate_bill
2714
2715     if ( exists($opt{'amount'})
2716           and $part_pkg->option('setup_fee') != $opt{'amount'}
2717           and $opt{'amount'} > 0 ) {
2718
2719       $pkg_opt{'setup_fee'} = $opt{'amount'};
2720       $pkg_opt_modified = 1;
2721     }
2722
2723     if ( exists($opt{'setup_cost'})
2724           and $part_pkg->setup_cost != $opt{'setup_cost'}
2725           and $opt{'setup_cost'} > 0 ) {
2726
2727       $part_pkg->set('setup_cost', $opt{'setup_cost'});
2728     }
2729
2730     if ( exists($opt{'quantity'})
2731           and $opt{'quantity'} != $self->quantity
2732           and $opt{'quantity'} > 0 ) {
2733
2734       $self->set('quantity', $opt{'quantity'});
2735     }
2736
2737     if ( exists($opt{'start_date'})
2738           and $opt{'start_date'} != $self->start_date ) {
2739
2740       $self->set('start_date', $opt{'start_date'});
2741     }
2742
2743     if ( exists($opt{'separate_bill'})
2744           and $opt{'separate_bill'} ne $self->separate_bill ) {
2745
2746       $self->set('separate_bill', $opt{'separate_bill'});
2747     }
2748
2749
2750   } # else simply ignore them; the UI shouldn't allow editing the fields
2751
2752
2753   if ( exists($opt{'taxclass'})
2754           and $part_pkg->taxclass ne $opt{'taxclass'}) {
2755
2756       $part_pkg->set('taxclass', $opt{'taxclass'});
2757   }
2758
2759   my $error;
2760   if ( $part_pkg->modified or $pkg_opt_modified ) {
2761     # can we safely modify the package def?
2762     # Yes, if it's not available for purchase, and this is the only instance
2763     # of it.
2764     if ( $part_pkg->disabled
2765          and FS::cust_pkg->count('pkgpart = '.$part_pkg->pkgpart) == 1
2766          and FS::quotation_pkg->count('pkgpart = '.$part_pkg->pkgpart) == 0
2767        ) {
2768       $error = $part_pkg->replace( options => \%pkg_opt );
2769     } else {
2770       # clone it
2771       $part_pkg = $part_pkg->clone;
2772       $part_pkg->set('disabled' => 'Y');
2773       $error = $part_pkg->insert( options => \%pkg_opt );
2774       # and associate this as yet-unbilled package to the new package def
2775       $self->set('pkgpart' => $part_pkg->pkgpart);
2776     }
2777     if ( $error ) {
2778       $dbh->rollback if $oldAutoCommit;
2779       return $error;
2780     }
2781   }
2782
2783   if ($self->modified) { # for quantity or start_date change, or if we had
2784                          # to clone the existing package def
2785     my $error = $self->replace;
2786     return $error if $error;
2787   }
2788   if (defined $old_classnum) {
2789     # fix invoice grouping records
2790     my $old_catname = $old_classnum
2791                       ? FS::pkg_class->by_key($old_classnum)->categoryname
2792                       : '';
2793     my $new_catname = $opt{'classnum'}
2794                       ? $part_pkg->pkg_class->categoryname
2795                       : '';
2796     if ( $old_catname ne $new_catname ) {
2797       foreach my $cust_bill_pkg ($self->cust_bill_pkg) {
2798         # (there should only be one...)
2799         my @display = qsearch( 'cust_bill_pkg_display', {
2800             'billpkgnum'  => $cust_bill_pkg->billpkgnum,
2801             'section'     => $old_catname,
2802         });
2803         foreach (@display) {
2804           $_->set('section', $new_catname);
2805           $error = $_->replace;
2806           if ( $error ) {
2807             $dbh->rollback if $oldAutoCommit;
2808             return $error;
2809           }
2810         }
2811       } # foreach $cust_bill_pkg
2812     }
2813
2814     if ( $opt{'adjust_commission'} ) {
2815       # fix commission credits...tricky.
2816       foreach my $cust_event ($self->cust_event) {
2817         my $part_event = $cust_event->part_event;
2818         foreach my $table (qw(sales agent)) {
2819           my $class =
2820             "FS::part_event::Action::Mixin::credit_${table}_pkg_class";
2821           my $credit = qsearchs('cust_credit', {
2822               'eventnum' => $cust_event->eventnum,
2823           });
2824           if ( $part_event->isa($class) ) {
2825             # Yes, this results in current commission rates being applied
2826             # retroactively to a one-time charge.  For accounting purposes
2827             # there ought to be some kind of time limit on doing this.
2828             my $amount = $part_event->_calc_credit($self);
2829             if ( $credit and $credit->amount ne $amount ) {
2830               # Void the old credit.
2831               $error = $credit->void('Package class changed');
2832               if ( $error ) {
2833                 $dbh->rollback if $oldAutoCommit;
2834                 return "$error (adjusting commission credit)";
2835               }
2836             }
2837             # redo the event action to recreate the credit.
2838             local $@ = '';
2839             eval { $part_event->do_action( $self, $cust_event ) };
2840             if ( $@ ) {
2841               $dbh->rollback if $oldAutoCommit;
2842               return $@;
2843             }
2844           } # if $part_event->isa($class)
2845         } # foreach $table
2846       } # foreach $cust_event
2847     } # if $opt{'adjust_commission'}
2848   } # if defined $old_classnum
2849
2850   $dbh->commit if $oldAutoCommit;
2851   '';
2852 }
2853
2854
2855
2856 use Data::Dumper;
2857 sub process_bulk_cust_pkg {
2858   my $job = shift;
2859   my $param = shift;
2860   warn Dumper($param) if $DEBUG;
2861
2862   my $old_part_pkg = qsearchs('part_pkg',
2863                               { pkgpart => $param->{'old_pkgpart'} });
2864   my $new_part_pkg = qsearchs('part_pkg',
2865                               { pkgpart => $param->{'new_pkgpart'} });
2866   die "Must select a new package type\n" unless $new_part_pkg;
2867   #my $keep_dates = $param->{'keep_dates'} || 0;
2868   my $keep_dates = 1; # there is no good reason to turn this off
2869
2870   my $oldAutoCommit = $FS::UID::AutoCommit;
2871   local $FS::UID::AutoCommit = 0;
2872   my $dbh = dbh;
2873
2874   my @cust_pkgs = qsearch('cust_pkg', { 'pkgpart' => $param->{'old_pkgpart'} } );
2875
2876   my $i = 0;
2877   foreach my $old_cust_pkg ( @cust_pkgs ) {
2878     $i++;
2879     $job->update_statustext(int(100*$i/(scalar @cust_pkgs)));
2880     if ( $old_cust_pkg->getfield('cancel') ) {
2881       warn '[process_bulk_cust_pkg ] skipping canceled pkgnum '.
2882         $old_cust_pkg->pkgnum."\n"
2883         if $DEBUG;
2884       next;
2885     }
2886     warn '[process_bulk_cust_pkg] changing pkgnum '.$old_cust_pkg->pkgnum."\n"
2887       if $DEBUG;
2888     my $error = $old_cust_pkg->change(
2889       'pkgpart'     => $param->{'new_pkgpart'},
2890       'keep_dates'  => $keep_dates
2891     );
2892     if ( !ref($error) ) { # change returns the cust_pkg on success
2893       $dbh->rollback;
2894       die "Error changing pkgnum ".$old_cust_pkg->pkgnum.": '$error'\n";
2895     }
2896   }
2897   $dbh->commit if $oldAutoCommit;
2898   return;
2899 }
2900
2901 =item last_bill
2902
2903 Returns the last bill date, or if there is no last bill date, the setup date.
2904 Useful for billing metered services.
2905
2906 =cut
2907
2908 sub last_bill {
2909   my $self = shift;
2910   return $self->setfield('last_bill', $_[0]) if @_;
2911   return $self->getfield('last_bill') if $self->getfield('last_bill');
2912   my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
2913                                                   'edate'  => $self->bill,  } );
2914   $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
2915 }
2916
2917 =item last_cust_pkg_reason ACTION
2918
2919 Returns the most recent ACTION FS::cust_pkg_reason associated with the package.
2920 Returns false if there is no reason or the package is not currenly ACTION'd
2921 ACTION is one of adjourn, susp, cancel, or expire.
2922
2923 =cut
2924
2925 sub last_cust_pkg_reason {
2926   my ( $self, $action ) = ( shift, shift );
2927   my $date = $self->get($action);
2928   qsearchs( {
2929               'table' => 'cust_pkg_reason',
2930               'hashref' => { 'pkgnum' => $self->pkgnum,
2931                              'action' => substr(uc($action), 0, 1),
2932                              'date'   => $date,
2933                            },
2934               'order_by' => 'ORDER BY num DESC LIMIT 1',
2935            } );
2936 }
2937
2938 =item last_reason ACTION
2939
2940 Returns the most recent ACTION FS::reason associated with the package.
2941 Returns false if there is no reason or the package is not currenly ACTION'd
2942 ACTION is one of adjourn, susp, cancel, or expire.
2943
2944 =cut
2945
2946 sub last_reason {
2947   my $cust_pkg_reason = shift->last_cust_pkg_reason(@_);
2948   $cust_pkg_reason->reason
2949     if $cust_pkg_reason;
2950 }
2951
2952 =item part_pkg
2953
2954 Returns the definition for this billing item, as an FS::part_pkg object (see
2955 L<FS::part_pkg>).
2956
2957 =cut
2958
2959 sub part_pkg {
2960   my $self = shift;
2961   return $self->{'_pkgpart'} if $self->{'_pkgpart'};
2962   cluck "cust_pkg->part_pkg called" if $DEBUG > 1;
2963   qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
2964 }
2965
2966 =item old_cust_pkg
2967
2968 Returns the cancelled package this package was changed from, if any.
2969
2970 =cut
2971
2972 sub old_cust_pkg {
2973   my $self = shift;
2974   return '' unless $self->change_pkgnum;
2975   qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
2976 }
2977
2978 =item change_cust_main
2979
2980 Returns the customter this package was detached to, if any.
2981
2982 =cut
2983
2984 sub change_cust_main {
2985   my $self = shift;
2986   return '' unless $self->change_custnum;
2987   qsearchs('cust_main', { 'custnum' => $self->change_custnum } );
2988 }
2989
2990 =item calc_setup
2991
2992 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
2993 item.
2994
2995 =cut
2996
2997 sub calc_setup {
2998   my $self = shift;
2999   $self->part_pkg->calc_setup($self, @_);
3000 }
3001
3002 =item calc_recur
3003
3004 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
3005 item.
3006
3007 =cut
3008
3009 sub calc_recur {
3010   my $self = shift;
3011   $self->part_pkg->calc_recur($self, @_);
3012 }
3013
3014 =item base_setup
3015
3016 Calls the I<base_setup> of the FS::part_pkg object associated with this billing
3017 item.
3018
3019 =cut
3020
3021 sub base_setup {
3022   my $self = shift;
3023   $self->part_pkg->base_setup($self, @_);
3024 }
3025
3026 =item base_recur
3027
3028 Calls the I<base_recur> of the FS::part_pkg object associated with this billing
3029 item.
3030
3031 =cut
3032
3033 sub base_recur {
3034   my $self = shift;
3035   $self->part_pkg->base_recur($self, @_);
3036 }
3037
3038 =item calc_remain
3039
3040 Calls the I<calc_remain> of the FS::part_pkg object associated with this
3041 billing item.
3042
3043 =cut
3044
3045 sub calc_remain {
3046   my $self = shift;
3047   $self->part_pkg->calc_remain($self, @_);
3048 }
3049
3050 =item calc_cancel
3051
3052 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
3053 billing item.
3054
3055 =cut
3056
3057 sub calc_cancel {
3058   my $self = shift;
3059   $self->part_pkg->calc_cancel($self, @_);
3060 }
3061
3062 =item cust_bill_pkg
3063
3064 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
3065
3066 =cut
3067
3068 sub cust_bill_pkg {
3069   my $self = shift;
3070   qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
3071 }
3072
3073 =item cust_pkg_detail [ DETAILTYPE ]
3074
3075 Returns any customer package details for this package (see
3076 L<FS::cust_pkg_detail>).
3077
3078 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
3079
3080 =cut
3081
3082 sub cust_pkg_detail {
3083   my $self = shift;
3084   my %hash = ( 'pkgnum' => $self->pkgnum );
3085   $hash{detailtype} = shift if @_;
3086   qsearch({
3087     'table'    => 'cust_pkg_detail',
3088     'hashref'  => \%hash,
3089     'order_by' => 'ORDER BY weight, pkgdetailnum',
3090   });
3091 }
3092
3093 =item set_cust_pkg_detail DETAILTYPE [ DETAIL, DETAIL, ... ]
3094
3095 Sets customer package details for this package (see L<FS::cust_pkg_detail>).
3096
3097 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
3098
3099 If there is an error, returns the error, otherwise returns false.
3100
3101 =cut
3102
3103 sub set_cust_pkg_detail {
3104   my( $self, $detailtype, @details ) = @_;
3105
3106   my $oldAutoCommit = $FS::UID::AutoCommit;
3107   local $FS::UID::AutoCommit = 0;
3108   my $dbh = dbh;
3109
3110   foreach my $current ( $self->cust_pkg_detail($detailtype) ) {
3111     my $error = $current->delete;
3112     if ( $error ) {
3113       $dbh->rollback if $oldAutoCommit;
3114       return "error removing old detail: $error";
3115     }
3116   }
3117
3118   foreach my $detail ( @details ) {
3119     my $cust_pkg_detail = new FS::cust_pkg_detail {
3120       'pkgnum'     => $self->pkgnum,
3121       'detailtype' => $detailtype,
3122       'detail'     => $detail,
3123     };
3124     my $error = $cust_pkg_detail->insert;
3125     if ( $error ) {
3126       $dbh->rollback if $oldAutoCommit;
3127       return "error adding new detail: $error";
3128     }
3129
3130   }
3131
3132   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3133   '';
3134
3135 }
3136
3137 =item cust_event
3138
3139 Returns the customer billing events (see L<FS::cust_event>) for this invoice.
3140
3141 =cut
3142
3143 #false laziness w/cust_bill.pm
3144 sub cust_event {
3145   my $self = shift;
3146   qsearch({
3147     'table'     => 'cust_event',
3148     'addl_from' => 'JOIN part_event USING ( eventpart )',
3149     'hashref'   => { 'tablenum' => $self->pkgnum },
3150     'extra_sql' => " AND eventtable = 'cust_pkg' ",
3151   });
3152 }
3153
3154 =item num_cust_event
3155
3156 Returns the number of customer billing events (see L<FS::cust_event>) for this package.
3157
3158 =cut
3159
3160 #false laziness w/cust_bill.pm
3161 sub num_cust_event {
3162   my $self = shift;
3163   my $sql = "SELECT COUNT(*) ". $self->_from_cust_event_where;
3164   $self->_prep_ex($sql, $self->pkgnum)->fetchrow_arrayref->[0];
3165 }
3166
3167 =item exists_cust_event
3168
3169 Returns true if there are customer billing events (see L<FS::cust_event>) for this package.  More efficient than using num_cust_event.
3170
3171 =cut
3172
3173 sub exists_cust_event {
3174   my $self = shift;
3175   my $sql = "SELECT 1 ". $self->_from_cust_event_where. " LIMIT 1";
3176   my $row = $self->_prep_ex($sql, $self->pkgnum)->fetchrow_arrayref;
3177   $row ? $row->[0] : '';
3178 }
3179
3180 sub _from_cust_event_where {
3181   #my $self = shift;
3182   " FROM cust_event JOIN part_event USING ( eventpart ) ".
3183   "  WHERE tablenum = ? AND eventtable = 'cust_pkg' ";
3184 }
3185
3186 sub _prep_ex {
3187   my( $self, $sql, @args ) = @_;
3188   my $sth = dbh->prepare($sql) or die  dbh->errstr. " preparing $sql";
3189   $sth->execute(@args)         or die $sth->errstr. " executing $sql";
3190   $sth;
3191 }
3192
3193 =item part_pkg_currency_option OPTIONNAME
3194
3195 Returns a two item list consisting of the currency of this customer, if any,
3196 and a value for the provided option.  If the customer has a currency, the value
3197 is the option value the given name and the currency (see
3198 L<FS::part_pkg_currency>).  Otherwise, if the customer has no currency, is the
3199 regular option value for the given name (see L<FS::part_pkg_option>).
3200
3201 =cut
3202
3203 sub part_pkg_currency_option {
3204   my( $self, $optionname ) = @_;
3205   my $part_pkg = $self->part_pkg;
3206   if ( my $currency = $self->cust_main->currency ) {
3207     ($currency, $part_pkg->part_pkg_currency_option($currency, $optionname) );
3208   } else {
3209     ('', $part_pkg->option($optionname) );
3210   }
3211 }
3212
3213 =item cust_svc [ SVCPART ] (old, deprecated usage)
3214
3215 =item cust_svc [ OPTION => VALUE ... ] (current usage)
3216
3217 =item cust_svc_unsorted [ OPTION => VALUE ... ]
3218
3219 Returns the services for this package, as FS::cust_svc objects (see
3220 L<FS::cust_svc>).  Available options are svcpart and svcdb.  If either is
3221 spcififed, returns only the matching services.
3222
3223 As an optimization, use the cust_svc_unsorted version if you are not displaying
3224 the results.
3225
3226 =cut
3227
3228 sub cust_svc {
3229   my $self = shift;
3230   cluck "cust_pkg->cust_svc called" if $DEBUG > 2;
3231   $self->_sort_cust_svc( $self->cust_svc_unsorted_arrayref(@_) );
3232 }
3233
3234 sub cust_svc_unsorted {
3235   my $self = shift;
3236   @{ $self->cust_svc_unsorted_arrayref(@_) };
3237 }
3238
3239 sub cust_svc_unsorted_arrayref {
3240   my $self = shift;
3241
3242   return [] unless $self->num_cust_svc(@_);
3243
3244   my %opt = ();
3245   if ( @_ && $_[0] =~ /^\d+/ ) {
3246     $opt{svcpart} = shift;
3247   } elsif ( @_ && ref($_[0]) eq 'HASH' ) {
3248     %opt = %{ $_[0] };
3249   } elsif ( @_ ) {
3250     %opt = @_;
3251   }
3252
3253   my %search = (
3254     'table'   => 'cust_svc',
3255     'hashref' => { 'pkgnum' => $self->pkgnum },
3256   );
3257   if ( $opt{svcpart} ) {
3258     $search{hashref}->{svcpart} = $opt{'svcpart'};
3259   }
3260   if ( $opt{'svcdb'} ) {
3261     $search{addl_from} = ' LEFT JOIN part_svc USING ( svcpart ) ';
3262     $search{extra_sql} = ' AND svcdb = '. dbh->quote( $opt{'svcdb'} );
3263   }
3264
3265   [ qsearch(\%search) ];
3266
3267 }
3268
3269 =item overlimit [ SVCPART ]
3270
3271 Returns the services for this package which have exceeded their
3272 usage limit as FS::cust_svc objects (see L<FS::cust_svc>).  If a svcpart
3273 is specified, return only the matching services.
3274
3275 =cut
3276
3277 sub overlimit {
3278   my $self = shift;
3279   return () unless $self->num_cust_svc(@_);
3280   grep { $_->overlimit } $self->cust_svc(@_);
3281 }
3282
3283 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
3284
3285 Returns historical services for this package created before END TIMESTAMP and
3286 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
3287 (see L<FS::h_cust_svc>).  If MODE is 'I' (for 'invoice'), services with the
3288 I<pkg_svc.hidden> flag will be omitted.
3289
3290 =cut
3291
3292 sub h_cust_svc {
3293   my $self = shift;
3294   warn "$me _h_cust_svc called on $self\n"
3295     if $DEBUG;
3296
3297   my ($end, $start, $mode) = @_;
3298
3299   local($FS::Record::qsearch_qualify_columns) = 0;
3300
3301   my @cust_svc = $self->_sort_cust_svc(
3302     [ qsearch( 'h_cust_svc',
3303       { 'pkgnum' => $self->pkgnum, },
3304       FS::h_cust_svc->sql_h_search(@_),
3305     ) ]
3306   );
3307
3308   if ( defined($mode) && $mode eq 'I' ) {
3309     my %hidden_svcpart = map { $_->svcpart => $_->hidden } $self->part_svc;
3310     return grep { !$hidden_svcpart{$_->svcpart} } @cust_svc;
3311   } else {
3312     return @cust_svc;
3313   }
3314 }
3315
3316 sub _sort_cust_svc {
3317   my( $self, $arrayref ) = @_;
3318
3319   my $sort =
3320     sub ($$) { my ($a, $b) = @_; $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] };
3321
3322   my %pkg_svc = map { $_->svcpart => $_ }
3323                 qsearch( 'pkg_svc', { 'pkgpart' => $self->pkgpart } );
3324
3325   map  { $_->[0] }
3326   sort $sort
3327   map {
3328         my $pkg_svc = $pkg_svc{ $_->svcpart } || '';
3329         [ $_,
3330           $pkg_svc ? $pkg_svc->primary_svc : '',
3331           $pkg_svc ? $pkg_svc->quantity : 0,
3332         ];
3333       }
3334   @$arrayref;
3335
3336 }
3337
3338 =item num_cust_svc [ SVCPART ] (old, deprecated usage)
3339
3340 =item num_cust_svc [ OPTION => VALUE ... ] (current usage)
3341
3342 Returns the number of services for this package.  Available options are svcpart
3343 and svcdb.  If either is spcififed, returns only the matching services.
3344
3345 =cut
3346
3347 sub num_cust_svc {
3348   my $self = shift;
3349
3350   return $self->{'_num_cust_svc'}
3351     if !scalar(@_)
3352        && exists($self->{'_num_cust_svc'})
3353        && $self->{'_num_cust_svc'} =~ /\d/;
3354
3355   cluck "cust_pkg->num_cust_svc called, _num_cust_svc:".$self->{'_num_cust_svc'}
3356     if $DEBUG > 2;
3357
3358   my %opt = ();
3359   if ( @_ && $_[0] =~ /^\d+/ ) {
3360     $opt{svcpart} = shift;
3361   } elsif ( @_ && ref($_[0]) eq 'HASH' ) {
3362     %opt = %{ $_[0] };
3363   } elsif ( @_ ) {
3364     %opt = @_;
3365   }
3366
3367   my $select = 'SELECT COUNT(*) FROM cust_svc ';
3368   my $where = ' WHERE pkgnum = ? ';
3369   my @param = ($self->pkgnum);
3370
3371   if ( $opt{'svcpart'} ) {
3372     $where .= ' AND svcpart = ? ';
3373     push @param, $opt{'svcpart'};
3374   }
3375   if ( $opt{'svcdb'} ) {
3376     $select .= ' LEFT JOIN part_svc USING ( svcpart ) ';
3377     $where .= ' AND svcdb = ? ';
3378     push @param, $opt{'svcdb'};
3379   }
3380
3381   my $sth = dbh->prepare("$select $where") or die  dbh->errstr;
3382   $sth->execute(@param) or die $sth->errstr;
3383   $sth->fetchrow_arrayref->[0];
3384 }
3385
3386 =item available_part_svc
3387
3388 Returns a list of FS::part_svc objects representing services included in this
3389 package but not yet provisioned.  Each FS::part_svc object also has an extra
3390 field, I<num_avail>, which specifies the number of available services.
3391
3392 =cut
3393
3394 sub available_part_svc {
3395   my $self = shift;
3396
3397   my $pkg_quantity = $self->quantity || 1;
3398
3399   grep { $_->num_avail > 0 }
3400     map {
3401           my $part_svc = $_->part_svc;
3402           $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
3403             $pkg_quantity * $_->quantity - $self->num_cust_svc($_->svcpart);
3404
3405           # more evil encapsulation breakage
3406           if($part_svc->{'Hash'}{'num_avail'} > 0) {
3407             my @exports = $part_svc->part_export_did;
3408             $part_svc->{'Hash'}{'can_get_dids'} = scalar(@exports);
3409           }
3410
3411           $part_svc;
3412         }
3413       $self->part_pkg->pkg_svc;
3414 }
3415
3416 =item part_svc [ OPTION => VALUE ... ]
3417
3418 Returns a list of FS::part_svc objects representing provisioned and available
3419 services included in this package.  Each FS::part_svc object also has the
3420 following extra fields:
3421
3422 =over 4
3423
3424 =item num_cust_svc
3425
3426 (count)
3427
3428 =item num_avail
3429
3430 (quantity - count)
3431
3432 =item cust_pkg_svc
3433
3434 (services) - array reference containing the provisioned services, as cust_svc objects
3435
3436 =back
3437
3438 Accepts two options:
3439
3440 =over 4
3441
3442 =item summarize_size
3443
3444 If true, will omit the extra cust_pkg_svc option for objects where num_cust_svc
3445 is this size or greater.
3446
3447 =item hide_discontinued
3448
3449 If true, will omit looking for services that are no longer avaialble in the
3450 package definition.
3451
3452 =back
3453
3454 =cut
3455
3456 #svcnum
3457 #label -> ($cust_svc->label)[1]
3458
3459 sub part_svc {
3460   my $self = shift;
3461   my %opt = @_;
3462
3463   my $pkg_quantity = $self->quantity || 1;
3464
3465   #XXX some sort of sort order besides numeric by svcpart...
3466   my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
3467     my $pkg_svc = $_;
3468     my $part_svc = $pkg_svc->part_svc;
3469     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
3470     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
3471     $part_svc->{'Hash'}{'num_avail'}    =
3472       max( 0, $pkg_quantity * $pkg_svc->quantity - $num_cust_svc );
3473     $part_svc->{'Hash'}{'cust_pkg_svc'} =
3474         $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : []
3475       unless exists($opt{summarize_size}) && $opt{summarize_size} > 0
3476           && $num_cust_svc >= $opt{summarize_size};
3477     $part_svc->{'Hash'}{'hidden'} = $pkg_svc->hidden;
3478     $part_svc;
3479   } $self->part_pkg->pkg_svc;
3480
3481   unless ( $opt{hide_discontinued} ) {
3482     #extras
3483     push @part_svc, map {
3484       my $part_svc = $_;
3485       my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
3486       $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
3487       $part_svc->{'Hash'}{'num_avail'}    = 0; #0-$num_cust_svc ?
3488       $part_svc->{'Hash'}{'cust_pkg_svc'} =
3489         $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
3490       $part_svc;
3491     } $self->extra_part_svc;
3492   }
3493
3494   @part_svc;
3495
3496 }
3497
3498 =item extra_part_svc
3499
3500 Returns a list of FS::part_svc objects corresponding to services in this
3501 package which are still provisioned but not (any longer) available in the
3502 package definition.
3503
3504 =cut
3505
3506 sub extra_part_svc {
3507   my $self = shift;
3508
3509   my $pkgnum  = $self->pkgnum;
3510   #my $pkgpart = $self->pkgpart;
3511
3512 #  qsearch( {
3513 #    'table'     => 'part_svc',
3514 #    'hashref'   => {},
3515 #    'extra_sql' =>
3516 #      "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
3517 #                     WHERE pkg_svc.svcpart = part_svc.svcpart
3518 #                       AND pkg_svc.pkgpart = ?
3519 #                       AND quantity > 0
3520 #                 )
3521 #        AND 0 < ( SELECT COUNT(*) FROM cust_svc
3522 #                       LEFT JOIN cust_pkg USING ( pkgnum )
3523 #                     WHERE cust_svc.svcpart = part_svc.svcpart
3524 #                       AND pkgnum = ?
3525 #                 )",
3526 #    'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
3527 #  } );
3528
3529 #seems to benchmark slightly faster... (or did?)
3530
3531   my @pkgparts = map $_->pkgpart, $self->part_pkg->self_and_svc_linked;
3532   my $pkgparts = join(',', @pkgparts);
3533
3534   qsearch( {
3535     #'select'      => 'DISTINCT ON (svcpart) part_svc.*',
3536     #MySQL doesn't grok DISINCT ON
3537     'select'      => 'DISTINCT part_svc.*',
3538     'table'       => 'part_svc',
3539     'addl_from'   =>
3540       "LEFT JOIN pkg_svc  ON (     pkg_svc.svcpart   = part_svc.svcpart
3541                                AND pkg_svc.pkgpart IN ($pkgparts)
3542                                AND quantity > 0
3543                              )
3544        LEFT JOIN cust_svc ON (     cust_svc.svcpart = part_svc.svcpart )
3545        LEFT JOIN cust_pkg USING ( pkgnum )
3546       ",
3547     'hashref'     => {},
3548     'extra_sql'   => "WHERE pkgsvcnum IS NULL AND cust_pkg.pkgnum = ? ",
3549     'extra_param' => [ [$self->pkgnum=>'int'] ],
3550   } );
3551 }
3552
3553 =item status
3554
3555 Returns a short status string for this package, currently:
3556
3557 =over 4
3558
3559 =item on hold
3560
3561 =item not yet billed
3562
3563 =item one-time charge
3564
3565 =item active
3566
3567 =item suspended
3568
3569 =item cancelled
3570
3571 =back
3572
3573 =cut
3574
3575 sub status {
3576   my $self = shift;
3577
3578   my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
3579
3580   return 'cancelled' if $self->get('cancel');
3581   return 'on hold' if $self->susp && ! $self->setup;
3582   return 'suspended' if $self->susp;
3583   return 'not yet billed' unless $self->setup;
3584   return 'one-time charge' if $freq =~ /^(0|$)/;
3585   return 'active';
3586 }
3587
3588 =item ucfirst_status
3589
3590 Returns the status with the first character capitalized.
3591
3592 =cut
3593
3594 sub ucfirst_status {
3595   ucfirst(shift->status);
3596 }
3597
3598 =item statuses
3599
3600 Class method that returns the list of possible status strings for packages
3601 (see L<the status method|/status>).  For example:
3602
3603   @statuses = FS::cust_pkg->statuses();
3604
3605 =cut
3606
3607 tie my %statuscolor, 'Tie::IxHash',
3608   'on hold'         => 'FF00F5', #brighter purple!
3609   'not yet billed'  => '009999', #teal? cyan?
3610   'one-time charge' => '0000CC', #blue  #'000000',
3611   'active'          => '00CC00',
3612   'suspended'       => 'FF9900',
3613   'cancelled'       => 'FF0000',
3614 ;
3615
3616 sub statuses {
3617   my $self = shift; #could be class...
3618   #grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
3619   #                                    # mayble split btw one-time vs. recur
3620     keys %statuscolor;
3621 }
3622
3623 sub statuscolors {
3624   #my $self = shift;
3625   \%statuscolor;
3626 }
3627
3628 =item statuscolor
3629
3630 Returns a hex triplet color string for this package's status.
3631
3632 =cut
3633
3634 sub statuscolor {
3635   my $self = shift;
3636   $statuscolor{$self->status};
3637 }
3638
3639 =item is_status_delay_cancel
3640
3641 Returns true if part_pkg has option delay_cancel,
3642 cust_pkg status is 'suspended' and expire is set
3643 to cancel package within the next day (or however
3644 many days are set in global config part_pkg-delay_cancel-days.
3645
3646 Accepts option I<part_pkg-delay_cancel-days> which should be
3647 the value of the config setting, to avoid looking it up again.
3648
3649 This is not a real status, this only meant for hacking display
3650 values, because otherwise treating the package as suspended is
3651 really the whole point of the delay_cancel option.
3652
3653 =cut
3654
3655 sub is_status_delay_cancel {
3656   my ($self,%opt) = @_;
3657   if ( $self->main_pkgnum and $self->pkglinknum ) {
3658     return $self->main_pkg->is_status_delay_cancel;
3659   }
3660   return 0 unless $self->part_pkg->option('delay_cancel',1);
3661   return 0 unless $self->status eq 'suspended';
3662   return 0 unless $self->expire;
3663   my $expdays = $opt{'part_pkg-delay_cancel-days'};
3664   unless ($expdays) {
3665     my $conf = new FS::Conf;
3666     $expdays = $conf->config('part_pkg-delay_cancel-days') || 1;
3667   }
3668   my $expsecs = 60*60*24*$expdays;
3669   return 0 unless $self->expire < time + $expsecs;
3670   return 1;
3671 }
3672
3673 =item pkg_label
3674
3675 Returns a label for this package.  (Currently "pkgnum: pkg - comment" or
3676 "pkg - comment" depending on user preference).
3677
3678 =cut
3679
3680 sub pkg_label {
3681   my $self = shift;
3682   my $label = $self->part_pkg->pkg_comment( cust_pkg=>$self, nopkgpart=>1 );
3683   $label = $self->pkgnum. ": $label"
3684     if $FS::CurrentUser::CurrentUser->option('show_pkgnum');
3685   $label;
3686 }
3687
3688 =item pkg_label_long
3689
3690 Returns a long label for this package, adding the primary service's label to
3691 pkg_label.
3692
3693 =cut
3694
3695 sub pkg_label_long {
3696   my $self = shift;
3697   my $label = $self->pkg_label;
3698   my $cust_svc = $self->primary_cust_svc;
3699   $label .= ' ('. ($cust_svc->label)[1]. ')' if $cust_svc;
3700   $label;
3701 }
3702
3703 =item pkg_locale
3704
3705 Returns a customer-localized label for this package.
3706
3707 =cut
3708
3709 sub pkg_locale {
3710   my $self = shift;
3711   $self->part_pkg->pkg_locale( $self->cust_main->locale );
3712 }
3713
3714 =item primary_cust_svc
3715
3716 Returns a primary service (as FS::cust_svc object) if one can be identified.
3717
3718 =cut
3719
3720 #for labeling purposes - might not 100% match up with part_pkg->svcpart's idea
3721
3722 sub primary_cust_svc {
3723   my $self = shift;
3724
3725   my @cust_svc = $self->cust_svc;
3726
3727   return '' unless @cust_svc; #no serivces - irrelevant then
3728
3729   return $cust_svc[0] if scalar(@cust_svc) == 1; #always return a single service
3730
3731   # primary service as specified in the package definition
3732   # or exactly one service definition with quantity one
3733   my $svcpart = $self->part_pkg->svcpart;
3734   @cust_svc = grep { $_->svcpart == $svcpart } @cust_svc;
3735   return $cust_svc[0] if scalar(@cust_svc) == 1;
3736
3737   #couldn't identify one thing..
3738   return '';
3739 }
3740
3741 =item labels
3742
3743 Returns a list of lists, calling the label method for all services
3744 (see L<FS::cust_svc>) of this billing item.
3745
3746 =cut
3747
3748 sub labels {
3749   my $self = shift;
3750   map { [ $_->label ] } $self->cust_svc;
3751 }
3752
3753 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
3754
3755 Like the labels method, but returns historical information on services that
3756 were active as of END_TIMESTAMP and (optionally) not cancelled before
3757 START_TIMESTAMP.  If MODE is 'I' (for 'invoice'), services with the
3758 I<pkg_svc.hidden> flag will be omitted.
3759
3760 Returns a list of lists, calling the label method for all (historical) services
3761 (see L<FS::h_cust_svc>) of this billing item.
3762
3763 =cut
3764
3765 sub h_labels {
3766   my $self = shift;
3767   warn "$me _h_labels called on $self\n"
3768     if $DEBUG;
3769   map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
3770 }
3771
3772 =item labels_short
3773
3774 Like labels, except returns a simple flat list, and shortens long
3775 (currently >5 or the cust_bill-max_same_services configuration value) lists of
3776 identical services to one line that lists the service label and the number of
3777 individual services rather than individual items.
3778
3779 =cut
3780
3781 sub labels_short {
3782   shift->_labels_short( 'labels', @_ );
3783 }
3784
3785 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
3786
3787 Like h_labels, except returns a simple flat list, and shortens long
3788 (currently >5 or the cust_bill-max_same_services configuration value) lists of
3789 identical services to one line that lists the service label and the number of
3790 individual services rather than individual items.
3791
3792 =cut
3793
3794 sub h_labels_short {
3795   shift->_labels_short( 'h_labels', @_ );
3796 }
3797
3798 sub _labels_short {
3799   my( $self, $method ) = ( shift, shift );
3800
3801   warn "$me _labels_short called on $self with $method method\n"
3802     if $DEBUG;
3803
3804   my $conf = new FS::Conf;
3805   my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
3806
3807   warn "$me _labels_short populating \%labels\n"
3808     if $DEBUG;
3809
3810   my %labels;
3811   #tie %labels, 'Tie::IxHash';
3812   push @{ $labels{$_->[0]} }, $_->[1]
3813     foreach $self->$method(@_);
3814
3815   warn "$me _labels_short populating \@labels\n"
3816     if $DEBUG;
3817
3818   my @labels;
3819   foreach my $label ( keys %labels ) {
3820     my %seen = ();
3821     my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
3822     my $num = scalar(@values);
3823     warn "$me _labels_short $num items for $label\n"
3824       if $DEBUG;
3825
3826     if ( $num > $max_same_services ) {
3827       warn "$me _labels_short   more than $max_same_services, so summarizing\n"
3828         if $DEBUG;
3829       push @labels, "$label ($num)";
3830     } else {
3831       if ( $conf->exists('cust_bill-consolidate_services') ) {
3832         warn "$me _labels_short   consolidating services\n"
3833           if $DEBUG;
3834         # push @labels, "$label: ". join(', ', @values);
3835         while ( @values ) {
3836           my $detail = "$label: ";
3837           $detail .= shift(@values). ', '
3838             while @values
3839                && ( length($detail.$values[0]) < 78 || $detail eq "$label: " );
3840           $detail =~ s/, $//;
3841           push @labels, $detail;
3842         }
3843         warn "$me _labels_short   done consolidating services\n"
3844           if $DEBUG;
3845       } else {
3846         warn "$me _labels_short   adding service data\n"
3847           if $DEBUG;
3848         push @labels, map { "$label: $_" } @values;
3849       }
3850     }
3851   }
3852
3853  @labels;
3854
3855 }
3856
3857 =item cust_main
3858
3859 Returns the parent customer object (see L<FS::cust_main>).
3860
3861 =item balance
3862
3863 Returns the balance for this specific package, when using
3864 experimental package balance.
3865
3866 =cut
3867
3868 sub balance {
3869   my $self = shift;
3870   $self->cust_main->balance_pkgnum( $self->pkgnum );
3871 }
3872
3873 #these subs are in location_Mixin.pm now... unfortunately the POD doesn't mixin
3874
3875 =item cust_location
3876
3877 Returns the location object, if any (see L<FS::cust_location>).
3878
3879 =item cust_location_or_main
3880
3881 If this package is associated with a location, returns the locaiton (see
3882 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
3883
3884 =item location_label [ OPTION => VALUE ... ]
3885
3886 Returns the label of the location object (see L<FS::cust_location>).
3887
3888 =cut
3889
3890 #end of subs in location_Mixin.pm now... unfortunately the POD doesn't mixin
3891
3892 =item tax_locationnum
3893
3894 Returns the foreign key to a L<FS::cust_location> object for calculating
3895 tax on this package, as determined by the C<tax-pkg_address> and
3896 C<tax-ship_address> configuration flags.
3897
3898 =cut
3899
3900 sub tax_locationnum {
3901   my $self = shift;
3902   my $conf = FS::Conf->new;
3903   if ( $conf->exists('tax-pkg_address') ) {
3904     return $self->locationnum;
3905   }
3906   elsif ( $conf->exists('tax-ship_address') ) {
3907     return $self->cust_main->ship_locationnum;
3908   }
3909   else {
3910     return $self->cust_main->bill_locationnum;
3911   }
3912 }
3913
3914 =item tax_location
3915
3916 Returns the L<FS::cust_location> object for tax_locationnum.
3917
3918 =cut
3919
3920 sub tax_location {
3921   my $self = shift;
3922   my $conf = FS::Conf->new;
3923   if ( $conf->exists('tax-pkg_address') and $self->locationnum ) {
3924     return FS::cust_location->by_key($self->locationnum);
3925   }
3926   elsif ( $conf->exists('tax-ship_address') ) {
3927     return $self->cust_main->ship_location;
3928   }
3929   else {
3930     return $self->cust_main->bill_location;
3931   }
3932 }
3933
3934 =item seconds_since TIMESTAMP
3935
3936 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
3937 package have been online since TIMESTAMP, according to the session monitor.
3938
3939 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
3940 L<Time::Local> and L<Date::Parse> for conversion functions.
3941
3942 =cut
3943
3944 sub seconds_since {
3945   my($self, $since) = @_;
3946   my $seconds = 0;
3947
3948   foreach my $cust_svc (
3949     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
3950   ) {
3951     $seconds += $cust_svc->seconds_since($since);
3952   }
3953
3954   $seconds;
3955
3956 }
3957
3958 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
3959
3960 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
3961 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
3962 (exclusive).
3963
3964 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
3965 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
3966 functions.
3967
3968
3969 =cut
3970
3971 sub seconds_since_sqlradacct {
3972   my($self, $start, $end) = @_;
3973
3974   my $seconds = 0;
3975
3976   foreach my $cust_svc (
3977     grep {
3978       my $part_svc = $_->part_svc;
3979       $part_svc->svcdb eq 'svc_acct'
3980         && scalar($part_svc->part_export_usage);
3981     } $self->cust_svc
3982   ) {
3983     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
3984   }
3985
3986   $seconds;
3987
3988 }
3989
3990 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
3991
3992 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
3993 in this package for sessions ending between TIMESTAMP_START (inclusive) and
3994 TIMESTAMP_END
3995 (exclusive).
3996
3997 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
3998 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
3999 functions.
4000
4001 =cut
4002
4003 sub attribute_since_sqlradacct {
4004   my($self, $start, $end, $attrib) = @_;
4005
4006   my $sum = 0;
4007
4008   foreach my $cust_svc (
4009     grep {
4010       my $part_svc = $_->part_svc;
4011       scalar($part_svc->part_export_usage);
4012     } $self->cust_svc
4013   ) {
4014     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
4015   }
4016
4017   $sum;
4018
4019 }
4020
4021 =item quantity
4022
4023 =cut
4024
4025 sub quantity {
4026   my( $self, $value ) = @_;
4027   if ( defined($value) ) {
4028     $self->setfield('quantity', $value);
4029   }
4030   $self->getfield('quantity') || 1;
4031 }
4032
4033 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
4034
4035 Transfers as many services as possible from this package to another package.
4036
4037 The destination package can be specified by pkgnum by passing an FS::cust_pkg
4038 object.  The destination package must already exist.
4039
4040 Services are moved only if the destination allows services with the correct
4041 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
4042 this option with caution!  No provision is made for export differences
4043 between the old and new service definitions.  Probably only should be used
4044 when your exports for all service definitions of a given svcdb are identical.
4045 (attempt a transfer without it first, to move all possible svcpart-matching
4046 services)
4047
4048 Any services that can't be moved remain in the original package.
4049
4050 Returns an error, if there is one; otherwise, returns the number of services
4051 that couldn't be moved.
4052
4053 =cut
4054
4055 sub transfer {
4056   my ($self, $dest_pkgnum, %opt) = @_;
4057
4058   my $remaining = 0;
4059   my $dest;
4060   my %target;
4061
4062   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
4063     $dest = $dest_pkgnum;
4064     $dest_pkgnum = $dest->pkgnum;
4065   } else {
4066     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
4067   }
4068
4069   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
4070
4071   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
4072     $target{$pkg_svc->svcpart} = $pkg_svc->quantity * ( $dest->quantity || 1 );
4073   }
4074
4075   foreach my $cust_svc ($dest->cust_svc) {
4076     $target{$cust_svc->svcpart}--;
4077   }
4078
4079   my %svcpart2svcparts = ();
4080   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
4081     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
4082     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
4083       next if exists $svcpart2svcparts{$svcpart};
4084       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
4085       $svcpart2svcparts{$svcpart} = [
4086         map  { $_->[0] }
4087         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
4088         map {
4089               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
4090                                                    'svcpart' => $_          } );
4091               [ $_,
4092                 $pkg_svc ? $pkg_svc->primary_svc : '',
4093                 $pkg_svc ? $pkg_svc->quantity : 0,
4094               ];
4095             }
4096
4097         grep { $_ != $svcpart }
4098         map  { $_->svcpart }
4099         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
4100       ];
4101       warn "alternates for svcpart $svcpart: ".
4102            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
4103         if $DEBUG;
4104     }
4105   }
4106
4107   my $error;
4108   foreach my $cust_svc ($self->cust_svc) {
4109     my $svcnum = $cust_svc->svcnum;
4110     if($target{$cust_svc->svcpart} > 0
4111        or $FS::cust_svc::ignore_quantity) { # maybe should be a 'force' option
4112       $target{$cust_svc->svcpart}--;
4113       my $new = new FS::cust_svc { $cust_svc->hash };
4114       $new->pkgnum($dest_pkgnum);
4115       $error = $new->replace($cust_svc);
4116     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
4117       if ( $DEBUG ) {
4118         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
4119         warn "alternates to consider: ".
4120              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
4121       }
4122       my @alternate = grep {
4123                              warn "considering alternate svcpart $_: ".
4124                                   "$target{$_} available in new package\n"
4125                                if $DEBUG;
4126                              $target{$_} > 0;
4127                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
4128       if ( @alternate ) {
4129         warn "alternate(s) found\n" if $DEBUG;
4130         my $change_svcpart = $alternate[0];
4131         $target{$change_svcpart}--;
4132         my $new = new FS::cust_svc { $cust_svc->hash };
4133         $new->svcpart($change_svcpart);
4134         $new->pkgnum($dest_pkgnum);
4135         $error = $new->replace($cust_svc);
4136       } else {
4137         $remaining++;
4138       }
4139     } else {
4140       $remaining++
4141     }
4142     if ( $error ) {
4143       my @label = $cust_svc->label;
4144       return "$label[0] $label[1]: $error";
4145     }
4146   }
4147   return $remaining;
4148 }
4149
4150 =item grab_svcnums SVCNUM, SVCNUM ...
4151
4152 Change the pkgnum for the provided services to this packages.  If there is an
4153 error, returns the error, otherwise returns false.
4154
4155 =cut
4156
4157 sub grab_svcnums {
4158   my $self = shift;
4159   my @svcnum = @_;
4160
4161   my $oldAutoCommit = $FS::UID::AutoCommit;
4162   local $FS::UID::AutoCommit = 0;
4163   my $dbh = dbh;
4164
4165   foreach my $svcnum (@svcnum) {
4166     my $cust_svc = qsearchs('cust_svc', { svcnum=>$svcnum } ) or do {
4167       $dbh->rollback if $oldAutoCommit;
4168       return "unknown svcnum $svcnum";
4169     };
4170     $cust_svc->pkgnum( $self->pkgnum );
4171     my $error = $cust_svc->replace;
4172     if ( $error ) {
4173       $dbh->rollback if $oldAutoCommit;
4174       return $error;
4175     }
4176   }
4177
4178   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4179   '';
4180
4181 }
4182
4183 =item reexport
4184
4185 This method is deprecated.  See the I<depend_jobnum> option to the insert and
4186 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
4187
4188 =cut
4189
4190 #looks like this is still used by the order_pkg and change_pkg methods in
4191 # ClientAPI/MyAccount, need to look into those before removing
4192 sub reexport {
4193   my $self = shift;
4194
4195   my $oldAutoCommit = $FS::UID::AutoCommit;
4196   local $FS::UID::AutoCommit = 0;
4197   my $dbh = dbh;
4198
4199   foreach my $cust_svc ( $self->cust_svc ) {
4200     #false laziness w/svc_Common::insert
4201     my $svc_x = $cust_svc->svc_x;
4202     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
4203       my $error = $part_export->export_insert($svc_x);
4204       if ( $error ) {
4205         $dbh->rollback if $oldAutoCommit;
4206         return $error;
4207       }
4208     }
4209   }
4210
4211   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4212   '';
4213
4214 }
4215
4216 =item export_pkg_change OLD_CUST_PKG
4217
4218 Calls the "pkg_change" export action for all services attached to this package.
4219
4220 =cut
4221
4222 sub export_pkg_change {
4223   my( $self, $old )  = ( shift, shift );
4224
4225   my $oldAutoCommit = $FS::UID::AutoCommit;
4226   local $FS::UID::AutoCommit = 0;
4227   my $dbh = dbh;
4228
4229   foreach my $svc_x ( map $_->svc_x, $self->cust_svc ) {
4230     my $error = $svc_x->export('pkg_change', $self, $old);
4231     if ( $error ) {
4232       $dbh->rollback if $oldAutoCommit;
4233       return $error;
4234     }
4235   }
4236
4237   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4238   '';
4239
4240 }
4241
4242 =item insert_reason
4243
4244 Associates this package with a (suspension or cancellation) reason (see
4245 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
4246 L<FS::reason>).
4247
4248 Available options are:
4249
4250 =over 4
4251
4252 =item reason
4253
4254 can be set to a cancellation reason (see L<FS:reason>), either a reasonnum of an existing reason, or passing a hashref will create a new reason.  The hashref should have the following keys: typenum - Reason type (see L<FS::reason_type>, reason - Text of the new reason.
4255
4256 =item reason_otaker
4257
4258 the access_user (see L<FS::access_user>) providing the reason
4259
4260 =item date
4261
4262 a unix timestamp
4263
4264 =item action
4265
4266 the action (cancel, susp, adjourn, expire) associated with the reason
4267
4268 =back
4269
4270 If there is an error, returns the error, otherwise returns false.
4271
4272 =cut
4273
4274 sub insert_reason {
4275   my ($self, %options) = @_;
4276
4277   my $otaker = $options{reason_otaker} ||
4278                $FS::CurrentUser::CurrentUser->username;
4279
4280   my $reasonnum;
4281   if ( $options{'reason'} =~ /^(\d+)$/ ) {
4282
4283     $reasonnum = $1;
4284
4285   } elsif ( ref($options{'reason'}) ) {
4286
4287     return 'Enter a new reason (or select an existing one)'
4288       unless $options{'reason'}->{'reason'} !~ /^\s*$/;
4289
4290     my $reason = new FS::reason({
4291       'reason_type' => $options{'reason'}->{'typenum'},
4292       'reason'      => $options{'reason'}->{'reason'},
4293     });
4294     my $error = $reason->insert;
4295     return $error if $error;
4296
4297     $reasonnum = $reason->reasonnum;
4298
4299   } else {
4300     return "Unparseable reason: ". $options{'reason'};
4301   }
4302
4303   my $cust_pkg_reason =
4304     new FS::cust_pkg_reason({ 'pkgnum'    => $self->pkgnum,
4305                               'reasonnum' => $reasonnum,
4306                               'otaker'    => $otaker,
4307                               'action'    => substr(uc($options{'action'}),0,1),
4308                               'date'      => $options{'date'}
4309                                                ? $options{'date'}
4310                                                : time,
4311                             });
4312
4313   $cust_pkg_reason->insert;
4314 }
4315
4316 =item insert_discount
4317
4318 Associates this package with a discount (see L<FS::cust_pkg_discount>, possibly
4319 inserting a new discount on the fly (see L<FS::discount>).
4320
4321 Available options are:
4322
4323 =over 4
4324
4325 =item discountnum
4326
4327 =back
4328
4329 If there is an error, returns the error, otherwise returns false.
4330
4331 =cut
4332
4333 sub insert_discount {
4334   #my ($self, %options) = @_;
4335   my $self = shift;
4336
4337   my $cust_pkg_discount = new FS::cust_pkg_discount {
4338     'pkgnum'      => $self->pkgnum,
4339     'discountnum' => $self->discountnum,
4340     'months_used' => 0,
4341     'end_date'    => '', #XXX
4342     #for the create a new discount case
4343     '_type'       => $self->discountnum__type,
4344     'amount'      => $self->discountnum_amount,
4345     'percent'     => $self->discountnum_percent,
4346     'months'      => $self->discountnum_months,
4347     'setup'      => $self->discountnum_setup,
4348     #'disabled'    => $self->discountnum_disabled,
4349   };
4350
4351   $cust_pkg_discount->insert;
4352 }
4353
4354 =item set_usage USAGE_VALUE_HASHREF
4355
4356 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
4357 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
4358 upbytes, downbytes, and totalbytes are appropriate keys.
4359
4360 All svc_accts which are part of this package have their values reset.
4361
4362 =cut
4363
4364 sub set_usage {
4365   my ($self, $valueref, %opt) = @_;
4366
4367   #only svc_acct can set_usage for now
4368   foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
4369     my $svc_x = $cust_svc->svc_x;
4370     $svc_x->set_usage($valueref, %opt)
4371       if $svc_x->can("set_usage");
4372   }
4373 }
4374
4375 =item recharge USAGE_VALUE_HASHREF
4376
4377 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
4378 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
4379 upbytes, downbytes, and totalbytes are appropriate keys.
4380
4381 All svc_accts which are part of this package have their values incremented.
4382
4383 =cut
4384
4385 sub recharge {
4386   my ($self, $valueref) = @_;
4387
4388   #only svc_acct can set_usage for now
4389   foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
4390     my $svc_x = $cust_svc->svc_x;
4391     $svc_x->recharge($valueref)
4392       if $svc_x->can("recharge");
4393   }
4394 }
4395
4396 =item apply_usageprice
4397
4398 =cut
4399
4400 sub apply_usageprice {
4401   my $self = shift;
4402
4403   my $oldAutoCommit = $FS::UID::AutoCommit;
4404   local $FS::UID::AutoCommit = 0;
4405   my $dbh = dbh;
4406
4407   my $error = '';
4408
4409   foreach my $cust_pkg_usageprice ( $self->cust_pkg_usageprice ) {
4410     $error ||= $cust_pkg_usageprice->apply;
4411   }
4412
4413   if ( $error ) {
4414     $dbh->rollback if $oldAutoCommit;
4415     die "error applying part_pkg_usageprice add-ons, pkgnum ". $self->pkgnum.
4416         ": $error\n";
4417   } else {
4418     $dbh->commit if $oldAutoCommit;
4419   }
4420
4421
4422 }
4423
4424 =item cust_pkg_discount
4425
4426 =item cust_pkg_discount_active
4427
4428 =cut
4429
4430 sub cust_pkg_discount_active {
4431   my $self = shift;
4432   grep { $_->status eq 'active' } $self->cust_pkg_discount;
4433 }
4434
4435 =item cust_pkg_usage
4436
4437 Returns a list of all voice usage counters attached to this package.
4438
4439 =item apply_usage OPTIONS
4440
4441 Takes the following options:
4442 - cdr: a call detail record (L<FS::cdr>)
4443 - rate_detail: the rate determined for this call (L<FS::rate_detail>)
4444 - minutes: the maximum number of minutes to be charged
4445
4446 Finds available usage minutes for a call of this class, and subtracts
4447 up to that many minutes from the usage pool.  If the usage pool is empty,
4448 and the C<cdr-minutes_priority> global config option is set, minutes may
4449 be taken from other calls as well.  Either way, an allocation record will
4450 be created (L<FS::cdr_cust_pkg_usage>) and this method will return the
4451 number of minutes of usage applied to the call.
4452
4453 =cut
4454
4455 sub apply_usage {
4456   my ($self, %opt) = @_;
4457   my $cdr = $opt{cdr};
4458   my $rate_detail = $opt{rate_detail};
4459   my $minutes = $opt{minutes};
4460   my $classnum = $rate_detail->classnum;
4461   my $pkgnum = $self->pkgnum;
4462   my $custnum = $self->custnum;
4463
4464   my $oldAutoCommit = $FS::UID::AutoCommit;
4465   local $FS::UID::AutoCommit = 0;
4466   my $dbh = dbh;
4467
4468   my $order = FS::Conf->new->config('cdr-minutes_priority');
4469
4470   my $is_classnum;
4471   if ( $classnum ) {
4472     $is_classnum = ' part_pkg_usage_class.classnum = '.$classnum;
4473   } else {
4474     $is_classnum = ' part_pkg_usage_class.classnum IS NULL';
4475   }
4476   my @usage_recs = qsearch({
4477       'table'     => 'cust_pkg_usage',
4478       'addl_from' => ' JOIN part_pkg_usage       USING (pkgusagepart)'.
4479                      ' JOIN cust_pkg             USING (pkgnum)'.
4480                      ' JOIN part_pkg_usage_class USING (pkgusagepart)',
4481       'select'    => 'cust_pkg_usage.*',
4482       'extra_sql' => " WHERE ( cust_pkg.pkgnum = $pkgnum OR ".
4483                      " ( cust_pkg.custnum = $custnum AND ".
4484                      " part_pkg_usage.shared IS NOT NULL ) ) AND ".
4485                      $is_classnum . ' AND '.
4486                      " cust_pkg_usage.minutes > 0",
4487       'order_by'  => " ORDER BY priority ASC",
4488   });
4489
4490   my $orig_minutes = $minutes;
4491   my $error;
4492   while (!$error and $minutes > 0 and @usage_recs) {
4493     my $cust_pkg_usage = shift @usage_recs;
4494     $cust_pkg_usage->select_for_update;
4495     my $cdr_cust_pkg_usage = FS::cdr_cust_pkg_usage->new({
4496         pkgusagenum => $cust_pkg_usage->pkgusagenum,
4497         acctid      => $cdr->acctid,
4498         minutes     => min($cust_pkg_usage->minutes, $minutes),
4499     });
4500     $cust_pkg_usage->set('minutes',
4501       $cust_pkg_usage->minutes - $cdr_cust_pkg_usage->minutes
4502     );
4503     $error = $cust_pkg_usage->replace || $cdr_cust_pkg_usage->insert;
4504     $minutes -= $cdr_cust_pkg_usage->minutes;
4505   }
4506   if ( $order and $minutes > 0 and !$error ) {
4507     # then try to steal minutes from another call
4508     my %search = (
4509         'table'     => 'cdr_cust_pkg_usage',
4510         'addl_from' => ' JOIN cust_pkg_usage        USING (pkgusagenum)'.
4511                        ' JOIN part_pkg_usage        USING (pkgusagepart)'.
4512                        ' JOIN cust_pkg              USING (pkgnum)'.
4513                        ' JOIN part_pkg_usage_class  USING (pkgusagepart)'.
4514                        ' JOIN cdr                   USING (acctid)',
4515         'select'    => 'cdr_cust_pkg_usage.*',
4516         'extra_sql' => " WHERE cdr.freesidestatus = 'rated' AND ".
4517                        " ( cust_pkg.pkgnum = $pkgnum OR ".
4518                        " ( cust_pkg.custnum = $custnum AND ".
4519                        " part_pkg_usage.shared IS NOT NULL ) ) AND ".
4520                        " part_pkg_usage_class.classnum = $classnum",
4521         'order_by'  => ' ORDER BY part_pkg_usage.priority ASC',
4522     );
4523     if ( $order eq 'time' ) {
4524       # find CDRs that are using minutes, but have a later startdate
4525       # than this call
4526       my $startdate = $cdr->startdate;
4527       if ($startdate !~ /^\d+$/) {
4528         die "bad cdr startdate '$startdate'";
4529       }
4530       $search{'extra_sql'} .= " AND cdr.startdate > $startdate";
4531       # minimize needless reshuffling
4532       $search{'order_by'} .= ', cdr.startdate DESC';
4533     } else {
4534       # XXX may not work correctly with rate_time schedules.  Could
4535       # fix this by storing ratedetailnum in cdr_cust_pkg_usage, I
4536       # think...
4537       $search{'addl_from'} .=
4538         ' JOIN rate_detail'.
4539         ' ON (cdr.rated_ratedetailnum = rate_detail.ratedetailnum)';
4540       if ( $order eq 'rate_high' ) {
4541         $search{'extra_sql'} .= ' AND rate_detail.min_charge < '.
4542                                 $rate_detail->min_charge;
4543         $search{'order_by'} .= ', rate_detail.min_charge ASC';
4544       } elsif ( $order eq 'rate_low' ) {
4545         $search{'extra_sql'} .= ' AND rate_detail.min_charge > '.
4546                                 $rate_detail->min_charge;
4547         $search{'order_by'} .= ', rate_detail.min_charge DESC';
4548       } else {
4549         #  this should really never happen
4550         die "invalid cdr-minutes_priority value '$order'\n";
4551       }
4552     }
4553     my @cdr_usage_recs = qsearch(\%search);
4554     my %reproc_cdrs;
4555     while (!$error and @cdr_usage_recs and $minutes > 0) {
4556       my $cdr_cust_pkg_usage = shift @cdr_usage_recs;
4557       my $cust_pkg_usage = $cdr_cust_pkg_usage->cust_pkg_usage;
4558       my $old_cdr = $cdr_cust_pkg_usage->cdr;
4559       $reproc_cdrs{$old_cdr->acctid} = $old_cdr;
4560       $cdr_cust_pkg_usage->select_for_update;
4561       $old_cdr->select_for_update;
4562       $cust_pkg_usage->select_for_update;
4563       # in case someone else stole the usage from this CDR
4564       # while waiting for the lock...
4565       next if $old_cdr->acctid != $cdr_cust_pkg_usage->acctid;
4566       # steal the usage allocation and flag the old CDR for reprocessing
4567       $cdr_cust_pkg_usage->set('acctid', $cdr->acctid);
4568       # if the allocation is more minutes than we need, adjust it...
4569       my $delta = $cdr_cust_pkg_usage->minutes - $minutes;
4570       if ( $delta > 0 ) {
4571         $cdr_cust_pkg_usage->set('minutes', $minutes);
4572         $cust_pkg_usage->set('minutes', $cust_pkg_usage->minutes + $delta);
4573         $error = $cust_pkg_usage->replace;
4574       }
4575       #warn 'CDR '.$cdr->acctid . ' stealing allocation '.$cdr_cust_pkg_usage->cdrusagenum.' from CDR '.$old_cdr->acctid."\n";
4576       $error ||= $cdr_cust_pkg_usage->replace;
4577       # deduct the stolen minutes
4578       $minutes -= $cdr_cust_pkg_usage->minutes;
4579     }
4580     # after all minute-stealing is done, reset the affected CDRs
4581     foreach (values %reproc_cdrs) {
4582       $error ||= $_->set_status('');
4583       # XXX or should we just call $cdr->rate right here?
4584       # it's not like we can create a loop this way, since the min_charge
4585       # or call time has to go monotonically in one direction.
4586       # we COULD get some very deep recursions going, though...
4587     }
4588   } # if $order and $minutes
4589   if ( $error ) {
4590     $dbh->rollback;
4591     die "error applying included minutes\npkgnum ".$self->pkgnum.", class $classnum, acctid ".$cdr->acctid."\n$error\n"
4592   } else {
4593     $dbh->commit if $oldAutoCommit;
4594     return $orig_minutes - $minutes;
4595   }
4596 }
4597
4598 =item supplemental_pkgs
4599
4600 Returns a list of all packages supplemental to this one.
4601
4602 =cut
4603
4604 sub supplemental_pkgs {
4605   my $self = shift;
4606   qsearch('cust_pkg', { 'main_pkgnum' => $self->pkgnum });
4607 }
4608
4609 =item main_pkg
4610
4611 Returns the package that this one is supplemental to, if any.
4612
4613 =cut
4614
4615 sub main_pkg {
4616   my $self = shift;
4617   if ( $self->main_pkgnum ) {
4618     return FS::cust_pkg->by_key($self->main_pkgnum);
4619   }
4620   return;
4621 }
4622
4623 =back
4624
4625 =head1 CLASS METHODS
4626
4627 =over 4
4628
4629 =item recurring_sql
4630
4631 Returns an SQL expression identifying recurring packages.
4632
4633 =cut
4634
4635 sub recurring_sql { "
4636   '0' != ( select freq from part_pkg
4637              where cust_pkg.pkgpart = part_pkg.pkgpart )
4638 "; }
4639
4640 =item onetime_sql
4641
4642 Returns an SQL expression identifying one-time packages.
4643
4644 =cut
4645
4646 sub onetime_sql { "
4647   '0' = ( select freq from part_pkg
4648             where cust_pkg.pkgpart = part_pkg.pkgpart )
4649 "; }
4650
4651 =item ordered_sql
4652
4653 Returns an SQL expression identifying ordered packages (recurring packages not
4654 yet billed).
4655
4656 =cut
4657
4658 sub ordered_sql {
4659    $_[0]->recurring_sql. " AND ". $_[0]->not_yet_billed_sql;
4660 }
4661
4662 =item active_sql
4663
4664 Returns an SQL expression identifying active packages.
4665
4666 =cut
4667
4668 sub active_sql {
4669   $_[0]->recurring_sql. "
4670   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
4671   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4672   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
4673 "; }
4674
4675 =item not_yet_billed_sql
4676
4677 Returns an SQL expression identifying packages which have not yet been billed.
4678
4679 =cut
4680
4681 sub not_yet_billed_sql { "
4682       ( cust_pkg.setup  IS NULL OR cust_pkg.setup  = 0 )
4683   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4684   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
4685 "; }
4686
4687 =item inactive_sql
4688
4689 Returns an SQL expression identifying inactive packages (one-time packages
4690 that are otherwise unsuspended/uncancelled).
4691
4692 =cut
4693
4694 sub inactive_sql { "
4695   ". $_[0]->onetime_sql(). "
4696   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
4697   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4698   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
4699 "; }
4700
4701 =item on_hold_sql
4702
4703 Returns an SQL expression identifying on-hold packages.
4704
4705 =cut
4706
4707 sub on_hold_sql {
4708   #$_[0]->recurring_sql(). ' AND '.
4709   "
4710         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel  = 0 )
4711     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp   != 0
4712     AND ( cust_pkg.setup  IS     NULL  OR cust_pkg.setup   = 0 )
4713   ";
4714 }
4715
4716 =item susp_sql
4717 =item suspended_sql
4718
4719 Returns an SQL expression identifying suspended packages.
4720
4721 =cut
4722
4723 sub suspended_sql { susp_sql(@_); }
4724 sub susp_sql {
4725   #$_[0]->recurring_sql(). ' AND '.
4726   "
4727         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
4728     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
4729     AND   cust_pkg.setup  IS NOT NULL AND cust_pkg.setup != 0
4730   ";
4731 }
4732
4733 =item cancel_sql
4734 =item cancelled_sql
4735
4736 Returns an SQL exprression identifying cancelled packages.
4737
4738 =cut
4739
4740 sub cancelled_sql { cancel_sql(@_); }
4741 sub cancel_sql {
4742   #$_[0]->recurring_sql(). ' AND '.
4743   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
4744 }
4745
4746 =item status_sql
4747
4748 Returns an SQL expression to give the package status as a string.
4749
4750 =cut
4751
4752 sub status_sql {
4753 "CASE
4754   WHEN cust_pkg.cancel IS NOT NULL THEN 'cancelled'
4755   WHEN ( cust_pkg.susp IS NOT NULL AND cust_pkg.setup IS NULL ) THEN 'on hold'
4756   WHEN cust_pkg.susp IS NOT NULL THEN 'suspended'
4757   WHEN cust_pkg.setup IS NULL THEN 'not yet billed'
4758   WHEN ".onetime_sql()." THEN 'one-time charge'
4759   ELSE 'active'
4760 END"
4761 }
4762
4763 =item fcc_477_count
4764
4765 Returns a list of two package counts.  The first is a count of packages
4766 based on the supplied criteria and the second is the count of residential
4767 packages with those same criteria.  Criteria are specified as in the search
4768 method.
4769
4770 =cut
4771
4772 sub fcc_477_count {
4773   my ($class, $params) = @_;
4774
4775   my $sql_query = $class->search( $params );
4776
4777   my $count_sql = delete($sql_query->{'count_query'});
4778   $count_sql =~ s/ FROM/,count(CASE WHEN cust_main.company IS NULL OR cust_main.company = '' THEN 1 END) FROM/
4779     or die "couldn't parse count_sql";
4780
4781   my $count_sth = dbh->prepare($count_sql)
4782     or die "Error preparing $count_sql: ". dbh->errstr;
4783   $count_sth->execute
4784     or die "Error executing $count_sql: ". $count_sth->errstr;
4785   my $count_arrayref = $count_sth->fetchrow_arrayref;
4786
4787   return ( @$count_arrayref );
4788
4789 }
4790
4791 =item tax_locationnum_sql
4792
4793 Returns an SQL expression for the tax location for a package, based
4794 on the settings of 'tax-pkg_address' and 'tax-ship_address'.
4795
4796 =cut
4797
4798 sub tax_locationnum_sql {
4799   my $conf = FS::Conf->new;
4800   if ( $conf->exists('tax-pkg_address') ) {
4801     'cust_pkg.locationnum';
4802   }
4803   elsif ( $conf->exists('tax-ship_address') ) {
4804     'cust_main.ship_locationnum';
4805   }
4806   else {
4807     'cust_main.bill_locationnum';
4808   }
4809 }
4810
4811 =item location_sql
4812
4813 Returns a list: the first item is an SQL fragment identifying matching
4814 packages/customers via location (taking into account shipping and package
4815 address taxation, if enabled), and subsequent items are the parameters to
4816 substitute for the placeholders in that fragment.
4817
4818 =cut
4819
4820 sub location_sql {
4821   my($class, %opt) = @_;
4822   my $ornull = $opt{'ornull'};
4823
4824   my $conf = new FS::Conf;
4825
4826   # '?' placeholders in _location_sql_where
4827   my $x = $ornull ? 3 : 2;
4828   my @bill_param = (
4829     ('district')x3,
4830     ('city')x3,
4831     ('county')x$x,
4832     ('state')x$x,
4833     'country'
4834   );
4835
4836   my $main_where;
4837   my @main_param;
4838   if ( $conf->exists('tax-ship_address') ) {
4839
4840     $main_where = "(
4841          (     ( ship_last IS NULL     OR  ship_last  = '' )
4842            AND ". _location_sql_where('cust_main', '', $ornull ). "
4843          )
4844       OR (       ship_last IS NOT NULL AND ship_last != ''
4845            AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
4846          )
4847     )";
4848     #    AND payby != 'COMP'
4849
4850     @main_param = ( @bill_param, @bill_param );
4851
4852   } else {
4853
4854     $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
4855     @main_param = @bill_param;
4856
4857   }
4858
4859   my $where;
4860   my @param;
4861   if ( $conf->exists('tax-pkg_address') ) {
4862
4863     my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
4864
4865     $where = " (
4866                     ( cust_pkg.locationnum IS     NULL AND $main_where )
4867                  OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where  )
4868                )
4869              ";
4870     @param = ( @main_param, @bill_param );
4871
4872   } else {
4873
4874     $where = $main_where;
4875     @param = @main_param;
4876
4877   }
4878
4879   ( $where, @param );
4880
4881 }
4882
4883 #subroutine, helper for location_sql
4884 sub _location_sql_where {
4885   my $table  = shift;
4886   my $prefix = @_ ? shift : '';
4887   my $ornull = @_ ? shift : '';
4888
4889 #  $ornull             = $ornull          ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
4890
4891   $ornull = $ornull ? ' OR ? IS NULL ' : '';
4892
4893   my $or_empty_city     = " OR ( ? = '' AND $table.${prefix}city     IS NULL )";
4894   my $or_empty_county   = " OR ( ? = '' AND $table.${prefix}county   IS NULL )";
4895   my $or_empty_state    = " OR ( ? = '' AND $table.${prefix}state    IS NULL )";
4896
4897   my $text = (driver_name =~ /^mysql/i) ? 'char' : 'text';
4898
4899 #        ( $table.${prefix}city    = ? $or_empty_city   $ornull )
4900   "
4901         ( $table.district = ? OR ? = '' OR CAST(? AS $text) IS NULL )
4902     AND ( $table.${prefix}city     = ? OR ? = '' OR CAST(? AS $text) IS NULL )
4903     AND ( $table.${prefix}county   = ? $or_empty_county $ornull )
4904     AND ( $table.${prefix}state    = ? $or_empty_state  $ornull )
4905     AND   $table.${prefix}country  = ?
4906   ";
4907 }
4908
4909 sub _X_show_zero {
4910   my( $self, $what ) = @_;
4911
4912   my $what_show_zero = $what. '_show_zero';
4913   length($self->$what_show_zero())
4914     ? ($self->$what_show_zero() eq 'Y')
4915     : $self->part_pkg->$what_show_zero();
4916 }
4917
4918 =head1 SUBROUTINES
4919
4920 =over 4
4921
4922 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
4923
4924 Bulk cancel + order subroutine.  Perhaps slightly deprecated, only used by the
4925 bulk cancel+order in the web UI and nowhere else (edit/process/cust_pkg.cgi)
4926
4927 CUSTNUM is a customer (see L<FS::cust_main>)
4928
4929 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
4930 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
4931 permitted.
4932
4933 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
4934 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
4935 new billing items.  An error is returned if this is not possible (see
4936 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
4937 parameter.
4938
4939 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
4940 newly-created cust_pkg objects.
4941
4942 REFNUM, if specified, will specify the FS::pkg_referral record to be created
4943 and inserted.  Multiple FS::pkg_referral records can be created by
4944 setting I<refnum> to an array reference of refnums or a hash reference with
4945 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
4946 record will be created corresponding to cust_main.refnum.
4947
4948 =cut
4949
4950 sub order {
4951   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
4952
4953   my $conf = new FS::Conf;
4954
4955   # Transactionize this whole mess
4956   my $oldAutoCommit = $FS::UID::AutoCommit;
4957   local $FS::UID::AutoCommit = 0;
4958   my $dbh = dbh;
4959
4960   my $error;
4961 #  my $cust_main = qsearchs('cust_main', { custnum => $custnum });
4962 #  return "Customer not found: $custnum" unless $cust_main;
4963
4964   warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
4965     if $DEBUG;
4966
4967   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
4968                          @$remove_pkgnum;
4969
4970   my $change = scalar(@old_cust_pkg) != 0;
4971
4972   my %hash = ();
4973   if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
4974
4975     warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
4976          " to pkgpart ". $pkgparts->[0]. "\n"
4977       if $DEBUG;
4978
4979     my $err_or_cust_pkg =
4980       $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
4981                                 'refnum'  => $refnum,
4982                               );
4983
4984     unless (ref($err_or_cust_pkg)) {
4985       $dbh->rollback if $oldAutoCommit;
4986       return $err_or_cust_pkg;
4987     }
4988
4989     push @$return_cust_pkg, $err_or_cust_pkg;
4990     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4991     return '';
4992
4993   }
4994
4995   # Create the new packages.
4996   foreach my $pkgpart (@$pkgparts) {
4997
4998     warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
4999
5000     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
5001                                       pkgpart => $pkgpart,
5002                                       refnum  => $refnum,
5003                                       %hash,
5004                                     };
5005     $error = $cust_pkg->insert( 'change' => $change );
5006     push @$return_cust_pkg, $cust_pkg;
5007
5008     foreach my $link ($cust_pkg->part_pkg->supp_part_pkg_link) {
5009       my $supp_pkg = FS::cust_pkg->new({
5010           custnum => $custnum,
5011           pkgpart => $link->dst_pkgpart,
5012           refnum  => $refnum,
5013           main_pkgnum => $cust_pkg->pkgnum,
5014           %hash,
5015       });
5016       $error ||= $supp_pkg->insert( 'change' => $change );
5017       push @$return_cust_pkg, $supp_pkg;
5018     }
5019
5020     if ($error) {
5021       $dbh->rollback if $oldAutoCommit;
5022       return $error;
5023     }
5024
5025   }
5026   # $return_cust_pkg now contains refs to all of the newly
5027   # created packages.
5028
5029   # Transfer services and cancel old packages.
5030   foreach my $old_pkg (@old_cust_pkg) {
5031
5032     warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
5033       if $DEBUG;
5034
5035     foreach my $new_pkg (@$return_cust_pkg) {
5036       $error = $old_pkg->transfer($new_pkg);
5037       if ($error and $error == 0) {
5038         # $old_pkg->transfer failed.
5039         $dbh->rollback if $oldAutoCommit;
5040         return $error;
5041       }
5042     }
5043
5044     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
5045       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
5046       foreach my $new_pkg (@$return_cust_pkg) {
5047         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
5048         if ($error and $error == 0) {
5049           # $old_pkg->transfer failed.
5050         $dbh->rollback if $oldAutoCommit;
5051         return $error;
5052         }
5053       }
5054     }
5055
5056     if ($error > 0) {
5057       # Transfers were successful, but we went through all of the
5058       # new packages and still had services left on the old package.
5059       # We can't cancel the package under the circumstances, so abort.
5060       $dbh->rollback if $oldAutoCommit;
5061       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
5062     }
5063     $error = $old_pkg->cancel( quiet=>1, 'no_delay_cancel'=>1 );
5064     if ($error) {
5065       $dbh->rollback;
5066       return $error;
5067     }
5068   }
5069   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
5070   '';
5071 }
5072
5073 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
5074
5075 A bulk change method to change packages for multiple customers.
5076
5077 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
5078 L<FS::part_pkg>) to order for each customer.  Duplicates are of course
5079 permitted.
5080
5081 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
5082 replace.  The services (see L<FS::cust_svc>) are moved to the
5083 new billing items.  An error is returned if this is not possible (see
5084 L<FS::pkg_svc>).
5085
5086 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
5087 newly-created cust_pkg objects.
5088
5089 =cut
5090
5091 sub bulk_change {
5092   my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
5093
5094   # Transactionize this whole mess
5095   my $oldAutoCommit = $FS::UID::AutoCommit;
5096   local $FS::UID::AutoCommit = 0;
5097   my $dbh = dbh;
5098
5099   my @errors;
5100   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
5101                          @$remove_pkgnum;
5102
5103   while(scalar(@old_cust_pkg)) {
5104     my @return = ();
5105     my $custnum = $old_cust_pkg[0]->custnum;
5106     my (@remove) = map { $_->pkgnum }
5107                    grep { $_->custnum == $custnum } @old_cust_pkg;
5108     @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
5109
5110     my $error = order $custnum, $pkgparts, \@remove, \@return;
5111
5112     push @errors, $error
5113       if $error;
5114     push @$return_cust_pkg, @return;
5115   }
5116
5117   if (scalar(@errors)) {
5118     $dbh->rollback if $oldAutoCommit;
5119     return join(' / ', @errors);
5120   }
5121
5122   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
5123   '';
5124 }
5125
5126 =item forward_emails
5127
5128 Returns a hash of svcnums and corresponding email addresses
5129 for svc_acct services that can be used as source or dest
5130 for svc_forward services provisioned in this package.
5131
5132 Accepts options I<svc_forward> OR I<svcnum> for a svc_forward
5133 service;  if included, will ensure the current values of the
5134 specified service are included in the list, even if for some
5135 other reason they wouldn't be.  If called as a class method
5136 with a specified service, returns only these current values.
5137
5138 Caution: does not actually check if svc_forward services are
5139 available to be provisioned on this package.
5140
5141 =cut
5142
5143 sub forward_emails {
5144   my $self = shift;
5145   my %opt = @_;
5146
5147   #load optional service, thoroughly validated
5148   die "Use svcnum or svc_forward, not both"
5149     if $opt{'svcnum'} && $opt{'svc_forward'};
5150   my $svc_forward = $opt{'svc_forward'};
5151   $svc_forward ||= qsearchs('svc_forward',{ 'svcnum' => $opt{'svcnum'} })
5152     if $opt{'svcnum'};
5153   die "Specified service is not a forward service"
5154     if $svc_forward && (ref($svc_forward) ne 'FS::svc_forward');
5155   die "Specified service not found"
5156     if ($opt{'svcnum'} || $opt{'svc_forward'}) && !$svc_forward;
5157
5158   my %email;
5159
5160   ## everything below was basically copied from httemplate/edit/svc_forward.cgi
5161   ## with minimal refactoring, not sure why we can't just load all svc_accts for this custnum
5162
5163   #add current values from specified service, if there was one
5164   if ($svc_forward) {
5165     foreach my $method (qw( srcsvc_acct dstsvc_acct )) {
5166       my $svc_acct = $svc_forward->$method();
5167       $email{$svc_acct->svcnum} = $svc_acct->email if $svc_acct;
5168     }
5169   }
5170
5171   if (ref($self) eq 'FS::cust_pkg') {
5172
5173     #and including the rest for this customer
5174     my($u_part_svc,@u_acct_svcparts);
5175     foreach $u_part_svc ( qsearch('part_svc',{'svcdb'=>'svc_acct'}) ) {
5176       push @u_acct_svcparts,$u_part_svc->getfield('svcpart');
5177     }
5178
5179     my $custnum = $self->getfield('custnum');
5180     foreach my $i_cust_pkg ( qsearch('cust_pkg',{'custnum'=>$custnum}) ) {
5181       my $cust_pkgnum = $i_cust_pkg->getfield('pkgnum');
5182       #now find the corresponding record(s) in cust_svc (for this pkgnum!)
5183       foreach my $acct_svcpart (@u_acct_svcparts) {
5184         foreach my $i_cust_svc (
5185           qsearch( 'cust_svc', { 'pkgnum'  => $cust_pkgnum,
5186                                  'svcpart' => $acct_svcpart } )
5187         ) {
5188           my $svc_acct = qsearchs( 'svc_acct', { 'svcnum' => $i_cust_svc->svcnum } );
5189           $email{$svc_acct->svcnum} = $svc_acct->email;
5190         }
5191       }
5192     }
5193   }
5194
5195   return %email;
5196 }
5197
5198 # Used by FS::Upgrade to migrate to a new database.
5199 sub _upgrade_data {  # class method
5200   my ($class, %opts) = @_;
5201   $class->_upgrade_otaker(%opts);
5202   my @statements = (
5203     # RT#10139, bug resulting in contract_end being set when it shouldn't
5204   'UPDATE cust_pkg SET contract_end = NULL WHERE contract_end = -1',
5205     # RT#10830, bad calculation of prorate date near end of year
5206     # the date range for bill is December 2009, and we move it forward
5207     # one year if it's before the previous bill date (which it should
5208     # never be)
5209   'UPDATE cust_pkg SET bill = bill + (365*24*60*60) WHERE bill < last_bill
5210   AND bill > 1259654400 AND bill < 1262332800 AND (SELECT plan FROM part_pkg
5211   WHERE part_pkg.pkgpart = cust_pkg.pkgpart) = \'prorate\'',
5212     # RT6628, add order_date to cust_pkg
5213     'update cust_pkg set order_date = (select history_date from h_cust_pkg
5214         where h_cust_pkg.pkgnum = cust_pkg.pkgnum and
5215         history_action = \'insert\') where order_date is null',
5216   );
5217   foreach my $sql (@statements) {
5218     my $sth = dbh->prepare($sql);
5219     $sth->execute or die $sth->errstr;
5220   }
5221
5222   # RT31194: supplemental package links that are deleted don't clean up
5223   # linked records
5224   my @pkglinknums = qsearch({
5225       'select'    => 'DISTINCT cust_pkg.pkglinknum',
5226       'table'     => 'cust_pkg',
5227       'addl_from' => ' LEFT JOIN part_pkg_link USING (pkglinknum) ',
5228       'extra_sql' => ' WHERE cust_pkg.pkglinknum IS NOT NULL
5229                         AND part_pkg_link.pkglinknum IS NULL',
5230   });
5231   foreach (@pkglinknums) {
5232     my $pkglinknum = $_->pkglinknum;
5233     warn "cleaning part_pkg_link #$pkglinknum\n";
5234     my $part_pkg_link = FS::part_pkg_link->new({pkglinknum => $pkglinknum});
5235     my $error = $part_pkg_link->remove_linked;
5236     die $error if $error;
5237   }
5238 }
5239
5240 =back
5241
5242 =head1 BUGS
5243
5244 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
5245
5246 In sub order, the @pkgparts array (passed by reference) is clobbered.
5247
5248 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
5249 method to pass dates to the recur_prog expression, it should do so.
5250
5251 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
5252 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
5253 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
5254 configuration values.  Probably need a subroutine which decides what to do
5255 based on whether or not we've fetched the user yet, rather than a hash.  See
5256 FS::UID and the TODO.
5257
5258 Now that things are transactional should the check in the insert method be
5259 moved to check ?
5260
5261 =head1 SEE ALSO
5262
5263 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
5264 L<FS::pkg_svc>, schema.html from the base documentation
5265
5266 =cut
5267
5268 1;
5269