FS/FS/cust_pkg.pm

   1 package FS::cust_pkg;
   2
   3 use strict;
   4 use vars qw(@ISA $disable_agentcheck $DEBUG);
   5 use Carp qw(cluck);
   6 use Scalar::Util qw( blessed );
   7 use List::Util qw(max);
   8 use Tie::IxHash;
   9 use FS::UID qw( getotaker dbh );
  10 use FS::Misc qw( send_email );
  11 use FS::Record qw( qsearch qsearchs );
  12 use FS::m2m_Common;
  13 use FS::cust_main_Mixin;
  14 use FS::cust_svc;
  15 use FS::part_pkg;
  16 use FS::cust_main;
  17 use FS::cust_location;
  18 use FS::pkg_svc;
  19 use FS::cust_bill_pkg;
  20 use FS::cust_pkg_detail;
  21 use FS::cust_event;
  22 use FS::h_cust_svc;
  23 use FS::reg_code;
  24 use FS::part_svc;
  25 use FS::cust_pkg_reason;
  26 use FS::reason;
  27 use FS::UI::Web;
  28
  29 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
  30 # setup }
  31 # because they load configuration by setting FS::UID::callback (see TODO)
  32 use FS::svc_acct;
  33 use FS::svc_domain;
  34 use FS::svc_www;
  35 use FS::svc_forward;
  36
  37 # for sending cancel emails in sub cancel
  38 use FS::Conf;
  39
  40 @ISA = qw( FS::m2m_Common FS::cust_main_Mixin FS::option_Common FS::Record );
  41
  42 $DEBUG = 0;
  43
  44 $disable_agentcheck = 0;
  45
  46 sub _cache {
  47   my $self = shift;
  48   my ( $hashref, $cache ) = @_;
  49   #if ( $hashref->{'pkgpart'} ) {
  50   if ( $hashref->{'pkg'} ) {
  51     # #@{ $self->{'_pkgnum'} } = ();
  52     # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
  53     # $self->{'_pkgpart'} = $subcache;
  54     # #push @{ $self->{'_pkgnum'} },
  55     #   FS::part_pkg->new_or_cached($hashref, $subcache);
  56     $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
  57   }
  58   if ( exists $hashref->{'svcnum'} ) {
  59     #@{ $self->{'_pkgnum'} } = ();
  60     my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
  61     $self->{'_svcnum'} = $subcache;
  62     #push @{ $self->{'_pkgnum'} },
  63     FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
  64   }
  65 }
  66
  67 =head1 NAME
  68
  69 FS::cust_pkg - Object methods for cust_pkg objects
  70
  71 =head1 SYNOPSIS
  72
  73   use FS::cust_pkg;
  74
  75   $record = new FS::cust_pkg \%hash;
  76   $record = new FS::cust_pkg { 'column' => 'value' };
  77
  78   $error = $record->insert;
  79
  80   $error = $new_record->replace($old_record);
  81
  82   $error = $record->delete;
  83
  84   $error = $record->check;
  85
  86   $error = $record->cancel;
  87
  88   $error = $record->suspend;
  89
  90   $error = $record->unsuspend;
  91
  92   $part_pkg = $record->part_pkg;
  93
  94   @labels = $record->labels;
  95
  96   $seconds = $record->seconds_since($timestamp);
  97
  98   $error = FS::cust_pkg::order( $custnum, \@pkgparts );
  99   $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
 100
 101 =head1 DESCRIPTION
 102
 103 An FS::cust_pkg object represents a customer billing item.  FS::cust_pkg
 104 inherits from FS::Record.  The following fields are currently supported:
 105
 106 =over 4
 107
 108 =item pkgnum
 109
 110 Primary key (assigned automatically for new billing items)
 111
 112 =item custnum
 113
 114 Customer (see L<FS::cust_main>)
 115
 116 =item pkgpart
 117
 118 Billing item definition (see L<FS::part_pkg>)
 119
 120 =item locationnum
 121
 122 Optional link to package location (see L<FS::location>)
 123
 124 =item setup
 125
 126 date
 127
 128 =item bill
 129
 130 date (next bill date)
 131
 132 =item last_bill
 133
 134 last bill date
 135
 136 =item adjourn
 137
 138 date
 139
 140 =item susp
 141
 142 date
 143
 144 =item expire
 145
 146 date
 147
 148 =item cancel
 149
 150 date
 151
 152 =item otaker
 153
 154 order taker (assigned automatically if null, see L<FS::UID>)
 155
 156 =item manual_flag
 157
 158 If this field is set to 1, disables the automatic
 159 unsuspension of this package when using the B<unsuspendauto> config option.
 160
 161 =item quantity
 162
 163 If not set, defaults to 1
 164
 165 =item change_date
 166
 167 Date of change from previous package
 168
 169 =item change_pkgnum
 170
 171 Previous pkgnum
 172
 173 =item change_pkgpart
 174
 175 Previous pkgpart
 176
 177 =item change_locationnum
 178
 179 Previous locationnum
 180
 181 =back
 182
 183 Note: setup, last_bill, bill, adjourn, susp, expire, cancel and change_date
 184 are specified as UNIX timestamps; see L<perlfunc/"time">.  Also see
 185 L<Time::Local> and L<Date::Parse> for conversion functions.
 186
 187 =head1 METHODS
 188
 189 =over 4
 190
 191 =item new HASHREF
 192
 193 Create a new billing item.  To add the item to the database, see L<"insert">.
 194
 195 =cut
 196
 197 sub table { 'cust_pkg'; }
 198 sub cust_linked { $_[0]->cust_main_custnum; }
 199 sub cust_unlinked_msg {
 200   my $self = shift;
 201   "WARNING: can't find cust_main.custnum ". $self->custnum.
 202   ' (cust_pkg.pkgnum '. $self->pkgnum. ')';
 203 }
 204
 205 =item insert [ OPTION => VALUE ... ]
 206
 207 Adds this billing item to the database ("Orders" the item).  If there is an
 208 error, returns the error, otherwise returns false.
 209
 210 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
 211 will be used to look up the package definition and agent restrictions will be
 212 ignored.
 213
 214 If the additional field I<refnum> is defined, an FS::pkg_referral record will
 215 be created and inserted.  Multiple FS::pkg_referral records can be created by
 216 setting I<refnum> to an array reference of refnums or a hash reference with
 217 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
 218 record will be created corresponding to cust_main.refnum.
 219
 220 The following options are available:
 221
 222 =over 4
 223
 224 =item change
 225
 226 If set true, supresses any referral credit to a referring customer.
 227
 228 =item options
 229
 230 cust_pkg_option records will be created
 231
 232 =back
 233
 234 =cut
 235
 236 sub insert {
 237   my( $self, %options ) = @_;
 238
 239   local $SIG{HUP} = 'IGNORE';
 240   local $SIG{INT} = 'IGNORE';
 241   local $SIG{QUIT} = 'IGNORE';
 242   local $SIG{TERM} = 'IGNORE';
 243   local $SIG{TSTP} = 'IGNORE';
 244   local $SIG{PIPE} = 'IGNORE';
 245
 246   my $oldAutoCommit = $FS::UID::AutoCommit;
 247   local $FS::UID::AutoCommit = 0;
 248   my $dbh = dbh;
 249
 250   my $error = $self->SUPER::insert($options{options} ? %{$options{options}} : ());
 251   if ( $error ) {
 252     $dbh->rollback if $oldAutoCommit;
 253     return $error;
 254   }
 255
 256   $self->refnum($self->cust_main->refnum) unless $self->refnum;
 257   $self->refnum( [ $self->refnum ] ) unless ref($self->refnum);
 258   $self->process_m2m( 'link_table'   => 'pkg_referral',
 259                       'target_table' => 'part_referral',
 260                       'params'       => $self->refnum,
 261                     );
 262
 263   #if ( $self->reg_code ) {
 264   #  my $reg_code = qsearchs('reg_code', { 'code' => $self->reg_code } );
 265   #  $error = $reg_code->delete;
 266   #  if ( $error ) {
 267   #    $dbh->rollback if $oldAutoCommit;
 268   #    return $error;
 269   #  }
 270   #}
 271
 272   my $conf = new FS::Conf;
 273
 274   if ($conf->config('welcome_letter') && $self->cust_main->num_pkgs == 1) {
 275     my $queue = new FS::queue {
 276       'job'     => 'FS::cust_main::queueable_print',
 277     };
 278     $error = $queue->insert(
 279       'custnum'  => $self->custnum,
 280       'template' => 'welcome_letter',
 281     );
 282
 283     if ($error) {
 284       warn "can't send welcome letter: $error";
 285     }
 286
 287   }
 288
 289   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 290   '';
 291
 292 }
 293
 294 =item delete
 295
 296 This method now works but you probably shouldn't use it.
 297
 298 You don't want to delete billing items, because there would then be no record
 299 the customer ever purchased the item.  Instead, see the cancel method.
 300
 301 =cut
 302
 303 #sub delete {
 304 #  return "Can't delete cust_pkg records!";
 305 #}
 306
 307 =item replace [ OLD_RECORD ] [ HASHREF | OPTION => VALUE ... ]
 308
 309 Replaces the OLD_RECORD with this one in the database.  If there is an error,
 310 returns the error, otherwise returns false.
 311
 312 Currently, custnum, setup, bill, adjourn, susp, expire, and cancel may be changed.
 313
 314 Changing pkgpart may have disasterous effects.  See the order subroutine.
 315
 316 setup and bill are normally updated by calling the bill method of a customer
 317 object (see L<FS::cust_main>).
 318
 319 suspend is normally updated by the suspend and unsuspend methods.
 320
 321 cancel is normally updated by the cancel method (and also the order subroutine
 322 in some cases).
 323
 324 Available options are:
 325
 326 =over 4
 327
 328 =item reason
 329
 330 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.
 331
 332 =item reason_otaker
 333
 334 the access_user (see L<FS::access_user>) providing the reason
 335
 336 =item options
 337
 338 hashref of keys and values - cust_pkg_option records will be created, updated or removed as appopriate
 339
 340 =back
 341
 342 =cut
 343
 344 sub replace {
 345   my $new = shift;
 346
 347   my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
 348               ? shift
 349               : $new->replace_old;
 350
 351   my $options =
 352     ( ref($_[0]) eq 'HASH' )
 353       ? shift
 354       : { @_ };
 355
 356   #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
 357   return "Can't change otaker!" if $old->otaker ne $new->otaker;
 358
 359   #allow this *sigh*
 360   #return "Can't change setup once it exists!"
 361   #  if $old->getfield('setup') &&
 362   #     $old->getfield('setup') != $new->getfield('setup');
 363
 364   #some logic for bill, susp, cancel?
 365
 366   local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
 367
 368   local $SIG{HUP} = 'IGNORE';
 369   local $SIG{INT} = 'IGNORE';
 370   local $SIG{QUIT} = 'IGNORE';
 371   local $SIG{TERM} = 'IGNORE';
 372   local $SIG{TSTP} = 'IGNORE';
 373   local $SIG{PIPE} = 'IGNORE';
 374
 375   my $oldAutoCommit = $FS::UID::AutoCommit;
 376   local $FS::UID::AutoCommit = 0;
 377   my $dbh = dbh;
 378
 379   foreach my $method ( qw(adjourn expire) ) {  # How many reasons?
 380     if ($options->{'reason'} && $new->$method && $old->$method ne $new->$method) {
 381       my $error = $new->insert_reason(
 382         'reason'        => $options->{'reason'},
 383         'date'          => $new->$method,
 384         'action'        => $method,
 385         'reason_otaker' => $options->{'reason_otaker'},
 386       );
 387       if ( $error ) {
 388         dbh->rollback if $oldAutoCommit;
 389         return "Error inserting cust_pkg_reason: $error";
 390       }
 391     }
 392   }
 393
 394   #save off and freeze RADIUS attributes for any associated svc_acct records
 395   my @svc_acct = ();
 396   if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
 397
 398                 #also check for specific exports?
 399                 # to avoid spurious modify export events
 400     @svc_acct = map  { $_->svc_x }
 401                 grep { $_->part_svc->svcdb eq 'svc_acct' }
 402                      $old->cust_svc;
 403
 404     $_->snapshot foreach @svc_acct;
 405
 406   }
 407
 408   my $error = $new->SUPER::replace($old,
 409                                    $options->{options} ? $options->{options} : ()
 410                                   );
 411   if ( $error ) {
 412     $dbh->rollback if $oldAutoCommit;
 413     return $error;
 414   }
 415
 416   #for prepaid packages,
 417   #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
 418   foreach my $old_svc_acct ( @svc_acct ) {
 419     my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
 420     my $s_error = $new_svc_acct->replace($old_svc_acct);
 421     if ( $s_error ) {
 422       $dbh->rollback if $oldAutoCommit;
 423       return $s_error;
 424     }
 425   }
 426
 427   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 428   '';
 429
 430 }
 431
 432 =item check
 433
 434 Checks all fields to make sure this is a valid billing item.  If there is an
 435 error, returns the error, otherwise returns false.  Called by the insert and
 436 replace methods.
 437
 438 =cut
 439
 440 sub check {
 441   my $self = shift;
 442
 443   $self->locationnum('') if !$self->locationnum || $self->locationnum == -1;
 444
 445   my $error =
 446     $self->ut_numbern('pkgnum')
 447     || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
 448     || $self->ut_numbern('pkgpart')
 449     || $self->ut_foreign_keyn('locationnum', 'cust_location', 'locationnum')
 450     || $self->ut_numbern('setup')
 451     || $self->ut_numbern('bill')
 452     || $self->ut_numbern('susp')
 453     || $self->ut_numbern('cancel')
 454     || $self->ut_numbern('adjourn')
 455     || $self->ut_numbern('expire')
 456   ;
 457   return $error if $error;
 458
 459   if ( $self->reg_code ) {
 460
 461     unless ( grep { $self->pkgpart == $_->pkgpart }
 462              map  { $_->reg_code_pkg }
 463              qsearchs( 'reg_code', { 'code'     => $self->reg_code,
 464                                      'agentnum' => $self->cust_main->agentnum })
 465            ) {
 466       return "Unknown registration code";
 467     }
 468
 469   } elsif ( $self->promo_code ) {
 470
 471     my $promo_part_pkg =
 472       qsearchs('part_pkg', {
 473         'pkgpart'    => $self->pkgpart,
 474         'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
 475       } );
 476     return 'Unknown promotional code' unless $promo_part_pkg;
 477
 478   } else {
 479
 480     unless ( $disable_agentcheck ) {
 481       my $agent =
 482         qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
 483       my $pkgpart_href = $agent->pkgpart_hashref;
 484       return "agent ". $agent->agentnum.
 485              " can't purchase pkgpart ". $self->pkgpart
 486         unless $pkgpart_href->{ $self->pkgpart };
 487     }
 488
 489     $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
 490     return $error if $error;
 491
 492   }
 493
 494   $self->otaker(getotaker) unless $self->otaker;
 495   $self->otaker =~ /^(\w{1,32})$/ or return "Illegal otaker";
 496   $self->otaker($1);
 497
 498   if ( $self->dbdef_table->column('manual_flag') ) {
 499     $self->manual_flag('') if $self->manual_flag eq ' ';
 500     $self->manual_flag =~ /^([01]?)$/
 501       or return "Illegal manual_flag ". $self->manual_flag;
 502     $self->manual_flag($1);
 503   }
 504
 505   $self->SUPER::check;
 506 }
 507
 508 =item cancel [ OPTION => VALUE ... ]
 509
 510 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
 511 in this package, then cancels the package itself (sets the cancel field to
 512 now).
 513
 514 Available options are:
 515
 516 =over 4
 517
 518 =item quiet - can be set true to supress email cancellation notices.
 519
 520 =item time -  can be set to cancel the package based on a specific future or historical date.  Using time ensures that the remaining amount is calculated correctly.  Note however that this is an immediate cancel and just changes the date.  You are PROBABLY looking to expire the account instead of using this.
 521
 522 =item reason - 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.
 523
 524 =item date - can be set to a unix style timestamp to specify when to cancel (expire)
 525
 526 =back
 527
 528 If there is an error, returns the error, otherwise returns false.
 529
 530 =cut
 531
 532 sub cancel {
 533   my( $self, %options ) = @_;
 534   my $error;
 535
 536   warn "cust_pkg::cancel called with options".
 537        join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
 538     if $DEBUG;
 539
 540   local $SIG{HUP} = 'IGNORE';
 541   local $SIG{INT} = 'IGNORE';
 542   local $SIG{QUIT} = 'IGNORE';
 543   local $SIG{TERM} = 'IGNORE';
 544   local $SIG{TSTP} = 'IGNORE';
 545   local $SIG{PIPE} = 'IGNORE';
 546
 547   my $oldAutoCommit = $FS::UID::AutoCommit;
 548   local $FS::UID::AutoCommit = 0;
 549   my $dbh = dbh;
 550
 551   my $old = $self->select_for_update;
 552
 553   if ( $old->get('cancel') || $self->get('cancel') ) {
 554     dbh->rollback if $oldAutoCommit;
 555     return "";  # no error
 556   }
 557
 558   my $date = $options{date} if $options{date}; # expire/cancel later
 559   $date = '' if ($date && $date <= time);      # complain instead?
 560
 561   my $cancel_time = $options{'time'} || time;
 562
 563   if ( $options{'reason'} ) {
 564     $error = $self->insert_reason( 'reason' => $options{'reason'},
 565                                    'action' => $date ? 'expire' : 'cancel',
 566                                    'date'   => $date ? $date : $cancel_time,
 567                                    'reason_otaker' => $options{'reason_otaker'},
 568                                  );
 569     if ( $error ) {
 570       dbh->rollback if $oldAutoCommit;
 571       return "Error inserting cust_pkg_reason: $error";
 572     }
 573   }
 574
 575   my %svc;
 576   unless ( $date ) {
 577     foreach my $cust_svc (
 578       #schwartz
 579       map  { $_->[0] }
 580       sort { $a->[1] <=> $b->[1] }
 581       map  { [ $_, $_->svc_x->table_info->{'cancel_weight'} ]; }
 582       qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 583     ) {
 584
 585       my $error = $cust_svc->cancel;
 586
 587       if ( $error ) {
 588         $dbh->rollback if $oldAutoCommit;
 589         return "Error cancelling cust_svc: $error";
 590       }
 591     }
 592
 593     # Add a credit for remaining service
 594     my $remaining_value = $self->calc_remain(time=>$cancel_time);
 595     if ( $remaining_value > 0 && !$options{'no_credit'} ) {
 596       my $conf = new FS::Conf;
 597       my $error = $self->cust_main->credit(
 598         $remaining_value,
 599         'Credit for unused time on '. $self->part_pkg->pkg,
 600         'reason_type' => $conf->config('cancel_credit_type'),
 601       );
 602       if ($error) {
 603         $dbh->rollback if $oldAutoCommit;
 604         return "Error crediting customer \$$remaining_value for unused time on".
 605                $self->part_pkg->pkg. ": $error";
 606       }
 607     }
 608   }
 609
 610   my %hash = $self->hash;
 611   $date ? ($hash{'expire'} = $date) : ($hash{'cancel'} = $cancel_time);
 612   my $new = new FS::cust_pkg ( \%hash );
 613   $error = $new->replace( $self, options => { $self->options } );
 614   if ( $error ) {
 615     $dbh->rollback if $oldAutoCommit;
 616     return $error;
 617   }
 618
 619   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 620   return '' if $date; #no errors
 621
 622   my $conf = new FS::Conf;
 623   my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
 624   if ( !$options{'quiet'} && $conf->exists('emailcancel') && @invoicing_list ) {
 625     my $conf = new FS::Conf;
 626     my $error = send_email(
 627       'from'    => $conf->config('invoice_from', $self->cust_main->agentnum),
 628       'to'      => \@invoicing_list,
 629       'subject' => ( $conf->config('cancelsubject') || 'Cancellation Notice' ),
 630       'body'    => [ map "$_\n", $conf->config('cancelmessage') ],
 631     );
 632     #should this do something on errors?
 633   }
 634
 635   ''; #no errors
 636
 637 }
 638
 639 =item cancel_if_expired [ NOW_TIMESTAMP ]
 640
 641 Cancels this package if its expire date has been reached.
 642
 643 =cut
 644
 645 sub cancel_if_expired {
 646   my $self = shift;
 647   my $time = shift || time;
 648   return '' unless $self->expire && $self->expire <= $time;
 649   my $error = $self->cancel;
 650   if ( $error ) {
 651     return "Error cancelling expired pkg ". $self->pkgnum. " for custnum ".
 652            $self->custnum. ": $error";
 653   }
 654   '';
 655 }
 656
 657 =item unexpire
 658
 659 Cancels any pending expiration (sets the expire field to null).
 660
 661 If there is an error, returns the error, otherwise returns false.
 662
 663 =cut
 664
 665 sub unexpire {
 666   my( $self, %options ) = @_;
 667   my $error;
 668
 669   local $SIG{HUP} = 'IGNORE';
 670   local $SIG{INT} = 'IGNORE';
 671   local $SIG{QUIT} = 'IGNORE';
 672   local $SIG{TERM} = 'IGNORE';
 673   local $SIG{TSTP} = 'IGNORE';
 674   local $SIG{PIPE} = 'IGNORE';
 675
 676   my $oldAutoCommit = $FS::UID::AutoCommit;
 677   local $FS::UID::AutoCommit = 0;
 678   my $dbh = dbh;
 679
 680   my $old = $self->select_for_update;
 681
 682   my $pkgnum = $old->pkgnum;
 683   if ( $old->get('cancel') || $self->get('cancel') ) {
 684     dbh->rollback if $oldAutoCommit;
 685     return "Can't unexpire cancelled package $pkgnum";
 686     # or at least it's pointless
 687   }
 688
 689   unless ( $old->get('expire') && $self->get('expire') ) {
 690     dbh->rollback if $oldAutoCommit;
 691     return "";  # no error
 692   }
 693
 694   my %hash = $self->hash;
 695   $hash{'expire'} = '';
 696   my $new = new FS::cust_pkg ( \%hash );
 697   $error = $new->replace( $self, options => { $self->options } );
 698   if ( $error ) {
 699     $dbh->rollback if $oldAutoCommit;
 700     return $error;
 701   }
 702
 703   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 704
 705   ''; #no errors
 706
 707 }
 708
 709 =item suspend [ OPTION => VALUE ... ]
 710
 711 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 712 package, then suspends the package itself (sets the susp field to now).
 713
 714 Available options are:
 715
 716 =over 4
 717
 718 =item reason - 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.
 719
 720 =item date - can be set to a unix style timestamp to specify when to suspend (adjourn)
 721
 722 =back
 723
 724 If there is an error, returns the error, otherwise returns false.
 725
 726 =cut
 727
 728 sub suspend {
 729   my( $self, %options ) = @_;
 730   my $error;
 731
 732   local $SIG{HUP} = 'IGNORE';
 733   local $SIG{INT} = 'IGNORE';
 734   local $SIG{QUIT} = 'IGNORE';
 735   local $SIG{TERM} = 'IGNORE';
 736   local $SIG{TSTP} = 'IGNORE';
 737   local $SIG{PIPE} = 'IGNORE';
 738
 739   my $oldAutoCommit = $FS::UID::AutoCommit;
 740   local $FS::UID::AutoCommit = 0;
 741   my $dbh = dbh;
 742
 743   my $old = $self->select_for_update;
 744
 745   my $pkgnum = $old->pkgnum;
 746   if ( $old->get('cancel') || $self->get('cancel') ) {
 747     dbh->rollback if $oldAutoCommit;
 748     return "Can't suspend cancelled package $pkgnum";
 749   }
 750
 751   if ( $old->get('susp') || $self->get('susp') ) {
 752     dbh->rollback if $oldAutoCommit;
 753     return "";  # no error                     # complain on adjourn?
 754   }
 755
 756   my $date = $options{date} if $options{date}; # adjourn/suspend later
 757   $date = '' if ($date && $date <= time);      # complain instead?
 758
 759   if ( $date && $old->get('expire') && $old->get('expire') < $date ) {
 760     dbh->rollback if $oldAutoCommit;
 761     return "Package $pkgnum expires before it would be suspended.";
 762   }
 763
 764   my $suspend_time = $options{'time'} || time;
 765
 766   if ( $options{'reason'} ) {
 767     $error = $self->insert_reason( 'reason' => $options{'reason'},
 768                                    'action' => $date ? 'adjourn' : 'suspend',
 769                                    'date'   => $date ? $date : $suspend_time,
 770                                    'reason_otaker' => $options{'reason_otaker'},
 771                                  );
 772     if ( $error ) {
 773       dbh->rollback if $oldAutoCommit;
 774       return "Error inserting cust_pkg_reason: $error";
 775     }
 776   }
 777
 778   unless ( $date ) {
 779
 780     my @labels = ();
 781
 782     foreach my $cust_svc (
 783       qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 784     ) {
 785       my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 786
 787       $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 788         $dbh->rollback if $oldAutoCommit;
 789         return "Illegal svcdb value in part_svc!";
 790       };
 791       my $svcdb = $1;
 792       require "FS/$svcdb.pm";
 793
 794       my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
 795       if ($svc) {
 796         $error = $svc->suspend;
 797         if ( $error ) {
 798           $dbh->rollback if $oldAutoCommit;
 799           return $error;
 800         }
 801         my( $label, $value ) = $cust_svc->label;
 802         push @labels, "$label: $value";
 803       }
 804     }
 805
 806     my $conf = new FS::Conf;
 807     if ( $conf->config('suspend_email_admin') ) {
 808
 809       my $error = send_email(
 810         'from'    => $conf->config('invoice_from', $self->cust_main->agentnum),
 811                                    #invoice_from ??? well as good as any
 812         'to'      => $conf->config('suspend_email_admin'),
 813         'subject' => 'FREESIDE NOTIFICATION: Customer package suspended',
 814         'body'    => [
 815           "This is an automatic message from your Freeside installation\n",
 816           "informing you that the following customer package has been suspended:\n",
 817           "\n",
 818           'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
 819           'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
 820           ( map { "Service : $_\n" } @labels ),
 821         ],
 822       );
 823
 824       if ( $error ) {
 825         warn "WARNING: can't send suspension admin email (suspending anyway): ".
 826              "$error\n";
 827       }
 828
 829     }
 830
 831   }
 832
 833   my %hash = $self->hash;
 834   if ( $date ) {
 835     $hash{'adjourn'} = $date;
 836   } else {
 837     $hash{'susp'} = $suspend_time;
 838   }
 839   my $new = new FS::cust_pkg ( \%hash );
 840   $error = $new->replace( $self, options => { $self->options } );
 841   if ( $error ) {
 842     $dbh->rollback if $oldAutoCommit;
 843     return $error;
 844   }
 845
 846   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 847
 848   ''; #no errors
 849 }
 850
 851 =item unsuspend [ OPTION => VALUE ... ]
 852
 853 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 854 package, then unsuspends the package itself (clears the susp field and the
 855 adjourn field if it is in the past).
 856
 857 Available options are:
 858
 859 =over 4
 860
 861 =item adjust_next_bill
 862
 863 Can be set true to adjust the next bill date forward by
 864 the amount of time the account was inactive.  This was set true by default
 865 since 1.4.2 and 1.5.0pre6; however, starting with 1.7.0 this needs to be
 866 explicitly requested.  Price plans for which this makes sense (anniversary-date
 867 based than prorate or subscription) could have an option to enable this
 868 behaviour?
 869
 870 =back
 871
 872 If there is an error, returns the error, otherwise returns false.
 873
 874 =cut
 875
 876 sub unsuspend {
 877   my( $self, %opt ) = @_;
 878   my $error;
 879
 880   local $SIG{HUP} = 'IGNORE';
 881   local $SIG{INT} = 'IGNORE';
 882   local $SIG{QUIT} = 'IGNORE';
 883   local $SIG{TERM} = 'IGNORE';
 884   local $SIG{TSTP} = 'IGNORE';
 885   local $SIG{PIPE} = 'IGNORE';
 886
 887   my $oldAutoCommit = $FS::UID::AutoCommit;
 888   local $FS::UID::AutoCommit = 0;
 889   my $dbh = dbh;
 890
 891   my $old = $self->select_for_update;
 892
 893   my $pkgnum = $old->pkgnum;
 894   if ( $old->get('cancel') || $self->get('cancel') ) {
 895     dbh->rollback if $oldAutoCommit;
 896     return "Can't unsuspend cancelled package $pkgnum";
 897   }
 898
 899   unless ( $old->get('susp') && $self->get('susp') ) {
 900     dbh->rollback if $oldAutoCommit;
 901     return "";  # no error                     # complain instead?
 902   }
 903
 904   foreach my $cust_svc (
 905     qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
 906   ) {
 907     my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 908
 909     $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 910       $dbh->rollback if $oldAutoCommit;
 911       return "Illegal svcdb value in part_svc!";
 912     };
 913     my $svcdb = $1;
 914     require "FS/$svcdb.pm";
 915
 916     my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
 917     if ($svc) {
 918       $error = $svc->unsuspend;
 919       if ( $error ) {
 920         $dbh->rollback if $oldAutoCommit;
 921         return $error;
 922       }
 923     }
 924
 925   }
 926
 927   my %hash = $self->hash;
 928   my $inactive = time - $hash{'susp'};
 929
 930   my $conf = new FS::Conf;
 931
 932   $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive
 933     if ( $opt{'adjust_next_bill'}
 934          || $conf->exists('unsuspend-always_adjust_next_bill_date') )
 935     && $inactive > 0 && ( $hash{'bill'} || $hash{'setup'} );
 936
 937   $hash{'susp'} = '';
 938   $hash{'adjourn'} = '' if $hash{'adjourn'} < time;
 939   my $new = new FS::cust_pkg ( \%hash );
 940   $error = $new->replace( $self, options => { $self->options } );
 941   if ( $error ) {
 942     $dbh->rollback if $oldAutoCommit;
 943     return $error;
 944   }
 945
 946   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 947
 948   ''; #no errors
 949 }
 950
 951 =item unadjourn
 952
 953 Cancels any pending suspension (sets the adjourn field to null).
 954
 955 If there is an error, returns the error, otherwise returns false.
 956
 957 =cut
 958
 959 sub unadjourn {
 960   my( $self, %options ) = @_;
 961   my $error;
 962
 963   local $SIG{HUP} = 'IGNORE';
 964   local $SIG{INT} = 'IGNORE';
 965   local $SIG{QUIT} = 'IGNORE';
 966   local $SIG{TERM} = 'IGNORE';
 967   local $SIG{TSTP} = 'IGNORE';
 968   local $SIG{PIPE} = 'IGNORE';
 969
 970   my $oldAutoCommit = $FS::UID::AutoCommit;
 971   local $FS::UID::AutoCommit = 0;
 972   my $dbh = dbh;
 973
 974   my $old = $self->select_for_update;
 975
 976   my $pkgnum = $old->pkgnum;
 977   if ( $old->get('cancel') || $self->get('cancel') ) {
 978     dbh->rollback if $oldAutoCommit;
 979     return "Can't unadjourn cancelled package $pkgnum";
 980     # or at least it's pointless
 981   }
 982
 983   if ( $old->get('susp') || $self->get('susp') ) {
 984     dbh->rollback if $oldAutoCommit;
 985     return "Can't unadjourn suspended package $pkgnum";
 986     # perhaps this is arbitrary
 987   }
 988
 989   unless ( $old->get('adjourn') && $self->get('adjourn') ) {
 990     dbh->rollback if $oldAutoCommit;
 991     return "";  # no error
 992   }
 993
 994   my %hash = $self->hash;
 995   $hash{'adjourn'} = '';
 996   my $new = new FS::cust_pkg ( \%hash );
 997   $error = $new->replace( $self, options => { $self->options } );
 998   if ( $error ) {
 999     $dbh->rollback if $oldAutoCommit;
1000     return $error;
1001   }
1002
1003   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1004
1005   ''; #no errors
1006
1007 }
1008
1009
1010 =item change HASHREF | OPTION => VALUE ...
1011
1012 Changes this package: cancels it and creates a new one, with a different
1013 pkgpart or locationnum or both.  All services are transferred to the new
1014 package (no change will be made if this is not possible).
1015
1016 Options may be passed as a list of key/value pairs or as a hash reference.
1017 Options are:
1018
1019 =over 4
1020
1021 =item locaitonnum
1022
1023 New locationnum, to change the location for this package.
1024
1025 =item cust_location
1026
1027 New FS::cust_location object, to create a new location and assign it
1028 to this package.
1029
1030 =item pkgpart
1031
1032 New pkgpart (see L<FS::part_pkg>).
1033
1034 =item refnum
1035
1036 New refnum (see L<FS::part_referral>).
1037
1038 =back
1039
1040 At least one option must be specified (otherwise, what's the point?)
1041
1042 Returns either the new FS::cust_pkg object or a scalar error.
1043
1044 For example:
1045
1046   my $err_or_new_cust_pkg = $old_cust_pkg->change
1047
1048 =cut
1049
1050 #some false laziness w/order
1051 sub change {
1052   my $self = shift;
1053   my $opt = ref($_[0]) ? shift : { @_ };
1054
1055 #  my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
1056 #
1057
1058   my $conf = new FS::Conf;
1059
1060   # Transactionize this whole mess
1061   local $SIG{HUP} = 'IGNORE';
1062   local $SIG{INT} = 'IGNORE';
1063   local $SIG{QUIT} = 'IGNORE';
1064   local $SIG{TERM} = 'IGNORE';
1065   local $SIG{TSTP} = 'IGNORE';
1066   local $SIG{PIPE} = 'IGNORE';
1067
1068   my $oldAutoCommit = $FS::UID::AutoCommit;
1069   local $FS::UID::AutoCommit = 0;
1070   my $dbh = dbh;
1071
1072   my $error;
1073
1074   my %hash = ();
1075
1076   my $time = time;
1077
1078   #$hash{$_} = $self->$_() foreach qw( last_bill bill );
1079
1080   #$hash{$_} = $self->$_() foreach qw( setup );
1081
1082   $hash{'setup'} = $time if $self->setup;
1083
1084   $hash{'change_date'} = $time;
1085   $hash{"change_$_"}  = $self->$_()
1086     foreach qw( pkgnum pkgpart locationnum );
1087
1088   if ( $opt->{'cust_location'} &&
1089        ( ! $opt->{'locationnum'} || $opt->{'locationnum'} == -1 ) ) {
1090     $error = $opt->{'cust_location'}->insert;
1091     if ( $error ) {
1092       $dbh->rollback if $oldAutoCommit;
1093       return "inserting cust_location (transaction rolled back): $error";
1094     }
1095     $opt->{'locationnum'} = $opt->{'cust_location'}->locationnum;
1096   }
1097
1098   # Create the new package.
1099   my $cust_pkg = new FS::cust_pkg {
1100     custnum      => $self->custnum,
1101     pkgpart      => ( $opt->{'pkgpart'}     || $self->pkgpart      ),
1102     refnum       => ( $opt->{'refnum'}      || $self->refnum       ),
1103     locationnum  => ( $opt->{'locationnum'} || $self->locationnum  ),
1104     %hash,
1105   };
1106
1107   $error = $cust_pkg->insert( 'change' => 1 );
1108   if ($error) {
1109     $dbh->rollback if $oldAutoCommit;
1110     return $error;
1111   }
1112
1113   # Transfer services and cancel old package.
1114
1115   $error = $self->transfer($cust_pkg);
1116   if ($error and $error == 0) {
1117     # $old_pkg->transfer failed.
1118     $dbh->rollback if $oldAutoCommit;
1119     return $error;
1120   }
1121
1122   if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1123     warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1124     $error = $self->transfer($cust_pkg, 'change_svcpart'=>1 );
1125     if ($error and $error == 0) {
1126       # $old_pkg->transfer failed.
1127       $dbh->rollback if $oldAutoCommit;
1128       return $error;
1129     }
1130   }
1131
1132   if ($error > 0) {
1133     # Transfers were successful, but we still had services left on the old
1134     # package.  We can't change the package under this circumstances, so abort.
1135     $dbh->rollback if $oldAutoCommit;
1136     return "Unable to transfer all services from package ". $self->pkgnum;
1137   }
1138
1139   #reset usage if changing pkgpart
1140   if ($self->pkgpart != $cust_pkg->pkgpart) {
1141     my $part_pkg = $cust_pkg->part_pkg;
1142     $error = $part_pkg->reset_usage($cust_pkg, $part_pkg->is_prepaid
1143                                                  ? ()
1144                                                  : ( 'null' => 1 )
1145                                    )
1146       if $part_pkg->can('reset_usage');
1147
1148     if ($error) {
1149       $dbh->rollback if $oldAutoCommit;
1150       return "Error setting usage values: $error";
1151     }
1152   }
1153
1154   #Good to go, cancel old package.
1155   $error = $self->cancel( quiet=>1 );
1156   if ($error) {
1157     $dbh->rollback;
1158     return $error;
1159   }
1160
1161   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1162   $cust_pkg;
1163
1164 }
1165
1166 =item last_bill
1167
1168 Returns the last bill date, or if there is no last bill date, the setup date.
1169 Useful for billing metered services.
1170
1171 =cut
1172
1173 sub last_bill {
1174   my $self = shift;
1175   return $self->setfield('last_bill', $_[0]) if @_;
1176   return $self->getfield('last_bill') if $self->getfield('last_bill');
1177   my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
1178                                                   'edate'  => $self->bill,  } );
1179   $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
1180 }
1181
1182 =item last_cust_pkg_reason ACTION
1183
1184 Returns the most recent ACTION FS::cust_pkg_reason associated with the package.
1185 Returns false if there is no reason or the package is not currenly ACTION'd
1186 ACTION is one of adjourn, susp, cancel, or expire.
1187
1188 =cut
1189
1190 sub last_cust_pkg_reason {
1191   my ( $self, $action ) = ( shift, shift );
1192   my $date = $self->get($action);
1193   qsearchs( {
1194               'table' => 'cust_pkg_reason',
1195               'hashref' => { 'pkgnum' => $self->pkgnum,
1196                              'action' => substr(uc($action), 0, 1),
1197                              'date'   => $date,
1198                            },
1199               'order_by' => 'ORDER BY num DESC LIMIT 1',
1200            } );
1201 }
1202
1203 =item last_reason ACTION
1204
1205 Returns the most recent ACTION FS::reason associated with the package.
1206 Returns false if there is no reason or the package is not currenly ACTION'd
1207 ACTION is one of adjourn, susp, cancel, or expire.
1208
1209 =cut
1210
1211 sub last_reason {
1212   my $cust_pkg_reason = shift->last_cust_pkg_reason(@_);
1213   $cust_pkg_reason->reason
1214     if $cust_pkg_reason;
1215 }
1216
1217 =item part_pkg
1218
1219 Returns the definition for this billing item, as an FS::part_pkg object (see
1220 L<FS::part_pkg>).
1221
1222 =cut
1223
1224 sub part_pkg {
1225   my $self = shift;
1226   return $self->{'_pkgpart'} if $self->{'_pkgpart'};
1227   cluck "cust_pkg->part_pkg called" if $DEBUG > 1;
1228   qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
1229 }
1230
1231 =item old_cust_pkg
1232
1233 Returns the cancelled package this package was changed from, if any.
1234
1235 =cut
1236
1237 sub old_cust_pkg {
1238   my $self = shift;
1239   return '' unless $self->change_pkgnum;
1240   qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
1241 }
1242
1243 =item calc_setup
1244
1245 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
1246 item.
1247
1248 =cut
1249
1250 sub calc_setup {
1251   my $self = shift;
1252   $self->part_pkg->calc_setup($self, @_);
1253 }
1254
1255 =item calc_recur
1256
1257 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
1258 item.
1259
1260 =cut
1261
1262 sub calc_recur {
1263   my $self = shift;
1264   $self->part_pkg->calc_recur($self, @_);
1265 }
1266
1267 =item calc_remain
1268
1269 Calls the I<calc_remain> of the FS::part_pkg object associated with this
1270 billing item.
1271
1272 =cut
1273
1274 sub calc_remain {
1275   my $self = shift;
1276   $self->part_pkg->calc_remain($self, @_);
1277 }
1278
1279 =item calc_cancel
1280
1281 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
1282 billing item.
1283
1284 =cut
1285
1286 sub calc_cancel {
1287   my $self = shift;
1288   $self->part_pkg->calc_cancel($self, @_);
1289 }
1290
1291 =item cust_bill_pkg
1292
1293 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
1294
1295 =cut
1296
1297 sub cust_bill_pkg {
1298   my $self = shift;
1299   qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
1300 }
1301
1302 =item cust_pkg_detail [ DETAILTYPE ]
1303
1304 Returns any customer package details for this package (see
1305 L<FS::cust_pkg_detail>).
1306
1307 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
1308
1309 =cut
1310
1311 sub cust_pkg_detail {
1312   my $self = shift;
1313   my %hash = ( 'pkgnum' => $self->pkgnum );
1314   $hash{detailtype} = shift if @_;
1315   qsearch({
1316     'table'    => 'cust_pkg_detail',
1317     'hashref'  => \%hash,
1318     'order_by' => 'ORDER BY weight, pkgdetailnum',
1319   });
1320 }
1321
1322 =item set_cust_pkg_detail DETAILTYPE [ DETAIL, DETAIL, ... ]
1323
1324 Sets customer package details for this package (see L<FS::cust_pkg_detail>).
1325
1326 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
1327
1328 If there is an error, returns the error, otherwise returns false.
1329
1330 =cut
1331
1332 sub set_cust_pkg_detail {
1333   my( $self, $detailtype, @details ) = @_;
1334
1335   local $SIG{HUP} = 'IGNORE';
1336   local $SIG{INT} = 'IGNORE';
1337   local $SIG{QUIT} = 'IGNORE';
1338   local $SIG{TERM} = 'IGNORE';
1339   local $SIG{TSTP} = 'IGNORE';
1340   local $SIG{PIPE} = 'IGNORE';
1341
1342   my $oldAutoCommit = $FS::UID::AutoCommit;
1343   local $FS::UID::AutoCommit = 0;
1344   my $dbh = dbh;
1345
1346   foreach my $current ( $self->cust_pkg_detail($detailtype) ) {
1347     my $error = $current->delete;
1348     if ( $error ) {
1349       $dbh->rollback if $oldAutoCommit;
1350       return "error removing old detail: $error";
1351     }
1352   }
1353
1354   foreach my $detail ( @details ) {
1355     my $cust_pkg_detail = new FS::cust_pkg_detail {
1356       'pkgnum'     => $self->pkgnum,
1357       'detailtype' => $detailtype,
1358       'detail'     => $detail,
1359     };
1360     my $error = $cust_pkg_detail->insert;
1361     if ( $error ) {
1362       $dbh->rollback if $oldAutoCommit;
1363       return "error adding new detail: $error";
1364     }
1365
1366   }
1367
1368   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1369   '';
1370
1371 }
1372
1373 =item cust_event
1374
1375 Returns the new-style customer billing events (see L<FS::cust_event>) for this invoice.
1376
1377 =cut
1378
1379 #false laziness w/cust_bill.pm
1380 sub cust_event {
1381   my $self = shift;
1382   qsearch({
1383     'table'     => 'cust_event',
1384     'addl_from' => 'JOIN part_event USING ( eventpart )',
1385     'hashref'   => { 'tablenum' => $self->pkgnum },
1386     'extra_sql' => " AND eventtable = 'cust_pkg' ",
1387   });
1388 }
1389
1390 =item num_cust_event
1391
1392 Returns the number of new-style customer billing events (see L<FS::cust_event>) for this invoice.
1393
1394 =cut
1395
1396 #false laziness w/cust_bill.pm
1397 sub num_cust_event {
1398   my $self = shift;
1399   my $sql =
1400     "SELECT COUNT(*) FROM cust_event JOIN part_event USING ( eventpart ) ".
1401     "  WHERE tablenum = ? AND eventtable = 'cust_pkg'";
1402   my $sth = dbh->prepare($sql) or die  dbh->errstr. " preparing $sql";
1403   $sth->execute($self->pkgnum) or die $sth->errstr. " executing $sql";
1404   $sth->fetchrow_arrayref->[0];
1405 }
1406
1407 =item cust_svc [ SVCPART ]
1408
1409 Returns the services for this package, as FS::cust_svc objects (see
1410 L<FS::cust_svc>).  If a svcpart is specified, return only the matching
1411 services.
1412
1413 =cut
1414
1415 sub cust_svc {
1416   my $self = shift;
1417
1418   return () unless $self->num_cust_svc(@_);
1419
1420   if ( @_ ) {
1421     return qsearch( 'cust_svc', { 'pkgnum'  => $self->pkgnum,
1422                                   'svcpart' => shift,          } );
1423   }
1424
1425   cluck "cust_pkg->cust_svc called" if $DEBUG > 2;
1426
1427   #if ( $self->{'_svcnum'} ) {
1428   #  values %{ $self->{'_svcnum'}->cache };
1429   #} else {
1430     $self->_sort_cust_svc(
1431       [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
1432     );
1433   #}
1434
1435 }
1436
1437 =item overlimit [ SVCPART ]
1438
1439 Returns the services for this package which have exceeded their
1440 usage limit as FS::cust_svc objects (see L<FS::cust_svc>).  If a svcpart
1441 is specified, return only the matching services.
1442
1443 =cut
1444
1445 sub overlimit {
1446   my $self = shift;
1447   return () unless $self->num_cust_svc(@_);
1448   grep { $_->overlimit } $self->cust_svc(@_);
1449 }
1450
1451 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ]
1452
1453 Returns historical services for this package created before END TIMESTAMP and
1454 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
1455 (see L<FS::h_cust_svc>).
1456
1457 =cut
1458
1459 sub h_cust_svc {
1460   my $self = shift;
1461
1462   $self->_sort_cust_svc(
1463     [ qsearch( 'h_cust_svc',
1464                { 'pkgnum' => $self->pkgnum, },
1465                FS::h_cust_svc->sql_h_search(@_),
1466              )
1467     ]
1468   );
1469 }
1470
1471 sub _sort_cust_svc {
1472   my( $self, $arrayref ) = @_;
1473
1474   map  { $_->[0] }
1475   sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
1476   map {
1477         my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
1478                                              'svcpart' => $_->svcpart     } );
1479         [ $_,
1480           $pkg_svc ? $pkg_svc->primary_svc : '',
1481           $pkg_svc ? $pkg_svc->quantity : 0,
1482         ];
1483       }
1484   @$arrayref;
1485
1486 }
1487
1488 =item num_cust_svc [ SVCPART ]
1489
1490 Returns the number of provisioned services for this package.  If a svcpart is
1491 specified, counts only the matching services.
1492
1493 =cut
1494
1495 sub num_cust_svc {
1496   my $self = shift;
1497
1498   return $self->{'_num_cust_svc'}
1499     if !scalar(@_)
1500        && exists($self->{'_num_cust_svc'})
1501        && $self->{'_num_cust_svc'} =~ /\d/;
1502
1503   my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
1504   $sql .= ' AND svcpart = ?' if @_;
1505
1506   my $sth = dbh->prepare($sql)     or die  dbh->errstr;
1507   $sth->execute($self->pkgnum, @_) or die $sth->errstr;
1508   $sth->fetchrow_arrayref->[0];
1509 }
1510
1511 =item available_part_svc
1512
1513 Returns a list of FS::part_svc objects representing services included in this
1514 package but not yet provisioned.  Each FS::part_svc object also has an extra
1515 field, I<num_avail>, which specifies the number of available services.
1516
1517 =cut
1518
1519 sub available_part_svc {
1520   my $self = shift;
1521   grep { $_->num_avail > 0 }
1522     map {
1523           my $part_svc = $_->part_svc;
1524           $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
1525             $_->quantity - $self->num_cust_svc($_->svcpart);
1526           $part_svc;
1527         }
1528       $self->part_pkg->pkg_svc;
1529 }
1530
1531 =item part_svc
1532
1533 Returns a list of FS::part_svc objects representing provisioned and available
1534 services included in this package.  Each FS::part_svc object also has the
1535 following extra fields:
1536
1537 =over 4
1538
1539 =item num_cust_svc  (count)
1540
1541 =item num_avail     (quantity - count)
1542
1543 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
1544
1545 svcnum
1546 label -> ($cust_svc->label)[1]
1547
1548 =back
1549
1550 =cut
1551
1552 sub part_svc {
1553   my $self = shift;
1554
1555   #XXX some sort of sort order besides numeric by svcpart...
1556   my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
1557     my $pkg_svc = $_;
1558     my $part_svc = $pkg_svc->part_svc;
1559     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1560     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
1561     $part_svc->{'Hash'}{'num_avail'}    =
1562       max( 0, $pkg_svc->quantity - $num_cust_svc );
1563     $part_svc->{'Hash'}{'cust_pkg_svc'} =
1564       $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
1565     $part_svc;
1566   } $self->part_pkg->pkg_svc;
1567
1568   #extras
1569   push @part_svc, map {
1570     my $part_svc = $_;
1571     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1572     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
1573     $part_svc->{'Hash'}{'num_avail'}    = 0; #0-$num_cust_svc ?
1574     $part_svc->{'Hash'}{'cust_pkg_svc'} =
1575       $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
1576     $part_svc;
1577   } $self->extra_part_svc;
1578
1579   @part_svc;
1580
1581 }
1582
1583 =item extra_part_svc
1584
1585 Returns a list of FS::part_svc objects corresponding to services in this
1586 package which are still provisioned but not (any longer) available in the
1587 package definition.
1588
1589 =cut
1590
1591 sub extra_part_svc {
1592   my $self = shift;
1593
1594   my $pkgnum  = $self->pkgnum;
1595   my $pkgpart = $self->pkgpart;
1596
1597 #  qsearch( {
1598 #    'table'     => 'part_svc',
1599 #    'hashref'   => {},
1600 #    'extra_sql' =>
1601 #      "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
1602 #                     WHERE pkg_svc.svcpart = part_svc.svcpart
1603 #                       AND pkg_svc.pkgpart = ?
1604 #                       AND quantity > 0
1605 #                 )
1606 #        AND 0 < ( SELECT COUNT(*) FROM cust_svc
1607 #                       LEFT JOIN cust_pkg USING ( pkgnum )
1608 #                     WHERE cust_svc.svcpart = part_svc.svcpart
1609 #                       AND pkgnum = ?
1610 #                 )",
1611 #    'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
1612 #  } );
1613
1614 #seems to benchmark slightly faster...
1615   qsearch( {
1616     'select'      => 'DISTINCT ON (svcpart) part_svc.*',
1617     'table'       => 'part_svc',
1618     'addl_from'   =>
1619       'LEFT JOIN pkg_svc  ON (     pkg_svc.svcpart   = part_svc.svcpart
1620                                AND pkg_svc.pkgpart   = ?
1621                                AND quantity > 0
1622                              )
1623        LEFT JOIN cust_svc ON (     cust_svc.svcpart = part_svc.svcpart )
1624        LEFT JOIN cust_pkg USING ( pkgnum )
1625       ',
1626     'hashref'     => {},
1627     'extra_sql'   => "WHERE pkgsvcnum IS NULL AND cust_pkg.pkgnum = ? ",
1628     'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
1629   } );
1630 }
1631
1632 =item status
1633
1634 Returns a short status string for this package, currently:
1635
1636 =over 4
1637
1638 =item not yet billed
1639
1640 =item one-time charge
1641
1642 =item active
1643
1644 =item suspended
1645
1646 =item cancelled
1647
1648 =back
1649
1650 =cut
1651
1652 sub status {
1653   my $self = shift;
1654
1655   my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
1656
1657   return 'cancelled' if $self->get('cancel');
1658   return 'suspended' if $self->susp;
1659   return 'not yet billed' unless $self->setup;
1660   return 'one-time charge' if $freq =~ /^(0|$)/;
1661   return 'active';
1662 }
1663
1664 =item statuses
1665
1666 Class method that returns the list of possible status strings for packages
1667 (see L<the status method|/status>).  For example:
1668
1669   @statuses = FS::cust_pkg->statuses();
1670
1671 =cut
1672
1673 tie my %statuscolor, 'Tie::IxHash',
1674   'not yet billed'  => '000000',
1675   'one-time charge' => '000000',
1676   'active'          => '00CC00',
1677   'suspended'       => 'FF9900',
1678   'cancelled'       => 'FF0000',
1679 ;
1680
1681 sub statuses {
1682   my $self = shift; #could be class...
1683   grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
1684                                       # mayble split btw one-time vs. recur
1685     keys %statuscolor;
1686 }
1687
1688 =item statuscolor
1689
1690 Returns a hex triplet color string for this package's status.
1691
1692 =cut
1693
1694 sub statuscolor {
1695   my $self = shift;
1696   $statuscolor{$self->status};
1697 }
1698
1699 =item labels
1700
1701 Returns a list of lists, calling the label method for all services
1702 (see L<FS::cust_svc>) of this billing item.
1703
1704 =cut
1705
1706 sub labels {
1707   my $self = shift;
1708   map { [ $_->label ] } $self->cust_svc;
1709 }
1710
1711 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
1712
1713 Like the labels method, but returns historical information on services that
1714 were active as of END_TIMESTAMP and (optionally) not cancelled before
1715 START_TIMESTAMP.
1716
1717 Returns a list of lists, calling the label method for all (historical) services
1718 (see L<FS::h_cust_svc>) of this billing item.
1719
1720 =cut
1721
1722 sub h_labels {
1723   my $self = shift;
1724   map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
1725 }
1726
1727 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
1728
1729 Like h_labels, except returns a simple flat list, and shortens long
1730 (currently >5 or the cust_bill-max_same_services configuration value) lists of
1731 identical services to one line that lists the service label and the number of
1732 individual services rather than individual items.
1733
1734 =cut
1735
1736 sub h_labels_short {
1737   my $self = shift;
1738
1739   my $conf = new FS::Conf;
1740   my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
1741
1742   my %labels;
1743   #tie %labels, 'Tie::IxHash';
1744   push @{ $labels{$_->[0]} }, $_->[1]
1745     foreach $self->h_labels(@_);
1746   my @labels;
1747   foreach my $label ( keys %labels ) {
1748     my %seen = ();
1749     my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
1750     my $num = scalar(@values);
1751     if ( $num > $max_same_services ) {
1752       push @labels, "$label ($num)";
1753     } else {
1754       push @labels, map { "$label: $_" } @values;
1755     }
1756   }
1757
1758  @labels;
1759
1760 }
1761
1762 =item cust_main
1763
1764 Returns the parent customer object (see L<FS::cust_main>).
1765
1766 =cut
1767
1768 sub cust_main {
1769   my $self = shift;
1770   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
1771 }
1772
1773 =item cust_location
1774
1775 Returns the location object, if any (see L<FS::cust_location>).
1776
1777 =cut
1778
1779 sub cust_location {
1780   my $self = shift;
1781   return '' unless $self->locationnum;
1782   qsearchs( 'cust_location', { 'locationnum' => $self->locationnum } );
1783 }
1784
1785 =item cust_location_or_main
1786
1787 If this package is associated with a location, returns the locaiton (see
1788 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
1789
1790 =cut
1791
1792 sub cust_location_or_main {
1793   my $self = shift;
1794   $self->cust_location || $self->cust_main;
1795 }
1796
1797 =item seconds_since TIMESTAMP
1798
1799 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
1800 package have been online since TIMESTAMP, according to the session monitor.
1801
1802 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1803 L<Time::Local> and L<Date::Parse> for conversion functions.
1804
1805 =cut
1806
1807 sub seconds_since {
1808   my($self, $since) = @_;
1809   my $seconds = 0;
1810
1811   foreach my $cust_svc (
1812     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
1813   ) {
1814     $seconds += $cust_svc->seconds_since($since);
1815   }
1816
1817   $seconds;
1818
1819 }
1820
1821 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1822
1823 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
1824 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
1825 (exclusive).
1826
1827 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1828 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1829 functions.
1830
1831
1832 =cut
1833
1834 sub seconds_since_sqlradacct {
1835   my($self, $start, $end) = @_;
1836
1837   my $seconds = 0;
1838
1839   foreach my $cust_svc (
1840     grep {
1841       my $part_svc = $_->part_svc;
1842       $part_svc->svcdb eq 'svc_acct'
1843         && scalar($part_svc->part_export('sqlradius'));
1844     } $self->cust_svc
1845   ) {
1846     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
1847   }
1848
1849   $seconds;
1850
1851 }
1852
1853 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1854
1855 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1856 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1857 TIMESTAMP_END
1858 (exclusive).
1859
1860 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1861 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1862 functions.
1863
1864 =cut
1865
1866 sub attribute_since_sqlradacct {
1867   my($self, $start, $end, $attrib) = @_;
1868
1869   my $sum = 0;
1870
1871   foreach my $cust_svc (
1872     grep {
1873       my $part_svc = $_->part_svc;
1874       $part_svc->svcdb eq 'svc_acct'
1875         && scalar($part_svc->part_export('sqlradius'));
1876     } $self->cust_svc
1877   ) {
1878     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
1879   }
1880
1881   $sum;
1882
1883 }
1884
1885 =item quantity
1886
1887 =cut
1888
1889 sub quantity {
1890   my( $self, $value ) = @_;
1891   if ( defined($value) ) {
1892     $self->setfield('quantity', $value);
1893   }
1894   $self->getfield('quantity') || 1;
1895 }
1896
1897 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
1898
1899 Transfers as many services as possible from this package to another package.
1900
1901 The destination package can be specified by pkgnum by passing an FS::cust_pkg
1902 object.  The destination package must already exist.
1903
1904 Services are moved only if the destination allows services with the correct
1905 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
1906 this option with caution!  No provision is made for export differences
1907 between the old and new service definitions.  Probably only should be used
1908 when your exports for all service definitions of a given svcdb are identical.
1909 (attempt a transfer without it first, to move all possible svcpart-matching
1910 services)
1911
1912 Any services that can't be moved remain in the original package.
1913
1914 Returns an error, if there is one; otherwise, returns the number of services
1915 that couldn't be moved.
1916
1917 =cut
1918
1919 sub transfer {
1920   my ($self, $dest_pkgnum, %opt) = @_;
1921
1922   my $remaining = 0;
1923   my $dest;
1924   my %target;
1925
1926   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
1927     $dest = $dest_pkgnum;
1928     $dest_pkgnum = $dest->pkgnum;
1929   } else {
1930     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
1931   }
1932
1933   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
1934
1935   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
1936     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
1937   }
1938
1939   foreach my $cust_svc ($dest->cust_svc) {
1940     $target{$cust_svc->svcpart}--;
1941   }
1942
1943   my %svcpart2svcparts = ();
1944   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1945     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
1946     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
1947       next if exists $svcpart2svcparts{$svcpart};
1948       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
1949       $svcpart2svcparts{$svcpart} = [
1950         map  { $_->[0] }
1951         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
1952         map {
1953               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
1954                                                    'svcpart' => $_          } );
1955               [ $_,
1956                 $pkg_svc ? $pkg_svc->primary_svc : '',
1957                 $pkg_svc ? $pkg_svc->quantity : 0,
1958               ];
1959             }
1960
1961         grep { $_ != $svcpart }
1962         map  { $_->svcpart }
1963         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
1964       ];
1965       warn "alternates for svcpart $svcpart: ".
1966            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
1967         if $DEBUG;
1968     }
1969   }
1970
1971   foreach my $cust_svc ($self->cust_svc) {
1972     if($target{$cust_svc->svcpart} > 0) {
1973       $target{$cust_svc->svcpart}--;
1974       my $new = new FS::cust_svc { $cust_svc->hash };
1975       $new->pkgnum($dest_pkgnum);
1976       my $error = $new->replace($cust_svc);
1977       return $error if $error;
1978     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1979       if ( $DEBUG ) {
1980         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
1981         warn "alternates to consider: ".
1982              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
1983       }
1984       my @alternate = grep {
1985                              warn "considering alternate svcpart $_: ".
1986                                   "$target{$_} available in new package\n"
1987                                if $DEBUG;
1988                              $target{$_} > 0;
1989                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
1990       if ( @alternate ) {
1991         warn "alternate(s) found\n" if $DEBUG;
1992         my $change_svcpart = $alternate[0];
1993         $target{$change_svcpart}--;
1994         my $new = new FS::cust_svc { $cust_svc->hash };
1995         $new->svcpart($change_svcpart);
1996         $new->pkgnum($dest_pkgnum);
1997         my $error = $new->replace($cust_svc);
1998         return $error if $error;
1999       } else {
2000         $remaining++;
2001       }
2002     } else {
2003       $remaining++
2004     }
2005   }
2006   return $remaining;
2007 }
2008
2009 =item reexport
2010
2011 This method is deprecated.  See the I<depend_jobnum> option to the insert and
2012 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
2013
2014 =cut
2015
2016 sub reexport {
2017   my $self = shift;
2018
2019   local $SIG{HUP} = 'IGNORE';
2020   local $SIG{INT} = 'IGNORE';
2021   local $SIG{QUIT} = 'IGNORE';
2022   local $SIG{TERM} = 'IGNORE';
2023   local $SIG{TSTP} = 'IGNORE';
2024   local $SIG{PIPE} = 'IGNORE';
2025
2026   my $oldAutoCommit = $FS::UID::AutoCommit;
2027   local $FS::UID::AutoCommit = 0;
2028   my $dbh = dbh;
2029
2030   foreach my $cust_svc ( $self->cust_svc ) {
2031     #false laziness w/svc_Common::insert
2032     my $svc_x = $cust_svc->svc_x;
2033     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
2034       my $error = $part_export->export_insert($svc_x);
2035       if ( $error ) {
2036         $dbh->rollback if $oldAutoCommit;
2037         return $error;
2038       }
2039     }
2040   }
2041
2042   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2043   '';
2044
2045 }
2046
2047 =back
2048
2049 =head1 CLASS METHODS
2050
2051 =over 4
2052
2053 =item recurring_sql
2054
2055 Returns an SQL expression identifying recurring packages.
2056
2057 =cut
2058
2059 sub recurring_sql { "
2060   '0' != ( select freq from part_pkg
2061              where cust_pkg.pkgpart = part_pkg.pkgpart )
2062 "; }
2063
2064 =item onetime_sql
2065
2066 Returns an SQL expression identifying one-time packages.
2067
2068 =cut
2069
2070 sub onetime_sql { "
2071   '0' = ( select freq from part_pkg
2072             where cust_pkg.pkgpart = part_pkg.pkgpart )
2073 "; }
2074
2075 =item active_sql
2076
2077 Returns an SQL expression identifying active packages.
2078
2079 =cut
2080
2081 sub active_sql { "
2082   ". $_[0]->recurring_sql(). "
2083   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2084   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2085 "; }
2086
2087 =item inactive_sql
2088
2089 Returns an SQL expression identifying inactive packages (one-time packages
2090 that are otherwise unsuspended/uncancelled).
2091
2092 =cut
2093
2094 sub inactive_sql { "
2095   ". $_[0]->onetime_sql(). "
2096   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2097   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2098 "; }
2099
2100 =item susp_sql
2101 =item suspended_sql
2102
2103 Returns an SQL expression identifying suspended packages.
2104
2105 =cut
2106
2107 sub suspended_sql { susp_sql(@_); }
2108 sub susp_sql {
2109   #$_[0]->recurring_sql(). ' AND '.
2110   "
2111         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
2112     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
2113   ";
2114 }
2115
2116 =item cancel_sql
2117 =item cancelled_sql
2118
2119 Returns an SQL exprression identifying cancelled packages.
2120
2121 =cut
2122
2123 sub cancelled_sql { cancel_sql(@_); }
2124 sub cancel_sql {
2125   #$_[0]->recurring_sql(). ' AND '.
2126   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
2127 }
2128
2129 =item search_sql HASHREF
2130
2131 (Class method)
2132
2133 Returns a qsearch hash expression to search for parameters specified in HASHREF.
2134 Valid parameters are
2135
2136 =over 4
2137
2138 =item agentnum
2139
2140 =item magic
2141
2142 active, inactive, suspended, cancel (or cancelled)
2143
2144 =item status
2145
2146 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
2147
2148 =item classnum
2149
2150 =item pkgpart
2151
2152 list specified how?
2153
2154 =item setup
2155
2156 arrayref of beginning and ending epoch date
2157
2158 =item last_bill
2159
2160 arrayref of beginning and ending epoch date
2161
2162 =item bill
2163
2164 arrayref of beginning and ending epoch date
2165
2166 =item adjourn
2167
2168 arrayref of beginning and ending epoch date
2169
2170 =item susp
2171
2172 arrayref of beginning and ending epoch date
2173
2174 =item expire
2175
2176 arrayref of beginning and ending epoch date
2177
2178 =item cancel
2179
2180 arrayref of beginning and ending epoch date
2181
2182 =item query
2183
2184 pkgnum or APKG_pkgnum
2185
2186 =item cust_fields
2187
2188 a value suited to passing to FS::UI::Web::cust_header
2189
2190 =item CurrentUser
2191
2192 specifies the user for agent virtualization
2193
2194 =back
2195
2196 =cut
2197
2198 sub search_sql {
2199   my ($class, $params) = @_;
2200   my @where = ();
2201
2202   ##
2203   # parse agent
2204   ##
2205
2206   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2207     push @where,
2208       "cust_main.agentnum = $1";
2209   }
2210
2211   ##
2212   # parse status
2213   ##
2214
2215   if (    $params->{'magic'}  eq 'active'
2216        || $params->{'status'} eq 'active' ) {
2217
2218     push @where, FS::cust_pkg->active_sql();
2219
2220   } elsif (    $params->{'magic'}  eq 'inactive'
2221             || $params->{'status'} eq 'inactive' ) {
2222
2223     push @where, FS::cust_pkg->inactive_sql();
2224
2225   } elsif (    $params->{'magic'}  eq 'suspended'
2226             || $params->{'status'} eq 'suspended'  ) {
2227
2228     push @where, FS::cust_pkg->suspended_sql();
2229
2230   } elsif (    $params->{'magic'}  =~ /^cancell?ed$/
2231             || $params->{'status'} =~ /^cancell?ed$/ ) {
2232
2233     push @where, FS::cust_pkg->cancelled_sql();
2234
2235   } elsif ( $params->{'status'} =~ /^(one-time charge|inactive)$/ ) {
2236
2237     push @where, FS::cust_pkg->inactive_sql();
2238
2239   }
2240
2241   ###
2242   # parse package class
2243   ###
2244
2245   #false lazinessish w/graph/cust_bill_pkg.cgi
2246   my $classnum = 0;
2247   my @pkg_class = ();
2248   if ( exists($params->{'classnum'})
2249        && $params->{'classnum'} =~ /^(\d*)$/
2250      )
2251   {
2252     $classnum = $1;
2253     if ( $classnum ) { #a specific class
2254       push @where, "classnum = $classnum";
2255
2256       #@pkg_class = ( qsearchs('pkg_class', { 'classnum' => $classnum } ) );
2257       #die "classnum $classnum not found!" unless $pkg_class[0];
2258       #$title .= $pkg_class[0]->classname.' ';
2259
2260     } elsif ( $classnum eq '' ) { #the empty class
2261
2262       push @where, "classnum IS NULL";
2263       #$title .= 'Empty class ';
2264       #@pkg_class = ( '(empty class)' );
2265     } elsif ( $classnum eq '0' ) {
2266       #@pkg_class = qsearch('pkg_class', {} ); # { 'disabled' => '' } );
2267       #push @pkg_class, '(empty class)';
2268     } else {
2269       die "illegal classnum";
2270     }
2271   }
2272   #eslaf
2273
2274   ###
2275   # parse part_pkg
2276   ###
2277
2278   my $pkgpart = join (' OR pkgpart=',
2279                       grep {$_} map { /^(\d+)$/; } ($params->{'pkgpart'}));
2280   push @where,  '(pkgpart=' . $pkgpart . ')' if $pkgpart;
2281
2282   ###
2283   # parse dates
2284   ###
2285
2286   my $orderby = '';
2287
2288   #false laziness w/report_cust_pkg.html
2289   my %disable = (
2290     'all'             => {},
2291     'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
2292     'active'          => { 'susp'=>1, 'cancel'=>1 },
2293     'suspended'       => { 'cancel' => 1 },
2294     'cancelled'       => {},
2295     ''                => {},
2296   );
2297
2298   foreach my $field (qw( setup last_bill bill adjourn susp expire cancel )) {
2299
2300     next unless exists($params->{$field});
2301
2302     my($beginning, $ending) = @{$params->{$field}};
2303
2304     next if $beginning == 0 && $ending == 4294967295;
2305
2306     push @where,
2307       "cust_pkg.$field IS NOT NULL",
2308       "cust_pkg.$field >= $beginning",
2309       "cust_pkg.$field <= $ending";
2310
2311     $orderby ||= "ORDER BY cust_pkg.$field";
2312
2313   }
2314
2315   $orderby ||= 'ORDER BY bill';
2316
2317   ###
2318   # parse magic, legacy, etc.
2319   ###
2320
2321   if ( $params->{'magic'} &&
2322        $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
2323   ) {
2324
2325     $orderby = 'ORDER BY pkgnum';
2326
2327     if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
2328       push @where, "pkgpart = $1";
2329     }
2330
2331   } elsif ( $params->{'query'} eq 'pkgnum' ) {
2332
2333     $orderby = 'ORDER BY pkgnum';
2334
2335   } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
2336
2337     $orderby = 'ORDER BY pkgnum';
2338
2339     push @where, '0 < (
2340       SELECT count(*) FROM pkg_svc
2341        WHERE pkg_svc.pkgpart =  cust_pkg.pkgpart
2342          AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
2343                                    WHERE cust_svc.pkgnum  = cust_pkg.pkgnum
2344                                      AND cust_svc.svcpart = pkg_svc.svcpart
2345                                 )
2346     )';
2347
2348   }
2349
2350   ##
2351   # setup queries, links, subs, etc. for the search
2352   ##
2353
2354   # here is the agent virtualization
2355   if ($params->{CurrentUser}) {
2356     my $access_user =
2357       qsearchs('access_user', { username => $params->{CurrentUser} });
2358
2359     if ($access_user) {
2360       push @where, $access_user->agentnums_sql('table'=>'cust_main');
2361     }else{
2362       push @where, "1=0";
2363     }
2364   }else{
2365     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
2366   }
2367
2368   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
2369
2370   my $addl_from = 'LEFT JOIN cust_main USING ( custnum  ) '.
2371                   'LEFT JOIN part_pkg  USING ( pkgpart  ) '.
2372                   'LEFT JOIN pkg_class USING ( classnum ) ';
2373
2374   my $count_query = "SELECT COUNT(*) FROM cust_pkg $addl_from $extra_sql";
2375
2376   my $sql_query = {
2377     'table'       => 'cust_pkg',
2378     'hashref'     => {},
2379     'select'      => join(', ',
2380                                 'cust_pkg.*',
2381                                 ( map "part_pkg.$_", qw( pkg freq ) ),
2382                                 'pkg_class.classname',
2383                                 'cust_main.custnum as cust_main_custnum',
2384                                 FS::UI::Web::cust_sql_fields(
2385                                   $params->{'cust_fields'}
2386                                 ),
2387                      ),
2388     'extra_sql'   => "$extra_sql $orderby",
2389     'addl_from'   => $addl_from,
2390     'count_query' => $count_query,
2391   };
2392
2393 }
2394
2395 =item location_sql
2396
2397 Returns a list: the first item is an SQL fragment identifying matching
2398 packages/customers via location (taking into account shipping and package
2399 address taxation, if enabled), and subsequent items are the parameters to
2400 substitute for the placeholders in that fragment.
2401
2402 =cut
2403
2404 sub location_sql {
2405   my($class, %opt) = @_;
2406   my $ornull = $opt{'ornull'};
2407
2408   my $conf = new FS::Conf;
2409
2410   # '?' placeholders in _location_sql_where
2411   my @bill_param;
2412   if ( $ornull ) {
2413     @bill_param = qw( county county state state state country );
2414   } else {
2415     @bill_param = qw( county state state country );
2416   }
2417   unshift @bill_param, 'county'; # unless $nec;
2418
2419   my $main_where;
2420   my @main_param;
2421   if ( $conf->exists('tax-ship_address') ) {
2422
2423     $main_where = "(
2424          (     ( ship_last IS NULL     OR  ship_last  = '' )
2425            AND ". _location_sql_where('cust_main', '', $ornull ). "
2426          )
2427       OR (       ship_last IS NOT NULL AND ship_last != ''
2428            AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
2429          )
2430     )";
2431     #    AND payby != 'COMP'
2432
2433     @main_param = ( @bill_param, @bill_param );
2434
2435   } else {
2436
2437     $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
2438     @main_param = @bill_param;
2439
2440   }
2441
2442   my $where;
2443   my @param;
2444   if ( $conf->exists('tax-pkg_address') ) {
2445
2446     my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
2447
2448     $where = " (
2449                     ( cust_pkg.locationnum IS     NULL AND $main_where )
2450                  OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where  )
2451                )
2452              ";
2453     @param = ( @main_param, @bill_param );
2454
2455   } else {
2456
2457     $where = $main_where;
2458     @param = @main_param;
2459
2460   }
2461
2462   ( $where, @param );
2463
2464 }
2465
2466 #subroutine, helper for location_sql
2467 sub _location_sql_where {
2468   my $table  = shift;
2469   my $prefix = @_ ? shift : '';
2470   my $ornull = @_ ? shift : '';
2471
2472 #  $ornull             = $ornull          ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
2473
2474   $ornull = $ornull ? ' OR ? IS NULL ' : '';
2475
2476   my $or_empty_county = " OR ( ? = '' AND $table.${prefix}county IS NULL ) ";
2477   my $or_empty_state =  " OR ( ? = '' AND $table.${prefix}state  IS NULL ) ";
2478
2479   "
2480         ( $table.${prefix}county  = ? $or_empty_county $ornull )
2481     AND ( $table.${prefix}state   = ? $or_empty_state  $ornull )
2482     AND   $table.${prefix}country = ?
2483   ";
2484 }
2485
2486 =head1 SUBROUTINES
2487
2488 =over 4
2489
2490 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
2491
2492 CUSTNUM is a customer (see L<FS::cust_main>)
2493
2494 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
2495 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
2496 permitted.
2497
2498 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
2499 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
2500 new billing items.  An error is returned if this is not possible (see
2501 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
2502 parameter.
2503
2504 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
2505 newly-created cust_pkg objects.
2506
2507 REFNUM, if specified, will specify the FS::pkg_referral record to be created
2508 and inserted.  Multiple FS::pkg_referral records can be created by
2509 setting I<refnum> to an array reference of refnums or a hash reference with
2510 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
2511 record will be created corresponding to cust_main.refnum.
2512
2513 =cut
2514
2515 sub order {
2516   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
2517
2518   my $conf = new FS::Conf;
2519
2520   # Transactionize this whole mess
2521   local $SIG{HUP} = 'IGNORE';
2522   local $SIG{INT} = 'IGNORE';
2523   local $SIG{QUIT} = 'IGNORE';
2524   local $SIG{TERM} = 'IGNORE';
2525   local $SIG{TSTP} = 'IGNORE';
2526   local $SIG{PIPE} = 'IGNORE';
2527
2528   my $oldAutoCommit = $FS::UID::AutoCommit;
2529   local $FS::UID::AutoCommit = 0;
2530   my $dbh = dbh;
2531
2532   my $error;
2533 #  my $cust_main = qsearchs('cust_main', { custnum => $custnum });
2534 #  return "Customer not found: $custnum" unless $cust_main;
2535
2536   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
2537                          @$remove_pkgnum;
2538
2539   my $change = scalar(@old_cust_pkg) != 0;
2540
2541   my %hash = ();
2542   if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
2543
2544     my $err_or_cust_pkg =
2545       $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
2546                                 'refnum'  => $refnum,
2547                               );
2548
2549     unless (ref($err_or_cust_pkg)) {
2550       $dbh->rollback if $oldAutoCommit;
2551       return $err_or_cust_pkg;
2552     }
2553
2554     push @$return_cust_pkg, $err_or_cust_pkg;
2555     return '';
2556
2557   }
2558
2559   # Create the new packages.
2560   foreach my $pkgpart (@$pkgparts) {
2561     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
2562                                       pkgpart => $pkgpart,
2563                                       refnum  => $refnum,
2564                                       %hash,
2565                                     };
2566     $error = $cust_pkg->insert( 'change' => $change );
2567     if ($error) {
2568       $dbh->rollback if $oldAutoCommit;
2569       return $error;
2570     }
2571     push @$return_cust_pkg, $cust_pkg;
2572   }
2573   # $return_cust_pkg now contains refs to all of the newly
2574   # created packages.
2575
2576   # Transfer services and cancel old packages.
2577   foreach my $old_pkg (@old_cust_pkg) {
2578
2579     foreach my $new_pkg (@$return_cust_pkg) {
2580       $error = $old_pkg->transfer($new_pkg);
2581       if ($error and $error == 0) {
2582         # $old_pkg->transfer failed.
2583         $dbh->rollback if $oldAutoCommit;
2584         return $error;
2585       }
2586     }
2587
2588     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
2589       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
2590       foreach my $new_pkg (@$return_cust_pkg) {
2591         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
2592         if ($error and $error == 0) {
2593           # $old_pkg->transfer failed.
2594         $dbh->rollback if $oldAutoCommit;
2595         return $error;
2596         }
2597       }
2598     }
2599
2600     if ($error > 0) {
2601       # Transfers were successful, but we went through all of the
2602       # new packages and still had services left on the old package.
2603       # We can't cancel the package under the circumstances, so abort.
2604       $dbh->rollback if $oldAutoCommit;
2605       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
2606     }
2607     $error = $old_pkg->cancel( quiet=>1 );
2608     if ($error) {
2609       $dbh->rollback;
2610       return $error;
2611     }
2612   }
2613   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2614   '';
2615 }
2616
2617 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
2618
2619 A bulk change method to change packages for multiple customers.
2620
2621 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
2622 L<FS::part_pkg>) to order for each customer.  Duplicates are of course
2623 permitted.
2624
2625 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
2626 replace.  The services (see L<FS::cust_svc>) are moved to the
2627 new billing items.  An error is returned if this is not possible (see
2628 L<FS::pkg_svc>).
2629
2630 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
2631 newly-created cust_pkg objects.
2632
2633 =cut
2634
2635 sub bulk_change {
2636   my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
2637
2638   # Transactionize this whole mess
2639   local $SIG{HUP} = 'IGNORE';
2640   local $SIG{INT} = 'IGNORE';
2641   local $SIG{QUIT} = 'IGNORE';
2642   local $SIG{TERM} = 'IGNORE';
2643   local $SIG{TSTP} = 'IGNORE';
2644   local $SIG{PIPE} = 'IGNORE';
2645
2646   my $oldAutoCommit = $FS::UID::AutoCommit;
2647   local $FS::UID::AutoCommit = 0;
2648   my $dbh = dbh;
2649
2650   my @errors;
2651   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
2652                          @$remove_pkgnum;
2653
2654   while(scalar(@old_cust_pkg)) {
2655     my @return = ();
2656     my $custnum = $old_cust_pkg[0]->custnum;
2657     my (@remove) = map { $_->pkgnum }
2658                    grep { $_->custnum == $custnum } @old_cust_pkg;
2659     @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
2660
2661     my $error = order $custnum, $pkgparts, \@remove, \@return;
2662
2663     push @errors, $error
2664       if $error;
2665     push @$return_cust_pkg, @return;
2666   }
2667
2668   if (scalar(@errors)) {
2669     $dbh->rollback if $oldAutoCommit;
2670     return join(' / ', @errors);
2671   }
2672
2673   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2674   '';
2675 }
2676
2677 =item insert_reason
2678
2679 Associates this package with a (suspension or cancellation) reason (see
2680 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
2681 L<FS::reason>).
2682
2683 Available options are:
2684
2685 =over 4
2686
2687 =item reason
2688
2689 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.
2690
2691 =item reason_otaker
2692
2693 the access_user (see L<FS::access_user>) providing the reason
2694
2695 =item date
2696
2697 a unix timestamp
2698
2699 =item action
2700
2701 the action (cancel, susp, adjourn, expire) associated with the reason
2702
2703 =back
2704
2705 If there is an error, returns the error, otherwise returns false.
2706
2707 =cut
2708
2709 sub insert_reason {
2710   my ($self, %options) = @_;
2711
2712   my $otaker = $options{reason_otaker} ||
2713                $FS::CurrentUser::CurrentUser->username;
2714
2715   my $reasonnum;
2716   if ( $options{'reason'} =~ /^(\d+)$/ ) {
2717
2718     $reasonnum = $1;
2719
2720   } elsif ( ref($options{'reason'}) ) {
2721
2722     return 'Enter a new reason (or select an existing one)'
2723       unless $options{'reason'}->{'reason'} !~ /^\s*$/;
2724
2725     my $reason = new FS::reason({
2726       'reason_type' => $options{'reason'}->{'typenum'},
2727       'reason'      => $options{'reason'}->{'reason'},
2728     });
2729     my $error = $reason->insert;
2730     return $error if $error;
2731
2732     $reasonnum = $reason->reasonnum;
2733
2734   } else {
2735     return "Unparsable reason: ". $options{'reason'};
2736   }
2737
2738   my $cust_pkg_reason =
2739     new FS::cust_pkg_reason({ 'pkgnum'    => $self->pkgnum,
2740                               'reasonnum' => $reasonnum,
2741                               'otaker'    => $otaker,
2742                               'action'    => substr(uc($options{'action'}),0,1),
2743                               'date'      => $options{'date'}
2744                                                ? $options{'date'}
2745                                                : time,
2746                             });
2747
2748   $cust_pkg_reason->insert;
2749 }
2750
2751 =item set_usage USAGE_VALUE_HASHREF
2752
2753 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2754 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
2755 upbytes, downbytes, and totalbytes are appropriate keys.
2756
2757 All svc_accts which are part of this package have their values reset.
2758
2759 =cut
2760
2761 sub set_usage {
2762   my ($self, $valueref, %opt) = @_;
2763
2764   foreach my $cust_svc ($self->cust_svc){
2765     my $svc_x = $cust_svc->svc_x;
2766     $svc_x->set_usage($valueref, %opt)
2767       if $svc_x->can("set_usage");
2768   }
2769 }
2770
2771 =item recharge USAGE_VALUE_HASHREF
2772
2773 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2774 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
2775 upbytes, downbytes, and totalbytes are appropriate keys.
2776
2777 All svc_accts which are part of this package have their values incremented.
2778
2779 =cut
2780
2781 sub recharge {
2782   my ($self, $valueref) = @_;
2783
2784   foreach my $cust_svc ($self->cust_svc){
2785     my $svc_x = $cust_svc->svc_x;
2786     $svc_x->recharge($valueref)
2787       if $svc_x->can("recharge");
2788   }
2789 }
2790
2791 =back
2792
2793 =head1 BUGS
2794
2795 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
2796
2797 In sub order, the @pkgparts array (passed by reference) is clobbered.
2798
2799 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
2800 method to pass dates to the recur_prog expression, it should do so.
2801
2802 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
2803 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
2804 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
2805 configuration values.  Probably need a subroutine which decides what to do
2806 based on whether or not we've fetched the user yet, rather than a hash.  See
2807 FS::UID and the TODO.
2808
2809 Now that things are transactional should the check in the insert method be
2810 moved to check ?
2811
2812 =head1 SEE ALSO
2813
2814 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
2815 L<FS::pkg_svc>, schema.html from the base documentation
2816
2817 =cut
2818
2819 1;
2820