FS/FS/cust_pkg.pm

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