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   if ( @_ ) {
1419     return qsearch( 'cust_svc', { 'pkgnum'  => $self->pkgnum,
1420                                   'svcpart' => shift,          } );
1421   }
1422
1423   return () unless $self->num_cust_svc;
1424
1425   cluck "cust_pkg->cust_svc called" if $DEBUG > 1;
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 !@_ && exists($self->{'_num_cust_svc'})
1500            && $self->{'_num_cust_svc'} =~ /\d/;
1501
1502   my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
1503   $sql .= ' AND svcpart = ?' if @_;
1504
1505   my $sth = dbh->prepare($sql)     or die  dbh->errstr;
1506   $sth->execute($self->pkgnum, @_) or die $sth->errstr;
1507   $sth->fetchrow_arrayref->[0];
1508 }
1509
1510 =item available_part_svc
1511
1512 Returns a list of FS::part_svc objects representing services included in this
1513 package but not yet provisioned.  Each FS::part_svc object also has an extra
1514 field, I<num_avail>, which specifies the number of available services.
1515
1516 =cut
1517
1518 sub available_part_svc {
1519   my $self = shift;
1520   grep { $_->num_avail > 0 }
1521     map {
1522           my $part_svc = $_->part_svc;
1523           $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
1524             $_->quantity - $self->num_cust_svc($_->svcpart);
1525           $part_svc;
1526         }
1527       $self->part_pkg->pkg_svc;
1528 }
1529
1530 =item part_svc
1531
1532 Returns a list of FS::part_svc objects representing provisioned and available
1533 services included in this package.  Each FS::part_svc object also has the
1534 following extra fields:
1535
1536 =over 4
1537
1538 =item num_cust_svc  (count)
1539
1540 =item num_avail     (quantity - count)
1541
1542 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
1543
1544 svcnum
1545 label -> ($cust_svc->label)[1]
1546
1547 =back
1548
1549 =cut
1550
1551 sub part_svc {
1552   my $self = shift;
1553
1554   #XXX some sort of sort order besides numeric by svcpart...
1555   my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
1556     my $pkg_svc = $_;
1557     my $part_svc = $pkg_svc->part_svc;
1558     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1559     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
1560     $part_svc->{'Hash'}{'num_avail'}    =
1561       max( 0, $pkg_svc->quantity - $num_cust_svc );
1562     $part_svc->{'Hash'}{'cust_pkg_svc'} =
1563       $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
1564     $part_svc;
1565   } $self->part_pkg->pkg_svc;
1566
1567   #extras
1568   push @part_svc, map {
1569     my $part_svc = $_;
1570     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1571     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
1572     $part_svc->{'Hash'}{'num_avail'}    = 0; #0-$num_cust_svc ?
1573     $part_svc->{'Hash'}{'cust_pkg_svc'} =
1574       $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
1575     $part_svc;
1576   } $self->extra_part_svc;
1577
1578   @part_svc;
1579
1580 }
1581
1582 =item extra_part_svc
1583
1584 Returns a list of FS::part_svc objects corresponding to services in this
1585 package which are still provisioned but not (any longer) available in the
1586 package definition.
1587
1588 =cut
1589
1590 sub extra_part_svc {
1591   my $self = shift;
1592
1593   my $pkgnum  = $self->pkgnum;
1594   my $pkgpart = $self->pkgpart;
1595
1596 #  qsearch( {
1597 #    'table'     => 'part_svc',
1598 #    'hashref'   => {},
1599 #    'extra_sql' =>
1600 #      "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
1601 #                     WHERE pkg_svc.svcpart = part_svc.svcpart
1602 #                       AND pkg_svc.pkgpart = ?
1603 #                       AND quantity > 0
1604 #                 )
1605 #        AND 0 < ( SELECT COUNT(*) FROM cust_svc
1606 #                       LEFT JOIN cust_pkg USING ( pkgnum )
1607 #                     WHERE cust_svc.svcpart = part_svc.svcpart
1608 #                       AND pkgnum = ?
1609 #                 )",
1610 #    'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
1611 #  } );
1612
1613 #seems to benchmark slightly faster...
1614   qsearch( {
1615     'select'      => 'DISTINCT ON (svcpart) part_svc.*',
1616     'table'       => 'part_svc',
1617     'addl_from'   =>
1618       'LEFT JOIN pkg_svc  ON (     pkg_svc.svcpart   = part_svc.svcpart
1619                                AND pkg_svc.pkgpart   = ?
1620                                AND quantity > 0
1621                              )
1622        LEFT JOIN cust_svc ON (     cust_svc.svcpart = part_svc.svcpart )
1623        LEFT JOIN cust_pkg USING ( pkgnum )
1624       ',
1625     'hashref'     => {},
1626     'extra_sql'   => "WHERE pkgsvcnum IS NULL AND cust_pkg.pkgnum = ? ",
1627     'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
1628   } );
1629 }
1630
1631 =item status
1632
1633 Returns a short status string for this package, currently:
1634
1635 =over 4
1636
1637 =item not yet billed
1638
1639 =item one-time charge
1640
1641 =item active
1642
1643 =item suspended
1644
1645 =item cancelled
1646
1647 =back
1648
1649 =cut
1650
1651 sub status {
1652   my $self = shift;
1653
1654   my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
1655
1656   return 'cancelled' if $self->get('cancel');
1657   return 'suspended' if $self->susp;
1658   return 'not yet billed' unless $self->setup;
1659   return 'one-time charge' if $freq =~ /^(0|$)/;
1660   return 'active';
1661 }
1662
1663 =item statuses
1664
1665 Class method that returns the list of possible status strings for packages
1666 (see L<the status method|/status>).  For example:
1667
1668   @statuses = FS::cust_pkg->statuses();
1669
1670 =cut
1671
1672 tie my %statuscolor, 'Tie::IxHash',
1673   'not yet billed'  => '000000',
1674   'one-time charge' => '000000',
1675   'active'          => '00CC00',
1676   'suspended'       => 'FF9900',
1677   'cancelled'       => 'FF0000',
1678 ;
1679
1680 sub statuses {
1681   my $self = shift; #could be class...
1682   grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
1683                                       # mayble split btw one-time vs. recur
1684     keys %statuscolor;
1685 }
1686
1687 =item statuscolor
1688
1689 Returns a hex triplet color string for this package's status.
1690
1691 =cut
1692
1693 sub statuscolor {
1694   my $self = shift;
1695   $statuscolor{$self->status};
1696 }
1697
1698 =item labels
1699
1700 Returns a list of lists, calling the label method for all services
1701 (see L<FS::cust_svc>) of this billing item.
1702
1703 =cut
1704
1705 sub labels {
1706   my $self = shift;
1707   map { [ $_->label ] } $self->cust_svc;
1708 }
1709
1710 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
1711
1712 Like the labels method, but returns historical information on services that
1713 were active as of END_TIMESTAMP and (optionally) not cancelled before
1714 START_TIMESTAMP.
1715
1716 Returns a list of lists, calling the label method for all (historical) services
1717 (see L<FS::h_cust_svc>) of this billing item.
1718
1719 =cut
1720
1721 sub h_labels {
1722   my $self = shift;
1723   map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
1724 }
1725
1726 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
1727
1728 Like h_labels, except returns a simple flat list, and shortens long
1729 (currently >5 or the cust_bill-max_same_services configuration value) lists of
1730 identical services to one line that lists the service label and the number of
1731 individual services rather than individual items.
1732
1733 =cut
1734
1735 sub h_labels_short {
1736   my $self = shift;
1737
1738   my $conf = new FS::Conf;
1739   my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
1740
1741   my %labels;
1742   #tie %labels, 'Tie::IxHash';
1743   push @{ $labels{$_->[0]} }, $_->[1]
1744     foreach $self->h_labels(@_);
1745   my @labels;
1746   foreach my $label ( keys %labels ) {
1747     my %seen = ();
1748     my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
1749     my $num = scalar(@values);
1750     if ( $num > $max_same_services ) {
1751       push @labels, "$label ($num)";
1752     } else {
1753       push @labels, map { "$label: $_" } @values;
1754     }
1755   }
1756
1757  @labels;
1758
1759 }
1760
1761 =item cust_main
1762
1763 Returns the parent customer object (see L<FS::cust_main>).
1764
1765 =cut
1766
1767 sub cust_main {
1768   my $self = shift;
1769   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
1770 }
1771
1772 =item cust_location
1773
1774 Returns the location object, if any (see L<FS::cust_location>).
1775
1776 =cut
1777
1778 sub cust_location {
1779   my $self = shift;
1780   return '' unless $self->locationnum;
1781   qsearchs( 'cust_location', { 'locationnum' => $self->locationnum } );
1782 }
1783
1784 =item cust_location_or_main
1785
1786 If this package is associated with a location, returns the locaiton (see
1787 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
1788
1789 =cut
1790
1791 sub cust_location_or_main {
1792   my $self = shift;
1793   $self->cust_location || $self->cust_main;
1794 }
1795
1796 =item seconds_since TIMESTAMP
1797
1798 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
1799 package have been online since TIMESTAMP, according to the session monitor.
1800
1801 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1802 L<Time::Local> and L<Date::Parse> for conversion functions.
1803
1804 =cut
1805
1806 sub seconds_since {
1807   my($self, $since) = @_;
1808   my $seconds = 0;
1809
1810   foreach my $cust_svc (
1811     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
1812   ) {
1813     $seconds += $cust_svc->seconds_since($since);
1814   }
1815
1816   $seconds;
1817
1818 }
1819
1820 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1821
1822 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
1823 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
1824 (exclusive).
1825
1826 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1827 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1828 functions.
1829
1830
1831 =cut
1832
1833 sub seconds_since_sqlradacct {
1834   my($self, $start, $end) = @_;
1835
1836   my $seconds = 0;
1837
1838   foreach my $cust_svc (
1839     grep {
1840       my $part_svc = $_->part_svc;
1841       $part_svc->svcdb eq 'svc_acct'
1842         && scalar($part_svc->part_export('sqlradius'));
1843     } $self->cust_svc
1844   ) {
1845     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
1846   }
1847
1848   $seconds;
1849
1850 }
1851
1852 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1853
1854 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1855 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1856 TIMESTAMP_END
1857 (exclusive).
1858
1859 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1860 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1861 functions.
1862
1863 =cut
1864
1865 sub attribute_since_sqlradacct {
1866   my($self, $start, $end, $attrib) = @_;
1867
1868   my $sum = 0;
1869
1870   foreach my $cust_svc (
1871     grep {
1872       my $part_svc = $_->part_svc;
1873       $part_svc->svcdb eq 'svc_acct'
1874         && scalar($part_svc->part_export('sqlradius'));
1875     } $self->cust_svc
1876   ) {
1877     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
1878   }
1879
1880   $sum;
1881
1882 }
1883
1884 =item quantity
1885
1886 =cut
1887
1888 sub quantity {
1889   my( $self, $value ) = @_;
1890   if ( defined($value) ) {
1891     $self->setfield('quantity', $value);
1892   }
1893   $self->getfield('quantity') || 1;
1894 }
1895
1896 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
1897
1898 Transfers as many services as possible from this package to another package.
1899
1900 The destination package can be specified by pkgnum by passing an FS::cust_pkg
1901 object.  The destination package must already exist.
1902
1903 Services are moved only if the destination allows services with the correct
1904 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
1905 this option with caution!  No provision is made for export differences
1906 between the old and new service definitions.  Probably only should be used
1907 when your exports for all service definitions of a given svcdb are identical.
1908 (attempt a transfer without it first, to move all possible svcpart-matching
1909 services)
1910
1911 Any services that can't be moved remain in the original package.
1912
1913 Returns an error, if there is one; otherwise, returns the number of services
1914 that couldn't be moved.
1915
1916 =cut
1917
1918 sub transfer {
1919   my ($self, $dest_pkgnum, %opt) = @_;
1920
1921   my $remaining = 0;
1922   my $dest;
1923   my %target;
1924
1925   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
1926     $dest = $dest_pkgnum;
1927     $dest_pkgnum = $dest->pkgnum;
1928   } else {
1929     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
1930   }
1931
1932   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
1933
1934   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
1935     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
1936   }
1937
1938   foreach my $cust_svc ($dest->cust_svc) {
1939     $target{$cust_svc->svcpart}--;
1940   }
1941
1942   my %svcpart2svcparts = ();
1943   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1944     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
1945     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
1946       next if exists $svcpart2svcparts{$svcpart};
1947       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
1948       $svcpart2svcparts{$svcpart} = [
1949         map  { $_->[0] }
1950         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
1951         map {
1952               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
1953                                                    'svcpart' => $_          } );
1954               [ $_,
1955                 $pkg_svc ? $pkg_svc->primary_svc : '',
1956                 $pkg_svc ? $pkg_svc->quantity : 0,
1957               ];
1958             }
1959
1960         grep { $_ != $svcpart }
1961         map  { $_->svcpart }
1962         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
1963       ];
1964       warn "alternates for svcpart $svcpart: ".
1965            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
1966         if $DEBUG;
1967     }
1968   }
1969
1970   foreach my $cust_svc ($self->cust_svc) {
1971     if($target{$cust_svc->svcpart} > 0) {
1972       $target{$cust_svc->svcpart}--;
1973       my $new = new FS::cust_svc { $cust_svc->hash };
1974       $new->pkgnum($dest_pkgnum);
1975       my $error = $new->replace($cust_svc);
1976       return $error if $error;
1977     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1978       if ( $DEBUG ) {
1979         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
1980         warn "alternates to consider: ".
1981              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
1982       }
1983       my @alternate = grep {
1984                              warn "considering alternate svcpart $_: ".
1985                                   "$target{$_} available in new package\n"
1986                                if $DEBUG;
1987                              $target{$_} > 0;
1988                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
1989       if ( @alternate ) {
1990         warn "alternate(s) found\n" if $DEBUG;
1991         my $change_svcpart = $alternate[0];
1992         $target{$change_svcpart}--;
1993         my $new = new FS::cust_svc { $cust_svc->hash };
1994         $new->svcpart($change_svcpart);
1995         $new->pkgnum($dest_pkgnum);
1996         my $error = $new->replace($cust_svc);
1997         return $error if $error;
1998       } else {
1999         $remaining++;
2000       }
2001     } else {
2002       $remaining++
2003     }
2004   }
2005   return $remaining;
2006 }
2007
2008 =item reexport
2009
2010 This method is deprecated.  See the I<depend_jobnum> option to the insert and
2011 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
2012
2013 =cut
2014
2015 sub reexport {
2016   my $self = shift;
2017
2018   local $SIG{HUP} = 'IGNORE';
2019   local $SIG{INT} = 'IGNORE';
2020   local $SIG{QUIT} = 'IGNORE';
2021   local $SIG{TERM} = 'IGNORE';
2022   local $SIG{TSTP} = 'IGNORE';
2023   local $SIG{PIPE} = 'IGNORE';
2024
2025   my $oldAutoCommit = $FS::UID::AutoCommit;
2026   local $FS::UID::AutoCommit = 0;
2027   my $dbh = dbh;
2028
2029   foreach my $cust_svc ( $self->cust_svc ) {
2030     #false laziness w/svc_Common::insert
2031     my $svc_x = $cust_svc->svc_x;
2032     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
2033       my $error = $part_export->export_insert($svc_x);
2034       if ( $error ) {
2035         $dbh->rollback if $oldAutoCommit;
2036         return $error;
2037       }
2038     }
2039   }
2040
2041   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2042   '';
2043
2044 }
2045
2046 =back
2047
2048 =head1 CLASS METHODS
2049
2050 =over 4
2051
2052 =item recurring_sql
2053
2054 Returns an SQL expression identifying recurring packages.
2055
2056 =cut
2057
2058 sub recurring_sql { "
2059   '0' != ( select freq from part_pkg
2060              where cust_pkg.pkgpart = part_pkg.pkgpart )
2061 "; }
2062
2063 =item onetime_sql
2064
2065 Returns an SQL expression identifying one-time packages.
2066
2067 =cut
2068
2069 sub onetime_sql { "
2070   '0' = ( select freq from part_pkg
2071             where cust_pkg.pkgpart = part_pkg.pkgpart )
2072 "; }
2073
2074 =item active_sql
2075
2076 Returns an SQL expression identifying active packages.
2077
2078 =cut
2079
2080 sub active_sql { "
2081   ". $_[0]->recurring_sql(). "
2082   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2083   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2084 "; }
2085
2086 =item inactive_sql
2087
2088 Returns an SQL expression identifying inactive packages (one-time packages
2089 that are otherwise unsuspended/uncancelled).
2090
2091 =cut
2092
2093 sub inactive_sql { "
2094   ". $_[0]->onetime_sql(). "
2095   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2096   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2097 "; }
2098
2099 =item susp_sql
2100 =item suspended_sql
2101
2102 Returns an SQL expression identifying suspended packages.
2103
2104 =cut
2105
2106 sub suspended_sql { susp_sql(@_); }
2107 sub susp_sql {
2108   #$_[0]->recurring_sql(). ' AND '.
2109   "
2110         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
2111     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
2112   ";
2113 }
2114
2115 =item cancel_sql
2116 =item cancelled_sql
2117
2118 Returns an SQL exprression identifying cancelled packages.
2119
2120 =cut
2121
2122 sub cancelled_sql { cancel_sql(@_); }
2123 sub cancel_sql {
2124   #$_[0]->recurring_sql(). ' AND '.
2125   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
2126 }
2127
2128 =item search_sql HASHREF
2129
2130 (Class method)
2131
2132 Returns a qsearch hash expression to search for parameters specified in HASHREF.
2133 Valid parameters are
2134
2135 =over 4
2136
2137 =item agentnum
2138
2139 =item magic
2140
2141 active, inactive, suspended, cancel (or cancelled)
2142
2143 =item status
2144
2145 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
2146
2147 =item classnum
2148
2149 =item pkgpart
2150
2151 list specified how?
2152
2153 =item setup
2154
2155 arrayref of beginning and ending epoch date
2156
2157 =item last_bill
2158
2159 arrayref of beginning and ending epoch date
2160
2161 =item bill
2162
2163 arrayref of beginning and ending epoch date
2164
2165 =item adjourn
2166
2167 arrayref of beginning and ending epoch date
2168
2169 =item susp
2170
2171 arrayref of beginning and ending epoch date
2172
2173 =item expire
2174
2175 arrayref of beginning and ending epoch date
2176
2177 =item cancel
2178
2179 arrayref of beginning and ending epoch date
2180
2181 =item query
2182
2183 pkgnum or APKG_pkgnum
2184
2185 =item cust_fields
2186
2187 a value suited to passing to FS::UI::Web::cust_header
2188
2189 =item CurrentUser
2190
2191 specifies the user for agent virtualization
2192
2193 =back
2194
2195 =cut
2196
2197 sub search_sql {
2198   my ($class, $params) = @_;
2199   my @where = ();
2200
2201   ##
2202   # parse agent
2203   ##
2204
2205   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2206     push @where,
2207       "cust_main.agentnum = $1";
2208   }
2209
2210   ##
2211   # parse status
2212   ##
2213
2214   if (    $params->{'magic'}  eq 'active'
2215        || $params->{'status'} eq 'active' ) {
2216
2217     push @where, FS::cust_pkg->active_sql();
2218
2219   } elsif (    $params->{'magic'}  eq 'inactive'
2220             || $params->{'status'} eq 'inactive' ) {
2221
2222     push @where, FS::cust_pkg->inactive_sql();
2223
2224   } elsif (    $params->{'magic'}  eq 'suspended'
2225             || $params->{'status'} eq 'suspended'  ) {
2226
2227     push @where, FS::cust_pkg->suspended_sql();
2228
2229   } elsif (    $params->{'magic'}  =~ /^cancell?ed$/
2230             || $params->{'status'} =~ /^cancell?ed$/ ) {
2231
2232     push @where, FS::cust_pkg->cancelled_sql();
2233
2234   } elsif ( $params->{'status'} =~ /^(one-time charge|inactive)$/ ) {
2235
2236     push @where, FS::cust_pkg->inactive_sql();
2237
2238   }
2239
2240   ###
2241   # parse package class
2242   ###
2243
2244   #false lazinessish w/graph/cust_bill_pkg.cgi
2245   my $classnum = 0;
2246   my @pkg_class = ();
2247   if ( exists($params->{'classnum'})
2248        && $params->{'classnum'} =~ /^(\d*)$/
2249      )
2250   {
2251     $classnum = $1;
2252     if ( $classnum ) { #a specific class
2253       push @where, "classnum = $classnum";
2254
2255       #@pkg_class = ( qsearchs('pkg_class', { 'classnum' => $classnum } ) );
2256       #die "classnum $classnum not found!" unless $pkg_class[0];
2257       #$title .= $pkg_class[0]->classname.' ';
2258
2259     } elsif ( $classnum eq '' ) { #the empty class
2260
2261       push @where, "classnum IS NULL";
2262       #$title .= 'Empty class ';
2263       #@pkg_class = ( '(empty class)' );
2264     } elsif ( $classnum eq '0' ) {
2265       #@pkg_class = qsearch('pkg_class', {} ); # { 'disabled' => '' } );
2266       #push @pkg_class, '(empty class)';
2267     } else {
2268       die "illegal classnum";
2269     }
2270   }
2271   #eslaf
2272
2273   ###
2274   # parse part_pkg
2275   ###
2276
2277   my $pkgpart = join (' OR pkgpart=',
2278                       grep {$_} map { /^(\d+)$/; } ($params->{'pkgpart'}));
2279   push @where,  '(pkgpart=' . $pkgpart . ')' if $pkgpart;
2280
2281   ###
2282   # parse dates
2283   ###
2284
2285   my $orderby = '';
2286
2287   #false laziness w/report_cust_pkg.html
2288   my %disable = (
2289     'all'             => {},
2290     'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
2291     'active'          => { 'susp'=>1, 'cancel'=>1 },
2292     'suspended'       => { 'cancel' => 1 },
2293     'cancelled'       => {},
2294     ''                => {},
2295   );
2296
2297   foreach my $field (qw( setup last_bill bill adjourn susp expire cancel )) {
2298
2299     next unless exists($params->{$field});
2300
2301     my($beginning, $ending) = @{$params->{$field}};
2302
2303     next if $beginning == 0 && $ending == 4294967295;
2304
2305     push @where,
2306       "cust_pkg.$field IS NOT NULL",
2307       "cust_pkg.$field >= $beginning",
2308       "cust_pkg.$field <= $ending";
2309
2310     $orderby ||= "ORDER BY cust_pkg.$field";
2311
2312   }
2313
2314   $orderby ||= 'ORDER BY bill';
2315
2316   ###
2317   # parse magic, legacy, etc.
2318   ###
2319
2320   if ( $params->{'magic'} &&
2321        $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
2322   ) {
2323
2324     $orderby = 'ORDER BY pkgnum';
2325
2326     if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
2327       push @where, "pkgpart = $1";
2328     }
2329
2330   } elsif ( $params->{'query'} eq 'pkgnum' ) {
2331
2332     $orderby = 'ORDER BY pkgnum';
2333
2334   } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
2335
2336     $orderby = 'ORDER BY pkgnum';
2337
2338     push @where, '0 < (
2339       SELECT count(*) FROM pkg_svc
2340        WHERE pkg_svc.pkgpart =  cust_pkg.pkgpart
2341          AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
2342                                    WHERE cust_svc.pkgnum  = cust_pkg.pkgnum
2343                                      AND cust_svc.svcpart = pkg_svc.svcpart
2344                                 )
2345     )';
2346
2347   }
2348
2349   ##
2350   # setup queries, links, subs, etc. for the search
2351   ##
2352
2353   # here is the agent virtualization
2354   if ($params->{CurrentUser}) {
2355     my $access_user =
2356       qsearchs('access_user', { username => $params->{CurrentUser} });
2357
2358     if ($access_user) {
2359       push @where, $access_user->agentnums_sql('table'=>'cust_main');
2360     }else{
2361       push @where, "1=0";
2362     }
2363   }else{
2364     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
2365   }
2366
2367   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
2368
2369   my $addl_from = 'LEFT JOIN cust_main USING ( custnum  ) '.
2370                   'LEFT JOIN part_pkg  USING ( pkgpart  ) '.
2371                   'LEFT JOIN pkg_class USING ( classnum ) ';
2372
2373   my $count_query = "SELECT COUNT(*) FROM cust_pkg $addl_from $extra_sql";
2374
2375   my $sql_query = {
2376     'table'       => 'cust_pkg',
2377     'hashref'     => {},
2378     'select'      => join(', ',
2379                                 'cust_pkg.*',
2380                                 ( map "part_pkg.$_", qw( pkg freq ) ),
2381                                 'pkg_class.classname',
2382                                 'cust_main.custnum as cust_main_custnum',
2383                                 FS::UI::Web::cust_sql_fields(
2384                                   $params->{'cust_fields'}
2385                                 ),
2386                      ),
2387     'extra_sql'   => "$extra_sql $orderby",
2388     'addl_from'   => $addl_from,
2389     'count_query' => $count_query,
2390   };
2391
2392 }
2393
2394 =item location_sql
2395
2396 Returns a list: the first item is an SQL fragment identifying matching
2397 packages/customers via location (taking into account shipping and package
2398 address taxation, if enabled), and subsequent items are the parameters to
2399 substitute for the placeholders in that fragment.
2400
2401 =cut
2402
2403 sub location_sql {
2404   my($class, %opt) = @_;
2405   my $ornull = $opt{'ornull'};
2406
2407   my $conf = new FS::Conf;
2408
2409   # '?' placeholders in _location_sql_where
2410   my @bill_param;
2411   if ( $ornull ) {
2412     @bill_param = qw( county county state state state country );
2413   } else {
2414     @bill_param = qw( county state state country );
2415   }
2416   unshift @bill_param, 'county'; # unless $nec;
2417
2418   my $main_where;
2419   my @main_param;
2420   if ( $conf->exists('tax-ship_address') ) {
2421
2422     $main_where = "(
2423          (     ( ship_last IS NULL     OR  ship_last  = '' )
2424            AND ". _location_sql_where('cust_main', '', $ornull ). "
2425          )
2426       OR (       ship_last IS NOT NULL AND ship_last != ''
2427            AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
2428          )
2429     )";
2430     #    AND payby != 'COMP'
2431
2432     @main_param = ( @bill_param, @bill_param );
2433
2434   } else {
2435
2436     $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
2437     @main_param = @bill_param;
2438
2439   }
2440
2441   my $where;
2442   my @param;
2443   if ( $conf->exists('tax-pkg_address') ) {
2444
2445     my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
2446
2447     $where = " (
2448                     ( cust_pkg.locationnum IS     NULL AND $main_where )
2449                  OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where  )
2450                )
2451              ";
2452     @param = ( @main_param, @bill_param );
2453
2454   } else {
2455
2456     $where = $main_where;
2457     @param = @main_param;
2458
2459   }
2460
2461   ( $where, @param );
2462
2463 }
2464
2465 #subroutine, helper for location_sql
2466 sub _location_sql_where {
2467   my $table  = shift;
2468   my $prefix = @_ ? shift : '';
2469   my $ornull = @_ ? shift : '';
2470
2471 #  $ornull             = $ornull          ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
2472
2473   $ornull = $ornull ? ' OR ? IS NULL ' : '';
2474
2475   my $or_empty_county = " OR ( ? = '' AND $table.${prefix}county IS NULL ) ";
2476   my $or_empty_state =  " OR ( ? = '' AND $table.${prefix}state  IS NULL ) ";
2477
2478   "
2479         ( $table.${prefix}county  = ? $or_empty_county $ornull )
2480     AND ( $table.${prefix}state   = ? $or_empty_state  $ornull )
2481     AND   $table.${prefix}country = ?
2482   ";
2483 }
2484
2485 =head1 SUBROUTINES
2486
2487 =over 4
2488
2489 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
2490
2491 CUSTNUM is a customer (see L<FS::cust_main>)
2492
2493 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
2494 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
2495 permitted.
2496
2497 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
2498 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
2499 new billing items.  An error is returned if this is not possible (see
2500 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
2501 parameter.
2502
2503 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
2504 newly-created cust_pkg objects.
2505
2506 REFNUM, if specified, will specify the FS::pkg_referral record to be created
2507 and inserted.  Multiple FS::pkg_referral records can be created by
2508 setting I<refnum> to an array reference of refnums or a hash reference with
2509 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
2510 record will be created corresponding to cust_main.refnum.
2511
2512 =cut
2513
2514 sub order {
2515   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
2516
2517   my $conf = new FS::Conf;
2518
2519   # Transactionize this whole mess
2520   local $SIG{HUP} = 'IGNORE';
2521   local $SIG{INT} = 'IGNORE';
2522   local $SIG{QUIT} = 'IGNORE';
2523   local $SIG{TERM} = 'IGNORE';
2524   local $SIG{TSTP} = 'IGNORE';
2525   local $SIG{PIPE} = 'IGNORE';
2526
2527   my $oldAutoCommit = $FS::UID::AutoCommit;
2528   local $FS::UID::AutoCommit = 0;
2529   my $dbh = dbh;
2530
2531   my $error;
2532 #  my $cust_main = qsearchs('cust_main', { custnum => $custnum });
2533 #  return "Customer not found: $custnum" unless $cust_main;
2534
2535   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
2536                          @$remove_pkgnum;
2537
2538   my $change = scalar(@old_cust_pkg) != 0;
2539
2540   my %hash = ();
2541   if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
2542
2543     my $err_or_cust_pkg =
2544       $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
2545                                 'refnum'  => $refnum,
2546                               );
2547
2548     unless (ref($err_or_cust_pkg)) {
2549       $dbh->rollback if $oldAutoCommit;
2550       return $err_or_cust_pkg;
2551     }
2552
2553     push @$return_cust_pkg, $err_or_cust_pkg;
2554     return '';
2555
2556   }
2557
2558   # Create the new packages.
2559   foreach my $pkgpart (@$pkgparts) {
2560     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
2561                                       pkgpart => $pkgpart,
2562                                       refnum  => $refnum,
2563                                       %hash,
2564                                     };
2565     $error = $cust_pkg->insert( 'change' => $change );
2566     if ($error) {
2567       $dbh->rollback if $oldAutoCommit;
2568       return $error;
2569     }
2570     push @$return_cust_pkg, $cust_pkg;
2571   }
2572   # $return_cust_pkg now contains refs to all of the newly
2573   # created packages.
2574
2575   # Transfer services and cancel old packages.
2576   foreach my $old_pkg (@old_cust_pkg) {
2577
2578     foreach my $new_pkg (@$return_cust_pkg) {
2579       $error = $old_pkg->transfer($new_pkg);
2580       if ($error and $error == 0) {
2581         # $old_pkg->transfer failed.
2582         $dbh->rollback if $oldAutoCommit;
2583         return $error;
2584       }
2585     }
2586
2587     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
2588       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
2589       foreach my $new_pkg (@$return_cust_pkg) {
2590         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
2591         if ($error and $error == 0) {
2592           # $old_pkg->transfer failed.
2593         $dbh->rollback if $oldAutoCommit;
2594         return $error;
2595         }
2596       }
2597     }
2598
2599     if ($error > 0) {
2600       # Transfers were successful, but we went through all of the
2601       # new packages and still had services left on the old package.
2602       # We can't cancel the package under the circumstances, so abort.
2603       $dbh->rollback if $oldAutoCommit;
2604       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
2605     }
2606     $error = $old_pkg->cancel( quiet=>1 );
2607     if ($error) {
2608       $dbh->rollback;
2609       return $error;
2610     }
2611   }
2612   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2613   '';
2614 }
2615
2616 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
2617
2618 A bulk change method to change packages for multiple customers.
2619
2620 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
2621 L<FS::part_pkg>) to order for each customer.  Duplicates are of course
2622 permitted.
2623
2624 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
2625 replace.  The services (see L<FS::cust_svc>) are moved to the
2626 new billing items.  An error is returned if this is not possible (see
2627 L<FS::pkg_svc>).
2628
2629 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
2630 newly-created cust_pkg objects.
2631
2632 =cut
2633
2634 sub bulk_change {
2635   my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
2636
2637   # Transactionize this whole mess
2638   local $SIG{HUP} = 'IGNORE';
2639   local $SIG{INT} = 'IGNORE';
2640   local $SIG{QUIT} = 'IGNORE';
2641   local $SIG{TERM} = 'IGNORE';
2642   local $SIG{TSTP} = 'IGNORE';
2643   local $SIG{PIPE} = 'IGNORE';
2644
2645   my $oldAutoCommit = $FS::UID::AutoCommit;
2646   local $FS::UID::AutoCommit = 0;
2647   my $dbh = dbh;
2648
2649   my @errors;
2650   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
2651                          @$remove_pkgnum;
2652
2653   while(scalar(@old_cust_pkg)) {
2654     my @return = ();
2655     my $custnum = $old_cust_pkg[0]->custnum;
2656     my (@remove) = map { $_->pkgnum }
2657                    grep { $_->custnum == $custnum } @old_cust_pkg;
2658     @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
2659
2660     my $error = order $custnum, $pkgparts, \@remove, \@return;
2661
2662     push @errors, $error
2663       if $error;
2664     push @$return_cust_pkg, @return;
2665   }
2666
2667   if (scalar(@errors)) {
2668     $dbh->rollback if $oldAutoCommit;
2669     return join(' / ', @errors);
2670   }
2671
2672   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2673   '';
2674 }
2675
2676 =item insert_reason
2677
2678 Associates this package with a (suspension or cancellation) reason (see
2679 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
2680 L<FS::reason>).
2681
2682 Available options are:
2683
2684 =over 4
2685
2686 =item reason
2687
2688 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.
2689
2690 =item reason_otaker
2691
2692 the access_user (see L<FS::access_user>) providing the reason
2693
2694 =item date
2695
2696 a unix timestamp
2697
2698 =item action
2699
2700 the action (cancel, susp, adjourn, expire) associated with the reason
2701
2702 =back
2703
2704 If there is an error, returns the error, otherwise returns false.
2705
2706 =cut
2707
2708 sub insert_reason {
2709   my ($self, %options) = @_;
2710
2711   my $otaker = $options{reason_otaker} ||
2712                $FS::CurrentUser::CurrentUser->username;
2713
2714   my $reasonnum;
2715   if ( $options{'reason'} =~ /^(\d+)$/ ) {
2716
2717     $reasonnum = $1;
2718
2719   } elsif ( ref($options{'reason'}) ) {
2720
2721     return 'Enter a new reason (or select an existing one)'
2722       unless $options{'reason'}->{'reason'} !~ /^\s*$/;
2723
2724     my $reason = new FS::reason({
2725       'reason_type' => $options{'reason'}->{'typenum'},
2726       'reason'      => $options{'reason'}->{'reason'},
2727     });
2728     my $error = $reason->insert;
2729     return $error if $error;
2730
2731     $reasonnum = $reason->reasonnum;
2732
2733   } else {
2734     return "Unparsable reason: ". $options{'reason'};
2735   }
2736
2737   my $cust_pkg_reason =
2738     new FS::cust_pkg_reason({ 'pkgnum'    => $self->pkgnum,
2739                               'reasonnum' => $reasonnum,
2740                               'otaker'    => $otaker,
2741                               'action'    => substr(uc($options{'action'}),0,1),
2742                               'date'      => $options{'date'}
2743                                                ? $options{'date'}
2744                                                : time,
2745                             });
2746
2747   $cust_pkg_reason->insert;
2748 }
2749
2750 =item set_usage USAGE_VALUE_HASHREF
2751
2752 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2753 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
2754 upbytes, downbytes, and totalbytes are appropriate keys.
2755
2756 All svc_accts which are part of this package have their values reset.
2757
2758 =cut
2759
2760 sub set_usage {
2761   my ($self, $valueref, %opt) = @_;
2762
2763   foreach my $cust_svc ($self->cust_svc){
2764     my $svc_x = $cust_svc->svc_x;
2765     $svc_x->set_usage($valueref, %opt)
2766       if $svc_x->can("set_usage");
2767   }
2768 }
2769
2770 =item recharge USAGE_VALUE_HASHREF
2771
2772 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2773 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
2774 upbytes, downbytes, and totalbytes are appropriate keys.
2775
2776 All svc_accts which are part of this package have their values incremented.
2777
2778 =cut
2779
2780 sub recharge {
2781   my ($self, $valueref) = @_;
2782
2783   foreach my $cust_svc ($self->cust_svc){
2784     my $svc_x = $cust_svc->svc_x;
2785     $svc_x->recharge($valueref)
2786       if $svc_x->can("recharge");
2787   }
2788 }
2789
2790 =back
2791
2792 =head1 BUGS
2793
2794 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
2795
2796 In sub order, the @pkgparts array (passed by reference) is clobbered.
2797
2798 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
2799 method to pass dates to the recur_prog expression, it should do so.
2800
2801 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
2802 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
2803 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
2804 configuration values.  Probably need a subroutine which decides what to do
2805 based on whether or not we've fetched the user yet, rather than a hash.  See
2806 FS::UID and the TODO.
2807
2808 Now that things are transactional should the check in the insert method be
2809 moved to check ?
2810
2811 =head1 SEE ALSO
2812
2813 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
2814 L<FS::pkg_svc>, schema.html from the base documentation
2815
2816 =cut
2817
2818 1;
2819