FS/FS/cust_pkg.pm

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