FS/FS/cust_pkg.pm

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