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