FS/FS/cust_pkg.pm

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