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