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