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