FS/FS/cust_pkg.pm

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