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