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