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