FS/FS/cust_pkg.pm

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