FS/FS/cust_pkg.pm

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