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