FS/FS/cust_pkg.pm

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