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