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   # Enforce service limits only if this is a pkgpart change.
2037   local $FS::cust_svc::ignore_quantity;
2038   $FS::cust_svc::ignore_quantity = 1 if $same_pkgpart;
2039   $error = $self->transfer($cust_pkg);
2040   if ($error and $error == 0) {
2041     # $old_pkg->transfer failed.
2042     $dbh->rollback if $oldAutoCommit;
2043     return "transferring $error";
2044   }
2045
2046   if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
2047     warn "trying transfer again with change_svcpart option\n" if $DEBUG;
2048     $error = $self->transfer($cust_pkg, 'change_svcpart'=>1 );
2049     if ($error and $error == 0) {
2050       # $old_pkg->transfer failed.
2051       $dbh->rollback if $oldAutoCommit;
2052       return "converting $error";
2053     }
2054   }
2055
2056   # We set unprotect_svcs when executing a "future package change".  It's
2057   # not a user-interactive operation, so returning an error means the
2058   # package change will just fail.  Rather than have that happen, we'll
2059   # let leftover services be deleted.
2060   if ($error > 0 and !$opt->{'unprotect_svcs'}) {
2061     # Transfers were successful, but we still had services left on the old
2062     # package.  We can't change the package under this circumstances, so abort.
2063     $dbh->rollback if $oldAutoCommit;
2064     return "unable to transfer all services";
2065   }
2066
2067   #reset usage if changing pkgpart
2068   # AND usage rollover is off (otherwise adds twice, now and at package bill)
2069   if ($self->pkgpart != $cust_pkg->pkgpart) {
2070     my $part_pkg = $cust_pkg->part_pkg;
2071     $error = $part_pkg->reset_usage($cust_pkg, $part_pkg->is_prepaid
2072                                                  ? ()
2073                                                  : ( 'null' => 1 )
2074                                    )
2075       if $part_pkg->can('reset_usage') && ! $part_pkg->option('usage_rollover',1);
2076
2077     if ($error) {
2078       $dbh->rollback if $oldAutoCommit;
2079       return "setting usage values: $error";
2080     }
2081   } else {
2082     # if NOT changing pkgpart, transfer any usage pools over
2083     foreach my $usage ($self->cust_pkg_usage) {
2084       $usage->set('pkgnum', $cust_pkg->pkgnum);
2085       $error = $usage->replace;
2086       if ( $error ) {
2087         $dbh->rollback if $oldAutoCommit;
2088         return "transferring usage pools: $error";
2089       }
2090     }
2091   }
2092
2093   # transfer usage pricing add-ons, if we're not changing pkgpart
2094   if ( $same_pkgpart ) {
2095     foreach my $old_cust_pkg_usageprice ($self->cust_pkg_usageprice) {
2096       my $new_cust_pkg_usageprice = new FS::cust_pkg_usageprice {
2097         'pkgnum'         => $cust_pkg->pkgnum,
2098         'usagepricepart' => $old_cust_pkg_usageprice->usagepricepart,
2099         'quantity'       => $old_cust_pkg_usageprice->quantity,
2100       };
2101       $error = $new_cust_pkg_usageprice->insert;
2102       if ( $error ) {
2103         $dbh->rollback if $oldAutoCommit;
2104         return "Error transferring usage pricing add-on: $error";
2105       }
2106     }
2107   }
2108
2109   # transfer discounts, if we're not changing pkgpart
2110   if ( $same_pkgpart ) {
2111     foreach my $old_discount ($self->cust_pkg_discount_active) {
2112       # don't remove the old discount, we may still need to bill that package.
2113       my $new_discount = new FS::cust_pkg_discount {
2114         'pkgnum'      => $cust_pkg->pkgnum,
2115         'discountnum' => $old_discount->discountnum,
2116         'months_used' => $old_discount->months_used,
2117       };
2118       $error = $new_discount->insert;
2119       if ( $error ) {
2120         $dbh->rollback if $oldAutoCommit;
2121         return "transferring discounts: $error";
2122       }
2123     }
2124   }
2125
2126   # transfer (copy) invoice details
2127   foreach my $detail ($self->cust_pkg_detail) {
2128     my $new_detail = FS::cust_pkg_detail->new({ $detail->hash });
2129     $new_detail->set('pkgdetailnum', '');
2130     $new_detail->set('pkgnum', $cust_pkg->pkgnum);
2131     $error = $new_detail->insert;
2132     if ( $error ) {
2133       $dbh->rollback if $oldAutoCommit;
2134       return "transferring package notes: $error";
2135     }
2136   }
2137
2138   my @new_supp_pkgs;
2139
2140   if ( !$opt->{'cust_pkg'} ) {
2141     # Order any supplemental packages.
2142     my $part_pkg = $cust_pkg->part_pkg;
2143     my @old_supp_pkgs = $self->supplemental_pkgs;
2144     foreach my $link ($part_pkg->supp_part_pkg_link) {
2145       my $old;
2146       foreach (@old_supp_pkgs) {
2147         if ($_->pkgpart == $link->dst_pkgpart) {
2148           $old = $_;
2149           $_->pkgpart(0); # so that it can't match more than once
2150         }
2151         last if $old;
2152       }
2153       # false laziness with FS::cust_main::Packages::order_pkg
2154       my $new = FS::cust_pkg->new({
2155           pkgpart       => $link->dst_pkgpart,
2156           pkglinknum    => $link->pkglinknum,
2157           custnum       => $custnum,
2158           main_pkgnum   => $cust_pkg->pkgnum,
2159           locationnum   => $cust_pkg->locationnum,
2160           start_date    => $cust_pkg->start_date,
2161           order_date    => $cust_pkg->order_date,
2162           expire        => $cust_pkg->expire,
2163           adjourn       => $cust_pkg->adjourn,
2164           contract_end  => $cust_pkg->contract_end,
2165           refnum        => $cust_pkg->refnum,
2166           discountnum   => $cust_pkg->discountnum,
2167           waive_setup   => $cust_pkg->waive_setup,
2168       });
2169       if ( $old and $opt->{'keep_dates'} ) {
2170         foreach (qw(setup bill last_bill)) {
2171           $new->set($_, $old->get($_));
2172         }
2173       }
2174       $error = $new->insert( allow_pkgpart => $same_pkgpart );
2175       # transfer services
2176       if ( $old ) {
2177         $error ||= $old->transfer($new);
2178       }
2179       if ( $error and $error > 0 ) {
2180         # no reason why this should ever fail, but still...
2181         $error = "Unable to transfer all services from supplemental package ".
2182           $old->pkgnum;
2183       }
2184       if ( $error ) {
2185         $dbh->rollback if $oldAutoCommit;
2186         return $error;
2187       }
2188       push @new_supp_pkgs, $new;
2189     }
2190   } # if !$opt->{'cust_pkg'}
2191     # because if there is one, then supplemental packages would already
2192     # have been created for it.
2193
2194   #Good to go, cancel old package.  Notify 'cancel' of whether to credit
2195   #remaining time.
2196   #Don't allow billing the package (preceding period packages and/or
2197   #outstanding usage) if we are keeping dates (i.e. location changing),
2198   #because the new package will be billed for the same date range.
2199   #Supplemental packages are also canceled here.
2200
2201   # during scheduled changes, avoid canceling the package we just
2202   # changed to (duh)
2203   $self->set('change_to_pkgnum' => '');
2204
2205   $error = $self->cancel(
2206     quiet          => 1,
2207     unused_credit  => $unused_credit,
2208     nobill         => $keep_dates,
2209     change_custnum => ( $self->custnum != $custnum ? $custnum : '' ),
2210     no_delay_cancel => 1,
2211   );
2212   if ($error) {
2213     $dbh->rollback if $oldAutoCommit;
2214     return "canceling old package: $error";
2215   }
2216
2217   if ( $conf->exists('cust_pkg-change_pkgpart-bill_now') ) {
2218     #$self->cust_main
2219     my $error = $cust_pkg->cust_main->bill(
2220       'pkg_list' => [ $cust_pkg, @new_supp_pkgs ]
2221     );
2222     if ( $error ) {
2223       $dbh->rollback if $oldAutoCommit;
2224       return "billing new package: $error";
2225     }
2226   }
2227
2228   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2229
2230   $cust_pkg;
2231
2232 }
2233
2234 =item change_later OPTION => VALUE...
2235
2236 Schedule a package change for a later date.  This actually orders the new
2237 package immediately, but sets its start date for a future date, and sets
2238 the current package to expire on the same date.
2239
2240 If the package is already scheduled for a change, this can be called with
2241 'start_date' to change the scheduled date, or with pkgpart and/or
2242 locationnum to modify the package change.  To cancel the scheduled change
2243 entirely, see C<abort_change>.
2244
2245 Options include:
2246
2247 =over 4
2248
2249 =item start_date
2250
2251 The date for the package change.  Required, and must be in the future.
2252
2253 =item pkgpart
2254
2255 =item locationnum
2256
2257 =item quantity
2258
2259 The pkgpart. locationnum, and quantity of the new package, with the same
2260 meaning as in C<change>.
2261
2262 =back
2263
2264 =cut
2265
2266 sub change_later {
2267   my $self = shift;
2268   my $opt = ref($_[0]) ? shift : { @_ };
2269
2270   my $oldAutoCommit = $FS::UID::AutoCommit;
2271   local $FS::UID::AutoCommit = 0;
2272   my $dbh = dbh;
2273
2274   my $cust_main = $self->cust_main;
2275
2276   my $date = delete $opt->{'start_date'} or return 'start_date required';
2277
2278   if ( $date <= time ) {
2279     $dbh->rollback if $oldAutoCommit;
2280     return "start_date $date is in the past";
2281   }
2282
2283   my $error;
2284
2285   if ( $self->change_to_pkgnum ) {
2286     my $change_to = FS::cust_pkg->by_key($self->change_to_pkgnum);
2287     my $new_pkgpart = $opt->{'pkgpart'}
2288         if $opt->{'pkgpart'} and $opt->{'pkgpart'} != $change_to->pkgpart;
2289     my $new_locationnum = $opt->{'locationnum'}
2290         if $opt->{'locationnum'} and $opt->{'locationnum'} != $change_to->locationnum;
2291     my $new_quantity = $opt->{'quantity'}
2292         if $opt->{'quantity'} and $opt->{'quantity'} != $change_to->quantity;
2293     if ( $new_pkgpart or $new_locationnum or $new_quantity ) {
2294       # it hasn't been billed yet, so in principle we could just edit
2295       # it in place (w/o a package change), but that's bad form.
2296       # So change the package according to the new options...
2297       my $err_or_pkg = $change_to->change(%$opt);
2298       if ( ref $err_or_pkg ) {
2299         # Then set that package up for a future start.
2300         $self->set('change_to_pkgnum', $err_or_pkg->pkgnum);
2301         $self->set('expire', $date); # in case it's different
2302         $err_or_pkg->set('start_date', $date);
2303         $err_or_pkg->set('change_date', '');
2304         $err_or_pkg->set('change_pkgnum', '');
2305
2306         $error = $self->replace       ||
2307                  $err_or_pkg->replace ||
2308                  $change_to->cancel('no_delay_cancel' => 1) ||
2309                  $change_to->delete;
2310       } else {
2311         $error = $err_or_pkg;
2312       }
2313     } else { # change the start date only.
2314       $self->set('expire', $date);
2315       $change_to->set('start_date', $date);
2316       $error = $self->replace || $change_to->replace;
2317     }
2318     if ( $error ) {
2319       $dbh->rollback if $oldAutoCommit;
2320       return $error;
2321     } else {
2322       $dbh->commit if $oldAutoCommit;
2323       return '';
2324     }
2325   } # if $self->change_to_pkgnum
2326
2327   my $new_pkgpart = $opt->{'pkgpart'}
2328       if $opt->{'pkgpart'} and $opt->{'pkgpart'} != $self->pkgpart;
2329   my $new_locationnum = $opt->{'locationnum'}
2330       if $opt->{'locationnum'} and $opt->{'locationnum'} != $self->locationnum;
2331   my $new_quantity = $opt->{'quantity'}
2332       if $opt->{'quantity'} and $opt->{'quantity'} != $self->quantity;
2333
2334   return '' unless $new_pkgpart or $new_locationnum or $new_quantity; # wouldn't do anything
2335
2336   # allow $opt->{'locationnum'} = '' to specifically set it to null
2337   # (i.e. customer default location)
2338   $opt->{'locationnum'} = $self->locationnum if !exists($opt->{'locationnum'});
2339
2340   my $new = FS::cust_pkg->new( {
2341     custnum     => $self->custnum,
2342     locationnum => $opt->{'locationnum'},
2343     start_date  => $date,
2344     map   {  $_ => ( $opt->{$_} || $self->$_() )  }
2345       qw( pkgpart quantity refnum salesnum )
2346   } );
2347   $error = $new->insert('change' => 1,
2348                         'allow_pkgpart' => ($new_pkgpart ? 0 : 1));
2349   if ( !$error ) {
2350     $self->set('change_to_pkgnum', $new->pkgnum);
2351     $self->set('expire', $date);
2352     $error = $self->replace;
2353   }
2354   if ( $error ) {
2355     $dbh->rollback if $oldAutoCommit;
2356   } else {
2357     $dbh->commit if $oldAutoCommit;
2358   }
2359
2360   $error;
2361 }
2362
2363 =item abort_change
2364
2365 Cancels a future package change scheduled by C<change_later>.
2366
2367 =cut
2368
2369 sub abort_change {
2370   my $self = shift;
2371   my $pkgnum = $self->change_to_pkgnum;
2372   my $change_to = FS::cust_pkg->by_key($pkgnum) if $pkgnum;
2373   my $error;
2374   if ( $change_to ) {
2375     $error = $change_to->cancel || $change_to->delete;
2376     return $error if $error;
2377   }
2378   $self->set('change_to_pkgnum', '');
2379   $self->set('expire', '');
2380   $self->replace;
2381 }
2382
2383 =item set_quantity QUANTITY
2384
2385 Change the package's quantity field.  This is one of the few package properties
2386 that can safely be changed without canceling and reordering the package
2387 (because it doesn't affect tax eligibility).  Returns an error or an
2388 empty string.
2389
2390 =cut
2391
2392 sub set_quantity {
2393   my $self = shift;
2394   $self = $self->replace_old; # just to make sure
2395   $self->quantity(shift);
2396   $self->replace;
2397 }
2398
2399 =item set_salesnum SALESNUM
2400
2401 Change the package's salesnum (sales person) field.  This is one of the few
2402 package properties that can safely be changed without canceling and reordering
2403 the package (because it doesn't affect tax eligibility).  Returns an error or
2404 an empty string.
2405
2406 =cut
2407
2408 sub set_salesnum {
2409   my $self = shift;
2410   $self = $self->replace_old; # just to make sure
2411   $self->salesnum(shift);
2412   $self->replace;
2413   # XXX this should probably reassign any credit that's already been given
2414 }
2415
2416 =item modify_charge OPTIONS
2417
2418 Change the properties of a one-time charge.  The following properties can
2419 be changed this way:
2420 - pkg: the package description
2421 - classnum: the package class
2422 - additional: arrayref of additional invoice details to add to this package
2423
2424 and, I<if the charge has not yet been billed>:
2425 - start_date: the date when it will be billed
2426 - amount: the setup fee to be charged
2427 - quantity: the multiplier for the setup fee
2428 - separate_bill: whether to put the charge on a separate invoice
2429
2430 If you pass 'adjust_commission' => 1, and the classnum changes, and there are
2431 commission credits linked to this charge, they will be recalculated.
2432
2433 =cut
2434
2435 sub modify_charge {
2436   my $self = shift;
2437   my %opt = @_;
2438   my $part_pkg = $self->part_pkg;
2439   my $pkgnum = $self->pkgnum;
2440
2441   my $dbh = dbh;
2442   my $oldAutoCommit = $FS::UID::AutoCommit;
2443   local $FS::UID::AutoCommit = 0;
2444
2445   return "Can't use modify_charge except on one-time charges"
2446     unless $part_pkg->freq eq '0';
2447
2448   if ( length($opt{'pkg'}) and $part_pkg->pkg ne $opt{'pkg'} ) {
2449     $part_pkg->set('pkg', $opt{'pkg'});
2450   }
2451
2452   my %pkg_opt = $part_pkg->options;
2453   my $pkg_opt_modified = 0;
2454
2455   $opt{'additional'} ||= [];
2456   my $i;
2457   my @old_additional;
2458   foreach (grep /^additional/, keys %pkg_opt) {
2459     ($i) = ($_ =~ /^additional_info(\d+)$/);
2460     $old_additional[$i] = $pkg_opt{$_} if $i;
2461     delete $pkg_opt{$_};
2462   }
2463
2464   for ( $i = 0; exists($opt{'additional'}->[$i]); $i++ ) {
2465     $pkg_opt{ "additional_info$i" } = $opt{'additional'}->[$i];
2466     if (!exists($old_additional[$i])
2467         or $old_additional[$i] ne $opt{'additional'}->[$i])
2468     {
2469       $pkg_opt_modified = 1;
2470     }
2471   }
2472   $pkg_opt_modified = 1 if (scalar(@old_additional) - 1) != $i;
2473   $pkg_opt{'additional_count'} = $i if $i > 0;
2474
2475   my $old_classnum;
2476   if ( exists($opt{'classnum'}) and $part_pkg->classnum ne $opt{'classnum'} )
2477   {
2478     # remember it
2479     $old_classnum = $part_pkg->classnum;
2480     $part_pkg->set('classnum', $opt{'classnum'});
2481   }
2482
2483   if ( !$self->get('setup') ) {
2484     # not yet billed, so allow amount, setup_cost, quantity, start_date,
2485     # and separate_bill
2486
2487     if ( exists($opt{'amount'})
2488           and $part_pkg->option('setup_fee') != $opt{'amount'}
2489           and $opt{'amount'} > 0 ) {
2490
2491       $pkg_opt{'setup_fee'} = $opt{'amount'};
2492       $pkg_opt_modified = 1;
2493     }
2494
2495     if ( exists($opt{'setup_cost'})
2496           and $part_pkg->setup_cost != $opt{'setup_cost'}
2497           and $opt{'setup_cost'} > 0 ) {
2498
2499       $part_pkg->set('setup_cost', $opt{'setup_cost'});
2500     }
2501
2502     if ( exists($opt{'quantity'})
2503           and $opt{'quantity'} != $self->quantity
2504           and $opt{'quantity'} > 0 ) {
2505
2506       $self->set('quantity', $opt{'quantity'});
2507     }
2508
2509     if ( exists($opt{'start_date'})
2510           and $opt{'start_date'} != $self->start_date ) {
2511
2512       $self->set('start_date', $opt{'start_date'});
2513     }
2514
2515     if ( exists($opt{'separate_bill'})
2516           and $opt{'separate_bill'} ne $self->separate_bill ) {
2517
2518       $self->set('separate_bill', $opt{'separate_bill'});
2519     }
2520
2521
2522   } # else simply ignore them; the UI shouldn't allow editing the fields
2523
2524
2525   if ( exists($opt{'taxclass'})
2526           and $part_pkg->taxclass ne $opt{'taxclass'}) {
2527
2528       $part_pkg->set('taxclass', $opt{'taxclass'});
2529   }
2530
2531   my $error;
2532   if ( $part_pkg->modified or $pkg_opt_modified ) {
2533     # can we safely modify the package def?
2534     # Yes, if it's not available for purchase, and this is the only instance
2535     # of it.
2536     if ( $part_pkg->disabled
2537          and FS::cust_pkg->count('pkgpart = '.$part_pkg->pkgpart) == 1
2538          and FS::quotation_pkg->count('pkgpart = '.$part_pkg->pkgpart) == 0
2539        ) {
2540       $error = $part_pkg->replace( options => \%pkg_opt );
2541     } else {
2542       # clone it
2543       $part_pkg = $part_pkg->clone;
2544       $part_pkg->set('disabled' => 'Y');
2545       $error = $part_pkg->insert( options => \%pkg_opt );
2546       # and associate this as yet-unbilled package to the new package def
2547       $self->set('pkgpart' => $part_pkg->pkgpart);
2548     }
2549     if ( $error ) {
2550       $dbh->rollback if $oldAutoCommit;
2551       return $error;
2552     }
2553   }
2554
2555   if ($self->modified) { # for quantity or start_date change, or if we had
2556                          # to clone the existing package def
2557     my $error = $self->replace;
2558     return $error if $error;
2559   }
2560   if (defined $old_classnum) {
2561     # fix invoice grouping records
2562     my $old_catname = $old_classnum
2563                       ? FS::pkg_class->by_key($old_classnum)->categoryname
2564                       : '';
2565     my $new_catname = $opt{'classnum'}
2566                       ? $part_pkg->pkg_class->categoryname
2567                       : '';
2568     if ( $old_catname ne $new_catname ) {
2569       foreach my $cust_bill_pkg ($self->cust_bill_pkg) {
2570         # (there should only be one...)
2571         my @display = qsearch( 'cust_bill_pkg_display', {
2572             'billpkgnum'  => $cust_bill_pkg->billpkgnum,
2573             'section'     => $old_catname,
2574         });
2575         foreach (@display) {
2576           $_->set('section', $new_catname);
2577           $error = $_->replace;
2578           if ( $error ) {
2579             $dbh->rollback if $oldAutoCommit;
2580             return $error;
2581           }
2582         }
2583       } # foreach $cust_bill_pkg
2584     }
2585
2586     if ( $opt{'adjust_commission'} ) {
2587       # fix commission credits...tricky.
2588       foreach my $cust_event ($self->cust_event) {
2589         my $part_event = $cust_event->part_event;
2590         foreach my $table (qw(sales agent)) {
2591           my $class =
2592             "FS::part_event::Action::Mixin::credit_${table}_pkg_class";
2593           my $credit = qsearchs('cust_credit', {
2594               'eventnum' => $cust_event->eventnum,
2595           });
2596           if ( $part_event->isa($class) ) {
2597             # Yes, this results in current commission rates being applied
2598             # retroactively to a one-time charge.  For accounting purposes
2599             # there ought to be some kind of time limit on doing this.
2600             my $amount = $part_event->_calc_credit($self);
2601             if ( $credit and $credit->amount ne $amount ) {
2602               # Void the old credit.
2603               $error = $credit->void('Package class changed');
2604               if ( $error ) {
2605                 $dbh->rollback if $oldAutoCommit;
2606                 return "$error (adjusting commission credit)";
2607               }
2608             }
2609             # redo the event action to recreate the credit.
2610             local $@ = '';
2611             eval { $part_event->do_action( $self, $cust_event ) };
2612             if ( $@ ) {
2613               $dbh->rollback if $oldAutoCommit;
2614               return $@;
2615             }
2616           } # if $part_event->isa($class)
2617         } # foreach $table
2618       } # foreach $cust_event
2619     } # if $opt{'adjust_commission'}
2620   } # if defined $old_classnum
2621
2622   $dbh->commit if $oldAutoCommit;
2623   '';
2624 }
2625
2626
2627
2628 use Data::Dumper;
2629 sub process_bulk_cust_pkg {
2630   my $job = shift;
2631   my $param = shift;
2632   warn Dumper($param) if $DEBUG;
2633
2634   my $old_part_pkg = qsearchs('part_pkg',
2635                               { pkgpart => $param->{'old_pkgpart'} });
2636   my $new_part_pkg = qsearchs('part_pkg',
2637                               { pkgpart => $param->{'new_pkgpart'} });
2638   die "Must select a new package type\n" unless $new_part_pkg;
2639   #my $keep_dates = $param->{'keep_dates'} || 0;
2640   my $keep_dates = 1; # there is no good reason to turn this off
2641
2642   my $oldAutoCommit = $FS::UID::AutoCommit;
2643   local $FS::UID::AutoCommit = 0;
2644   my $dbh = dbh;
2645
2646   my @cust_pkgs = qsearch('cust_pkg', { 'pkgpart' => $param->{'old_pkgpart'} } );
2647
2648   my $i = 0;
2649   foreach my $old_cust_pkg ( @cust_pkgs ) {
2650     $i++;
2651     $job->update_statustext(int(100*$i/(scalar @cust_pkgs)));
2652     if ( $old_cust_pkg->getfield('cancel') ) {
2653       warn '[process_bulk_cust_pkg ] skipping canceled pkgnum '.
2654         $old_cust_pkg->pkgnum."\n"
2655         if $DEBUG;
2656       next;
2657     }
2658     warn '[process_bulk_cust_pkg] changing pkgnum '.$old_cust_pkg->pkgnum."\n"
2659       if $DEBUG;
2660     my $error = $old_cust_pkg->change(
2661       'pkgpart'     => $param->{'new_pkgpart'},
2662       'keep_dates'  => $keep_dates
2663     );
2664     if ( !ref($error) ) { # change returns the cust_pkg on success
2665       $dbh->rollback;
2666       die "Error changing pkgnum ".$old_cust_pkg->pkgnum.": '$error'\n";
2667     }
2668   }
2669   $dbh->commit if $oldAutoCommit;
2670   return;
2671 }
2672
2673 =item last_bill
2674
2675 Returns the last bill date, or if there is no last bill date, the setup date.
2676 Useful for billing metered services.
2677
2678 =cut
2679
2680 sub last_bill {
2681   my $self = shift;
2682   return $self->setfield('last_bill', $_[0]) if @_;
2683   return $self->getfield('last_bill') if $self->getfield('last_bill');
2684   my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
2685                                                   'edate'  => $self->bill,  } );
2686   $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
2687 }
2688
2689 =item last_cust_pkg_reason ACTION
2690
2691 Returns the most recent ACTION FS::cust_pkg_reason associated with the package.
2692 Returns false if there is no reason or the package is not currenly ACTION'd
2693 ACTION is one of adjourn, susp, cancel, or expire.
2694
2695 =cut
2696
2697 sub last_cust_pkg_reason {
2698   my ( $self, $action ) = ( shift, shift );
2699   my $date = $self->get($action);
2700   qsearchs( {
2701               'table' => 'cust_pkg_reason',
2702               'hashref' => { 'pkgnum' => $self->pkgnum,
2703                              'action' => substr(uc($action), 0, 1),
2704                              'date'   => $date,
2705                            },
2706               'order_by' => 'ORDER BY num DESC LIMIT 1',
2707            } );
2708 }
2709
2710 =item last_reason ACTION
2711
2712 Returns the most recent ACTION FS::reason associated with the package.
2713 Returns false if there is no reason or the package is not currenly ACTION'd
2714 ACTION is one of adjourn, susp, cancel, or expire.
2715
2716 =cut
2717
2718 sub last_reason {
2719   my $cust_pkg_reason = shift->last_cust_pkg_reason(@_);
2720   $cust_pkg_reason->reason
2721     if $cust_pkg_reason;
2722 }
2723
2724 =item part_pkg
2725
2726 Returns the definition for this billing item, as an FS::part_pkg object (see
2727 L<FS::part_pkg>).
2728
2729 =cut
2730
2731 sub part_pkg {
2732   my $self = shift;
2733   return $self->{'_pkgpart'} if $self->{'_pkgpart'};
2734   cluck "cust_pkg->part_pkg called" if $DEBUG > 1;
2735   qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
2736 }
2737
2738 =item old_cust_pkg
2739
2740 Returns the cancelled package this package was changed from, if any.
2741
2742 =cut
2743
2744 sub old_cust_pkg {
2745   my $self = shift;
2746   return '' unless $self->change_pkgnum;
2747   qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
2748 }
2749
2750 =item change_cust_main
2751
2752 Returns the customter this package was detached to, if any.
2753
2754 =cut
2755
2756 sub change_cust_main {
2757   my $self = shift;
2758   return '' unless $self->change_custnum;
2759   qsearchs('cust_main', { 'custnum' => $self->change_custnum } );
2760 }
2761
2762 =item calc_setup
2763
2764 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
2765 item.
2766
2767 =cut
2768
2769 sub calc_setup {
2770   my $self = shift;
2771   $self->part_pkg->calc_setup($self, @_);
2772 }
2773
2774 =item calc_recur
2775
2776 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
2777 item.
2778
2779 =cut
2780
2781 sub calc_recur {
2782   my $self = shift;
2783   $self->part_pkg->calc_recur($self, @_);
2784 }
2785
2786 =item base_setup
2787
2788 Calls the I<base_setup> of the FS::part_pkg object associated with this billing
2789 item.
2790
2791 =cut
2792
2793 sub base_setup {
2794   my $self = shift;
2795   $self->part_pkg->base_setup($self, @_);
2796 }
2797
2798 =item base_recur
2799
2800 Calls the I<base_recur> of the FS::part_pkg object associated with this billing
2801 item.
2802
2803 =cut
2804
2805 sub base_recur {
2806   my $self = shift;
2807   $self->part_pkg->base_recur($self, @_);
2808 }
2809
2810 =item calc_remain
2811
2812 Calls the I<calc_remain> of the FS::part_pkg object associated with this
2813 billing item.
2814
2815 =cut
2816
2817 sub calc_remain {
2818   my $self = shift;
2819   $self->part_pkg->calc_remain($self, @_);
2820 }
2821
2822 =item calc_cancel
2823
2824 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
2825 billing item.
2826
2827 =cut
2828
2829 sub calc_cancel {
2830   my $self = shift;
2831   $self->part_pkg->calc_cancel($self, @_);
2832 }
2833
2834 =item cust_bill_pkg
2835
2836 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
2837
2838 =cut
2839
2840 sub cust_bill_pkg {
2841   my $self = shift;
2842   qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
2843 }
2844
2845 =item cust_pkg_detail [ DETAILTYPE ]
2846
2847 Returns any customer package details for this package (see
2848 L<FS::cust_pkg_detail>).
2849
2850 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
2851
2852 =cut
2853
2854 sub cust_pkg_detail {
2855   my $self = shift;
2856   my %hash = ( 'pkgnum' => $self->pkgnum );
2857   $hash{detailtype} = shift if @_;
2858   qsearch({
2859     'table'    => 'cust_pkg_detail',
2860     'hashref'  => \%hash,
2861     'order_by' => 'ORDER BY weight, pkgdetailnum',
2862   });
2863 }
2864
2865 =item set_cust_pkg_detail DETAILTYPE [ DETAIL, DETAIL, ... ]
2866
2867 Sets customer package details for this package (see L<FS::cust_pkg_detail>).
2868
2869 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
2870
2871 If there is an error, returns the error, otherwise returns false.
2872
2873 =cut
2874
2875 sub set_cust_pkg_detail {
2876   my( $self, $detailtype, @details ) = @_;
2877
2878   my $oldAutoCommit = $FS::UID::AutoCommit;
2879   local $FS::UID::AutoCommit = 0;
2880   my $dbh = dbh;
2881
2882   foreach my $current ( $self->cust_pkg_detail($detailtype) ) {
2883     my $error = $current->delete;
2884     if ( $error ) {
2885       $dbh->rollback if $oldAutoCommit;
2886       return "error removing old detail: $error";
2887     }
2888   }
2889
2890   foreach my $detail ( @details ) {
2891     my $cust_pkg_detail = new FS::cust_pkg_detail {
2892       'pkgnum'     => $self->pkgnum,
2893       'detailtype' => $detailtype,
2894       'detail'     => $detail,
2895     };
2896     my $error = $cust_pkg_detail->insert;
2897     if ( $error ) {
2898       $dbh->rollback if $oldAutoCommit;
2899       return "error adding new detail: $error";
2900     }
2901
2902   }
2903
2904   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2905   '';
2906
2907 }
2908
2909 =item cust_event
2910
2911 Returns the customer billing events (see L<FS::cust_event>) for this invoice.
2912
2913 =cut
2914
2915 #false laziness w/cust_bill.pm
2916 sub cust_event {
2917   my $self = shift;
2918   qsearch({
2919     'table'     => 'cust_event',
2920     'addl_from' => 'JOIN part_event USING ( eventpart )',
2921     'hashref'   => { 'tablenum' => $self->pkgnum },
2922     'extra_sql' => " AND eventtable = 'cust_pkg' ",
2923   });
2924 }
2925
2926 =item num_cust_event
2927
2928 Returns the number of customer billing events (see L<FS::cust_event>) for this package.
2929
2930 =cut
2931
2932 #false laziness w/cust_bill.pm
2933 sub num_cust_event {
2934   my $self = shift;
2935   my $sql = "SELECT COUNT(*) ". $self->_from_cust_event_where;
2936   $self->_prep_ex($sql, $self->pkgnum)->fetchrow_arrayref->[0];
2937 }
2938
2939 =item exists_cust_event
2940
2941 Returns true if there are customer billing events (see L<FS::cust_event>) for this package.  More efficient than using num_cust_event.
2942
2943 =cut
2944
2945 sub exists_cust_event {
2946   my $self = shift;
2947   my $sql = "SELECT 1 ". $self->_from_cust_event_where. " LIMIT 1";
2948   my $row = $self->_prep_ex($sql, $self->pkgnum)->fetchrow_arrayref;
2949   $row ? $row->[0] : '';
2950 }
2951
2952 sub _from_cust_event_where {
2953   #my $self = shift;
2954   " FROM cust_event JOIN part_event USING ( eventpart ) ".
2955   "  WHERE tablenum = ? AND eventtable = 'cust_pkg' ";
2956 }
2957
2958 sub _prep_ex {
2959   my( $self, $sql, @args ) = @_;
2960   my $sth = dbh->prepare($sql) or die  dbh->errstr. " preparing $sql";
2961   $sth->execute(@args)         or die $sth->errstr. " executing $sql";
2962   $sth;
2963 }
2964
2965 =item part_pkg_currency_option OPTIONNAME
2966
2967 Returns a two item list consisting of the currency of this customer, if any,
2968 and a value for the provided option.  If the customer has a currency, the value
2969 is the option value the given name and the currency (see
2970 L<FS::part_pkg_currency>).  Otherwise, if the customer has no currency, is the
2971 regular option value for the given name (see L<FS::part_pkg_option>).
2972
2973 =cut
2974
2975 sub part_pkg_currency_option {
2976   my( $self, $optionname ) = @_;
2977   my $part_pkg = $self->part_pkg;
2978   if ( my $currency = $self->cust_main->currency ) {
2979     ($currency, $part_pkg->part_pkg_currency_option($currency, $optionname) );
2980   } else {
2981     ('', $part_pkg->option($optionname) );
2982   }
2983 }
2984
2985 =item cust_svc [ SVCPART ] (old, deprecated usage)
2986
2987 =item cust_svc [ OPTION => VALUE ... ] (current usage)
2988
2989 =item cust_svc_unsorted [ OPTION => VALUE ... ]
2990
2991 Returns the services for this package, as FS::cust_svc objects (see
2992 L<FS::cust_svc>).  Available options are svcpart and svcdb.  If either is
2993 spcififed, returns only the matching services.
2994
2995 As an optimization, use the cust_svc_unsorted version if you are not displaying
2996 the results.
2997
2998 =cut
2999
3000 sub cust_svc {
3001   my $self = shift;
3002   cluck "cust_pkg->cust_svc called" if $DEBUG > 2;
3003   $self->_sort_cust_svc( $self->cust_svc_unsorted_arrayref(@_) );
3004 }
3005
3006 sub cust_svc_unsorted {
3007   my $self = shift;
3008   @{ $self->cust_svc_unsorted_arrayref(@_) };
3009 }
3010
3011 sub cust_svc_unsorted_arrayref {
3012   my $self = shift;
3013
3014   return [] unless $self->num_cust_svc(@_);
3015
3016   my %opt = ();
3017   if ( @_ && $_[0] =~ /^\d+/ ) {
3018     $opt{svcpart} = shift;
3019   } elsif ( @_ && ref($_[0]) eq 'HASH' ) {
3020     %opt = %{ $_[0] };
3021   } elsif ( @_ ) {
3022     %opt = @_;
3023   }
3024
3025   my %search = (
3026     'table'   => 'cust_svc',
3027     'hashref' => { 'pkgnum' => $self->pkgnum },
3028   );
3029   if ( $opt{svcpart} ) {
3030     $search{hashref}->{svcpart} = $opt{'svcpart'};
3031   }
3032   if ( $opt{'svcdb'} ) {
3033     $search{addl_from} = ' LEFT JOIN part_svc USING ( svcpart ) ';
3034     $search{extra_sql} = ' AND svcdb = '. dbh->quote( $opt{'svcdb'} );
3035   }
3036
3037   [ qsearch(\%search) ];
3038
3039 }
3040
3041 =item overlimit [ SVCPART ]
3042
3043 Returns the services for this package which have exceeded their
3044 usage limit as FS::cust_svc objects (see L<FS::cust_svc>).  If a svcpart
3045 is specified, return only the matching services.
3046
3047 =cut
3048
3049 sub overlimit {
3050   my $self = shift;
3051   return () unless $self->num_cust_svc(@_);
3052   grep { $_->overlimit } $self->cust_svc(@_);
3053 }
3054
3055 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
3056
3057 Returns historical services for this package created before END TIMESTAMP and
3058 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
3059 (see L<FS::h_cust_svc>).  If MODE is 'I' (for 'invoice'), services with the
3060 I<pkg_svc.hidden> flag will be omitted.
3061
3062 =cut
3063
3064 sub h_cust_svc {
3065   my $self = shift;
3066   warn "$me _h_cust_svc called on $self\n"
3067     if $DEBUG;
3068
3069   my ($end, $start, $mode) = @_;
3070
3071   local($FS::Record::qsearch_qualify_columns) = 0;
3072
3073   my @cust_svc = $self->_sort_cust_svc(
3074     [ qsearch( 'h_cust_svc',
3075       { 'pkgnum' => $self->pkgnum, },
3076       FS::h_cust_svc->sql_h_search(@_),
3077     ) ]
3078   );
3079
3080   if ( defined($mode) && $mode eq 'I' ) {
3081     my %hidden_svcpart = map { $_->svcpart => $_->hidden } $self->part_svc;
3082     return grep { !$hidden_svcpart{$_->svcpart} } @cust_svc;
3083   } else {
3084     return @cust_svc;
3085   }
3086 }
3087
3088 sub _sort_cust_svc {
3089   my( $self, $arrayref ) = @_;
3090
3091   my $sort =
3092     sub ($$) { my ($a, $b) = @_; $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] };
3093
3094   my %pkg_svc = map { $_->svcpart => $_ }
3095                 qsearch( 'pkg_svc', { 'pkgpart' => $self->pkgpart } );
3096
3097   map  { $_->[0] }
3098   sort $sort
3099   map {
3100         my $pkg_svc = $pkg_svc{ $_->svcpart } || '';
3101         [ $_,
3102           $pkg_svc ? $pkg_svc->primary_svc : '',
3103           $pkg_svc ? $pkg_svc->quantity : 0,
3104         ];
3105       }
3106   @$arrayref;
3107
3108 }
3109
3110 =item num_cust_svc [ SVCPART ] (old, deprecated usage)
3111
3112 =item num_cust_svc [ OPTION => VALUE ... ] (current usage)
3113
3114 Returns the number of services for this package.  Available options are svcpart
3115 and svcdb.  If either is spcififed, returns only the matching services.
3116
3117 =cut
3118
3119 sub num_cust_svc {
3120   my $self = shift;
3121
3122   return $self->{'_num_cust_svc'}
3123     if !scalar(@_)
3124        && exists($self->{'_num_cust_svc'})
3125        && $self->{'_num_cust_svc'} =~ /\d/;
3126
3127   cluck "cust_pkg->num_cust_svc called, _num_cust_svc:".$self->{'_num_cust_svc'}
3128     if $DEBUG > 2;
3129
3130   my %opt = ();
3131   if ( @_ && $_[0] =~ /^\d+/ ) {
3132     $opt{svcpart} = shift;
3133   } elsif ( @_ && ref($_[0]) eq 'HASH' ) {
3134     %opt = %{ $_[0] };
3135   } elsif ( @_ ) {
3136     %opt = @_;
3137   }
3138
3139   my $select = 'SELECT COUNT(*) FROM cust_svc ';
3140   my $where = ' WHERE pkgnum = ? ';
3141   my @param = ($self->pkgnum);
3142
3143   if ( $opt{'svcpart'} ) {
3144     $where .= ' AND svcpart = ? ';
3145     push @param, $opt{'svcpart'};
3146   }
3147   if ( $opt{'svcdb'} ) {
3148     $select .= ' LEFT JOIN part_svc USING ( svcpart ) ';
3149     $where .= ' AND svcdb = ? ';
3150     push @param, $opt{'svcdb'};
3151   }
3152
3153   my $sth = dbh->prepare("$select $where") or die  dbh->errstr;
3154   $sth->execute(@param) or die $sth->errstr;
3155   $sth->fetchrow_arrayref->[0];
3156 }
3157
3158 =item available_part_svc
3159
3160 Returns a list of FS::part_svc objects representing services included in this
3161 package but not yet provisioned.  Each FS::part_svc object also has an extra
3162 field, I<num_avail>, which specifies the number of available services.
3163
3164 =cut
3165
3166 sub available_part_svc {
3167   my $self = shift;
3168
3169   my $pkg_quantity = $self->quantity || 1;
3170
3171   grep { $_->num_avail > 0 }
3172     map {
3173           my $part_svc = $_->part_svc;
3174           $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
3175             $pkg_quantity * $_->quantity - $self->num_cust_svc($_->svcpart);
3176
3177           # more evil encapsulation breakage
3178           if($part_svc->{'Hash'}{'num_avail'} > 0) {
3179             my @exports = $part_svc->part_export_did;
3180             $part_svc->{'Hash'}{'can_get_dids'} = scalar(@exports);
3181           }
3182
3183           $part_svc;
3184         }
3185       $self->part_pkg->pkg_svc;
3186 }
3187
3188 =item part_svc [ OPTION => VALUE ... ]
3189
3190 Returns a list of FS::part_svc objects representing provisioned and available
3191 services included in this package.  Each FS::part_svc object also has the
3192 following extra fields:
3193
3194 =over 4
3195
3196 =item num_cust_svc
3197
3198 (count)
3199
3200 =item num_avail
3201
3202 (quantity - count)
3203
3204 =item cust_pkg_svc
3205
3206 (services) - array reference containing the provisioned services, as cust_svc objects
3207
3208 =back
3209
3210 Accepts two options:
3211
3212 =over 4
3213
3214 =item summarize_size
3215
3216 If true, will omit the extra cust_pkg_svc option for objects where num_cust_svc
3217 is this size or greater.
3218
3219 =item hide_discontinued
3220
3221 If true, will omit looking for services that are no longer avaialble in the
3222 package definition.
3223
3224 =back
3225
3226 =cut
3227
3228 #svcnum
3229 #label -> ($cust_svc->label)[1]
3230
3231 sub part_svc {
3232   my $self = shift;
3233   my %opt = @_;
3234
3235   my $pkg_quantity = $self->quantity || 1;
3236
3237   #XXX some sort of sort order besides numeric by svcpart...
3238   my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
3239     my $pkg_svc = $_;
3240     my $part_svc = $pkg_svc->part_svc;
3241     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
3242     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
3243     $part_svc->{'Hash'}{'num_avail'}    =
3244       max( 0, $pkg_quantity * $pkg_svc->quantity - $num_cust_svc );
3245     $part_svc->{'Hash'}{'cust_pkg_svc'} =
3246         $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : []
3247       unless exists($opt{summarize_size}) && $opt{summarize_size} > 0
3248           && $num_cust_svc >= $opt{summarize_size};
3249     $part_svc->{'Hash'}{'hidden'} = $pkg_svc->hidden;
3250     $part_svc;
3251   } $self->part_pkg->pkg_svc;
3252
3253   unless ( $opt{hide_discontinued} ) {
3254     #extras
3255     push @part_svc, map {
3256       my $part_svc = $_;
3257       my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
3258       $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
3259       $part_svc->{'Hash'}{'num_avail'}    = 0; #0-$num_cust_svc ?
3260       $part_svc->{'Hash'}{'cust_pkg_svc'} =
3261         $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
3262       $part_svc;
3263     } $self->extra_part_svc;
3264   }
3265
3266   @part_svc;
3267
3268 }
3269
3270 =item extra_part_svc
3271
3272 Returns a list of FS::part_svc objects corresponding to services in this
3273 package which are still provisioned but not (any longer) available in the
3274 package definition.
3275
3276 =cut
3277
3278 sub extra_part_svc {
3279   my $self = shift;
3280
3281   my $pkgnum  = $self->pkgnum;
3282   #my $pkgpart = $self->pkgpart;
3283
3284 #  qsearch( {
3285 #    'table'     => 'part_svc',
3286 #    'hashref'   => {},
3287 #    'extra_sql' =>
3288 #      "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
3289 #                     WHERE pkg_svc.svcpart = part_svc.svcpart
3290 #                       AND pkg_svc.pkgpart = ?
3291 #                       AND quantity > 0
3292 #                 )
3293 #        AND 0 < ( SELECT COUNT(*) FROM cust_svc
3294 #                       LEFT JOIN cust_pkg USING ( pkgnum )
3295 #                     WHERE cust_svc.svcpart = part_svc.svcpart
3296 #                       AND pkgnum = ?
3297 #                 )",
3298 #    'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
3299 #  } );
3300
3301 #seems to benchmark slightly faster... (or did?)
3302
3303   my @pkgparts = map $_->pkgpart, $self->part_pkg->self_and_svc_linked;
3304   my $pkgparts = join(',', @pkgparts);
3305
3306   qsearch( {
3307     #'select'      => 'DISTINCT ON (svcpart) part_svc.*',
3308     #MySQL doesn't grok DISINCT ON
3309     'select'      => 'DISTINCT part_svc.*',
3310     'table'       => 'part_svc',
3311     'addl_from'   =>
3312       "LEFT JOIN pkg_svc  ON (     pkg_svc.svcpart   = part_svc.svcpart
3313                                AND pkg_svc.pkgpart IN ($pkgparts)
3314                                AND quantity > 0
3315                              )
3316        LEFT JOIN cust_svc ON (     cust_svc.svcpart = part_svc.svcpart )
3317        LEFT JOIN cust_pkg USING ( pkgnum )
3318       ",
3319     'hashref'     => {},
3320     'extra_sql'   => "WHERE pkgsvcnum IS NULL AND cust_pkg.pkgnum = ? ",
3321     'extra_param' => [ [$self->pkgnum=>'int'] ],
3322   } );
3323 }
3324
3325 =item status
3326
3327 Returns a short status string for this package, currently:
3328
3329 =over 4
3330
3331 =item on hold
3332
3333 =item not yet billed
3334
3335 =item one-time charge
3336
3337 =item active
3338
3339 =item suspended
3340
3341 =item cancelled
3342
3343 =back
3344
3345 =cut
3346
3347 sub status {
3348   my $self = shift;
3349
3350   my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
3351
3352   return 'cancelled' if $self->get('cancel');
3353   return 'on hold' if $self->susp && ! $self->setup;
3354   return 'suspended' if $self->susp;
3355   return 'not yet billed' unless $self->setup;
3356   return 'one-time charge' if $freq =~ /^(0|$)/;
3357   return 'active';
3358 }
3359
3360 =item ucfirst_status
3361
3362 Returns the status with the first character capitalized.
3363
3364 =cut
3365
3366 sub ucfirst_status {
3367   ucfirst(shift->status);
3368 }
3369
3370 =item statuses
3371
3372 Class method that returns the list of possible status strings for packages
3373 (see L<the status method|/status>).  For example:
3374
3375   @statuses = FS::cust_pkg->statuses();
3376
3377 =cut
3378
3379 tie my %statuscolor, 'Tie::IxHash',
3380   'on hold'         => 'FF00F5', #brighter purple!
3381   'not yet billed'  => '009999', #teal? cyan?
3382   'one-time charge' => '0000CC', #blue  #'000000',
3383   'active'          => '00CC00',
3384   'suspended'       => 'FF9900',
3385   'cancelled'       => 'FF0000',
3386 ;
3387
3388 sub statuses {
3389   my $self = shift; #could be class...
3390   #grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
3391   #                                    # mayble split btw one-time vs. recur
3392     keys %statuscolor;
3393 }
3394
3395 sub statuscolors {
3396   #my $self = shift;
3397   \%statuscolor;
3398 }
3399
3400 =item statuscolor
3401
3402 Returns a hex triplet color string for this package's status.
3403
3404 =cut
3405
3406 sub statuscolor {
3407   my $self = shift;
3408   $statuscolor{$self->status};
3409 }
3410
3411 =item is_status_delay_cancel
3412
3413 Returns true if part_pkg has option delay_cancel,
3414 cust_pkg status is 'suspended' and expire is set
3415 to cancel package within the next day (or however
3416 many days are set in global config part_pkg-delay_cancel-days.
3417
3418 This is not a real status, this only meant for hacking display
3419 values, because otherwise treating the package as suspended is
3420 really the whole point of the delay_cancel option.
3421
3422 =cut
3423
3424 sub is_status_delay_cancel {
3425   my ($self) = @_;
3426   if ( $self->main_pkgnum and $self->pkglinknum ) {
3427     return $self->main_pkg->is_status_delay_cancel;
3428   }
3429   return 0 unless $self->part_pkg->option('delay_cancel',1);
3430   return 0 unless $self->status eq 'suspended';
3431   return 0 unless $self->expire;
3432   my $conf = new FS::Conf;
3433   my $expdays = $conf->config('part_pkg-delay_cancel-days') || 1;
3434   my $expsecs = 60*60*24*$expdays;
3435   return 0 unless $self->expire < time + $expsecs;
3436   return 1;
3437 }
3438
3439 =item pkg_label
3440
3441 Returns a label for this package.  (Currently "pkgnum: pkg - comment" or
3442 "pkg - comment" depending on user preference).
3443
3444 =cut
3445
3446 sub pkg_label {
3447   my $self = shift;
3448   my $label = $self->part_pkg->pkg_comment( cust_pkg=>$self, nopkgpart=>1 );
3449   $label = $self->pkgnum. ": $label"
3450     if $FS::CurrentUser::CurrentUser->option('show_pkgnum');
3451   $label;
3452 }
3453
3454 =item pkg_label_long
3455
3456 Returns a long label for this package, adding the primary service's label to
3457 pkg_label.
3458
3459 =cut
3460
3461 sub pkg_label_long {
3462   my $self = shift;
3463   my $label = $self->pkg_label;
3464   my $cust_svc = $self->primary_cust_svc;
3465   $label .= ' ('. ($cust_svc->label)[1]. ')' if $cust_svc;
3466   $label;
3467 }
3468
3469 =item pkg_locale
3470
3471 Returns a customer-localized label for this package.
3472
3473 =cut
3474
3475 sub pkg_locale {
3476   my $self = shift;
3477   $self->part_pkg->pkg_locale( $self->cust_main->locale );
3478 }
3479
3480 =item primary_cust_svc
3481
3482 Returns a primary service (as FS::cust_svc object) if one can be identified.
3483
3484 =cut
3485
3486 #for labeling purposes - might not 100% match up with part_pkg->svcpart's idea
3487
3488 sub primary_cust_svc {
3489   my $self = shift;
3490
3491   my @cust_svc = $self->cust_svc;
3492
3493   return '' unless @cust_svc; #no serivces - irrelevant then
3494
3495   return $cust_svc[0] if scalar(@cust_svc) == 1; #always return a single service
3496
3497   # primary service as specified in the package definition
3498   # or exactly one service definition with quantity one
3499   my $svcpart = $self->part_pkg->svcpart;
3500   @cust_svc = grep { $_->svcpart == $svcpart } @cust_svc;
3501   return $cust_svc[0] if scalar(@cust_svc) == 1;
3502
3503   #couldn't identify one thing..
3504   return '';
3505 }
3506
3507 =item labels
3508
3509 Returns a list of lists, calling the label method for all services
3510 (see L<FS::cust_svc>) of this billing item.
3511
3512 =cut
3513
3514 sub labels {
3515   my $self = shift;
3516   map { [ $_->label ] } $self->cust_svc;
3517 }
3518
3519 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
3520
3521 Like the labels method, but returns historical information on services that
3522 were active as of END_TIMESTAMP and (optionally) not cancelled before
3523 START_TIMESTAMP.  If MODE is 'I' (for 'invoice'), services with the
3524 I<pkg_svc.hidden> flag will be omitted.
3525
3526 Returns a list of lists, calling the label method for all (historical) services
3527 (see L<FS::h_cust_svc>) of this billing item.
3528
3529 =cut
3530
3531 sub h_labels {
3532   my $self = shift;
3533   warn "$me _h_labels called on $self\n"
3534     if $DEBUG;
3535   map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
3536 }
3537
3538 =item labels_short
3539
3540 Like labels, except returns a simple flat list, and shortens long
3541 (currently >5 or the cust_bill-max_same_services configuration value) lists of
3542 identical services to one line that lists the service label and the number of
3543 individual services rather than individual items.
3544
3545 =cut
3546
3547 sub labels_short {
3548   shift->_labels_short( 'labels', @_ );
3549 }
3550
3551 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
3552
3553 Like h_labels, except returns a simple flat list, and shortens long
3554 (currently >5 or the cust_bill-max_same_services configuration value) lists of
3555 identical services to one line that lists the service label and the number of
3556 individual services rather than individual items.
3557
3558 =cut
3559
3560 sub h_labels_short {
3561   shift->_labels_short( 'h_labels', @_ );
3562 }
3563
3564 sub _labels_short {
3565   my( $self, $method ) = ( shift, shift );
3566
3567   warn "$me _labels_short called on $self with $method method\n"
3568     if $DEBUG;
3569
3570   my $conf = new FS::Conf;
3571   my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
3572
3573   warn "$me _labels_short populating \%labels\n"
3574     if $DEBUG;
3575
3576   my %labels;
3577   #tie %labels, 'Tie::IxHash';
3578   push @{ $labels{$_->[0]} }, $_->[1]
3579     foreach $self->$method(@_);
3580
3581   warn "$me _labels_short populating \@labels\n"
3582     if $DEBUG;
3583
3584   my @labels;
3585   foreach my $label ( keys %labels ) {
3586     my %seen = ();
3587     my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
3588     my $num = scalar(@values);
3589     warn "$me _labels_short $num items for $label\n"
3590       if $DEBUG;
3591
3592     if ( $num > $max_same_services ) {
3593       warn "$me _labels_short   more than $max_same_services, so summarizing\n"
3594         if $DEBUG;
3595       push @labels, "$label ($num)";
3596     } else {
3597       if ( $conf->exists('cust_bill-consolidate_services') ) {
3598         warn "$me _labels_short   consolidating services\n"
3599           if $DEBUG;
3600         # push @labels, "$label: ". join(', ', @values);
3601         while ( @values ) {
3602           my $detail = "$label: ";
3603           $detail .= shift(@values). ', '
3604             while @values
3605                && ( length($detail.$values[0]) < 78 || $detail eq "$label: " );
3606           $detail =~ s/, $//;
3607           push @labels, $detail;
3608         }
3609         warn "$me _labels_short   done consolidating services\n"
3610           if $DEBUG;
3611       } else {
3612         warn "$me _labels_short   adding service data\n"
3613           if $DEBUG;
3614         push @labels, map { "$label: $_" } @values;
3615       }
3616     }
3617   }
3618
3619  @labels;
3620
3621 }
3622
3623 =item cust_main
3624
3625 Returns the parent customer object (see L<FS::cust_main>).
3626
3627 =item balance
3628
3629 Returns the balance for this specific package, when using
3630 experimental package balance.
3631
3632 =cut
3633
3634 sub balance {
3635   my $self = shift;
3636   $self->cust_main->balance_pkgnum( $self->pkgnum );
3637 }
3638
3639 #these subs are in location_Mixin.pm now... unfortunately the POD doesn't mixin
3640
3641 =item cust_location
3642
3643 Returns the location object, if any (see L<FS::cust_location>).
3644
3645 =item cust_location_or_main
3646
3647 If this package is associated with a location, returns the locaiton (see
3648 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
3649
3650 =item location_label [ OPTION => VALUE ... ]
3651
3652 Returns the label of the location object (see L<FS::cust_location>).
3653
3654 =cut
3655
3656 #end of subs in location_Mixin.pm now... unfortunately the POD doesn't mixin
3657
3658 =item tax_locationnum
3659
3660 Returns the foreign key to a L<FS::cust_location> object for calculating
3661 tax on this package, as determined by the C<tax-pkg_address> and
3662 C<tax-ship_address> configuration flags.
3663
3664 =cut
3665
3666 sub tax_locationnum {
3667   my $self = shift;
3668   my $conf = FS::Conf->new;
3669   if ( $conf->exists('tax-pkg_address') ) {
3670     return $self->locationnum;
3671   }
3672   elsif ( $conf->exists('tax-ship_address') ) {
3673     return $self->cust_main->ship_locationnum;
3674   }
3675   else {
3676     return $self->cust_main->bill_locationnum;
3677   }
3678 }
3679
3680 =item tax_location
3681
3682 Returns the L<FS::cust_location> object for tax_locationnum.
3683
3684 =cut
3685
3686 sub tax_location {
3687   my $self = shift;
3688   my $conf = FS::Conf->new;
3689   if ( $conf->exists('tax-pkg_address') and $self->locationnum ) {
3690     return FS::cust_location->by_key($self->locationnum);
3691   }
3692   elsif ( $conf->exists('tax-ship_address') ) {
3693     return $self->cust_main->ship_location;
3694   }
3695   else {
3696     return $self->cust_main->bill_location;
3697   }
3698 }
3699
3700 =item seconds_since TIMESTAMP
3701
3702 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
3703 package have been online since TIMESTAMP, according to the session monitor.
3704
3705 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
3706 L<Time::Local> and L<Date::Parse> for conversion functions.
3707
3708 =cut
3709
3710 sub seconds_since {
3711   my($self, $since) = @_;
3712   my $seconds = 0;
3713
3714   foreach my $cust_svc (
3715     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
3716   ) {
3717     $seconds += $cust_svc->seconds_since($since);
3718   }
3719
3720   $seconds;
3721
3722 }
3723
3724 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
3725
3726 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
3727 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
3728 (exclusive).
3729
3730 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
3731 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
3732 functions.
3733
3734
3735 =cut
3736
3737 sub seconds_since_sqlradacct {
3738   my($self, $start, $end) = @_;
3739
3740   my $seconds = 0;
3741
3742   foreach my $cust_svc (
3743     grep {
3744       my $part_svc = $_->part_svc;
3745       $part_svc->svcdb eq 'svc_acct'
3746         && scalar($part_svc->part_export_usage);
3747     } $self->cust_svc
3748   ) {
3749     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
3750   }
3751
3752   $seconds;
3753
3754 }
3755
3756 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
3757
3758 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
3759 in this package for sessions ending between TIMESTAMP_START (inclusive) and
3760 TIMESTAMP_END
3761 (exclusive).
3762
3763 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
3764 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
3765 functions.
3766
3767 =cut
3768
3769 sub attribute_since_sqlradacct {
3770   my($self, $start, $end, $attrib) = @_;
3771
3772   my $sum = 0;
3773
3774   foreach my $cust_svc (
3775     grep {
3776       my $part_svc = $_->part_svc;
3777       scalar($part_svc->part_export_usage);
3778     } $self->cust_svc
3779   ) {
3780     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
3781   }
3782
3783   $sum;
3784
3785 }
3786
3787 =item quantity
3788
3789 =cut
3790
3791 sub quantity {
3792   my( $self, $value ) = @_;
3793   if ( defined($value) ) {
3794     $self->setfield('quantity', $value);
3795   }
3796   $self->getfield('quantity') || 1;
3797 }
3798
3799 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
3800
3801 Transfers as many services as possible from this package to another package.
3802
3803 The destination package can be specified by pkgnum by passing an FS::cust_pkg
3804 object.  The destination package must already exist.
3805
3806 Services are moved only if the destination allows services with the correct
3807 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
3808 this option with caution!  No provision is made for export differences
3809 between the old and new service definitions.  Probably only should be used
3810 when your exports for all service definitions of a given svcdb are identical.
3811 (attempt a transfer without it first, to move all possible svcpart-matching
3812 services)
3813
3814 Any services that can't be moved remain in the original package.
3815
3816 Returns an error, if there is one; otherwise, returns the number of services
3817 that couldn't be moved.
3818
3819 =cut
3820
3821 sub transfer {
3822   my ($self, $dest_pkgnum, %opt) = @_;
3823
3824   my $remaining = 0;
3825   my $dest;
3826   my %target;
3827
3828   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
3829     $dest = $dest_pkgnum;
3830     $dest_pkgnum = $dest->pkgnum;
3831   } else {
3832     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
3833   }
3834
3835   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
3836
3837   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
3838     $target{$pkg_svc->svcpart} = $pkg_svc->quantity * ( $dest->quantity || 1 );
3839   }
3840
3841   foreach my $cust_svc ($dest->cust_svc) {
3842     $target{$cust_svc->svcpart}--;
3843   }
3844
3845   my %svcpart2svcparts = ();
3846   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
3847     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
3848     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
3849       next if exists $svcpart2svcparts{$svcpart};
3850       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
3851       $svcpart2svcparts{$svcpart} = [
3852         map  { $_->[0] }
3853         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
3854         map {
3855               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
3856                                                    'svcpart' => $_          } );
3857               [ $_,
3858                 $pkg_svc ? $pkg_svc->primary_svc : '',
3859                 $pkg_svc ? $pkg_svc->quantity : 0,
3860               ];
3861             }
3862
3863         grep { $_ != $svcpart }
3864         map  { $_->svcpart }
3865         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
3866       ];
3867       warn "alternates for svcpart $svcpart: ".
3868            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
3869         if $DEBUG;
3870     }
3871   }
3872
3873   my $error;
3874   foreach my $cust_svc ($self->cust_svc) {
3875     my $svcnum = $cust_svc->svcnum;
3876     if($target{$cust_svc->svcpart} > 0
3877        or $FS::cust_svc::ignore_quantity) { # maybe should be a 'force' option
3878       $target{$cust_svc->svcpart}--;
3879       my $new = new FS::cust_svc { $cust_svc->hash };
3880       $new->pkgnum($dest_pkgnum);
3881       $error = $new->replace($cust_svc);
3882     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
3883       if ( $DEBUG ) {
3884         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
3885         warn "alternates to consider: ".
3886              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
3887       }
3888       my @alternate = grep {
3889                              warn "considering alternate svcpart $_: ".
3890                                   "$target{$_} available in new package\n"
3891                                if $DEBUG;
3892                              $target{$_} > 0;
3893                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
3894       if ( @alternate ) {
3895         warn "alternate(s) found\n" if $DEBUG;
3896         my $change_svcpart = $alternate[0];
3897         $target{$change_svcpart}--;
3898         my $new = new FS::cust_svc { $cust_svc->hash };
3899         $new->svcpart($change_svcpart);
3900         $new->pkgnum($dest_pkgnum);
3901         $error = $new->replace($cust_svc);
3902       } else {
3903         $remaining++;
3904       }
3905     } else {
3906       $remaining++
3907     }
3908     if ( $error ) {
3909       my @label = $cust_svc->label;
3910       return "$label[0] $label[1]: $error";
3911     }
3912   }
3913   return $remaining;
3914 }
3915
3916 =item grab_svcnums SVCNUM, SVCNUM ...
3917
3918 Change the pkgnum for the provided services to this packages.  If there is an
3919 error, returns the error, otherwise returns false.
3920
3921 =cut
3922
3923 sub grab_svcnums {
3924   my $self = shift;
3925   my @svcnum = @_;
3926
3927   my $oldAutoCommit = $FS::UID::AutoCommit;
3928   local $FS::UID::AutoCommit = 0;
3929   my $dbh = dbh;
3930
3931   foreach my $svcnum (@svcnum) {
3932     my $cust_svc = qsearchs('cust_svc', { svcnum=>$svcnum } ) or do {
3933       $dbh->rollback if $oldAutoCommit;
3934       return "unknown svcnum $svcnum";
3935     };
3936     $cust_svc->pkgnum( $self->pkgnum );
3937     my $error = $cust_svc->replace;
3938     if ( $error ) {
3939       $dbh->rollback if $oldAutoCommit;
3940       return $error;
3941     }
3942   }
3943
3944   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3945   '';
3946
3947 }
3948
3949 =item reexport
3950
3951 This method is deprecated.  See the I<depend_jobnum> option to the insert and
3952 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
3953
3954 =cut
3955
3956 #looks like this is still used by the order_pkg and change_pkg methods in
3957 # ClientAPI/MyAccount, need to look into those before removing
3958 sub reexport {
3959   my $self = shift;
3960
3961   my $oldAutoCommit = $FS::UID::AutoCommit;
3962   local $FS::UID::AutoCommit = 0;
3963   my $dbh = dbh;
3964
3965   foreach my $cust_svc ( $self->cust_svc ) {
3966     #false laziness w/svc_Common::insert
3967     my $svc_x = $cust_svc->svc_x;
3968     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
3969       my $error = $part_export->export_insert($svc_x);
3970       if ( $error ) {
3971         $dbh->rollback if $oldAutoCommit;
3972         return $error;
3973       }
3974     }
3975   }
3976
3977   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3978   '';
3979
3980 }
3981
3982 =item export_pkg_change OLD_CUST_PKG
3983
3984 Calls the "pkg_change" export action for all services attached to this package.
3985
3986 =cut
3987
3988 sub export_pkg_change {
3989   my( $self, $old )  = ( shift, shift );
3990
3991   my $oldAutoCommit = $FS::UID::AutoCommit;
3992   local $FS::UID::AutoCommit = 0;
3993   my $dbh = dbh;
3994
3995   foreach my $svc_x ( map $_->svc_x, $self->cust_svc ) {
3996     my $error = $svc_x->export('pkg_change', $self, $old);
3997     if ( $error ) {
3998       $dbh->rollback if $oldAutoCommit;
3999       return $error;
4000     }
4001   }
4002
4003   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4004   '';
4005
4006 }
4007
4008 =item insert_reason
4009
4010 Associates this package with a (suspension or cancellation) reason (see
4011 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
4012 L<FS::reason>).
4013
4014 Available options are:
4015
4016 =over 4
4017
4018 =item reason
4019
4020 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.
4021
4022 =item reason_otaker
4023
4024 the access_user (see L<FS::access_user>) providing the reason
4025
4026 =item date
4027
4028 a unix timestamp
4029
4030 =item action
4031
4032 the action (cancel, susp, adjourn, expire) associated with the reason
4033
4034 =back
4035
4036 If there is an error, returns the error, otherwise returns false.
4037
4038 =cut
4039
4040 sub insert_reason {
4041   my ($self, %options) = @_;
4042
4043   my $otaker = $options{reason_otaker} ||
4044                $FS::CurrentUser::CurrentUser->username;
4045
4046   my $reasonnum;
4047   if ( $options{'reason'} =~ /^(\d+)$/ ) {
4048
4049     $reasonnum = $1;
4050
4051   } elsif ( ref($options{'reason'}) ) {
4052
4053     return 'Enter a new reason (or select an existing one)'
4054       unless $options{'reason'}->{'reason'} !~ /^\s*$/;
4055
4056     my $reason = new FS::reason({
4057       'reason_type' => $options{'reason'}->{'typenum'},
4058       'reason'      => $options{'reason'}->{'reason'},
4059     });
4060     my $error = $reason->insert;
4061     return $error if $error;
4062
4063     $reasonnum = $reason->reasonnum;
4064
4065   } else {
4066     return "Unparseable reason: ". $options{'reason'};
4067   }
4068
4069   my $cust_pkg_reason =
4070     new FS::cust_pkg_reason({ 'pkgnum'    => $self->pkgnum,
4071                               'reasonnum' => $reasonnum,
4072                               'otaker'    => $otaker,
4073                               'action'    => substr(uc($options{'action'}),0,1),
4074                               'date'      => $options{'date'}
4075                                                ? $options{'date'}
4076                                                : time,
4077                             });
4078
4079   $cust_pkg_reason->insert;
4080 }
4081
4082 =item insert_discount
4083
4084 Associates this package with a discount (see L<FS::cust_pkg_discount>, possibly
4085 inserting a new discount on the fly (see L<FS::discount>).
4086
4087 Available options are:
4088
4089 =over 4
4090
4091 =item discountnum
4092
4093 =back
4094
4095 If there is an error, returns the error, otherwise returns false.
4096
4097 =cut
4098
4099 sub insert_discount {
4100   #my ($self, %options) = @_;
4101   my $self = shift;
4102
4103   my $cust_pkg_discount = new FS::cust_pkg_discount {
4104     'pkgnum'      => $self->pkgnum,
4105     'discountnum' => $self->discountnum,
4106     'months_used' => 0,
4107     'end_date'    => '', #XXX
4108     #for the create a new discount case
4109     '_type'       => $self->discountnum__type,
4110     'amount'      => $self->discountnum_amount,
4111     'percent'     => $self->discountnum_percent,
4112     'months'      => $self->discountnum_months,
4113     'setup'      => $self->discountnum_setup,
4114     #'disabled'    => $self->discountnum_disabled,
4115   };
4116
4117   $cust_pkg_discount->insert;
4118 }
4119
4120 =item set_usage USAGE_VALUE_HASHREF
4121
4122 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
4123 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
4124 upbytes, downbytes, and totalbytes are appropriate keys.
4125
4126 All svc_accts which are part of this package have their values reset.
4127
4128 =cut
4129
4130 sub set_usage {
4131   my ($self, $valueref, %opt) = @_;
4132
4133   #only svc_acct can set_usage for now
4134   foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
4135     my $svc_x = $cust_svc->svc_x;
4136     $svc_x->set_usage($valueref, %opt)
4137       if $svc_x->can("set_usage");
4138   }
4139 }
4140
4141 =item recharge USAGE_VALUE_HASHREF
4142
4143 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
4144 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
4145 upbytes, downbytes, and totalbytes are appropriate keys.
4146
4147 All svc_accts which are part of this package have their values incremented.
4148
4149 =cut
4150
4151 sub recharge {
4152   my ($self, $valueref) = @_;
4153
4154   #only svc_acct can set_usage for now
4155   foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
4156     my $svc_x = $cust_svc->svc_x;
4157     $svc_x->recharge($valueref)
4158       if $svc_x->can("recharge");
4159   }
4160 }
4161
4162 =item apply_usageprice
4163
4164 =cut
4165
4166 sub apply_usageprice {
4167   my $self = shift;
4168
4169   my $oldAutoCommit = $FS::UID::AutoCommit;
4170   local $FS::UID::AutoCommit = 0;
4171   my $dbh = dbh;
4172
4173   my $error = '';
4174
4175   foreach my $cust_pkg_usageprice ( $self->cust_pkg_usageprice ) {
4176     $error ||= $cust_pkg_usageprice->apply;
4177   }
4178
4179   if ( $error ) {
4180     $dbh->rollback if $oldAutoCommit;
4181     die "error applying part_pkg_usageprice add-ons, pkgnum ". $self->pkgnum.
4182         ": $error\n";
4183   } else {
4184     $dbh->commit if $oldAutoCommit;
4185   }
4186
4187
4188 }
4189
4190 =item cust_pkg_discount
4191
4192 =item cust_pkg_discount_active
4193
4194 =cut
4195
4196 sub cust_pkg_discount_active {
4197   my $self = shift;
4198   grep { $_->status eq 'active' } $self->cust_pkg_discount;
4199 }
4200
4201 =item cust_pkg_usage
4202
4203 Returns a list of all voice usage counters attached to this package.
4204
4205 =item apply_usage OPTIONS
4206
4207 Takes the following options:
4208 - cdr: a call detail record (L<FS::cdr>)
4209 - rate_detail: the rate determined for this call (L<FS::rate_detail>)
4210 - minutes: the maximum number of minutes to be charged
4211
4212 Finds available usage minutes for a call of this class, and subtracts
4213 up to that many minutes from the usage pool.  If the usage pool is empty,
4214 and the C<cdr-minutes_priority> global config option is set, minutes may
4215 be taken from other calls as well.  Either way, an allocation record will
4216 be created (L<FS::cdr_cust_pkg_usage>) and this method will return the
4217 number of minutes of usage applied to the call.
4218
4219 =cut
4220
4221 sub apply_usage {
4222   my ($self, %opt) = @_;
4223   my $cdr = $opt{cdr};
4224   my $rate_detail = $opt{rate_detail};
4225   my $minutes = $opt{minutes};
4226   my $classnum = $rate_detail->classnum;
4227   my $pkgnum = $self->pkgnum;
4228   my $custnum = $self->custnum;
4229
4230   my $oldAutoCommit = $FS::UID::AutoCommit;
4231   local $FS::UID::AutoCommit = 0;
4232   my $dbh = dbh;
4233
4234   my $order = FS::Conf->new->config('cdr-minutes_priority');
4235
4236   my $is_classnum;
4237   if ( $classnum ) {
4238     $is_classnum = ' part_pkg_usage_class.classnum = '.$classnum;
4239   } else {
4240     $is_classnum = ' part_pkg_usage_class.classnum IS NULL';
4241   }
4242   my @usage_recs = qsearch({
4243       'table'     => 'cust_pkg_usage',
4244       'addl_from' => ' JOIN part_pkg_usage       USING (pkgusagepart)'.
4245                      ' JOIN cust_pkg             USING (pkgnum)'.
4246                      ' JOIN part_pkg_usage_class USING (pkgusagepart)',
4247       'select'    => 'cust_pkg_usage.*',
4248       'extra_sql' => " WHERE ( cust_pkg.pkgnum = $pkgnum OR ".
4249                      " ( cust_pkg.custnum = $custnum AND ".
4250                      " part_pkg_usage.shared IS NOT NULL ) ) AND ".
4251                      $is_classnum . ' AND '.
4252                      " cust_pkg_usage.minutes > 0",
4253       'order_by'  => " ORDER BY priority ASC",
4254   });
4255
4256   my $orig_minutes = $minutes;
4257   my $error;
4258   while (!$error and $minutes > 0 and @usage_recs) {
4259     my $cust_pkg_usage = shift @usage_recs;
4260     $cust_pkg_usage->select_for_update;
4261     my $cdr_cust_pkg_usage = FS::cdr_cust_pkg_usage->new({
4262         pkgusagenum => $cust_pkg_usage->pkgusagenum,
4263         acctid      => $cdr->acctid,
4264         minutes     => min($cust_pkg_usage->minutes, $minutes),
4265     });
4266     $cust_pkg_usage->set('minutes',
4267       $cust_pkg_usage->minutes - $cdr_cust_pkg_usage->minutes
4268     );
4269     $error = $cust_pkg_usage->replace || $cdr_cust_pkg_usage->insert;
4270     $minutes -= $cdr_cust_pkg_usage->minutes;
4271   }
4272   if ( $order and $minutes > 0 and !$error ) {
4273     # then try to steal minutes from another call
4274     my %search = (
4275         'table'     => 'cdr_cust_pkg_usage',
4276         'addl_from' => ' JOIN cust_pkg_usage        USING (pkgusagenum)'.
4277                        ' JOIN part_pkg_usage        USING (pkgusagepart)'.
4278                        ' JOIN cust_pkg              USING (pkgnum)'.
4279                        ' JOIN part_pkg_usage_class  USING (pkgusagepart)'.
4280                        ' JOIN cdr                   USING (acctid)',
4281         'select'    => 'cdr_cust_pkg_usage.*',
4282         'extra_sql' => " WHERE cdr.freesidestatus = 'rated' AND ".
4283                        " ( cust_pkg.pkgnum = $pkgnum OR ".
4284                        " ( cust_pkg.custnum = $custnum AND ".
4285                        " part_pkg_usage.shared IS NOT NULL ) ) AND ".
4286                        " part_pkg_usage_class.classnum = $classnum",
4287         'order_by'  => ' ORDER BY part_pkg_usage.priority ASC',
4288     );
4289     if ( $order eq 'time' ) {
4290       # find CDRs that are using minutes, but have a later startdate
4291       # than this call
4292       my $startdate = $cdr->startdate;
4293       if ($startdate !~ /^\d+$/) {
4294         die "bad cdr startdate '$startdate'";
4295       }
4296       $search{'extra_sql'} .= " AND cdr.startdate > $startdate";
4297       # minimize needless reshuffling
4298       $search{'order_by'} .= ', cdr.startdate DESC';
4299     } else {
4300       # XXX may not work correctly with rate_time schedules.  Could
4301       # fix this by storing ratedetailnum in cdr_cust_pkg_usage, I
4302       # think...
4303       $search{'addl_from'} .=
4304         ' JOIN rate_detail'.
4305         ' ON (cdr.rated_ratedetailnum = rate_detail.ratedetailnum)';
4306       if ( $order eq 'rate_high' ) {
4307         $search{'extra_sql'} .= ' AND rate_detail.min_charge < '.
4308                                 $rate_detail->min_charge;
4309         $search{'order_by'} .= ', rate_detail.min_charge ASC';
4310       } elsif ( $order eq 'rate_low' ) {
4311         $search{'extra_sql'} .= ' AND rate_detail.min_charge > '.
4312                                 $rate_detail->min_charge;
4313         $search{'order_by'} .= ', rate_detail.min_charge DESC';
4314       } else {
4315         #  this should really never happen
4316         die "invalid cdr-minutes_priority value '$order'\n";
4317       }
4318     }
4319     my @cdr_usage_recs = qsearch(\%search);
4320     my %reproc_cdrs;
4321     while (!$error and @cdr_usage_recs and $minutes > 0) {
4322       my $cdr_cust_pkg_usage = shift @cdr_usage_recs;
4323       my $cust_pkg_usage = $cdr_cust_pkg_usage->cust_pkg_usage;
4324       my $old_cdr = $cdr_cust_pkg_usage->cdr;
4325       $reproc_cdrs{$old_cdr->acctid} = $old_cdr;
4326       $cdr_cust_pkg_usage->select_for_update;
4327       $old_cdr->select_for_update;
4328       $cust_pkg_usage->select_for_update;
4329       # in case someone else stole the usage from this CDR
4330       # while waiting for the lock...
4331       next if $old_cdr->acctid != $cdr_cust_pkg_usage->acctid;
4332       # steal the usage allocation and flag the old CDR for reprocessing
4333       $cdr_cust_pkg_usage->set('acctid', $cdr->acctid);
4334       # if the allocation is more minutes than we need, adjust it...
4335       my $delta = $cdr_cust_pkg_usage->minutes - $minutes;
4336       if ( $delta > 0 ) {
4337         $cdr_cust_pkg_usage->set('minutes', $minutes);
4338         $cust_pkg_usage->set('minutes', $cust_pkg_usage->minutes + $delta);
4339         $error = $cust_pkg_usage->replace;
4340       }
4341       #warn 'CDR '.$cdr->acctid . ' stealing allocation '.$cdr_cust_pkg_usage->cdrusagenum.' from CDR '.$old_cdr->acctid."\n";
4342       $error ||= $cdr_cust_pkg_usage->replace;
4343       # deduct the stolen minutes
4344       $minutes -= $cdr_cust_pkg_usage->minutes;
4345     }
4346     # after all minute-stealing is done, reset the affected CDRs
4347     foreach (values %reproc_cdrs) {
4348       $error ||= $_->set_status('');
4349       # XXX or should we just call $cdr->rate right here?
4350       # it's not like we can create a loop this way, since the min_charge
4351       # or call time has to go monotonically in one direction.
4352       # we COULD get some very deep recursions going, though...
4353     }
4354   } # if $order and $minutes
4355   if ( $error ) {
4356     $dbh->rollback;
4357     die "error applying included minutes\npkgnum ".$self->pkgnum.", class $classnum, acctid ".$cdr->acctid."\n$error\n"
4358   } else {
4359     $dbh->commit if $oldAutoCommit;
4360     return $orig_minutes - $minutes;
4361   }
4362 }
4363
4364 =item supplemental_pkgs
4365
4366 Returns a list of all packages supplemental to this one.
4367
4368 =cut
4369
4370 sub supplemental_pkgs {
4371   my $self = shift;
4372   qsearch('cust_pkg', { 'main_pkgnum' => $self->pkgnum });
4373 }
4374
4375 =item main_pkg
4376
4377 Returns the package that this one is supplemental to, if any.
4378
4379 =cut
4380
4381 sub main_pkg {
4382   my $self = shift;
4383   if ( $self->main_pkgnum ) {
4384     return FS::cust_pkg->by_key($self->main_pkgnum);
4385   }
4386   return;
4387 }
4388
4389 =back
4390
4391 =head1 CLASS METHODS
4392
4393 =over 4
4394
4395 =item recurring_sql
4396
4397 Returns an SQL expression identifying recurring packages.
4398
4399 =cut
4400
4401 sub recurring_sql { "
4402   '0' != ( select freq from part_pkg
4403              where cust_pkg.pkgpart = part_pkg.pkgpart )
4404 "; }
4405
4406 =item onetime_sql
4407
4408 Returns an SQL expression identifying one-time packages.
4409
4410 =cut
4411
4412 sub onetime_sql { "
4413   '0' = ( select freq from part_pkg
4414             where cust_pkg.pkgpart = part_pkg.pkgpart )
4415 "; }
4416
4417 =item ordered_sql
4418
4419 Returns an SQL expression identifying ordered packages (recurring packages not
4420 yet billed).
4421
4422 =cut
4423
4424 sub ordered_sql {
4425    $_[0]->recurring_sql. " AND ". $_[0]->not_yet_billed_sql;
4426 }
4427
4428 =item active_sql
4429
4430 Returns an SQL expression identifying active packages.
4431
4432 =cut
4433
4434 sub active_sql {
4435   $_[0]->recurring_sql. "
4436   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
4437   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4438   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
4439 "; }
4440
4441 =item not_yet_billed_sql
4442
4443 Returns an SQL expression identifying packages which have not yet been billed.
4444
4445 =cut
4446
4447 sub not_yet_billed_sql { "
4448       ( cust_pkg.setup  IS NULL OR cust_pkg.setup  = 0 )
4449   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4450   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
4451 "; }
4452
4453 =item inactive_sql
4454
4455 Returns an SQL expression identifying inactive packages (one-time packages
4456 that are otherwise unsuspended/uncancelled).
4457
4458 =cut
4459
4460 sub inactive_sql { "
4461   ". $_[0]->onetime_sql(). "
4462   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
4463   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4464   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
4465 "; }
4466
4467 =item on_hold_sql
4468
4469 Returns an SQL expression identifying on-hold packages.
4470
4471 =cut
4472
4473 sub on_hold_sql {
4474   #$_[0]->recurring_sql(). ' AND '.
4475   "
4476         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel  = 0 )
4477     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp   != 0
4478     AND ( cust_pkg.setup  IS     NULL  OR cust_pkg.setup   = 0 )
4479   ";
4480 }
4481
4482 =item susp_sql
4483 =item suspended_sql
4484
4485 Returns an SQL expression identifying suspended packages.
4486
4487 =cut
4488
4489 sub suspended_sql { susp_sql(@_); }
4490 sub susp_sql {
4491   #$_[0]->recurring_sql(). ' AND '.
4492   "
4493         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
4494     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
4495     AND   cust_pkg.setup  IS NOT NULL AND cust_pkg.setup != 0
4496   ";
4497 }
4498
4499 =item cancel_sql
4500 =item cancelled_sql
4501
4502 Returns an SQL exprression identifying cancelled packages.
4503
4504 =cut
4505
4506 sub cancelled_sql { cancel_sql(@_); }
4507 sub cancel_sql {
4508   #$_[0]->recurring_sql(). ' AND '.
4509   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
4510 }
4511
4512 =item status_sql
4513
4514 Returns an SQL expression to give the package status as a string.
4515
4516 =cut
4517
4518 sub status_sql {
4519 "CASE
4520   WHEN cust_pkg.cancel IS NOT NULL THEN 'cancelled'
4521   WHEN ( cust_pkg.susp IS NOT NULL AND cust_pkg.setup IS NULL ) THEN 'on hold'
4522   WHEN cust_pkg.susp IS NOT NULL THEN 'suspended'
4523   WHEN cust_pkg.setup IS NULL THEN 'not yet billed'
4524   WHEN ".onetime_sql()." THEN 'one-time charge'
4525   ELSE 'active'
4526 END"
4527 }
4528
4529 =item fcc_477_count
4530
4531 Returns a list of two package counts.  The first is a count of packages
4532 based on the supplied criteria and the second is the count of residential
4533 packages with those same criteria.  Criteria are specified as in the search
4534 method.
4535
4536 =cut
4537
4538 sub fcc_477_count {
4539   my ($class, $params) = @_;
4540
4541   my $sql_query = $class->search( $params );
4542
4543   my $count_sql = delete($sql_query->{'count_query'});
4544   $count_sql =~ s/ FROM/,count(CASE WHEN cust_main.company IS NULL OR cust_main.company = '' THEN 1 END) FROM/
4545     or die "couldn't parse count_sql";
4546
4547   my $count_sth = dbh->prepare($count_sql)
4548     or die "Error preparing $count_sql: ". dbh->errstr;
4549   $count_sth->execute
4550     or die "Error executing $count_sql: ". $count_sth->errstr;
4551   my $count_arrayref = $count_sth->fetchrow_arrayref;
4552
4553   return ( @$count_arrayref );
4554
4555 }
4556
4557 =item tax_locationnum_sql
4558
4559 Returns an SQL expression for the tax location for a package, based
4560 on the settings of 'tax-pkg_address' and 'tax-ship_address'.
4561
4562 =cut
4563
4564 sub tax_locationnum_sql {
4565   my $conf = FS::Conf->new;
4566   if ( $conf->exists('tax-pkg_address') ) {
4567     'cust_pkg.locationnum';
4568   }
4569   elsif ( $conf->exists('tax-ship_address') ) {
4570     'cust_main.ship_locationnum';
4571   }
4572   else {
4573     'cust_main.bill_locationnum';
4574   }
4575 }
4576
4577 =item location_sql
4578
4579 Returns a list: the first item is an SQL fragment identifying matching
4580 packages/customers via location (taking into account shipping and package
4581 address taxation, if enabled), and subsequent items are the parameters to
4582 substitute for the placeholders in that fragment.
4583
4584 =cut
4585
4586 sub location_sql {
4587   my($class, %opt) = @_;
4588   my $ornull = $opt{'ornull'};
4589
4590   my $conf = new FS::Conf;
4591
4592   # '?' placeholders in _location_sql_where
4593   my $x = $ornull ? 3 : 2;
4594   my @bill_param = (
4595     ('district')x3,
4596     ('city')x3,
4597     ('county')x$x,
4598     ('state')x$x,
4599     'country'
4600   );
4601
4602   my $main_where;
4603   my @main_param;
4604   if ( $conf->exists('tax-ship_address') ) {
4605
4606     $main_where = "(
4607          (     ( ship_last IS NULL     OR  ship_last  = '' )
4608            AND ". _location_sql_where('cust_main', '', $ornull ). "
4609          )
4610       OR (       ship_last IS NOT NULL AND ship_last != ''
4611            AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
4612          )
4613     )";
4614     #    AND payby != 'COMP'
4615
4616     @main_param = ( @bill_param, @bill_param );
4617
4618   } else {
4619
4620     $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
4621     @main_param = @bill_param;
4622
4623   }
4624
4625   my $where;
4626   my @param;
4627   if ( $conf->exists('tax-pkg_address') ) {
4628
4629     my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
4630
4631     $where = " (
4632                     ( cust_pkg.locationnum IS     NULL AND $main_where )
4633                  OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where  )
4634                )
4635              ";
4636     @param = ( @main_param, @bill_param );
4637
4638   } else {
4639
4640     $where = $main_where;
4641     @param = @main_param;
4642
4643   }
4644
4645   ( $where, @param );
4646
4647 }
4648
4649 #subroutine, helper for location_sql
4650 sub _location_sql_where {
4651   my $table  = shift;
4652   my $prefix = @_ ? shift : '';
4653   my $ornull = @_ ? shift : '';
4654
4655 #  $ornull             = $ornull          ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
4656
4657   $ornull = $ornull ? ' OR ? IS NULL ' : '';
4658
4659   my $or_empty_city     = " OR ( ? = '' AND $table.${prefix}city     IS NULL )";
4660   my $or_empty_county   = " OR ( ? = '' AND $table.${prefix}county   IS NULL )";
4661   my $or_empty_state    = " OR ( ? = '' AND $table.${prefix}state    IS NULL )";
4662
4663   my $text = (driver_name =~ /^mysql/i) ? 'char' : 'text';
4664
4665 #        ( $table.${prefix}city    = ? $or_empty_city   $ornull )
4666   "
4667         ( $table.district = ? OR ? = '' OR CAST(? AS $text) IS NULL )
4668     AND ( $table.${prefix}city     = ? OR ? = '' OR CAST(? AS $text) IS NULL )
4669     AND ( $table.${prefix}county   = ? $or_empty_county $ornull )
4670     AND ( $table.${prefix}state    = ? $or_empty_state  $ornull )
4671     AND   $table.${prefix}country  = ?
4672   ";
4673 }
4674
4675 sub _X_show_zero {
4676   my( $self, $what ) = @_;
4677
4678   my $what_show_zero = $what. '_show_zero';
4679   length($self->$what_show_zero())
4680     ? ($self->$what_show_zero() eq 'Y')
4681     : $self->part_pkg->$what_show_zero();
4682 }
4683
4684 =head1 SUBROUTINES
4685
4686 =over 4
4687
4688 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
4689
4690 CUSTNUM is a customer (see L<FS::cust_main>)
4691
4692 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
4693 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
4694 permitted.
4695
4696 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
4697 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
4698 new billing items.  An error is returned if this is not possible (see
4699 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
4700 parameter.
4701
4702 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
4703 newly-created cust_pkg objects.
4704
4705 REFNUM, if specified, will specify the FS::pkg_referral record to be created
4706 and inserted.  Multiple FS::pkg_referral records can be created by
4707 setting I<refnum> to an array reference of refnums or a hash reference with
4708 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
4709 record will be created corresponding to cust_main.refnum.
4710
4711 =cut
4712
4713 sub order {
4714   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
4715
4716   my $conf = new FS::Conf;
4717
4718   # Transactionize this whole mess
4719   my $oldAutoCommit = $FS::UID::AutoCommit;
4720   local $FS::UID::AutoCommit = 0;
4721   my $dbh = dbh;
4722
4723   my $error;
4724 #  my $cust_main = qsearchs('cust_main', { custnum => $custnum });
4725 #  return "Customer not found: $custnum" unless $cust_main;
4726
4727   warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
4728     if $DEBUG;
4729
4730   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
4731                          @$remove_pkgnum;
4732
4733   my $change = scalar(@old_cust_pkg) != 0;
4734
4735   my %hash = ();
4736   if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
4737
4738     warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
4739          " to pkgpart ". $pkgparts->[0]. "\n"
4740       if $DEBUG;
4741
4742     my $err_or_cust_pkg =
4743       $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
4744                                 'refnum'  => $refnum,
4745                               );
4746
4747     unless (ref($err_or_cust_pkg)) {
4748       $dbh->rollback if $oldAutoCommit;
4749       return $err_or_cust_pkg;
4750     }
4751
4752     push @$return_cust_pkg, $err_or_cust_pkg;
4753     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4754     return '';
4755
4756   }
4757
4758   # Create the new packages.
4759   foreach my $pkgpart (@$pkgparts) {
4760
4761     warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
4762
4763     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
4764                                       pkgpart => $pkgpart,
4765                                       refnum  => $refnum,
4766                                       %hash,
4767                                     };
4768     $error = $cust_pkg->insert( 'change' => $change );
4769     push @$return_cust_pkg, $cust_pkg;
4770
4771     foreach my $link ($cust_pkg->part_pkg->supp_part_pkg_link) {
4772       my $supp_pkg = FS::cust_pkg->new({
4773           custnum => $custnum,
4774           pkgpart => $link->dst_pkgpart,
4775           refnum  => $refnum,
4776           main_pkgnum => $cust_pkg->pkgnum,
4777           %hash,
4778       });
4779       $error ||= $supp_pkg->insert( 'change' => $change );
4780       push @$return_cust_pkg, $supp_pkg;
4781     }
4782
4783     if ($error) {
4784       $dbh->rollback if $oldAutoCommit;
4785       return $error;
4786     }
4787
4788   }
4789   # $return_cust_pkg now contains refs to all of the newly
4790   # created packages.
4791
4792   # Transfer services and cancel old packages.
4793   foreach my $old_pkg (@old_cust_pkg) {
4794
4795     warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
4796       if $DEBUG;
4797
4798     foreach my $new_pkg (@$return_cust_pkg) {
4799       $error = $old_pkg->transfer($new_pkg);
4800       if ($error and $error == 0) {
4801         # $old_pkg->transfer failed.
4802         $dbh->rollback if $oldAutoCommit;
4803         return $error;
4804       }
4805     }
4806
4807     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
4808       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
4809       foreach my $new_pkg (@$return_cust_pkg) {
4810         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
4811         if ($error and $error == 0) {
4812           # $old_pkg->transfer failed.
4813         $dbh->rollback if $oldAutoCommit;
4814         return $error;
4815         }
4816       }
4817     }
4818
4819     if ($error > 0) {
4820       # Transfers were successful, but we went through all of the
4821       # new packages and still had services left on the old package.
4822       # We can't cancel the package under the circumstances, so abort.
4823       $dbh->rollback if $oldAutoCommit;
4824       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
4825     }
4826     $error = $old_pkg->cancel( quiet=>1, 'no_delay_cancel'=>1 );
4827     if ($error) {
4828       $dbh->rollback;
4829       return $error;
4830     }
4831   }
4832   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4833   '';
4834 }
4835
4836 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
4837
4838 A bulk change method to change packages for multiple customers.
4839
4840 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
4841 L<FS::part_pkg>) to order for each customer.  Duplicates are of course
4842 permitted.
4843
4844 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
4845 replace.  The services (see L<FS::cust_svc>) are moved to the
4846 new billing items.  An error is returned if this is not possible (see
4847 L<FS::pkg_svc>).
4848
4849 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
4850 newly-created cust_pkg objects.
4851
4852 =cut
4853
4854 sub bulk_change {
4855   my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
4856
4857   # Transactionize this whole mess
4858   my $oldAutoCommit = $FS::UID::AutoCommit;
4859   local $FS::UID::AutoCommit = 0;
4860   my $dbh = dbh;
4861
4862   my @errors;
4863   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
4864                          @$remove_pkgnum;
4865
4866   while(scalar(@old_cust_pkg)) {
4867     my @return = ();
4868     my $custnum = $old_cust_pkg[0]->custnum;
4869     my (@remove) = map { $_->pkgnum }
4870                    grep { $_->custnum == $custnum } @old_cust_pkg;
4871     @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
4872
4873     my $error = order $custnum, $pkgparts, \@remove, \@return;
4874
4875     push @errors, $error
4876       if $error;
4877     push @$return_cust_pkg, @return;
4878   }
4879
4880   if (scalar(@errors)) {
4881     $dbh->rollback if $oldAutoCommit;
4882     return join(' / ', @errors);
4883   }
4884
4885   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4886   '';
4887 }
4888
4889 # Used by FS::Upgrade to migrate to a new database.
4890 sub _upgrade_data {  # class method
4891   my ($class, %opts) = @_;
4892   $class->_upgrade_otaker(%opts);
4893   my @statements = (
4894     # RT#10139, bug resulting in contract_end being set when it shouldn't
4895   'UPDATE cust_pkg SET contract_end = NULL WHERE contract_end = -1',
4896     # RT#10830, bad calculation of prorate date near end of year
4897     # the date range for bill is December 2009, and we move it forward
4898     # one year if it's before the previous bill date (which it should
4899     # never be)
4900   'UPDATE cust_pkg SET bill = bill + (365*24*60*60) WHERE bill < last_bill
4901   AND bill > 1259654400 AND bill < 1262332800 AND (SELECT plan FROM part_pkg
4902   WHERE part_pkg.pkgpart = cust_pkg.pkgpart) = \'prorate\'',
4903     # RT6628, add order_date to cust_pkg
4904     'update cust_pkg set order_date = (select history_date from h_cust_pkg
4905         where h_cust_pkg.pkgnum = cust_pkg.pkgnum and
4906         history_action = \'insert\') where order_date is null',
4907   );
4908   foreach my $sql (@statements) {
4909     my $sth = dbh->prepare($sql);
4910     $sth->execute or die $sth->errstr;
4911   }
4912
4913   # RT31194: supplemental package links that are deleted don't clean up
4914   # linked records
4915   my @pkglinknums = qsearch({
4916       'select'    => 'DISTINCT cust_pkg.pkglinknum',
4917       'table'     => 'cust_pkg',
4918       'addl_from' => ' LEFT JOIN part_pkg_link USING (pkglinknum) ',
4919       'extra_sql' => ' WHERE cust_pkg.pkglinknum IS NOT NULL
4920                         AND part_pkg_link.pkglinknum IS NULL',
4921   });
4922   foreach (@pkglinknums) {
4923     my $pkglinknum = $_->pkglinknum;
4924     warn "cleaning part_pkg_link #$pkglinknum\n";
4925     my $part_pkg_link = FS::part_pkg_link->new({pkglinknum => $pkglinknum});
4926     my $error = $part_pkg_link->remove_linked;
4927     die $error if $error;
4928   }
4929 }
4930
4931 =back
4932
4933 =head1 BUGS
4934
4935 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
4936
4937 In sub order, the @pkgparts array (passed by reference) is clobbered.
4938
4939 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
4940 method to pass dates to the recur_prog expression, it should do so.
4941
4942 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
4943 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
4944 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
4945 configuration values.  Probably need a subroutine which decides what to do
4946 based on whether or not we've fetched the user yet, rather than a hash.  See
4947 FS::UID and the TODO.
4948
4949 Now that things are transactional should the check in the insert method be
4950 moved to check ?
4951
4952 =head1 SEE ALSO
4953
4954 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
4955 L<FS::pkg_svc>, schema.html from the base documentation
4956
4957 =cut
4958
4959 1;
4960