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