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