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