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