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