FS/FS/cust_pkg.pm

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