FS/FS/cust_pkg.pm

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