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