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