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