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