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 or if they were specified
2300   if ( $same_pkgpart || $opt->{'cust_pkg_usageprice'}) {
2301     my @old_cust_pkg_usageprice;
2302     if ($opt->{'cust_pkg_usageprice'}) {
2303       @old_cust_pkg_usageprice = @{ $opt->{'cust_pkg_usageprice'} };
2304     } else {
2305       @old_cust_pkg_usageprice = $self->cust_pkg_usageprice;
2306     }
2307     foreach my $old_cust_pkg_usageprice (@old_cust_pkg_usageprice) {
2308       my $new_cust_pkg_usageprice = new FS::cust_pkg_usageprice {
2309         'pkgnum'         => $cust_pkg->pkgnum,
2310         'usagepricepart' => $old_cust_pkg_usageprice->usagepricepart,
2311         'quantity'       => $old_cust_pkg_usageprice->quantity,
2312       };
2313       $error = $new_cust_pkg_usageprice->insert;
2314       if ( $error ) {
2315         $dbh->rollback if $oldAutoCommit;
2316         return "Error transferring usage pricing add-on: $error";
2317       }
2318     }
2319   }
2320
2321   # transfer discounts, if we're not changing pkgpart
2322   if ( $same_pkgpart ) {
2323     foreach my $old_discount ($self->cust_pkg_discount_active) {
2324       # don't remove the old discount, we may still need to bill that package.
2325       my $new_discount = new FS::cust_pkg_discount {
2326         'pkgnum'      => $cust_pkg->pkgnum,
2327         'discountnum' => $old_discount->discountnum,
2328         'months_used' => $old_discount->months_used,
2329       };
2330       $error = $new_discount->insert;
2331       if ( $error ) {
2332         $dbh->rollback if $oldAutoCommit;
2333         return "transferring discounts: $error";
2334       }
2335     }
2336   }
2337
2338   # transfer (copy) invoice details
2339   foreach my $detail ($self->cust_pkg_detail) {
2340     my $new_detail = FS::cust_pkg_detail->new({ $detail->hash });
2341     $new_detail->set('pkgdetailnum', '');
2342     $new_detail->set('pkgnum', $cust_pkg->pkgnum);
2343     $error = $new_detail->insert;
2344     if ( $error ) {
2345       $dbh->rollback if $oldAutoCommit;
2346       return "transferring package notes: $error";
2347     }
2348   }
2349
2350   my @new_supp_pkgs;
2351
2352   if ( !$opt->{'cust_pkg'} ) {
2353     # Order any supplemental packages.
2354     my $part_pkg = $cust_pkg->part_pkg;
2355     my @old_supp_pkgs = $self->supplemental_pkgs;
2356     foreach my $link ($part_pkg->supp_part_pkg_link) {
2357       my $old;
2358       foreach (@old_supp_pkgs) {
2359         if ($_->pkgpart == $link->dst_pkgpart) {
2360           $old = $_;
2361           $_->pkgpart(0); # so that it can't match more than once
2362         }
2363         last if $old;
2364       }
2365       # false laziness with FS::cust_main::Packages::order_pkg
2366       my $new = FS::cust_pkg->new({
2367           pkgpart       => $link->dst_pkgpart,
2368           pkglinknum    => $link->pkglinknum,
2369           custnum       => $custnum,
2370           main_pkgnum   => $cust_pkg->pkgnum,
2371           locationnum   => $cust_pkg->locationnum,
2372           start_date    => $cust_pkg->start_date,
2373           order_date    => $cust_pkg->order_date,
2374           expire        => $cust_pkg->expire,
2375           adjourn       => $cust_pkg->adjourn,
2376           contract_end  => $cust_pkg->contract_end,
2377           refnum        => $cust_pkg->refnum,
2378           discountnum   => $cust_pkg->discountnum,
2379           waive_setup   => $cust_pkg->waive_setup,
2380       });
2381       if ( $old and $opt->{'keep_dates'} ) {
2382         foreach (qw(setup bill last_bill)) {
2383           $new->set($_, $old->get($_));
2384         }
2385       }
2386       $error = $new->insert( allow_pkgpart => $same_pkgpart );
2387       # transfer services
2388       if ( $old ) {
2389         $error ||= $old->transfer($new);
2390       }
2391       if ( $error and $error > 0 ) {
2392         # no reason why this should ever fail, but still...
2393         $error = "Unable to transfer all services from supplemental package ".
2394           $old->pkgnum;
2395       }
2396       if ( $error ) {
2397         $dbh->rollback if $oldAutoCommit;
2398         return $error;
2399       }
2400       push @new_supp_pkgs, $new;
2401     }
2402   } # if !$opt->{'cust_pkg'}
2403     # because if there is one, then supplemental packages would already
2404     # have been created for it.
2405
2406   #Good to go, cancel old package.  Notify 'cancel' of whether to credit
2407   #remaining time.
2408   #Don't allow billing the package (preceding period packages and/or
2409   #outstanding usage) if we are keeping dates (i.e. location changing),
2410   #because the new package will be billed for the same date range.
2411   #Supplemental packages are also canceled here.
2412
2413   # during scheduled changes, avoid canceling the package we just
2414   # changed to (duh)
2415   $self->set('change_to_pkgnum' => '');
2416
2417   $error = $self->cancel(
2418     quiet          => 1,
2419     unused_credit  => $unused_credit,
2420     nobill         => $keep_dates,
2421     change_custnum => ( $self->custnum != $custnum ? $custnum : '' ),
2422     no_delay_cancel => 1,
2423   );
2424   if ($error) {
2425     $dbh->rollback if $oldAutoCommit;
2426     return "canceling old package: $error";
2427   }
2428
2429   if ( $conf->exists('cust_pkg-change_pkgpart-bill_now') ) {
2430     #$self->cust_main
2431     my $error = $cust_pkg->cust_main->bill(
2432       'pkg_list' => [ $cust_pkg, @new_supp_pkgs ]
2433     );
2434     if ( $error ) {
2435       $dbh->rollback if $oldAutoCommit;
2436       return "billing new package: $error";
2437     }
2438   }
2439
2440   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2441
2442   $cust_pkg;
2443
2444 }
2445
2446 =item change_later OPTION => VALUE...
2447
2448 Schedule a package change for a later date.  This actually orders the new
2449 package immediately, but sets its start date for a future date, and sets
2450 the current package to expire on the same date.
2451
2452 If the package is already scheduled for a change, this can be called with
2453 'start_date' to change the scheduled date, or with pkgpart and/or
2454 locationnum to modify the package change.  To cancel the scheduled change
2455 entirely, see C<abort_change>.
2456
2457 Options include:
2458
2459 =over 4
2460
2461 =item start_date
2462
2463 The date for the package change.  Required, and must be in the future.
2464
2465 =item pkgpart
2466
2467 =item locationnum
2468
2469 =item quantity
2470
2471 =item contract_end
2472
2473 The pkgpart, locationnum, quantity and optional contract_end of the new
2474 package, with the same meaning as in C<change>.
2475
2476 =back
2477
2478 =cut
2479
2480 sub change_later {
2481   my $self = shift;
2482   my $opt = ref($_[0]) ? shift : { @_ };
2483
2484   # check contract_end, prevent adding/removing
2485   my $error = $self->_check_change($opt);
2486   return $error if $error;
2487
2488   my $oldAutoCommit = $FS::UID::AutoCommit;
2489   local $FS::UID::AutoCommit = 0;
2490   my $dbh = dbh;
2491
2492   my $cust_main = $self->cust_main;
2493
2494   my $date = delete $opt->{'start_date'} or return 'start_date required';
2495
2496   if ( $date <= time ) {
2497     $dbh->rollback if $oldAutoCommit;
2498     return "start_date $date is in the past";
2499   }
2500
2501   if ( $self->change_to_pkgnum ) {
2502     my $change_to = FS::cust_pkg->by_key($self->change_to_pkgnum);
2503     my $new_pkgpart = $opt->{'pkgpart'}
2504         if $opt->{'pkgpart'} and $opt->{'pkgpart'} != $change_to->pkgpart;
2505     my $new_locationnum = $opt->{'locationnum'}
2506         if $opt->{'locationnum'} and $opt->{'locationnum'} != $change_to->locationnum;
2507     my $new_quantity = $opt->{'quantity'}
2508         if $opt->{'quantity'} and $opt->{'quantity'} != $change_to->quantity;
2509     my $new_contract_end = $opt->{'contract_end'}
2510         if $opt->{'contract_end'} and $opt->{'contract_end'} != $change_to->contract_end;
2511     if ( $new_pkgpart or $new_locationnum or $new_quantity or $new_contract_end ) {
2512       # it hasn't been billed yet, so in principle we could just edit
2513       # it in place (w/o a package change), but that's bad form.
2514       # So change the package according to the new options...
2515       my $err_or_pkg = $change_to->change(%$opt);
2516       if ( ref $err_or_pkg ) {
2517         # Then set that package up for a future start.
2518         $self->set('change_to_pkgnum', $err_or_pkg->pkgnum);
2519         $self->set('expire', $date); # in case it's different
2520         $err_or_pkg->set('start_date', $date);
2521         $err_or_pkg->set('change_date', '');
2522         $err_or_pkg->set('change_pkgnum', '');
2523
2524         $error = $self->replace       ||
2525                  $err_or_pkg->replace ||
2526                  #because change() might've edited existing scheduled change in place
2527                  (($err_or_pkg->pkgnum == $change_to->pkgnum) ? '' :
2528                   $change_to->cancel('no_delay_cancel' => 1) ||
2529                   $change_to->delete);
2530       } else {
2531         $error = $err_or_pkg;
2532       }
2533     } else { # change the start date only.
2534       $self->set('expire', $date);
2535       $change_to->set('start_date', $date);
2536       $error = $self->replace || $change_to->replace;
2537     }
2538     if ( $error ) {
2539       $dbh->rollback if $oldAutoCommit;
2540       return $error;
2541     } else {
2542       $dbh->commit if $oldAutoCommit;
2543       return '';
2544     }
2545   } # if $self->change_to_pkgnum
2546
2547   my $new_pkgpart = $opt->{'pkgpart'}
2548       if $opt->{'pkgpart'} and $opt->{'pkgpart'} != $self->pkgpart;
2549   my $new_locationnum = $opt->{'locationnum'}
2550       if $opt->{'locationnum'} and $opt->{'locationnum'} != $self->locationnum;
2551   my $new_quantity = $opt->{'quantity'}
2552       if $opt->{'quantity'} and $opt->{'quantity'} != $self->quantity;
2553   my $new_contract_end = $opt->{'contract_end'}
2554       if $opt->{'contract_end'} and $opt->{'contract_end'} != $self->contract_end;
2555
2556   return '' unless $new_pkgpart or $new_locationnum or $new_quantity or $new_contract_end; # wouldn't do anything
2557
2558   # allow $opt->{'locationnum'} = '' to specifically set it to null
2559   # (i.e. customer default location)
2560   $opt->{'locationnum'} = $self->locationnum if !exists($opt->{'locationnum'});
2561
2562   my $new = FS::cust_pkg->new( {
2563     custnum     => $self->custnum,
2564     locationnum => $opt->{'locationnum'},
2565     start_date  => $date,
2566     map   {  $_ => ( $opt->{$_} || $self->$_() )  }
2567       qw( pkgpart quantity refnum salesnum contract_end )
2568   } );
2569   $error = $new->insert('change' => 1,
2570                         'allow_pkgpart' => ($new_pkgpart ? 0 : 1));
2571   if ( !$error ) {
2572     $self->set('change_to_pkgnum', $new->pkgnum);
2573     $self->set('expire', $date);
2574     $error = $self->replace;
2575   }
2576   if ( $error ) {
2577     $dbh->rollback if $oldAutoCommit;
2578   } else {
2579     $dbh->commit if $oldAutoCommit;
2580   }
2581
2582   $error;
2583 }
2584
2585 =item abort_change
2586
2587 Cancels a future package change scheduled by C<change_later>.
2588
2589 =cut
2590
2591 sub abort_change {
2592   my $self = shift;
2593   my $oldAutoCommit = $FS::UID::AutoCommit;
2594   local $FS::UID::AutoCommit = 0;
2595
2596   my $pkgnum = $self->change_to_pkgnum;
2597   my $change_to = FS::cust_pkg->by_key($pkgnum) if $pkgnum;
2598   my $error;
2599   $self->set('change_to_pkgnum', '');
2600   $self->set('expire', '');
2601   $error = $self->replace;
2602   if ( $change_to ) {
2603     $error ||= $change_to->cancel || $change_to->delete;
2604   }
2605
2606   if ( $oldAutoCommit ) {
2607     if ( $error ) {
2608       dbh->rollback;
2609     } else {
2610       dbh->commit;
2611     }
2612   }
2613
2614   return $error;
2615 }
2616
2617 =item set_quantity QUANTITY
2618
2619 Change the package's quantity field.  This is one of the few package properties
2620 that can safely be changed without canceling and reordering the package
2621 (because it doesn't affect tax eligibility).  Returns an error or an
2622 empty string.
2623
2624 =cut
2625
2626 sub set_quantity {
2627   my $self = shift;
2628   $self = $self->replace_old; # just to make sure
2629   $self->quantity(shift);
2630   $self->replace;
2631 }
2632
2633 =item set_salesnum SALESNUM
2634
2635 Change the package's salesnum (sales person) field.  This is one of the few
2636 package properties that can safely be changed without canceling and reordering
2637 the package (because it doesn't affect tax eligibility).  Returns an error or
2638 an empty string.
2639
2640 =cut
2641
2642 sub set_salesnum {
2643   my $self = shift;
2644   $self = $self->replace_old; # just to make sure
2645   $self->salesnum(shift);
2646   $self->replace;
2647   # XXX this should probably reassign any credit that's already been given
2648 }
2649
2650 =item modify_charge OPTIONS
2651
2652 Change the properties of a one-time charge.  The following properties can
2653 be changed this way:
2654 - pkg: the package description
2655 - classnum: the package class
2656 - additional: arrayref of additional invoice details to add to this package
2657
2658 and, I<if the charge has not yet been billed>:
2659 - start_date: the date when it will be billed
2660 - amount: the setup fee to be charged
2661 - quantity: the multiplier for the setup fee
2662 - separate_bill: whether to put the charge on a separate invoice
2663
2664 If you pass 'adjust_commission' => 1, and the classnum changes, and there are
2665 commission credits linked to this charge, they will be recalculated.
2666
2667 =cut
2668
2669 sub modify_charge {
2670   my $self = shift;
2671   my %opt = @_;
2672   my $part_pkg = $self->part_pkg;
2673   my $pkgnum = $self->pkgnum;
2674
2675   my $dbh = dbh;
2676   my $oldAutoCommit = $FS::UID::AutoCommit;
2677   local $FS::UID::AutoCommit = 0;
2678
2679   return "Can't use modify_charge except on one-time charges"
2680     unless $part_pkg->freq eq '0';
2681
2682   if ( length($opt{'pkg'}) and $part_pkg->pkg ne $opt{'pkg'} ) {
2683     $part_pkg->set('pkg', $opt{'pkg'});
2684   }
2685
2686   my %pkg_opt = $part_pkg->options;
2687   my $pkg_opt_modified = 0;
2688
2689   $opt{'additional'} ||= [];
2690   my $i;
2691   my @old_additional;
2692   foreach (grep /^additional/, keys %pkg_opt) {
2693     ($i) = ($_ =~ /^additional_info(\d+)$/);
2694     $old_additional[$i] = $pkg_opt{$_} if $i;
2695     delete $pkg_opt{$_};
2696   }
2697
2698   for ( $i = 0; exists($opt{'additional'}->[$i]); $i++ ) {
2699     $pkg_opt{ "additional_info$i" } = $opt{'additional'}->[$i];
2700     if (!exists($old_additional[$i])
2701         or $old_additional[$i] ne $opt{'additional'}->[$i])
2702     {
2703       $pkg_opt_modified = 1;
2704     }
2705   }
2706   $pkg_opt_modified = 1 if (scalar(@old_additional) - 1) != $i;
2707   $pkg_opt{'additional_count'} = $i if $i > 0;
2708
2709   my $old_classnum;
2710   if ( exists($opt{'classnum'}) and $part_pkg->classnum ne $opt{'classnum'} )
2711   {
2712     # remember it
2713     $old_classnum = $part_pkg->classnum;
2714     $part_pkg->set('classnum', $opt{'classnum'});
2715   }
2716
2717   if ( !$self->get('setup') ) {
2718     # not yet billed, so allow amount, setup_cost, quantity, start_date,
2719     # and separate_bill
2720
2721     if ( exists($opt{'amount'})
2722           and $part_pkg->option('setup_fee') != $opt{'amount'}
2723           and $opt{'amount'} > 0 ) {
2724
2725       $pkg_opt{'setup_fee'} = $opt{'amount'};
2726       $pkg_opt_modified = 1;
2727     }
2728
2729     if ( exists($opt{'setup_cost'})
2730           and $part_pkg->setup_cost != $opt{'setup_cost'}
2731           and $opt{'setup_cost'} > 0 ) {
2732
2733       $part_pkg->set('setup_cost', $opt{'setup_cost'});
2734     }
2735
2736     if ( exists($opt{'quantity'})
2737           and $opt{'quantity'} != $self->quantity
2738           and $opt{'quantity'} > 0 ) {
2739
2740       $self->set('quantity', $opt{'quantity'});
2741     }
2742
2743     if ( exists($opt{'start_date'})
2744           and $opt{'start_date'} != $self->start_date ) {
2745
2746       $self->set('start_date', $opt{'start_date'});
2747     }
2748
2749     if ( exists($opt{'separate_bill'})
2750           and $opt{'separate_bill'} ne $self->separate_bill ) {
2751
2752       $self->set('separate_bill', $opt{'separate_bill'});
2753     }
2754
2755
2756   } # else simply ignore them; the UI shouldn't allow editing the fields
2757
2758
2759   if ( exists($opt{'taxclass'})
2760           and $part_pkg->taxclass ne $opt{'taxclass'}) {
2761
2762       $part_pkg->set('taxclass', $opt{'taxclass'});
2763   }
2764
2765   my $error;
2766   if ( $part_pkg->modified or $pkg_opt_modified ) {
2767     # can we safely modify the package def?
2768     # Yes, if it's not available for purchase, and this is the only instance
2769     # of it.
2770     if ( $part_pkg->disabled
2771          and FS::cust_pkg->count('pkgpart = '.$part_pkg->pkgpart) == 1
2772          and FS::quotation_pkg->count('pkgpart = '.$part_pkg->pkgpart) == 0
2773        ) {
2774       $error = $part_pkg->replace( options => \%pkg_opt );
2775     } else {
2776       # clone it
2777       $part_pkg = $part_pkg->clone;
2778       $part_pkg->set('disabled' => 'Y');
2779       $error = $part_pkg->insert( options => \%pkg_opt );
2780       # and associate this as yet-unbilled package to the new package def
2781       $self->set('pkgpart' => $part_pkg->pkgpart);
2782     }
2783     if ( $error ) {
2784       $dbh->rollback if $oldAutoCommit;
2785       return $error;
2786     }
2787   }
2788
2789   if ($self->modified) { # for quantity or start_date change, or if we had
2790                          # to clone the existing package def
2791     my $error = $self->replace;
2792     return $error if $error;
2793   }
2794   if (defined $old_classnum) {
2795     # fix invoice grouping records
2796     my $old_catname = $old_classnum
2797                       ? FS::pkg_class->by_key($old_classnum)->categoryname
2798                       : '';
2799     my $new_catname = $opt{'classnum'}
2800                       ? $part_pkg->pkg_class->categoryname
2801                       : '';
2802     if ( $old_catname ne $new_catname ) {
2803       foreach my $cust_bill_pkg ($self->cust_bill_pkg) {
2804         # (there should only be one...)
2805         my @display = qsearch( 'cust_bill_pkg_display', {
2806             'billpkgnum'  => $cust_bill_pkg->billpkgnum,
2807             'section'     => $old_catname,
2808         });
2809         foreach (@display) {
2810           $_->set('section', $new_catname);
2811           $error = $_->replace;
2812           if ( $error ) {
2813             $dbh->rollback if $oldAutoCommit;
2814             return $error;
2815           }
2816         }
2817       } # foreach $cust_bill_pkg
2818     }
2819
2820     if ( $opt{'adjust_commission'} ) {
2821       # fix commission credits...tricky.
2822       foreach my $cust_event ($self->cust_event) {
2823         my $part_event = $cust_event->part_event;
2824         foreach my $table (qw(sales agent)) {
2825           my $class =
2826             "FS::part_event::Action::Mixin::credit_${table}_pkg_class";
2827           my $credit = qsearchs('cust_credit', {
2828               'eventnum' => $cust_event->eventnum,
2829           });
2830           if ( $part_event->isa($class) ) {
2831             # Yes, this results in current commission rates being applied
2832             # retroactively to a one-time charge.  For accounting purposes
2833             # there ought to be some kind of time limit on doing this.
2834             my $amount = $part_event->_calc_credit($self);
2835             if ( $credit and $credit->amount ne $amount ) {
2836               # Void the old credit.
2837               $error = $credit->void('Package class changed');
2838               if ( $error ) {
2839                 $dbh->rollback if $oldAutoCommit;
2840                 return "$error (adjusting commission credit)";
2841               }
2842             }
2843             # redo the event action to recreate the credit.
2844             local $@ = '';
2845             eval { $part_event->do_action( $self, $cust_event ) };
2846             if ( $@ ) {
2847               $dbh->rollback if $oldAutoCommit;
2848               return $@;
2849             }
2850           } # if $part_event->isa($class)
2851         } # foreach $table
2852       } # foreach $cust_event
2853     } # if $opt{'adjust_commission'}
2854   } # if defined $old_classnum
2855
2856   $dbh->commit if $oldAutoCommit;
2857   '';
2858 }
2859
2860
2861
2862 use Data::Dumper;
2863 sub process_bulk_cust_pkg {
2864   my $job = shift;
2865   my $param = shift;
2866   warn Dumper($param) if $DEBUG;
2867
2868   my $old_part_pkg = qsearchs('part_pkg',
2869                               { pkgpart => $param->{'old_pkgpart'} });
2870   my $new_part_pkg = qsearchs('part_pkg',
2871                               { pkgpart => $param->{'new_pkgpart'} });
2872   die "Must select a new package type\n" unless $new_part_pkg;
2873   #my $keep_dates = $param->{'keep_dates'} || 0;
2874   my $keep_dates = 1; # there is no good reason to turn this off
2875
2876   my $oldAutoCommit = $FS::UID::AutoCommit;
2877   local $FS::UID::AutoCommit = 0;
2878   my $dbh = dbh;
2879
2880   my @cust_pkgs = qsearch('cust_pkg', { 'pkgpart' => $param->{'old_pkgpart'} } );
2881
2882   my $i = 0;
2883   foreach my $old_cust_pkg ( @cust_pkgs ) {
2884     $i++;
2885     $job->update_statustext(int(100*$i/(scalar @cust_pkgs)));
2886     if ( $old_cust_pkg->getfield('cancel') ) {
2887       warn '[process_bulk_cust_pkg ] skipping canceled pkgnum '.
2888         $old_cust_pkg->pkgnum."\n"
2889         if $DEBUG;
2890       next;
2891     }
2892     warn '[process_bulk_cust_pkg] changing pkgnum '.$old_cust_pkg->pkgnum."\n"
2893       if $DEBUG;
2894     my $error = $old_cust_pkg->change(
2895       'pkgpart'     => $param->{'new_pkgpart'},
2896       'keep_dates'  => $keep_dates
2897     );
2898     if ( !ref($error) ) { # change returns the cust_pkg on success
2899       $dbh->rollback;
2900       die "Error changing pkgnum ".$old_cust_pkg->pkgnum.": '$error'\n";
2901     }
2902   }
2903   $dbh->commit if $oldAutoCommit;
2904   return;
2905 }
2906
2907 =item last_bill
2908
2909 Returns the last bill date, or if there is no last bill date, the setup date.
2910 Useful for billing metered services.
2911
2912 =cut
2913
2914 sub last_bill {
2915   my $self = shift;
2916   return $self->setfield('last_bill', $_[0]) if @_;
2917   return $self->getfield('last_bill') if $self->getfield('last_bill');
2918   my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
2919                                                   'edate'  => $self->bill,  } );
2920   $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
2921 }
2922
2923 =item last_cust_pkg_reason ACTION
2924
2925 Returns the most recent ACTION FS::cust_pkg_reason associated with the package.
2926 Returns false if there is no reason or the package is not currenly ACTION'd
2927 ACTION is one of adjourn, susp, cancel, or expire.
2928
2929 =cut
2930
2931 sub last_cust_pkg_reason {
2932   my ( $self, $action ) = ( shift, shift );
2933   my $date = $self->get($action);
2934   qsearchs( {
2935               'table' => 'cust_pkg_reason',
2936               'hashref' => { 'pkgnum' => $self->pkgnum,
2937                              'action' => substr(uc($action), 0, 1),
2938                              'date'   => $date,
2939                            },
2940               'order_by' => 'ORDER BY num DESC LIMIT 1',
2941            } );
2942 }
2943
2944 =item last_reason ACTION
2945
2946 Returns the most recent ACTION FS::reason associated with the package.
2947 Returns false if there is no reason or the package is not currenly ACTION'd
2948 ACTION is one of adjourn, susp, cancel, or expire.
2949
2950 =cut
2951
2952 sub last_reason {
2953   my $cust_pkg_reason = shift->last_cust_pkg_reason(@_);
2954   $cust_pkg_reason->reason
2955     if $cust_pkg_reason;
2956 }
2957
2958 =item part_pkg
2959
2960 Returns the definition for this billing item, as an FS::part_pkg object (see
2961 L<FS::part_pkg>).
2962
2963 =cut
2964
2965 sub part_pkg {
2966   my $self = shift;
2967   return $self->{'_pkgpart'} if $self->{'_pkgpart'};
2968   cluck "cust_pkg->part_pkg called" if $DEBUG > 1;
2969   qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
2970 }
2971
2972 =item old_cust_pkg
2973
2974 Returns the cancelled package this package was changed from, if any.
2975
2976 =cut
2977
2978 sub old_cust_pkg {
2979   my $self = shift;
2980   return '' unless $self->change_pkgnum;
2981   qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
2982 }
2983
2984 =item change_cust_main
2985
2986 Returns the customter this package was detached to, if any.
2987
2988 =cut
2989
2990 sub change_cust_main {
2991   my $self = shift;
2992   return '' unless $self->change_custnum;
2993   qsearchs('cust_main', { 'custnum' => $self->change_custnum } );
2994 }
2995
2996 =item calc_setup
2997
2998 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
2999 item.
3000
3001 =cut
3002
3003 sub calc_setup {
3004   my $self = shift;
3005   $self->part_pkg->calc_setup($self, @_);
3006 }
3007
3008 =item calc_recur
3009
3010 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
3011 item.
3012
3013 =cut
3014
3015 sub calc_recur {
3016   my $self = shift;
3017   $self->part_pkg->calc_recur($self, @_);
3018 }
3019
3020 =item base_setup
3021
3022 Calls the I<base_setup> of the FS::part_pkg object associated with this billing
3023 item.
3024
3025 =cut
3026
3027 sub base_setup {
3028   my $self = shift;
3029   $self->part_pkg->base_setup($self, @_);
3030 }
3031
3032 =item base_recur
3033
3034 Calls the I<base_recur> of the FS::part_pkg object associated with this billing
3035 item.
3036
3037 =cut
3038
3039 sub base_recur {
3040   my $self = shift;
3041   $self->part_pkg->base_recur($self, @_);
3042 }
3043
3044 =item calc_remain
3045
3046 Calls the I<calc_remain> of the FS::part_pkg object associated with this
3047 billing item.
3048
3049 =cut
3050
3051 sub calc_remain {
3052   my $self = shift;
3053   $self->part_pkg->calc_remain($self, @_);
3054 }
3055
3056 =item calc_cancel
3057
3058 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
3059 billing item.
3060
3061 =cut
3062
3063 sub calc_cancel {
3064   my $self = shift;
3065   $self->part_pkg->calc_cancel($self, @_);
3066 }
3067
3068 =item cust_bill_pkg
3069
3070 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
3071
3072 =cut
3073
3074 sub cust_bill_pkg {
3075   my $self = shift;
3076   qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
3077 }
3078
3079 =item cust_pkg_detail [ DETAILTYPE ]
3080
3081 Returns any customer package details for this package (see
3082 L<FS::cust_pkg_detail>).
3083
3084 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
3085
3086 =cut
3087
3088 sub cust_pkg_detail {
3089   my $self = shift;
3090   my %hash = ( 'pkgnum' => $self->pkgnum );
3091   $hash{detailtype} = shift if @_;
3092   qsearch({
3093     'table'    => 'cust_pkg_detail',
3094     'hashref'  => \%hash,
3095     'order_by' => 'ORDER BY weight, pkgdetailnum',
3096   });
3097 }
3098
3099 =item set_cust_pkg_detail DETAILTYPE [ DETAIL, DETAIL, ... ]
3100
3101 Sets customer package details for this package (see L<FS::cust_pkg_detail>).
3102
3103 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
3104
3105 If there is an error, returns the error, otherwise returns false.
3106
3107 =cut
3108
3109 sub set_cust_pkg_detail {
3110   my( $self, $detailtype, @details ) = @_;
3111
3112   my $oldAutoCommit = $FS::UID::AutoCommit;
3113   local $FS::UID::AutoCommit = 0;
3114   my $dbh = dbh;
3115
3116   foreach my $current ( $self->cust_pkg_detail($detailtype) ) {
3117     my $error = $current->delete;
3118     if ( $error ) {
3119       $dbh->rollback if $oldAutoCommit;
3120       return "error removing old detail: $error";
3121     }
3122   }
3123
3124   foreach my $detail ( @details ) {
3125     my $cust_pkg_detail = new FS::cust_pkg_detail {
3126       'pkgnum'     => $self->pkgnum,
3127       'detailtype' => $detailtype,
3128       'detail'     => $detail,
3129     };
3130     my $error = $cust_pkg_detail->insert;
3131     if ( $error ) {
3132       $dbh->rollback if $oldAutoCommit;
3133       return "error adding new detail: $error";
3134     }
3135
3136   }
3137
3138   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3139   '';
3140
3141 }
3142
3143 =item cust_event
3144
3145 Returns the customer billing events (see L<FS::cust_event>) for this invoice.
3146
3147 =cut
3148
3149 #false laziness w/cust_bill.pm
3150 sub cust_event {
3151   my $self = shift;
3152   qsearch({
3153     'table'     => 'cust_event',
3154     'addl_from' => 'JOIN part_event USING ( eventpart )',
3155     'hashref'   => { 'tablenum' => $self->pkgnum },
3156     'extra_sql' => " AND eventtable = 'cust_pkg' ",
3157   });
3158 }
3159
3160 =item num_cust_event
3161
3162 Returns the number of customer billing events (see L<FS::cust_event>) for this package.
3163
3164 =cut
3165
3166 #false laziness w/cust_bill.pm
3167 sub num_cust_event {
3168   my $self = shift;
3169   my $sql = "SELECT COUNT(*) ". $self->_from_cust_event_where;
3170   $self->_prep_ex($sql, $self->pkgnum)->fetchrow_arrayref->[0];
3171 }
3172
3173 =item exists_cust_event
3174
3175 Returns true if there are customer billing events (see L<FS::cust_event>) for this package.  More efficient than using num_cust_event.
3176
3177 =cut
3178
3179 sub exists_cust_event {
3180   my $self = shift;
3181   my $sql = "SELECT 1 ". $self->_from_cust_event_where. " LIMIT 1";
3182   my $row = $self->_prep_ex($sql, $self->pkgnum)->fetchrow_arrayref;
3183   $row ? $row->[0] : '';
3184 }
3185
3186 sub _from_cust_event_where {
3187   #my $self = shift;
3188   " FROM cust_event JOIN part_event USING ( eventpart ) ".
3189   "  WHERE tablenum = ? AND eventtable = 'cust_pkg' ";
3190 }
3191
3192 sub _prep_ex {
3193   my( $self, $sql, @args ) = @_;
3194   my $sth = dbh->prepare($sql) or die  dbh->errstr. " preparing $sql";
3195   $sth->execute(@args)         or die $sth->errstr. " executing $sql";
3196   $sth;
3197 }
3198
3199 =item part_pkg_currency_option OPTIONNAME
3200
3201 Returns a two item list consisting of the currency of this customer, if any,
3202 and a value for the provided option.  If the customer has a currency, the value
3203 is the option value the given name and the currency (see
3204 L<FS::part_pkg_currency>).  Otherwise, if the customer has no currency, is the
3205 regular option value for the given name (see L<FS::part_pkg_option>).
3206
3207 =cut
3208
3209 sub part_pkg_currency_option {
3210   my( $self, $optionname ) = @_;
3211   my $part_pkg = $self->part_pkg;
3212   if ( my $currency = $self->cust_main->currency ) {
3213     ($currency, $part_pkg->part_pkg_currency_option($currency, $optionname) );
3214   } else {
3215     ('', $part_pkg->option($optionname) );
3216   }
3217 }
3218
3219 =item cust_svc [ SVCPART ] (old, deprecated usage)
3220
3221 =item cust_svc [ OPTION => VALUE ... ] (current usage)
3222
3223 =item cust_svc_unsorted [ OPTION => VALUE ... ]
3224
3225 Returns the services for this package, as FS::cust_svc objects (see
3226 L<FS::cust_svc>).  Available options are svcpart and svcdb.  If either is
3227 spcififed, returns only the matching services.
3228
3229 As an optimization, use the cust_svc_unsorted version if you are not displaying
3230 the results.
3231
3232 =cut
3233
3234 sub cust_svc {
3235   my $self = shift;
3236   cluck "cust_pkg->cust_svc called" if $DEBUG > 2;
3237   $self->_sort_cust_svc( $self->cust_svc_unsorted_arrayref(@_) );
3238 }
3239
3240 sub cust_svc_unsorted {
3241   my $self = shift;
3242   @{ $self->cust_svc_unsorted_arrayref(@_) };
3243 }
3244
3245 sub cust_svc_unsorted_arrayref {
3246   my $self = shift;
3247
3248   return [] unless $self->num_cust_svc(@_);
3249
3250   my %opt = ();
3251   if ( @_ && $_[0] =~ /^\d+/ ) {
3252     $opt{svcpart} = shift;
3253   } elsif ( @_ && ref($_[0]) eq 'HASH' ) {
3254     %opt = %{ $_[0] };
3255   } elsif ( @_ ) {
3256     %opt = @_;
3257   }
3258
3259   my %search = (
3260     'table'   => 'cust_svc',
3261     'hashref' => { 'pkgnum' => $self->pkgnum },
3262   );
3263   if ( $opt{svcpart} ) {
3264     $search{hashref}->{svcpart} = $opt{'svcpart'};
3265   }
3266   if ( $opt{'svcdb'} ) {
3267     $search{addl_from} = ' LEFT JOIN part_svc USING ( svcpart ) ';
3268     $search{extra_sql} = ' AND svcdb = '. dbh->quote( $opt{'svcdb'} );
3269   }
3270
3271   [ qsearch(\%search) ];
3272
3273 }
3274
3275 =item overlimit [ SVCPART ]
3276
3277 Returns the services for this package which have exceeded their
3278 usage limit as FS::cust_svc objects (see L<FS::cust_svc>).  If a svcpart
3279 is specified, return only the matching services.
3280
3281 =cut
3282
3283 sub overlimit {
3284   my $self = shift;
3285   return () unless $self->num_cust_svc(@_);
3286   grep { $_->overlimit } $self->cust_svc(@_);
3287 }
3288
3289 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
3290
3291 Returns historical services for this package created before END TIMESTAMP and
3292 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
3293 (see L<FS::h_cust_svc>).  If MODE is 'I' (for 'invoice'), services with the
3294 I<pkg_svc.hidden> flag will be omitted.
3295
3296 =cut
3297
3298 sub h_cust_svc {
3299   my $self = shift;
3300   warn "$me _h_cust_svc called on $self\n"
3301     if $DEBUG;
3302
3303   my ($end, $start, $mode) = @_;
3304
3305   local($FS::Record::qsearch_qualify_columns) = 0;
3306
3307   my @cust_svc = $self->_sort_cust_svc(
3308     [ qsearch( 'h_cust_svc',
3309       { 'pkgnum' => $self->pkgnum, },
3310       FS::h_cust_svc->sql_h_search(@_),
3311     ) ]
3312   );
3313
3314   if ( defined($mode) && $mode eq 'I' ) {
3315     my %hidden_svcpart = map { $_->svcpart => $_->hidden } $self->part_svc;
3316     return grep { !$hidden_svcpart{$_->svcpart} } @cust_svc;
3317   } else {
3318     return @cust_svc;
3319   }
3320 }
3321
3322 sub _sort_cust_svc {
3323   my( $self, $arrayref ) = @_;
3324
3325   my $sort =
3326     sub ($$) { my ($a, $b) = @_; $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] };
3327
3328   my %pkg_svc = map { $_->svcpart => $_ }
3329                 qsearch( 'pkg_svc', { 'pkgpart' => $self->pkgpart } );
3330
3331   map  { $_->[0] }
3332   sort $sort
3333   map {
3334         my $pkg_svc = $pkg_svc{ $_->svcpart } || '';
3335         [ $_,
3336           $pkg_svc ? $pkg_svc->primary_svc : '',
3337           $pkg_svc ? $pkg_svc->quantity : 0,
3338         ];
3339       }
3340   @$arrayref;
3341
3342 }
3343
3344 =item num_cust_svc [ SVCPART ] (old, deprecated usage)
3345
3346 =item num_cust_svc [ OPTION => VALUE ... ] (current usage)
3347
3348 Returns the number of services for this package.  Available options are svcpart
3349 and svcdb.  If either is spcififed, returns only the matching services.
3350
3351 =cut
3352
3353 sub num_cust_svc {
3354   my $self = shift;
3355
3356   return $self->{'_num_cust_svc'}
3357     if !scalar(@_)
3358        && exists($self->{'_num_cust_svc'})
3359        && $self->{'_num_cust_svc'} =~ /\d/;
3360
3361   cluck "cust_pkg->num_cust_svc called, _num_cust_svc:".$self->{'_num_cust_svc'}
3362     if $DEBUG > 2;
3363
3364   my %opt = ();
3365   if ( @_ && $_[0] =~ /^\d+/ ) {
3366     $opt{svcpart} = shift;
3367   } elsif ( @_ && ref($_[0]) eq 'HASH' ) {
3368     %opt = %{ $_[0] };
3369   } elsif ( @_ ) {
3370     %opt = @_;
3371   }
3372
3373   my $select = 'SELECT COUNT(*) FROM cust_svc ';
3374   my $where = ' WHERE pkgnum = ? ';
3375   my @param = ($self->pkgnum);
3376
3377   if ( $opt{'svcpart'} ) {
3378     $where .= ' AND svcpart = ? ';
3379     push @param, $opt{'svcpart'};
3380   }
3381   if ( $opt{'svcdb'} ) {
3382     $select .= ' LEFT JOIN part_svc USING ( svcpart ) ';
3383     $where .= ' AND svcdb = ? ';
3384     push @param, $opt{'svcdb'};
3385   }
3386
3387   my $sth = dbh->prepare("$select $where") or die  dbh->errstr;
3388   $sth->execute(@param) or die $sth->errstr;
3389   $sth->fetchrow_arrayref->[0];
3390 }
3391
3392 =item available_part_svc
3393
3394 Returns a list of FS::part_svc objects representing services included in this
3395 package but not yet provisioned.  Each FS::part_svc object also has an extra
3396 field, I<num_avail>, which specifies the number of available services.
3397
3398 Accepts option I<provision_hold>;  if true, only returns part_svc for which the
3399 associated pkg_svc has the provision_hold flag set.
3400
3401 =cut
3402
3403 sub available_part_svc {
3404   my $self = shift;
3405   my %opt  = @_;
3406
3407   my $pkg_quantity = $self->quantity || 1;
3408
3409   grep { $_->num_avail > 0 }
3410   map {
3411     my $part_svc = $_->part_svc;
3412     $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
3413     $pkg_quantity * $_->quantity - $self->num_cust_svc($_->svcpart);
3414
3415     # more evil encapsulation breakage
3416     if ($part_svc->{'Hash'}{'num_avail'} > 0) {
3417       my @exports = $part_svc->part_export_did;
3418       $part_svc->{'Hash'}{'can_get_dids'} = scalar(@exports);
3419         }
3420
3421     $part_svc;
3422   }
3423   grep { $opt{'provision_hold'} ? $_->provision_hold : 1 }
3424   $self->part_pkg->pkg_svc;
3425 }
3426
3427 =item part_svc [ OPTION => VALUE ... ]
3428
3429 Returns a list of FS::part_svc objects representing provisioned and available
3430 services included in this package.  Each FS::part_svc object also has the
3431 following extra fields:
3432
3433 =over 4
3434
3435 =item num_cust_svc
3436
3437 (count)
3438
3439 =item num_avail
3440
3441 (quantity - count)
3442
3443 =item cust_pkg_svc
3444
3445 (services) - array reference containing the provisioned services, as cust_svc objects
3446
3447 =back
3448
3449 Accepts two options:
3450
3451 =over 4
3452
3453 =item summarize_size
3454
3455 If true, will omit the extra cust_pkg_svc option for objects where num_cust_svc
3456 is this size or greater.
3457
3458 =item hide_discontinued
3459
3460 If true, will omit looking for services that are no longer avaialble in the
3461 package definition.
3462
3463 =back
3464
3465 =cut
3466
3467 #svcnum
3468 #label -> ($cust_svc->label)[1]
3469
3470 sub part_svc {
3471   my $self = shift;
3472   my %opt = @_;
3473
3474   my $pkg_quantity = $self->quantity || 1;
3475
3476   #XXX some sort of sort order besides numeric by svcpart...
3477   my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
3478     my $pkg_svc = $_;
3479     my $part_svc = $pkg_svc->part_svc;
3480     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
3481     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
3482     $part_svc->{'Hash'}{'num_avail'}    =
3483       max( 0, $pkg_quantity * $pkg_svc->quantity - $num_cust_svc );
3484     $part_svc->{'Hash'}{'cust_pkg_svc'} =
3485         $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : []
3486       unless exists($opt{summarize_size}) && $opt{summarize_size} > 0
3487           && $num_cust_svc >= $opt{summarize_size};
3488     $part_svc->{'Hash'}{'hidden'} = $pkg_svc->hidden;
3489     $part_svc;
3490   } $self->part_pkg->pkg_svc;
3491
3492   unless ( $opt{hide_discontinued} ) {
3493     #extras
3494     push @part_svc, map {
3495       my $part_svc = $_;
3496       my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
3497       $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
3498       $part_svc->{'Hash'}{'num_avail'}    = 0; #0-$num_cust_svc ?
3499       $part_svc->{'Hash'}{'cust_pkg_svc'} =
3500         $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
3501       $part_svc;
3502     } $self->extra_part_svc;
3503   }
3504
3505   @part_svc;
3506
3507 }
3508
3509 =item extra_part_svc
3510
3511 Returns a list of FS::part_svc objects corresponding to services in this
3512 package which are still provisioned but not (any longer) available in the
3513 package definition.
3514
3515 =cut
3516
3517 sub extra_part_svc {
3518   my $self = shift;
3519
3520   my $pkgnum  = $self->pkgnum;
3521   #my $pkgpart = $self->pkgpart;
3522
3523 #  qsearch( {
3524 #    'table'     => 'part_svc',
3525 #    'hashref'   => {},
3526 #    'extra_sql' =>
3527 #      "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
3528 #                     WHERE pkg_svc.svcpart = part_svc.svcpart
3529 #                       AND pkg_svc.pkgpart = ?
3530 #                       AND quantity > 0
3531 #                 )
3532 #        AND 0 < ( SELECT COUNT(*) FROM cust_svc
3533 #                       LEFT JOIN cust_pkg USING ( pkgnum )
3534 #                     WHERE cust_svc.svcpart = part_svc.svcpart
3535 #                       AND pkgnum = ?
3536 #                 )",
3537 #    'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
3538 #  } );
3539
3540 #seems to benchmark slightly faster... (or did?)
3541
3542   my @pkgparts = map $_->pkgpart, $self->part_pkg->self_and_svc_linked;
3543   my $pkgparts = join(',', @pkgparts);
3544
3545   qsearch( {
3546     #'select'      => 'DISTINCT ON (svcpart) part_svc.*',
3547     #MySQL doesn't grok DISINCT ON
3548     'select'      => 'DISTINCT part_svc.*',
3549     'table'       => 'part_svc',
3550     'addl_from'   =>
3551       "LEFT JOIN pkg_svc  ON (     pkg_svc.svcpart   = part_svc.svcpart
3552                                AND pkg_svc.pkgpart IN ($pkgparts)
3553                                AND quantity > 0
3554                              )
3555        LEFT JOIN cust_svc ON (     cust_svc.svcpart = part_svc.svcpart )
3556        LEFT JOIN cust_pkg USING ( pkgnum )
3557       ",
3558     'hashref'     => {},
3559     'extra_sql'   => "WHERE pkgsvcnum IS NULL AND cust_pkg.pkgnum = ? ",
3560     'extra_param' => [ [$self->pkgnum=>'int'] ],
3561   } );
3562 }
3563
3564 =item status
3565
3566 Returns a short status string for this package, currently:
3567
3568 =over 4
3569
3570 =item on hold
3571
3572 =item not yet billed
3573
3574 =item one-time charge
3575
3576 =item active
3577
3578 =item suspended
3579
3580 =item cancelled
3581
3582 =back
3583
3584 =cut
3585
3586 sub status {
3587   my $self = shift;
3588
3589   my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
3590
3591   return 'cancelled' if $self->get('cancel');
3592   return 'on hold' if $self->susp && ! $self->setup;
3593   return 'suspended' if $self->susp;
3594   return 'not yet billed' unless $self->setup;
3595   return 'one-time charge' if $freq =~ /^(0|$)/;
3596   return 'active';
3597 }
3598
3599 =item ucfirst_status
3600
3601 Returns the status with the first character capitalized.
3602
3603 =cut
3604
3605 sub ucfirst_status {
3606   ucfirst(shift->status);
3607 }
3608
3609 =item statuses
3610
3611 Class method that returns the list of possible status strings for packages
3612 (see L<the status method|/status>).  For example:
3613
3614   @statuses = FS::cust_pkg->statuses();
3615
3616 =cut
3617
3618 tie my %statuscolor, 'Tie::IxHash',
3619   'on hold'         => 'FF00F5', #brighter purple!
3620   'not yet billed'  => '009999', #teal? cyan?
3621   'one-time charge' => '0000CC', #blue  #'000000',
3622   'active'          => '00CC00',
3623   'suspended'       => 'FF9900',
3624   'cancelled'       => 'FF0000',
3625 ;
3626
3627 sub statuses {
3628   my $self = shift; #could be class...
3629   #grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
3630   #                                    # mayble split btw one-time vs. recur
3631     keys %statuscolor;
3632 }
3633
3634 sub statuscolors {
3635   #my $self = shift;
3636   \%statuscolor;
3637 }
3638
3639 =item statuscolor
3640
3641 Returns a hex triplet color string for this package's status.
3642
3643 =cut
3644
3645 sub statuscolor {
3646   my $self = shift;
3647   $statuscolor{$self->status};
3648 }
3649
3650 =item is_status_delay_cancel
3651
3652 Returns true if part_pkg has option delay_cancel,
3653 cust_pkg status is 'suspended' and expire is set
3654 to cancel package within the next day (or however
3655 many days are set in global config part_pkg-delay_cancel-days.
3656
3657 Accepts option I<part_pkg-delay_cancel-days> which should be
3658 the value of the config setting, to avoid looking it up again.
3659
3660 This is not a real status, this only meant for hacking display
3661 values, because otherwise treating the package as suspended is
3662 really the whole point of the delay_cancel option.
3663
3664 =cut
3665
3666 sub is_status_delay_cancel {
3667   my ($self,%opt) = @_;
3668   if ( $self->main_pkgnum and $self->pkglinknum ) {
3669     return $self->main_pkg->is_status_delay_cancel;
3670   }
3671   return 0 unless $self->part_pkg->option('delay_cancel',1);
3672   return 0 unless $self->status eq 'suspended';
3673   return 0 unless $self->expire;
3674   my $expdays = $opt{'part_pkg-delay_cancel-days'};
3675   unless ($expdays) {
3676     my $conf = new FS::Conf;
3677     $expdays = $conf->config('part_pkg-delay_cancel-days') || 1;
3678   }
3679   my $expsecs = 60*60*24*$expdays;
3680   return 0 unless $self->expire < time + $expsecs;
3681   return 1;
3682 }
3683
3684 =item pkg_label
3685
3686 Returns a label for this package.  (Currently "pkgnum: pkg - comment" or
3687 "pkg - comment" depending on user preference).
3688
3689 =cut
3690
3691 sub pkg_label {
3692   my $self = shift;
3693   my $label = $self->part_pkg->pkg_comment( cust_pkg=>$self, nopkgpart=>1 );
3694   $label = $self->pkgnum. ": $label"
3695     if $FS::CurrentUser::CurrentUser->option('show_pkgnum');
3696   $label;
3697 }
3698
3699 =item pkg_label_long
3700
3701 Returns a long label for this package, adding the primary service's label to
3702 pkg_label.
3703
3704 =cut
3705
3706 sub pkg_label_long {
3707   my $self = shift;
3708   my $label = $self->pkg_label;
3709   my $cust_svc = $self->primary_cust_svc;
3710   $label .= ' ('. ($cust_svc->label)[1]. ')' if $cust_svc;
3711   $label;
3712 }
3713
3714 =item pkg_locale
3715
3716 Returns a customer-localized label for this package.
3717
3718 =cut
3719
3720 sub pkg_locale {
3721   my $self = shift;
3722   $self->part_pkg->pkg_locale( $self->cust_main->locale );
3723 }
3724
3725 =item primary_cust_svc
3726
3727 Returns a primary service (as FS::cust_svc object) if one can be identified.
3728
3729 =cut
3730
3731 #for labeling purposes - might not 100% match up with part_pkg->svcpart's idea
3732
3733 sub primary_cust_svc {
3734   my $self = shift;
3735
3736   my @cust_svc = $self->cust_svc;
3737
3738   return '' unless @cust_svc; #no serivces - irrelevant then
3739
3740   return $cust_svc[0] if scalar(@cust_svc) == 1; #always return a single service
3741
3742   # primary service as specified in the package definition
3743   # or exactly one service definition with quantity one
3744   my $svcpart = $self->part_pkg->svcpart;
3745   @cust_svc = grep { $_->svcpart == $svcpart } @cust_svc;
3746   return $cust_svc[0] if scalar(@cust_svc) == 1;
3747
3748   #couldn't identify one thing..
3749   return '';
3750 }
3751
3752 =item labels
3753
3754 Returns a list of lists, calling the label method for all services
3755 (see L<FS::cust_svc>) of this billing item.
3756
3757 =cut
3758
3759 sub labels {
3760   my $self = shift;
3761   map { [ $_->label ] } $self->cust_svc;
3762 }
3763
3764 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
3765
3766 Like the labels method, but returns historical information on services that
3767 were active as of END_TIMESTAMP and (optionally) not cancelled before
3768 START_TIMESTAMP.  If MODE is 'I' (for 'invoice'), services with the
3769 I<pkg_svc.hidden> flag will be omitted.
3770
3771 Returns a list of lists, calling the label method for all (historical) services
3772 (see L<FS::h_cust_svc>) of this billing item.
3773
3774 =cut
3775
3776 sub h_labels {
3777   my $self = shift;
3778   warn "$me _h_labels called on $self\n"
3779     if $DEBUG;
3780   map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
3781 }
3782
3783 =item labels_short
3784
3785 Like labels, except returns a simple flat list, and shortens long
3786 (currently >5 or the cust_bill-max_same_services configuration value) lists of
3787 identical services to one line that lists the service label and the number of
3788 individual services rather than individual items.
3789
3790 =cut
3791
3792 sub labels_short {
3793   shift->_labels_short( 'labels', @_ );
3794 }
3795
3796 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
3797
3798 Like h_labels, except returns a simple flat list, and shortens long
3799 (currently >5 or the cust_bill-max_same_services configuration value) lists of
3800 identical services to one line that lists the service label and the number of
3801 individual services rather than individual items.
3802
3803 =cut
3804
3805 sub h_labels_short {
3806   shift->_labels_short( 'h_labels', @_ );
3807 }
3808
3809 sub _labels_short {
3810   my( $self, $method ) = ( shift, shift );
3811
3812   warn "$me _labels_short called on $self with $method method\n"
3813     if $DEBUG;
3814
3815   my $conf = new FS::Conf;
3816   my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
3817
3818   warn "$me _labels_short populating \%labels\n"
3819     if $DEBUG;
3820
3821   my %labels;
3822   #tie %labels, 'Tie::IxHash';
3823   push @{ $labels{$_->[0]} }, $_->[1]
3824     foreach $self->$method(@_);
3825
3826   warn "$me _labels_short populating \@labels\n"
3827     if $DEBUG;
3828
3829   my @labels;
3830   foreach my $label ( keys %labels ) {
3831     my %seen = ();
3832     my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
3833     my $num = scalar(@values);
3834     warn "$me _labels_short $num items for $label\n"
3835       if $DEBUG;
3836
3837     if ( $num > $max_same_services ) {
3838       warn "$me _labels_short   more than $max_same_services, so summarizing\n"
3839         if $DEBUG;
3840       push @labels, "$label ($num)";
3841     } else {
3842       if ( $conf->exists('cust_bill-consolidate_services') ) {
3843         warn "$me _labels_short   consolidating services\n"
3844           if $DEBUG;
3845         # push @labels, "$label: ". join(', ', @values);
3846         while ( @values ) {
3847           my $detail = "$label: ";
3848           $detail .= shift(@values). ', '
3849             while @values
3850                && ( length($detail.$values[0]) < 78 || $detail eq "$label: " );
3851           $detail =~ s/, $//;
3852           push @labels, $detail;
3853         }
3854         warn "$me _labels_short   done consolidating services\n"
3855           if $DEBUG;
3856       } else {
3857         warn "$me _labels_short   adding service data\n"
3858           if $DEBUG;
3859         push @labels, map { "$label: $_" } @values;
3860       }
3861     }
3862   }
3863
3864  @labels;
3865
3866 }
3867
3868 =item cust_main
3869
3870 Returns the parent customer object (see L<FS::cust_main>).
3871
3872 =item balance
3873
3874 Returns the balance for this specific package, when using
3875 experimental package balance.
3876
3877 =cut
3878
3879 sub balance {
3880   my $self = shift;
3881   $self->cust_main->balance_pkgnum( $self->pkgnum );
3882 }
3883
3884 #these subs are in location_Mixin.pm now... unfortunately the POD doesn't mixin
3885
3886 =item cust_location
3887
3888 Returns the location object, if any (see L<FS::cust_location>).
3889
3890 =item cust_location_or_main
3891
3892 If this package is associated with a location, returns the locaiton (see
3893 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
3894
3895 =item location_label [ OPTION => VALUE ... ]
3896
3897 Returns the label of the location object (see L<FS::cust_location>).
3898
3899 =cut
3900
3901 #end of subs in location_Mixin.pm now... unfortunately the POD doesn't mixin
3902
3903 =item tax_locationnum
3904
3905 Returns the foreign key to a L<FS::cust_location> object for calculating
3906 tax on this package, as determined by the C<tax-pkg_address> and
3907 C<tax-ship_address> configuration flags.
3908
3909 =cut
3910
3911 sub tax_locationnum {
3912   my $self = shift;
3913   my $conf = FS::Conf->new;
3914   if ( $conf->exists('tax-pkg_address') ) {
3915     return $self->locationnum;
3916   }
3917   elsif ( $conf->exists('tax-ship_address') ) {
3918     return $self->cust_main->ship_locationnum;
3919   }
3920   else {
3921     return $self->cust_main->bill_locationnum;
3922   }
3923 }
3924
3925 =item tax_location
3926
3927 Returns the L<FS::cust_location> object for tax_locationnum.
3928
3929 =cut
3930
3931 sub tax_location {
3932   my $self = shift;
3933   my $conf = FS::Conf->new;
3934   if ( $conf->exists('tax-pkg_address') and $self->locationnum ) {
3935     return FS::cust_location->by_key($self->locationnum);
3936   }
3937   elsif ( $conf->exists('tax-ship_address') ) {
3938     return $self->cust_main->ship_location;
3939   }
3940   else {
3941     return $self->cust_main->bill_location;
3942   }
3943 }
3944
3945 =item seconds_since TIMESTAMP
3946
3947 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
3948 package have been online since TIMESTAMP, according to the session monitor.
3949
3950 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
3951 L<Time::Local> and L<Date::Parse> for conversion functions.
3952
3953 =cut
3954
3955 sub seconds_since {
3956   my($self, $since) = @_;
3957   my $seconds = 0;
3958
3959   foreach my $cust_svc (
3960     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
3961   ) {
3962     $seconds += $cust_svc->seconds_since($since);
3963   }
3964
3965   $seconds;
3966
3967 }
3968
3969 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
3970
3971 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
3972 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
3973 (exclusive).
3974
3975 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
3976 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
3977 functions.
3978
3979
3980 =cut
3981
3982 sub seconds_since_sqlradacct {
3983   my($self, $start, $end) = @_;
3984
3985   my $seconds = 0;
3986
3987   foreach my $cust_svc (
3988     grep {
3989       my $part_svc = $_->part_svc;
3990       $part_svc->svcdb eq 'svc_acct'
3991         && scalar($part_svc->part_export_usage);
3992     } $self->cust_svc
3993   ) {
3994     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
3995   }
3996
3997   $seconds;
3998
3999 }
4000
4001 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
4002
4003 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
4004 in this package for sessions ending between TIMESTAMP_START (inclusive) and
4005 TIMESTAMP_END
4006 (exclusive).
4007
4008 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
4009 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
4010 functions.
4011
4012 =cut
4013
4014 sub attribute_since_sqlradacct {
4015   my($self, $start, $end, $attrib) = @_;
4016
4017   my $sum = 0;
4018
4019   foreach my $cust_svc (
4020     grep {
4021       my $part_svc = $_->part_svc;
4022       scalar($part_svc->part_export_usage);
4023     } $self->cust_svc
4024   ) {
4025     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
4026   }
4027
4028   $sum;
4029
4030 }
4031
4032 =item quantity
4033
4034 =cut
4035
4036 sub quantity {
4037   my( $self, $value ) = @_;
4038   if ( defined($value) ) {
4039     $self->setfield('quantity', $value);
4040   }
4041   $self->getfield('quantity') || 1;
4042 }
4043
4044 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
4045
4046 Transfers as many services as possible from this package to another package.
4047
4048 The destination package can be specified by pkgnum by passing an FS::cust_pkg
4049 object.  The destination package must already exist.
4050
4051 Services are moved only if the destination allows services with the correct
4052 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
4053 this option with caution!  No provision is made for export differences
4054 between the old and new service definitions.  Probably only should be used
4055 when your exports for all service definitions of a given svcdb are identical.
4056 (attempt a transfer without it first, to move all possible svcpart-matching
4057 services)
4058
4059 Any services that can't be moved remain in the original package.
4060
4061 Returns an error, if there is one; otherwise, returns the number of services
4062 that couldn't be moved.
4063
4064 =cut
4065
4066 sub transfer {
4067   my ($self, $dest_pkgnum, %opt) = @_;
4068
4069   my $remaining = 0;
4070   my $dest;
4071   my %target;
4072
4073   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
4074     $dest = $dest_pkgnum;
4075     $dest_pkgnum = $dest->pkgnum;
4076   } else {
4077     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
4078   }
4079
4080   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
4081
4082   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
4083     $target{$pkg_svc->svcpart} = $pkg_svc->quantity * ( $dest->quantity || 1 );
4084   }
4085
4086   foreach my $cust_svc ($dest->cust_svc) {
4087     $target{$cust_svc->svcpart}--;
4088   }
4089
4090   my %svcpart2svcparts = ();
4091   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
4092     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
4093     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
4094       next if exists $svcpart2svcparts{$svcpart};
4095       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
4096       $svcpart2svcparts{$svcpart} = [
4097         map  { $_->[0] }
4098         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
4099         map {
4100               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
4101                                                    'svcpart' => $_          } );
4102               [ $_,
4103                 $pkg_svc ? $pkg_svc->primary_svc : '',
4104                 $pkg_svc ? $pkg_svc->quantity : 0,
4105               ];
4106             }
4107
4108         grep { $_ != $svcpart }
4109         map  { $_->svcpart }
4110         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
4111       ];
4112       warn "alternates for svcpart $svcpart: ".
4113            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
4114         if $DEBUG;
4115     }
4116   }
4117
4118   my $error;
4119   foreach my $cust_svc ($self->cust_svc) {
4120     my $svcnum = $cust_svc->svcnum;
4121     if($target{$cust_svc->svcpart} > 0
4122        or $FS::cust_svc::ignore_quantity) { # maybe should be a 'force' option
4123       $target{$cust_svc->svcpart}--;
4124       my $new = new FS::cust_svc { $cust_svc->hash };
4125       $new->pkgnum($dest_pkgnum);
4126       $error = $new->replace($cust_svc);
4127     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
4128       if ( $DEBUG ) {
4129         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
4130         warn "alternates to consider: ".
4131              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
4132       }
4133       my @alternate = grep {
4134                              warn "considering alternate svcpart $_: ".
4135                                   "$target{$_} available in new package\n"
4136                                if $DEBUG;
4137                              $target{$_} > 0;
4138                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
4139       if ( @alternate ) {
4140         warn "alternate(s) found\n" if $DEBUG;
4141         my $change_svcpart = $alternate[0];
4142         $target{$change_svcpart}--;
4143         my $new = new FS::cust_svc { $cust_svc->hash };
4144         $new->svcpart($change_svcpart);
4145         $new->pkgnum($dest_pkgnum);
4146         $error = $new->replace($cust_svc);
4147       } else {
4148         $remaining++;
4149       }
4150     } else {
4151       $remaining++
4152     }
4153     if ( $error ) {
4154       my @label = $cust_svc->label;
4155       return "$label[0] $label[1]: $error";
4156     }
4157   }
4158   return $remaining;
4159 }
4160
4161 =item grab_svcnums SVCNUM, SVCNUM ...
4162
4163 Change the pkgnum for the provided services to this packages.  If there is an
4164 error, returns the error, otherwise returns false.
4165
4166 =cut
4167
4168 sub grab_svcnums {
4169   my $self = shift;
4170   my @svcnum = @_;
4171
4172   my $oldAutoCommit = $FS::UID::AutoCommit;
4173   local $FS::UID::AutoCommit = 0;
4174   my $dbh = dbh;
4175
4176   foreach my $svcnum (@svcnum) {
4177     my $cust_svc = qsearchs('cust_svc', { svcnum=>$svcnum } ) or do {
4178       $dbh->rollback if $oldAutoCommit;
4179       return "unknown svcnum $svcnum";
4180     };
4181     $cust_svc->pkgnum( $self->pkgnum );
4182     my $error = $cust_svc->replace;
4183     if ( $error ) {
4184       $dbh->rollback if $oldAutoCommit;
4185       return $error;
4186     }
4187   }
4188
4189   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4190   '';
4191
4192 }
4193
4194 =item reexport
4195
4196 This method is deprecated.  See the I<depend_jobnum> option to the insert and
4197 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
4198
4199 =cut
4200
4201 #looks like this is still used by the order_pkg and change_pkg methods in
4202 # ClientAPI/MyAccount, need to look into those before removing
4203 sub reexport {
4204   my $self = shift;
4205
4206   my $oldAutoCommit = $FS::UID::AutoCommit;
4207   local $FS::UID::AutoCommit = 0;
4208   my $dbh = dbh;
4209
4210   foreach my $cust_svc ( $self->cust_svc ) {
4211     #false laziness w/svc_Common::insert
4212     my $svc_x = $cust_svc->svc_x;
4213     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
4214       my $error = $part_export->export_insert($svc_x);
4215       if ( $error ) {
4216         $dbh->rollback if $oldAutoCommit;
4217         return $error;
4218       }
4219     }
4220   }
4221
4222   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4223   '';
4224
4225 }
4226
4227 =item export_pkg_change OLD_CUST_PKG
4228
4229 Calls the "pkg_change" export action for all services attached to this package.
4230
4231 =cut
4232
4233 sub export_pkg_change {
4234   my( $self, $old )  = ( shift, shift );
4235
4236   my $oldAutoCommit = $FS::UID::AutoCommit;
4237   local $FS::UID::AutoCommit = 0;
4238   my $dbh = dbh;
4239
4240   foreach my $svc_x ( map $_->svc_x, $self->cust_svc ) {
4241     my $error = $svc_x->export('pkg_change', $self, $old);
4242     if ( $error ) {
4243       $dbh->rollback if $oldAutoCommit;
4244       return $error;
4245     }
4246   }
4247
4248   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4249   '';
4250
4251 }
4252
4253 =item insert_reason
4254
4255 Associates this package with a (suspension or cancellation) reason (see
4256 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
4257 L<FS::reason>).
4258
4259 Available options are:
4260
4261 =over 4
4262
4263 =item reason
4264
4265 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.
4266
4267 =item reason_otaker
4268
4269 the access_user (see L<FS::access_user>) providing the reason
4270
4271 =item date
4272
4273 a unix timestamp
4274
4275 =item action
4276
4277 the action (cancel, susp, adjourn, expire) associated with the reason
4278
4279 =back
4280
4281 If there is an error, returns the error, otherwise returns false.
4282
4283 =cut
4284
4285 sub insert_reason {
4286   my ($self, %options) = @_;
4287
4288   my $otaker = $options{reason_otaker} ||
4289                $FS::CurrentUser::CurrentUser->username;
4290
4291   my $reasonnum;
4292   if ( $options{'reason'} =~ /^(\d+)$/ ) {
4293
4294     $reasonnum = $1;
4295
4296   } elsif ( ref($options{'reason'}) ) {
4297
4298     return 'Enter a new reason (or select an existing one)'
4299       unless $options{'reason'}->{'reason'} !~ /^\s*$/;
4300
4301     my $reason = new FS::reason({
4302       'reason_type' => $options{'reason'}->{'typenum'},
4303       'reason'      => $options{'reason'}->{'reason'},
4304     });
4305     my $error = $reason->insert;
4306     return $error if $error;
4307
4308     $reasonnum = $reason->reasonnum;
4309
4310   } else {
4311     return "Unparseable reason: ". $options{'reason'};
4312   }
4313
4314   my $cust_pkg_reason =
4315     new FS::cust_pkg_reason({ 'pkgnum'    => $self->pkgnum,
4316                               'reasonnum' => $reasonnum,
4317                               'otaker'    => $otaker,
4318                               'action'    => substr(uc($options{'action'}),0,1),
4319                               'date'      => $options{'date'}
4320                                                ? $options{'date'}
4321                                                : time,
4322                             });
4323
4324   $cust_pkg_reason->insert;
4325 }
4326
4327 =item insert_discount
4328
4329 Associates this package with a discount (see L<FS::cust_pkg_discount>, possibly
4330 inserting a new discount on the fly (see L<FS::discount>).
4331
4332 Available options are:
4333
4334 =over 4
4335
4336 =item discountnum
4337
4338 =back
4339
4340 If there is an error, returns the error, otherwise returns false.
4341
4342 =cut
4343
4344 sub insert_discount {
4345   #my ($self, %options) = @_;
4346   my $self = shift;
4347
4348   my $cust_pkg_discount = new FS::cust_pkg_discount {
4349     'pkgnum'      => $self->pkgnum,
4350     'discountnum' => $self->discountnum,
4351     'months_used' => 0,
4352     'end_date'    => '', #XXX
4353     #for the create a new discount case
4354     '_type'       => $self->discountnum__type,
4355     'amount'      => $self->discountnum_amount,
4356     'percent'     => $self->discountnum_percent,
4357     'months'      => $self->discountnum_months,
4358     'setup'      => $self->discountnum_setup,
4359     #'disabled'    => $self->discountnum_disabled,
4360   };
4361
4362   $cust_pkg_discount->insert;
4363 }
4364
4365 =item set_usage USAGE_VALUE_HASHREF
4366
4367 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
4368 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
4369 upbytes, downbytes, and totalbytes are appropriate keys.
4370
4371 All svc_accts which are part of this package have their values reset.
4372
4373 =cut
4374
4375 sub set_usage {
4376   my ($self, $valueref, %opt) = @_;
4377
4378   #only svc_acct can set_usage for now
4379   foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
4380     my $svc_x = $cust_svc->svc_x;
4381     $svc_x->set_usage($valueref, %opt)
4382       if $svc_x->can("set_usage");
4383   }
4384 }
4385
4386 =item recharge USAGE_VALUE_HASHREF
4387
4388 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
4389 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
4390 upbytes, downbytes, and totalbytes are appropriate keys.
4391
4392 All svc_accts which are part of this package have their values incremented.
4393
4394 =cut
4395
4396 sub recharge {
4397   my ($self, $valueref) = @_;
4398
4399   #only svc_acct can set_usage for now
4400   foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
4401     my $svc_x = $cust_svc->svc_x;
4402     $svc_x->recharge($valueref)
4403       if $svc_x->can("recharge");
4404   }
4405 }
4406
4407 =item apply_usageprice
4408
4409 =cut
4410
4411 sub apply_usageprice {
4412   my $self = shift;
4413
4414   my $oldAutoCommit = $FS::UID::AutoCommit;
4415   local $FS::UID::AutoCommit = 0;
4416   my $dbh = dbh;
4417
4418   my $error = '';
4419
4420   foreach my $cust_pkg_usageprice ( $self->cust_pkg_usageprice ) {
4421     $error ||= $cust_pkg_usageprice->apply;
4422   }
4423
4424   if ( $error ) {
4425     $dbh->rollback if $oldAutoCommit;
4426     die "error applying part_pkg_usageprice add-ons, pkgnum ". $self->pkgnum.
4427         ": $error\n";
4428   } else {
4429     $dbh->commit if $oldAutoCommit;
4430   }
4431
4432
4433 }
4434
4435 =item cust_pkg_discount
4436
4437 =item cust_pkg_discount_active
4438
4439 =cut
4440
4441 sub cust_pkg_discount_active {
4442   my $self = shift;
4443   grep { $_->status eq 'active' } $self->cust_pkg_discount;
4444 }
4445
4446 =item cust_pkg_usage
4447
4448 Returns a list of all voice usage counters attached to this package.
4449
4450 =item apply_usage OPTIONS
4451
4452 Takes the following options:
4453 - cdr: a call detail record (L<FS::cdr>)
4454 - rate_detail: the rate determined for this call (L<FS::rate_detail>)
4455 - minutes: the maximum number of minutes to be charged
4456
4457 Finds available usage minutes for a call of this class, and subtracts
4458 up to that many minutes from the usage pool.  If the usage pool is empty,
4459 and the C<cdr-minutes_priority> global config option is set, minutes may
4460 be taken from other calls as well.  Either way, an allocation record will
4461 be created (L<FS::cdr_cust_pkg_usage>) and this method will return the
4462 number of minutes of usage applied to the call.
4463
4464 =cut
4465
4466 sub apply_usage {
4467   my ($self, %opt) = @_;
4468   my $cdr = $opt{cdr};
4469   my $rate_detail = $opt{rate_detail};
4470   my $minutes = $opt{minutes};
4471   my $classnum = $rate_detail->classnum;
4472   my $pkgnum = $self->pkgnum;
4473   my $custnum = $self->custnum;
4474
4475   my $oldAutoCommit = $FS::UID::AutoCommit;
4476   local $FS::UID::AutoCommit = 0;
4477   my $dbh = dbh;
4478
4479   my $order = FS::Conf->new->config('cdr-minutes_priority');
4480
4481   my $is_classnum;
4482   if ( $classnum ) {
4483     $is_classnum = ' part_pkg_usage_class.classnum = '.$classnum;
4484   } else {
4485     $is_classnum = ' part_pkg_usage_class.classnum IS NULL';
4486   }
4487   my @usage_recs = qsearch({
4488       'table'     => 'cust_pkg_usage',
4489       'addl_from' => ' JOIN part_pkg_usage       USING (pkgusagepart)'.
4490                      ' JOIN cust_pkg             USING (pkgnum)'.
4491                      ' JOIN part_pkg_usage_class USING (pkgusagepart)',
4492       'select'    => 'cust_pkg_usage.*',
4493       'extra_sql' => " WHERE ( cust_pkg.pkgnum = $pkgnum OR ".
4494                      " ( cust_pkg.custnum = $custnum AND ".
4495                      " part_pkg_usage.shared IS NOT NULL ) ) AND ".
4496                      $is_classnum . ' AND '.
4497                      " cust_pkg_usage.minutes > 0",
4498       'order_by'  => " ORDER BY priority ASC",
4499   });
4500
4501   my $orig_minutes = $minutes;
4502   my $error;
4503   while (!$error and $minutes > 0 and @usage_recs) {
4504     my $cust_pkg_usage = shift @usage_recs;
4505     $cust_pkg_usage->select_for_update;
4506     my $cdr_cust_pkg_usage = FS::cdr_cust_pkg_usage->new({
4507         pkgusagenum => $cust_pkg_usage->pkgusagenum,
4508         acctid      => $cdr->acctid,
4509         minutes     => min($cust_pkg_usage->minutes, $minutes),
4510     });
4511     $cust_pkg_usage->set('minutes',
4512       $cust_pkg_usage->minutes - $cdr_cust_pkg_usage->minutes
4513     );
4514     $error = $cust_pkg_usage->replace || $cdr_cust_pkg_usage->insert;
4515     $minutes -= $cdr_cust_pkg_usage->minutes;
4516   }
4517   if ( $order and $minutes > 0 and !$error ) {
4518     # then try to steal minutes from another call
4519     my %search = (
4520         'table'     => 'cdr_cust_pkg_usage',
4521         'addl_from' => ' JOIN cust_pkg_usage        USING (pkgusagenum)'.
4522                        ' JOIN part_pkg_usage        USING (pkgusagepart)'.
4523                        ' JOIN cust_pkg              USING (pkgnum)'.
4524                        ' JOIN part_pkg_usage_class  USING (pkgusagepart)'.
4525                        ' JOIN cdr                   USING (acctid)',
4526         'select'    => 'cdr_cust_pkg_usage.*',
4527         'extra_sql' => " WHERE cdr.freesidestatus = 'rated' AND ".
4528                        " ( cust_pkg.pkgnum = $pkgnum OR ".
4529                        " ( cust_pkg.custnum = $custnum AND ".
4530                        " part_pkg_usage.shared IS NOT NULL ) ) AND ".
4531                        " part_pkg_usage_class.classnum = $classnum",
4532         'order_by'  => ' ORDER BY part_pkg_usage.priority ASC',
4533     );
4534     if ( $order eq 'time' ) {
4535       # find CDRs that are using minutes, but have a later startdate
4536       # than this call
4537       my $startdate = $cdr->startdate;
4538       if ($startdate !~ /^\d+$/) {
4539         die "bad cdr startdate '$startdate'";
4540       }
4541       $search{'extra_sql'} .= " AND cdr.startdate > $startdate";
4542       # minimize needless reshuffling
4543       $search{'order_by'} .= ', cdr.startdate DESC';
4544     } else {
4545       # XXX may not work correctly with rate_time schedules.  Could
4546       # fix this by storing ratedetailnum in cdr_cust_pkg_usage, I
4547       # think...
4548       $search{'addl_from'} .=
4549         ' JOIN rate_detail'.
4550         ' ON (cdr.rated_ratedetailnum = rate_detail.ratedetailnum)';
4551       if ( $order eq 'rate_high' ) {
4552         $search{'extra_sql'} .= ' AND rate_detail.min_charge < '.
4553                                 $rate_detail->min_charge;
4554         $search{'order_by'} .= ', rate_detail.min_charge ASC';
4555       } elsif ( $order eq 'rate_low' ) {
4556         $search{'extra_sql'} .= ' AND rate_detail.min_charge > '.
4557                                 $rate_detail->min_charge;
4558         $search{'order_by'} .= ', rate_detail.min_charge DESC';
4559       } else {
4560         #  this should really never happen
4561         die "invalid cdr-minutes_priority value '$order'\n";
4562       }
4563     }
4564     my @cdr_usage_recs = qsearch(\%search);
4565     my %reproc_cdrs;
4566     while (!$error and @cdr_usage_recs and $minutes > 0) {
4567       my $cdr_cust_pkg_usage = shift @cdr_usage_recs;
4568       my $cust_pkg_usage = $cdr_cust_pkg_usage->cust_pkg_usage;
4569       my $old_cdr = $cdr_cust_pkg_usage->cdr;
4570       $reproc_cdrs{$old_cdr->acctid} = $old_cdr;
4571       $cdr_cust_pkg_usage->select_for_update;
4572       $old_cdr->select_for_update;
4573       $cust_pkg_usage->select_for_update;
4574       # in case someone else stole the usage from this CDR
4575       # while waiting for the lock...
4576       next if $old_cdr->acctid != $cdr_cust_pkg_usage->acctid;
4577       # steal the usage allocation and flag the old CDR for reprocessing
4578       $cdr_cust_pkg_usage->set('acctid', $cdr->acctid);
4579       # if the allocation is more minutes than we need, adjust it...
4580       my $delta = $cdr_cust_pkg_usage->minutes - $minutes;
4581       if ( $delta > 0 ) {
4582         $cdr_cust_pkg_usage->set('minutes', $minutes);
4583         $cust_pkg_usage->set('minutes', $cust_pkg_usage->minutes + $delta);
4584         $error = $cust_pkg_usage->replace;
4585       }
4586       #warn 'CDR '.$cdr->acctid . ' stealing allocation '.$cdr_cust_pkg_usage->cdrusagenum.' from CDR '.$old_cdr->acctid."\n";
4587       $error ||= $cdr_cust_pkg_usage->replace;
4588       # deduct the stolen minutes
4589       $minutes -= $cdr_cust_pkg_usage->minutes;
4590     }
4591     # after all minute-stealing is done, reset the affected CDRs
4592     foreach (values %reproc_cdrs) {
4593       $error ||= $_->set_status('');
4594       # XXX or should we just call $cdr->rate right here?
4595       # it's not like we can create a loop this way, since the min_charge
4596       # or call time has to go monotonically in one direction.
4597       # we COULD get some very deep recursions going, though...
4598     }
4599   } # if $order and $minutes
4600   if ( $error ) {
4601     $dbh->rollback;
4602     die "error applying included minutes\npkgnum ".$self->pkgnum.", class $classnum, acctid ".$cdr->acctid."\n$error\n"
4603   } else {
4604     $dbh->commit if $oldAutoCommit;
4605     return $orig_minutes - $minutes;
4606   }
4607 }
4608
4609 =item supplemental_pkgs
4610
4611 Returns a list of all packages supplemental to this one.
4612
4613 =cut
4614
4615 sub supplemental_pkgs {
4616   my $self = shift;
4617   qsearch('cust_pkg', { 'main_pkgnum' => $self->pkgnum });
4618 }
4619
4620 =item main_pkg
4621
4622 Returns the package that this one is supplemental to, if any.
4623
4624 =cut
4625
4626 sub main_pkg {
4627   my $self = shift;
4628   if ( $self->main_pkgnum ) {
4629     return FS::cust_pkg->by_key($self->main_pkgnum);
4630   }
4631   return;
4632 }
4633
4634 =back
4635
4636 =head1 CLASS METHODS
4637
4638 =over 4
4639
4640 =item recurring_sql
4641
4642 Returns an SQL expression identifying recurring packages.
4643
4644 =cut
4645
4646 sub recurring_sql { "
4647   '0' != ( select freq from part_pkg
4648              where cust_pkg.pkgpart = part_pkg.pkgpart )
4649 "; }
4650
4651 =item onetime_sql
4652
4653 Returns an SQL expression identifying one-time packages.
4654
4655 =cut
4656
4657 sub onetime_sql { "
4658   '0' = ( select freq from part_pkg
4659             where cust_pkg.pkgpart = part_pkg.pkgpart )
4660 "; }
4661
4662 =item ordered_sql
4663
4664 Returns an SQL expression identifying ordered packages (recurring packages not
4665 yet billed).
4666
4667 =cut
4668
4669 sub ordered_sql {
4670    $_[0]->recurring_sql. " AND ". $_[0]->not_yet_billed_sql;
4671 }
4672
4673 =item active_sql
4674
4675 Returns an SQL expression identifying active packages.
4676
4677 =cut
4678
4679 sub active_sql {
4680   $_[0]->recurring_sql. "
4681   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
4682   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4683   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
4684 "; }
4685
4686 =item not_yet_billed_sql
4687
4688 Returns an SQL expression identifying packages which have not yet been billed.
4689
4690 =cut
4691
4692 sub not_yet_billed_sql { "
4693       ( cust_pkg.setup  IS NULL OR cust_pkg.setup  = 0 )
4694   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4695   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
4696 "; }
4697
4698 =item inactive_sql
4699
4700 Returns an SQL expression identifying inactive packages (one-time packages
4701 that are otherwise unsuspended/uncancelled).
4702
4703 =cut
4704
4705 sub inactive_sql { "
4706   ". $_[0]->onetime_sql(). "
4707   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
4708   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4709   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
4710 "; }
4711
4712 =item on_hold_sql
4713
4714 Returns an SQL expression identifying on-hold packages.
4715
4716 =cut
4717
4718 sub on_hold_sql {
4719   #$_[0]->recurring_sql(). ' AND '.
4720   "
4721         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel  = 0 )
4722     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp   != 0
4723     AND ( cust_pkg.setup  IS     NULL  OR cust_pkg.setup   = 0 )
4724   ";
4725 }
4726
4727 =item susp_sql
4728 =item suspended_sql
4729
4730 Returns an SQL expression identifying suspended packages.
4731
4732 =cut
4733
4734 sub suspended_sql { susp_sql(@_); }
4735 sub susp_sql {
4736   #$_[0]->recurring_sql(). ' AND '.
4737   "
4738         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
4739     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
4740     AND   cust_pkg.setup  IS NOT NULL AND cust_pkg.setup != 0
4741   ";
4742 }
4743
4744 =item cancel_sql
4745 =item cancelled_sql
4746
4747 Returns an SQL exprression identifying cancelled packages.
4748
4749 =cut
4750
4751 sub cancelled_sql { cancel_sql(@_); }
4752 sub cancel_sql {
4753   #$_[0]->recurring_sql(). ' AND '.
4754   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
4755 }
4756
4757 =item status_sql
4758
4759 Returns an SQL expression to give the package status as a string.
4760
4761 =cut
4762
4763 sub status_sql {
4764 "CASE
4765   WHEN cust_pkg.cancel IS NOT NULL THEN 'cancelled'
4766   WHEN ( cust_pkg.susp IS NOT NULL AND cust_pkg.setup IS NULL ) THEN 'on hold'
4767   WHEN cust_pkg.susp IS NOT NULL THEN 'suspended'
4768   WHEN cust_pkg.setup IS NULL THEN 'not yet billed'
4769   WHEN ".onetime_sql()." THEN 'one-time charge'
4770   ELSE 'active'
4771 END"
4772 }
4773
4774 =item fcc_477_count
4775
4776 Returns a list of two package counts.  The first is a count of packages
4777 based on the supplied criteria and the second is the count of residential
4778 packages with those same criteria.  Criteria are specified as in the search
4779 method.
4780
4781 =cut
4782
4783 sub fcc_477_count {
4784   my ($class, $params) = @_;
4785
4786   my $sql_query = $class->search( $params );
4787
4788   my $count_sql = delete($sql_query->{'count_query'});
4789   $count_sql =~ s/ FROM/,count(CASE WHEN cust_main.company IS NULL OR cust_main.company = '' THEN 1 END) FROM/
4790     or die "couldn't parse count_sql";
4791
4792   my $count_sth = dbh->prepare($count_sql)
4793     or die "Error preparing $count_sql: ". dbh->errstr;
4794   $count_sth->execute
4795     or die "Error executing $count_sql: ". $count_sth->errstr;
4796   my $count_arrayref = $count_sth->fetchrow_arrayref;
4797
4798   return ( @$count_arrayref );
4799
4800 }
4801
4802 =item tax_locationnum_sql
4803
4804 Returns an SQL expression for the tax location for a package, based
4805 on the settings of 'tax-pkg_address' and 'tax-ship_address'.
4806
4807 =cut
4808
4809 sub tax_locationnum_sql {
4810   my $conf = FS::Conf->new;
4811   if ( $conf->exists('tax-pkg_address') ) {
4812     'cust_pkg.locationnum';
4813   }
4814   elsif ( $conf->exists('tax-ship_address') ) {
4815     'cust_main.ship_locationnum';
4816   }
4817   else {
4818     'cust_main.bill_locationnum';
4819   }
4820 }
4821
4822 =item location_sql
4823
4824 Returns a list: the first item is an SQL fragment identifying matching
4825 packages/customers via location (taking into account shipping and package
4826 address taxation, if enabled), and subsequent items are the parameters to
4827 substitute for the placeholders in that fragment.
4828
4829 =cut
4830
4831 sub location_sql {
4832   my($class, %opt) = @_;
4833   my $ornull = $opt{'ornull'};
4834
4835   my $conf = new FS::Conf;
4836
4837   # '?' placeholders in _location_sql_where
4838   my $x = $ornull ? 3 : 2;
4839   my @bill_param = (
4840     ('district')x3,
4841     ('city')x3,
4842     ('county')x$x,
4843     ('state')x$x,
4844     'country'
4845   );
4846
4847   my $main_where;
4848   my @main_param;
4849   if ( $conf->exists('tax-ship_address') ) {
4850
4851     $main_where = "(
4852          (     ( ship_last IS NULL     OR  ship_last  = '' )
4853            AND ". _location_sql_where('cust_main', '', $ornull ). "
4854          )
4855       OR (       ship_last IS NOT NULL AND ship_last != ''
4856            AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
4857          )
4858     )";
4859     #    AND payby != 'COMP'
4860
4861     @main_param = ( @bill_param, @bill_param );
4862
4863   } else {
4864
4865     $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
4866     @main_param = @bill_param;
4867
4868   }
4869
4870   my $where;
4871   my @param;
4872   if ( $conf->exists('tax-pkg_address') ) {
4873
4874     my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
4875
4876     $where = " (
4877                     ( cust_pkg.locationnum IS     NULL AND $main_where )
4878                  OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where  )
4879                )
4880              ";
4881     @param = ( @main_param, @bill_param );
4882
4883   } else {
4884
4885     $where = $main_where;
4886     @param = @main_param;
4887
4888   }
4889
4890   ( $where, @param );
4891
4892 }
4893
4894 #subroutine, helper for location_sql
4895 sub _location_sql_where {
4896   my $table  = shift;
4897   my $prefix = @_ ? shift : '';
4898   my $ornull = @_ ? shift : '';
4899
4900 #  $ornull             = $ornull          ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
4901
4902   $ornull = $ornull ? ' OR ? IS NULL ' : '';
4903
4904   my $or_empty_city     = " OR ( ? = '' AND $table.${prefix}city     IS NULL )";
4905   my $or_empty_county   = " OR ( ? = '' AND $table.${prefix}county   IS NULL )";
4906   my $or_empty_state    = " OR ( ? = '' AND $table.${prefix}state    IS NULL )";
4907
4908   my $text = (driver_name =~ /^mysql/i) ? 'char' : 'text';
4909
4910 #        ( $table.${prefix}city    = ? $or_empty_city   $ornull )
4911   "
4912         ( $table.district = ? OR ? = '' OR CAST(? AS $text) IS NULL )
4913     AND ( $table.${prefix}city     = ? OR ? = '' OR CAST(? AS $text) IS NULL )
4914     AND ( $table.${prefix}county   = ? $or_empty_county $ornull )
4915     AND ( $table.${prefix}state    = ? $or_empty_state  $ornull )
4916     AND   $table.${prefix}country  = ?
4917   ";
4918 }
4919
4920 sub _X_show_zero {
4921   my( $self, $what ) = @_;
4922
4923   my $what_show_zero = $what. '_show_zero';
4924   length($self->$what_show_zero())
4925     ? ($self->$what_show_zero() eq 'Y')
4926     : $self->part_pkg->$what_show_zero();
4927 }
4928
4929 =head1 SUBROUTINES
4930
4931 =over 4
4932
4933 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
4934
4935 Bulk cancel + order subroutine.  Perhaps slightly deprecated, only used by the
4936 bulk cancel+order in the web UI and nowhere else (edit/process/cust_pkg.cgi)
4937
4938 CUSTNUM is a customer (see L<FS::cust_main>)
4939
4940 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
4941 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
4942 permitted.
4943
4944 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
4945 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
4946 new billing items.  An error is returned if this is not possible (see
4947 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
4948 parameter.
4949
4950 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
4951 newly-created cust_pkg objects.
4952
4953 REFNUM, if specified, will specify the FS::pkg_referral record to be created
4954 and inserted.  Multiple FS::pkg_referral records can be created by
4955 setting I<refnum> to an array reference of refnums or a hash reference with
4956 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
4957 record will be created corresponding to cust_main.refnum.
4958
4959 =cut
4960
4961 sub order {
4962   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
4963
4964   my $conf = new FS::Conf;
4965
4966   # Transactionize this whole mess
4967   my $oldAutoCommit = $FS::UID::AutoCommit;
4968   local $FS::UID::AutoCommit = 0;
4969   my $dbh = dbh;
4970
4971   my $error;
4972 #  my $cust_main = qsearchs('cust_main', { custnum => $custnum });
4973 #  return "Customer not found: $custnum" unless $cust_main;
4974
4975   warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
4976     if $DEBUG;
4977
4978   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
4979                          @$remove_pkgnum;
4980
4981   my $change = scalar(@old_cust_pkg) != 0;
4982
4983   my %hash = ();
4984   if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
4985
4986     warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
4987          " to pkgpart ". $pkgparts->[0]. "\n"
4988       if $DEBUG;
4989
4990     my $err_or_cust_pkg =
4991       $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
4992                                 'refnum'  => $refnum,
4993                               );
4994
4995     unless (ref($err_or_cust_pkg)) {
4996       $dbh->rollback if $oldAutoCommit;
4997       return $err_or_cust_pkg;
4998     }
4999
5000     push @$return_cust_pkg, $err_or_cust_pkg;
5001     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
5002     return '';
5003
5004   }
5005
5006   # Create the new packages.
5007   foreach my $pkgpart (@$pkgparts) {
5008
5009     warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
5010
5011     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
5012                                       pkgpart => $pkgpart,
5013                                       refnum  => $refnum,
5014                                       %hash,
5015                                     };
5016     $error = $cust_pkg->insert( 'change' => $change );
5017     push @$return_cust_pkg, $cust_pkg;
5018
5019     foreach my $link ($cust_pkg->part_pkg->supp_part_pkg_link) {
5020       my $supp_pkg = FS::cust_pkg->new({
5021           custnum => $custnum,
5022           pkgpart => $link->dst_pkgpart,
5023           refnum  => $refnum,
5024           main_pkgnum => $cust_pkg->pkgnum,
5025           %hash,
5026       });
5027       $error ||= $supp_pkg->insert( 'change' => $change );
5028       push @$return_cust_pkg, $supp_pkg;
5029     }
5030
5031     if ($error) {
5032       $dbh->rollback if $oldAutoCommit;
5033       return $error;
5034     }
5035
5036   }
5037   # $return_cust_pkg now contains refs to all of the newly
5038   # created packages.
5039
5040   # Transfer services and cancel old packages.
5041   foreach my $old_pkg (@old_cust_pkg) {
5042
5043     warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
5044       if $DEBUG;
5045
5046     foreach my $new_pkg (@$return_cust_pkg) {
5047       $error = $old_pkg->transfer($new_pkg);
5048       if ($error and $error == 0) {
5049         # $old_pkg->transfer failed.
5050         $dbh->rollback if $oldAutoCommit;
5051         return $error;
5052       }
5053     }
5054
5055     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
5056       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
5057       foreach my $new_pkg (@$return_cust_pkg) {
5058         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
5059         if ($error and $error == 0) {
5060           # $old_pkg->transfer failed.
5061         $dbh->rollback if $oldAutoCommit;
5062         return $error;
5063         }
5064       }
5065     }
5066
5067     if ($error > 0) {
5068       # Transfers were successful, but we went through all of the
5069       # new packages and still had services left on the old package.
5070       # We can't cancel the package under the circumstances, so abort.
5071       $dbh->rollback if $oldAutoCommit;
5072       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
5073     }
5074     $error = $old_pkg->cancel( quiet=>1, 'no_delay_cancel'=>1 );
5075     if ($error) {
5076       $dbh->rollback;
5077       return $error;
5078     }
5079   }
5080   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
5081   '';
5082 }
5083
5084 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
5085
5086 A bulk change method to change packages for multiple customers.
5087
5088 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
5089 L<FS::part_pkg>) to order for each customer.  Duplicates are of course
5090 permitted.
5091
5092 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
5093 replace.  The services (see L<FS::cust_svc>) are moved to the
5094 new billing items.  An error is returned if this is not possible (see
5095 L<FS::pkg_svc>).
5096
5097 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
5098 newly-created cust_pkg objects.
5099
5100 =cut
5101
5102 sub bulk_change {
5103   my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
5104
5105   # Transactionize this whole mess
5106   my $oldAutoCommit = $FS::UID::AutoCommit;
5107   local $FS::UID::AutoCommit = 0;
5108   my $dbh = dbh;
5109
5110   my @errors;
5111   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
5112                          @$remove_pkgnum;
5113
5114   while(scalar(@old_cust_pkg)) {
5115     my @return = ();
5116     my $custnum = $old_cust_pkg[0]->custnum;
5117     my (@remove) = map { $_->pkgnum }
5118                    grep { $_->custnum == $custnum } @old_cust_pkg;
5119     @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
5120
5121     my $error = order $custnum, $pkgparts, \@remove, \@return;
5122
5123     push @errors, $error
5124       if $error;
5125     push @$return_cust_pkg, @return;
5126   }
5127
5128   if (scalar(@errors)) {
5129     $dbh->rollback if $oldAutoCommit;
5130     return join(' / ', @errors);
5131   }
5132
5133   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
5134   '';
5135 }
5136
5137 =item forward_emails
5138
5139 Returns a hash of svcnums and corresponding email addresses
5140 for svc_acct services that can be used as source or dest
5141 for svc_forward services provisioned in this package.
5142
5143 Accepts options I<svc_forward> OR I<svcnum> for a svc_forward
5144 service;  if included, will ensure the current values of the
5145 specified service are included in the list, even if for some
5146 other reason they wouldn't be.  If called as a class method
5147 with a specified service, returns only these current values.
5148
5149 Caution: does not actually check if svc_forward services are
5150 available to be provisioned on this package.
5151
5152 =cut
5153
5154 sub forward_emails {
5155   my $self = shift;
5156   my %opt = @_;
5157
5158   #load optional service, thoroughly validated
5159   die "Use svcnum or svc_forward, not both"
5160     if $opt{'svcnum'} && $opt{'svc_forward'};
5161   my $svc_forward = $opt{'svc_forward'};
5162   $svc_forward ||= qsearchs('svc_forward',{ 'svcnum' => $opt{'svcnum'} })
5163     if $opt{'svcnum'};
5164   die "Specified service is not a forward service"
5165     if $svc_forward && (ref($svc_forward) ne 'FS::svc_forward');
5166   die "Specified service not found"
5167     if ($opt{'svcnum'} || $opt{'svc_forward'}) && !$svc_forward;
5168
5169   my %email;
5170
5171   ## everything below was basically copied from httemplate/edit/svc_forward.cgi
5172   ## with minimal refactoring, not sure why we can't just load all svc_accts for this custnum
5173
5174   #add current values from specified service, if there was one
5175   if ($svc_forward) {
5176     foreach my $method (qw( srcsvc_acct dstsvc_acct )) {
5177       my $svc_acct = $svc_forward->$method();
5178       $email{$svc_acct->svcnum} = $svc_acct->email if $svc_acct;
5179     }
5180   }
5181
5182   if (ref($self) eq 'FS::cust_pkg') {
5183
5184     #and including the rest for this customer
5185     my($u_part_svc,@u_acct_svcparts);
5186     foreach $u_part_svc ( qsearch('part_svc',{'svcdb'=>'svc_acct'}) ) {
5187       push @u_acct_svcparts,$u_part_svc->getfield('svcpart');
5188     }
5189
5190     my $custnum = $self->getfield('custnum');
5191     foreach my $i_cust_pkg ( qsearch('cust_pkg',{'custnum'=>$custnum}) ) {
5192       my $cust_pkgnum = $i_cust_pkg->getfield('pkgnum');
5193       #now find the corresponding record(s) in cust_svc (for this pkgnum!)
5194       foreach my $acct_svcpart (@u_acct_svcparts) {
5195         foreach my $i_cust_svc (
5196           qsearch( 'cust_svc', { 'pkgnum'  => $cust_pkgnum,
5197                                  'svcpart' => $acct_svcpart } )
5198         ) {
5199           my $svc_acct = qsearchs( 'svc_acct', { 'svcnum' => $i_cust_svc->svcnum } );
5200           $email{$svc_acct->svcnum} = $svc_acct->email;
5201         }
5202       }
5203     }
5204   }
5205
5206   return %email;
5207 }
5208
5209 # Used by FS::Upgrade to migrate to a new database.
5210 sub _upgrade_data {  # class method
5211   my ($class, %opts) = @_;
5212   $class->_upgrade_otaker(%opts);
5213   my @statements = (
5214     # RT#10139, bug resulting in contract_end being set when it shouldn't
5215   'UPDATE cust_pkg SET contract_end = NULL WHERE contract_end = -1',
5216     # RT#10830, bad calculation of prorate date near end of year
5217     # the date range for bill is December 2009, and we move it forward
5218     # one year if it's before the previous bill date (which it should
5219     # never be)
5220   'UPDATE cust_pkg SET bill = bill + (365*24*60*60) WHERE bill < last_bill
5221   AND bill > 1259654400 AND bill < 1262332800 AND (SELECT plan FROM part_pkg
5222   WHERE part_pkg.pkgpart = cust_pkg.pkgpart) = \'prorate\'',
5223     # RT6628, add order_date to cust_pkg
5224     'update cust_pkg set order_date = (select history_date from h_cust_pkg
5225         where h_cust_pkg.pkgnum = cust_pkg.pkgnum and
5226         history_action = \'insert\') where order_date is null',
5227   );
5228   foreach my $sql (@statements) {
5229     my $sth = dbh->prepare($sql);
5230     $sth->execute or die $sth->errstr;
5231   }
5232
5233   # RT31194: supplemental package links that are deleted don't clean up
5234   # linked records
5235   my @pkglinknums = qsearch({
5236       'select'    => 'DISTINCT cust_pkg.pkglinknum',
5237       'table'     => 'cust_pkg',
5238       'addl_from' => ' LEFT JOIN part_pkg_link USING (pkglinknum) ',
5239       'extra_sql' => ' WHERE cust_pkg.pkglinknum IS NOT NULL
5240                         AND part_pkg_link.pkglinknum IS NULL',
5241   });
5242   foreach (@pkglinknums) {
5243     my $pkglinknum = $_->pkglinknum;
5244     warn "cleaning part_pkg_link #$pkglinknum\n";
5245     my $part_pkg_link = FS::part_pkg_link->new({pkglinknum => $pkglinknum});
5246     my $error = $part_pkg_link->remove_linked;
5247     die $error if $error;
5248   }
5249 }
5250
5251 =back
5252
5253 =head1 BUGS
5254
5255 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
5256
5257 In sub order, the @pkgparts array (passed by reference) is clobbered.
5258
5259 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
5260 method to pass dates to the recur_prog expression, it should do so.
5261
5262 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
5263 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
5264 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
5265 configuration values.  Probably need a subroutine which decides what to do
5266 based on whether or not we've fetched the user yet, rather than a hash.  See
5267 FS::UID and the TODO.
5268
5269 Now that things are transactional should the check in the insert method be
5270 moved to check ?
5271
5272 =head1 SEE ALSO
5273
5274 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
5275 L<FS::pkg_svc>, schema.html from the base documentation
5276
5277 =cut
5278
5279 1;
5280