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