FS/FS/cust_pkg.pm

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