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('')
 443     if defined($self->locationnum) && length($self->locationnum)
 444     && ( $self->locationnum == 0 || $self->locationnum == -1 );
 445
 446   my $error =
 447     $self->ut_numbern('pkgnum')
 448     || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
 449     || $self->ut_numbern('pkgpart')
 450     || $self->ut_foreign_keyn('locationnum', 'cust_location', 'locationnum')
 451     || $self->ut_numbern('setup')
 452     || $self->ut_numbern('bill')
 453     || $self->ut_numbern('susp')
 454     || $self->ut_numbern('cancel')
 455     || $self->ut_numbern('adjourn')
 456     || $self->ut_numbern('expire')
 457   ;
 458   return $error if $error;
 459
 460   if ( $self->reg_code ) {
 461
 462     unless ( grep { $self->pkgpart == $_->pkgpart }
 463              map  { $_->reg_code_pkg }
 464              qsearchs( 'reg_code', { 'code'     => $self->reg_code,
 465                                      'agentnum' => $self->cust_main->agentnum })
 466            ) {
 467       return "Unknown registration code";
 468     }
 469
 470   } elsif ( $self->promo_code ) {
 471
 472     my $promo_part_pkg =
 473       qsearchs('part_pkg', {
 474         'pkgpart'    => $self->pkgpart,
 475         'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
 476       } );
 477     return 'Unknown promotional code' unless $promo_part_pkg;
 478
 479   } else {
 480
 481     unless ( $disable_agentcheck ) {
 482       my $agent =
 483         qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
 484       my $pkgpart_href = $agent->pkgpart_hashref;
 485       return "agent ". $agent->agentnum.
 486              " can't purchase pkgpart ". $self->pkgpart
 487         unless $pkgpart_href->{ $self->pkgpart };
 488     }
 489
 490     $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
 491     return $error if $error;
 492
 493   }
 494
 495   $self->otaker(getotaker) unless $self->otaker;
 496   $self->otaker =~ /^(\w{1,32})$/ or return "Illegal otaker";
 497   $self->otaker($1);
 498
 499   if ( $self->dbdef_table->column('manual_flag') ) {
 500     $self->manual_flag('') if $self->manual_flag eq ' ';
 501     $self->manual_flag =~ /^([01]?)$/
 502       or return "Illegal manual_flag ". $self->manual_flag;
 503     $self->manual_flag($1);
 504   }
 505
 506   $self->SUPER::check;
 507 }
 508
 509 =item cancel [ OPTION => VALUE ... ]
 510
 511 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
 512 in this package, then cancels the package itself (sets the cancel field to
 513 now).
 514
 515 Available options are:
 516
 517 =over 4
 518
 519 =item quiet - can be set true to supress email cancellation notices.
 520
 521 =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.
 522
 523 =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.
 524
 525 =item date - can be set to a unix style timestamp to specify when to cancel (expire)
 526
 527 =back
 528
 529 If there is an error, returns the error, otherwise returns false.
 530
 531 =cut
 532
 533 sub cancel {
 534   my( $self, %options ) = @_;
 535   my $error;
 536
 537   warn "cust_pkg::cancel called with options".
 538        join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
 539     if $DEBUG;
 540
 541   local $SIG{HUP} = 'IGNORE';
 542   local $SIG{INT} = 'IGNORE';
 543   local $SIG{QUIT} = 'IGNORE';
 544   local $SIG{TERM} = 'IGNORE';
 545   local $SIG{TSTP} = 'IGNORE';
 546   local $SIG{PIPE} = 'IGNORE';
 547
 548   my $oldAutoCommit = $FS::UID::AutoCommit;
 549   local $FS::UID::AutoCommit = 0;
 550   my $dbh = dbh;
 551
 552   my $old = $self->select_for_update;
 553
 554   if ( $old->get('cancel') || $self->get('cancel') ) {
 555     dbh->rollback if $oldAutoCommit;
 556     return "";  # no error
 557   }
 558
 559   my $date = $options{date} if $options{date}; # expire/cancel later
 560   $date = '' if ($date && $date <= time);      # complain instead?
 561
 562   my $cancel_time = $options{'time'} || time;
 563
 564   if ( $options{'reason'} ) {
 565     $error = $self->insert_reason( 'reason' => $options{'reason'},
 566                                    'action' => $date ? 'expire' : 'cancel',
 567                                    'date'   => $date ? $date : $cancel_time,
 568                                    'reason_otaker' => $options{'reason_otaker'},
 569                                  );
 570     if ( $error ) {
 571       dbh->rollback if $oldAutoCommit;
 572       return "Error inserting cust_pkg_reason: $error";
 573     }
 574   }
 575
 576   my %svc;
 577   unless ( $date ) {
 578     foreach my $cust_svc (
 579       #schwartz
 580       map  { $_->[0] }
 581       sort { $a->[1] <=> $b->[1] }
 582       map  { [ $_, $_->svc_x->table_info->{'cancel_weight'} ]; }
 583       qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 584     ) {
 585
 586       my $error = $cust_svc->cancel;
 587
 588       if ( $error ) {
 589         $dbh->rollback if $oldAutoCommit;
 590         return "Error cancelling cust_svc: $error";
 591       }
 592     }
 593
 594     # Add a credit for remaining service
 595     my $remaining_value = $self->calc_remain(time=>$cancel_time);
 596     if ( $remaining_value > 0 && !$options{'no_credit'} ) {
 597       my $conf = new FS::Conf;
 598       my $error = $self->cust_main->credit(
 599         $remaining_value,
 600         'Credit for unused time on '. $self->part_pkg->pkg,
 601         'reason_type' => $conf->config('cancel_credit_type'),
 602       );
 603       if ($error) {
 604         $dbh->rollback if $oldAutoCommit;
 605         return "Error crediting customer \$$remaining_value for unused time on".
 606                $self->part_pkg->pkg. ": $error";
 607       }
 608     }
 609   }
 610
 611   my %hash = $self->hash;
 612   $date ? ($hash{'expire'} = $date) : ($hash{'cancel'} = $cancel_time);
 613   my $new = new FS::cust_pkg ( \%hash );
 614   $error = $new->replace( $self, options => { $self->options } );
 615   if ( $error ) {
 616     $dbh->rollback if $oldAutoCommit;
 617     return $error;
 618   }
 619
 620   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 621   return '' if $date; #no errors
 622
 623   my $conf = new FS::Conf;
 624   my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
 625   if ( !$options{'quiet'} && $conf->exists('emailcancel') && @invoicing_list ) {
 626     my $conf = new FS::Conf;
 627     my $error = send_email(
 628       'from'    => $conf->config('invoice_from', $self->cust_main->agentnum),
 629       'to'      => \@invoicing_list,
 630       'subject' => ( $conf->config('cancelsubject') || 'Cancellation Notice' ),
 631       'body'    => [ map "$_\n", $conf->config('cancelmessage') ],
 632     );
 633     #should this do something on errors?
 634   }
 635
 636   ''; #no errors
 637
 638 }
 639
 640 =item cancel_if_expired [ NOW_TIMESTAMP ]
 641
 642 Cancels this package if its expire date has been reached.
 643
 644 =cut
 645
 646 sub cancel_if_expired {
 647   my $self = shift;
 648   my $time = shift || time;
 649   return '' unless $self->expire && $self->expire <= $time;
 650   my $error = $self->cancel;
 651   if ( $error ) {
 652     return "Error cancelling expired pkg ". $self->pkgnum. " for custnum ".
 653            $self->custnum. ": $error";
 654   }
 655   '';
 656 }
 657
 658 =item unexpire
 659
 660 Cancels any pending expiration (sets the expire field to null).
 661
 662 If there is an error, returns the error, otherwise returns false.
 663
 664 =cut
 665
 666 sub unexpire {
 667   my( $self, %options ) = @_;
 668   my $error;
 669
 670   local $SIG{HUP} = 'IGNORE';
 671   local $SIG{INT} = 'IGNORE';
 672   local $SIG{QUIT} = 'IGNORE';
 673   local $SIG{TERM} = 'IGNORE';
 674   local $SIG{TSTP} = 'IGNORE';
 675   local $SIG{PIPE} = 'IGNORE';
 676
 677   my $oldAutoCommit = $FS::UID::AutoCommit;
 678   local $FS::UID::AutoCommit = 0;
 679   my $dbh = dbh;
 680
 681   my $old = $self->select_for_update;
 682
 683   my $pkgnum = $old->pkgnum;
 684   if ( $old->get('cancel') || $self->get('cancel') ) {
 685     dbh->rollback if $oldAutoCommit;
 686     return "Can't unexpire cancelled package $pkgnum";
 687     # or at least it's pointless
 688   }
 689
 690   unless ( $old->get('expire') && $self->get('expire') ) {
 691     dbh->rollback if $oldAutoCommit;
 692     return "";  # no error
 693   }
 694
 695   my %hash = $self->hash;
 696   $hash{'expire'} = '';
 697   my $new = new FS::cust_pkg ( \%hash );
 698   $error = $new->replace( $self, options => { $self->options } );
 699   if ( $error ) {
 700     $dbh->rollback if $oldAutoCommit;
 701     return $error;
 702   }
 703
 704   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 705
 706   ''; #no errors
 707
 708 }
 709
 710 =item suspend [ OPTION => VALUE ... ]
 711
 712 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 713 package, then suspends the package itself (sets the susp field to now).
 714
 715 Available options are:
 716
 717 =over 4
 718
 719 =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.
 720
 721 =item date - can be set to a unix style timestamp to specify when to suspend (adjourn)
 722
 723 =back
 724
 725 If there is an error, returns the error, otherwise returns false.
 726
 727 =cut
 728
 729 sub suspend {
 730   my( $self, %options ) = @_;
 731   my $error;
 732
 733   local $SIG{HUP} = 'IGNORE';
 734   local $SIG{INT} = 'IGNORE';
 735   local $SIG{QUIT} = 'IGNORE';
 736   local $SIG{TERM} = 'IGNORE';
 737   local $SIG{TSTP} = 'IGNORE';
 738   local $SIG{PIPE} = 'IGNORE';
 739
 740   my $oldAutoCommit = $FS::UID::AutoCommit;
 741   local $FS::UID::AutoCommit = 0;
 742   my $dbh = dbh;
 743
 744   my $old = $self->select_for_update;
 745
 746   my $pkgnum = $old->pkgnum;
 747   if ( $old->get('cancel') || $self->get('cancel') ) {
 748     dbh->rollback if $oldAutoCommit;
 749     return "Can't suspend cancelled package $pkgnum";
 750   }
 751
 752   if ( $old->get('susp') || $self->get('susp') ) {
 753     dbh->rollback if $oldAutoCommit;
 754     return "";  # no error                     # complain on adjourn?
 755   }
 756
 757   my $date = $options{date} if $options{date}; # adjourn/suspend later
 758   $date = '' if ($date && $date <= time);      # complain instead?
 759
 760   if ( $date && $old->get('expire') && $old->get('expire') < $date ) {
 761     dbh->rollback if $oldAutoCommit;
 762     return "Package $pkgnum expires before it would be suspended.";
 763   }
 764
 765   my $suspend_time = $options{'time'} || time;
 766
 767   if ( $options{'reason'} ) {
 768     $error = $self->insert_reason( 'reason' => $options{'reason'},
 769                                    'action' => $date ? 'adjourn' : 'suspend',
 770                                    'date'   => $date ? $date : $suspend_time,
 771                                    'reason_otaker' => $options{'reason_otaker'},
 772                                  );
 773     if ( $error ) {
 774       dbh->rollback if $oldAutoCommit;
 775       return "Error inserting cust_pkg_reason: $error";
 776     }
 777   }
 778
 779   unless ( $date ) {
 780
 781     my @labels = ();
 782
 783     foreach my $cust_svc (
 784       qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 785     ) {
 786       my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 787
 788       $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 789         $dbh->rollback if $oldAutoCommit;
 790         return "Illegal svcdb value in part_svc!";
 791       };
 792       my $svcdb = $1;
 793       require "FS/$svcdb.pm";
 794
 795       my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
 796       if ($svc) {
 797         $error = $svc->suspend;
 798         if ( $error ) {
 799           $dbh->rollback if $oldAutoCommit;
 800           return $error;
 801         }
 802         my( $label, $value ) = $cust_svc->label;
 803         push @labels, "$label: $value";
 804       }
 805     }
 806
 807     my $conf = new FS::Conf;
 808     if ( $conf->config('suspend_email_admin') ) {
 809
 810       my $error = send_email(
 811         'from'    => $conf->config('invoice_from', $self->cust_main->agentnum),
 812                                    #invoice_from ??? well as good as any
 813         'to'      => $conf->config('suspend_email_admin'),
 814         'subject' => 'FREESIDE NOTIFICATION: Customer package suspended',
 815         'body'    => [
 816           "This is an automatic message from your Freeside installation\n",
 817           "informing you that the following customer package has been suspended:\n",
 818           "\n",
 819           'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
 820           'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
 821           ( map { "Service : $_\n" } @labels ),
 822         ],
 823       );
 824
 825       if ( $error ) {
 826         warn "WARNING: can't send suspension admin email (suspending anyway): ".
 827              "$error\n";
 828       }
 829
 830     }
 831
 832   }
 833
 834   my %hash = $self->hash;
 835   if ( $date ) {
 836     $hash{'adjourn'} = $date;
 837   } else {
 838     $hash{'susp'} = $suspend_time;
 839   }
 840   my $new = new FS::cust_pkg ( \%hash );
 841   $error = $new->replace( $self, options => { $self->options } );
 842   if ( $error ) {
 843     $dbh->rollback if $oldAutoCommit;
 844     return $error;
 845   }
 846
 847   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 848
 849   ''; #no errors
 850 }
 851
 852 =item unsuspend [ OPTION => VALUE ... ]
 853
 854 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 855 package, then unsuspends the package itself (clears the susp field and the
 856 adjourn field if it is in the past).
 857
 858 Available options are:
 859
 860 =over 4
 861
 862 =item adjust_next_bill
 863
 864 Can be set true to adjust the next bill date forward by
 865 the amount of time the account was inactive.  This was set true by default
 866 since 1.4.2 and 1.5.0pre6; however, starting with 1.7.0 this needs to be
 867 explicitly requested.  Price plans for which this makes sense (anniversary-date
 868 based than prorate or subscription) could have an option to enable this
 869 behaviour?
 870
 871 =back
 872
 873 If there is an error, returns the error, otherwise returns false.
 874
 875 =cut
 876
 877 sub unsuspend {
 878   my( $self, %opt ) = @_;
 879   my $error;
 880
 881   local $SIG{HUP} = 'IGNORE';
 882   local $SIG{INT} = 'IGNORE';
 883   local $SIG{QUIT} = 'IGNORE';
 884   local $SIG{TERM} = 'IGNORE';
 885   local $SIG{TSTP} = 'IGNORE';
 886   local $SIG{PIPE} = 'IGNORE';
 887
 888   my $oldAutoCommit = $FS::UID::AutoCommit;
 889   local $FS::UID::AutoCommit = 0;
 890   my $dbh = dbh;
 891
 892   my $old = $self->select_for_update;
 893
 894   my $pkgnum = $old->pkgnum;
 895   if ( $old->get('cancel') || $self->get('cancel') ) {
 896     dbh->rollback if $oldAutoCommit;
 897     return "Can't unsuspend cancelled package $pkgnum";
 898   }
 899
 900   unless ( $old->get('susp') && $self->get('susp') ) {
 901     dbh->rollback if $oldAutoCommit;
 902     return "";  # no error                     # complain instead?
 903   }
 904
 905   foreach my $cust_svc (
 906     qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
 907   ) {
 908     my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 909
 910     $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 911       $dbh->rollback if $oldAutoCommit;
 912       return "Illegal svcdb value in part_svc!";
 913     };
 914     my $svcdb = $1;
 915     require "FS/$svcdb.pm";
 916
 917     my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
 918     if ($svc) {
 919       $error = $svc->unsuspend;
 920       if ( $error ) {
 921         $dbh->rollback if $oldAutoCommit;
 922         return $error;
 923       }
 924     }
 925
 926   }
 927
 928   my %hash = $self->hash;
 929   my $inactive = time - $hash{'susp'};
 930
 931   my $conf = new FS::Conf;
 932
 933   $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive
 934     if ( $opt{'adjust_next_bill'}
 935          || $conf->exists('unsuspend-always_adjust_next_bill_date') )
 936     && $inactive > 0 && ( $hash{'bill'} || $hash{'setup'} );
 937
 938   $hash{'susp'} = '';
 939   $hash{'adjourn'} = '' if $hash{'adjourn'} < time;
 940   my $new = new FS::cust_pkg ( \%hash );
 941   $error = $new->replace( $self, options => { $self->options } );
 942   if ( $error ) {
 943     $dbh->rollback if $oldAutoCommit;
 944     return $error;
 945   }
 946
 947   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 948
 949   ''; #no errors
 950 }
 951
 952 =item unadjourn
 953
 954 Cancels any pending suspension (sets the adjourn field to null).
 955
 956 If there is an error, returns the error, otherwise returns false.
 957
 958 =cut
 959
 960 sub unadjourn {
 961   my( $self, %options ) = @_;
 962   my $error;
 963
 964   local $SIG{HUP} = 'IGNORE';
 965   local $SIG{INT} = 'IGNORE';
 966   local $SIG{QUIT} = 'IGNORE';
 967   local $SIG{TERM} = 'IGNORE';
 968   local $SIG{TSTP} = 'IGNORE';
 969   local $SIG{PIPE} = 'IGNORE';
 970
 971   my $oldAutoCommit = $FS::UID::AutoCommit;
 972   local $FS::UID::AutoCommit = 0;
 973   my $dbh = dbh;
 974
 975   my $old = $self->select_for_update;
 976
 977   my $pkgnum = $old->pkgnum;
 978   if ( $old->get('cancel') || $self->get('cancel') ) {
 979     dbh->rollback if $oldAutoCommit;
 980     return "Can't unadjourn cancelled package $pkgnum";
 981     # or at least it's pointless
 982   }
 983
 984   if ( $old->get('susp') || $self->get('susp') ) {
 985     dbh->rollback if $oldAutoCommit;
 986     return "Can't unadjourn suspended package $pkgnum";
 987     # perhaps this is arbitrary
 988   }
 989
 990   unless ( $old->get('adjourn') && $self->get('adjourn') ) {
 991     dbh->rollback if $oldAutoCommit;
 992     return "";  # no error
 993   }
 994
 995   my %hash = $self->hash;
 996   $hash{'adjourn'} = '';
 997   my $new = new FS::cust_pkg ( \%hash );
 998   $error = $new->replace( $self, options => { $self->options } );
 999   if ( $error ) {
1000     $dbh->rollback if $oldAutoCommit;
1001     return $error;
1002   }
1003
1004   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1005
1006   ''; #no errors
1007
1008 }
1009
1010
1011 =item change HASHREF | OPTION => VALUE ...
1012
1013 Changes this package: cancels it and creates a new one, with a different
1014 pkgpart or locationnum or both.  All services are transferred to the new
1015 package (no change will be made if this is not possible).
1016
1017 Options may be passed as a list of key/value pairs or as a hash reference.
1018 Options are:
1019
1020 =over 4
1021
1022 =item locaitonnum
1023
1024 New locationnum, to change the location for this package.
1025
1026 =item cust_location
1027
1028 New FS::cust_location object, to create a new location and assign it
1029 to this package.
1030
1031 =item pkgpart
1032
1033 New pkgpart (see L<FS::part_pkg>).
1034
1035 =item refnum
1036
1037 New refnum (see L<FS::part_referral>).
1038
1039 =back
1040
1041 At least one option must be specified (otherwise, what's the point?)
1042
1043 Returns either the new FS::cust_pkg object or a scalar error.
1044
1045 For example:
1046
1047   my $err_or_new_cust_pkg = $old_cust_pkg->change
1048
1049 =cut
1050
1051 #some false laziness w/order
1052 sub change {
1053   my $self = shift;
1054   my $opt = ref($_[0]) ? shift : { @_ };
1055
1056 #  my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
1057 #
1058
1059   my $conf = new FS::Conf;
1060
1061   # Transactionize this whole mess
1062   local $SIG{HUP} = 'IGNORE';
1063   local $SIG{INT} = 'IGNORE';
1064   local $SIG{QUIT} = 'IGNORE';
1065   local $SIG{TERM} = 'IGNORE';
1066   local $SIG{TSTP} = 'IGNORE';
1067   local $SIG{PIPE} = 'IGNORE';
1068
1069   my $oldAutoCommit = $FS::UID::AutoCommit;
1070   local $FS::UID::AutoCommit = 0;
1071   my $dbh = dbh;
1072
1073   my $error;
1074
1075   my %hash = ();
1076
1077   my $time = time;
1078
1079   #$hash{$_} = $self->$_() foreach qw( last_bill bill );
1080
1081   #$hash{$_} = $self->$_() foreach qw( setup );
1082
1083   $hash{'setup'} = $time if $self->setup;
1084
1085   $hash{'change_date'} = $time;
1086   $hash{"change_$_"}  = $self->$_()
1087     foreach qw( pkgnum pkgpart locationnum );
1088
1089   if ( $opt->{'cust_location'} &&
1090        ( ! $opt->{'locationnum'} || $opt->{'locationnum'} == -1 ) ) {
1091     $error = $opt->{'cust_location'}->insert;
1092     if ( $error ) {
1093       $dbh->rollback if $oldAutoCommit;
1094       return "inserting cust_location (transaction rolled back): $error";
1095     }
1096     $opt->{'locationnum'} = $opt->{'cust_location'}->locationnum;
1097   }
1098
1099   # Create the new package.
1100   my $cust_pkg = new FS::cust_pkg {
1101     custnum      => $self->custnum,
1102     pkgpart      => ( $opt->{'pkgpart'}     || $self->pkgpart      ),
1103     refnum       => ( $opt->{'refnum'}      || $self->refnum       ),
1104     locationnum  => ( $opt->{'locationnum'} || $self->locationnum  ),
1105     %hash,
1106   };
1107
1108   $error = $cust_pkg->insert( 'change' => 1 );
1109   if ($error) {
1110     $dbh->rollback if $oldAutoCommit;
1111     return $error;
1112   }
1113
1114   # Transfer services and cancel old package.
1115
1116   $error = $self->transfer($cust_pkg);
1117   if ($error and $error == 0) {
1118     # $old_pkg->transfer failed.
1119     $dbh->rollback if $oldAutoCommit;
1120     return $error;
1121   }
1122
1123   if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1124     warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1125     $error = $self->transfer($cust_pkg, 'change_svcpart'=>1 );
1126     if ($error and $error == 0) {
1127       # $old_pkg->transfer failed.
1128       $dbh->rollback if $oldAutoCommit;
1129       return $error;
1130     }
1131   }
1132
1133   if ($error > 0) {
1134     # Transfers were successful, but we still had services left on the old
1135     # package.  We can't change the package under this circumstances, so abort.
1136     $dbh->rollback if $oldAutoCommit;
1137     return "Unable to transfer all services from package ". $self->pkgnum;
1138   }
1139
1140   #Good to go, cancel old package.
1141   $error = $self->cancel( quiet=>1 );
1142   if ($error) {
1143     $dbh->rollback;
1144     return $error;
1145   }
1146
1147   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1148   $cust_pkg;
1149
1150 }
1151
1152 =item last_bill
1153
1154 Returns the last bill date, or if there is no last bill date, the setup date.
1155 Useful for billing metered services.
1156
1157 =cut
1158
1159 sub last_bill {
1160   my $self = shift;
1161   return $self->setfield('last_bill', $_[0]) if @_;
1162   return $self->getfield('last_bill') if $self->getfield('last_bill');
1163   my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
1164                                                   'edate'  => $self->bill,  } );
1165   $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
1166 }
1167
1168 =item last_cust_pkg_reason ACTION
1169
1170 Returns the most recent ACTION FS::cust_pkg_reason associated with the package.
1171 Returns false if there is no reason or the package is not currenly ACTION'd
1172 ACTION is one of adjourn, susp, cancel, or expire.
1173
1174 =cut
1175
1176 sub last_cust_pkg_reason {
1177   my ( $self, $action ) = ( shift, shift );
1178   my $date = $self->get($action);
1179   qsearchs( {
1180               'table' => 'cust_pkg_reason',
1181               'hashref' => { 'pkgnum' => $self->pkgnum,
1182                              'action' => substr(uc($action), 0, 1),
1183                              'date'   => $date,
1184                            },
1185               'order_by' => 'ORDER BY num DESC LIMIT 1',
1186            } );
1187 }
1188
1189 =item last_reason ACTION
1190
1191 Returns the most recent ACTION FS::reason associated with the package.
1192 Returns false if there is no reason or the package is not currenly ACTION'd
1193 ACTION is one of adjourn, susp, cancel, or expire.
1194
1195 =cut
1196
1197 sub last_reason {
1198   my $cust_pkg_reason = shift->last_cust_pkg_reason(@_);
1199   $cust_pkg_reason->reason
1200     if $cust_pkg_reason;
1201 }
1202
1203 =item part_pkg
1204
1205 Returns the definition for this billing item, as an FS::part_pkg object (see
1206 L<FS::part_pkg>).
1207
1208 =cut
1209
1210 sub part_pkg {
1211   my $self = shift;
1212   #exists( $self->{'_pkgpart'} )
1213   $self->{'_pkgpart'}
1214     ? $self->{'_pkgpart'}
1215     : qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
1216 }
1217
1218 =item old_cust_pkg
1219
1220 Returns the cancelled package this package was changed from, if any.
1221
1222 =cut
1223
1224 sub old_cust_pkg {
1225   my $self = shift;
1226   return '' unless $self->change_pkgnum;
1227   qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
1228 }
1229
1230 =item calc_setup
1231
1232 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
1233 item.
1234
1235 =cut
1236
1237 sub calc_setup {
1238   my $self = shift;
1239   $self->part_pkg->calc_setup($self, @_);
1240 }
1241
1242 =item calc_recur
1243
1244 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
1245 item.
1246
1247 =cut
1248
1249 sub calc_recur {
1250   my $self = shift;
1251   $self->part_pkg->calc_recur($self, @_);
1252 }
1253
1254 =item calc_remain
1255
1256 Calls the I<calc_remain> of the FS::part_pkg object associated with this
1257 billing item.
1258
1259 =cut
1260
1261 sub calc_remain {
1262   my $self = shift;
1263   $self->part_pkg->calc_remain($self, @_);
1264 }
1265
1266 =item calc_cancel
1267
1268 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
1269 billing item.
1270
1271 =cut
1272
1273 sub calc_cancel {
1274   my $self = shift;
1275   $self->part_pkg->calc_cancel($self, @_);
1276 }
1277
1278 =item cust_bill_pkg
1279
1280 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
1281
1282 =cut
1283
1284 sub cust_bill_pkg {
1285   my $self = shift;
1286   qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
1287 }
1288
1289 =item cust_pkg_detail [ DETAILTYPE ]
1290
1291 Returns any customer package details for this package (see
1292 L<FS::cust_pkg_detail>).
1293
1294 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
1295
1296 =cut
1297
1298 sub cust_pkg_detail {
1299   my $self = shift;
1300   my %hash = ( 'pkgnum' => $self->pkgnum );
1301   $hash{detailtype} = shift if @_;
1302   qsearch({
1303     'table'    => 'cust_pkg_detail',
1304     'hashref'  => \%hash,
1305     'order_by' => 'ORDER BY weight, pkgdetailnum',
1306   });
1307 }
1308
1309 =item set_cust_pkg_detail DETAILTYPE [ DETAIL, DETAIL, ... ]
1310
1311 Sets customer package details for this package (see L<FS::cust_pkg_detail>).
1312
1313 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
1314
1315 If there is an error, returns the error, otherwise returns false.
1316
1317 =cut
1318
1319 sub set_cust_pkg_detail {
1320   my( $self, $detailtype, @details ) = @_;
1321
1322   local $SIG{HUP} = 'IGNORE';
1323   local $SIG{INT} = 'IGNORE';
1324   local $SIG{QUIT} = 'IGNORE';
1325   local $SIG{TERM} = 'IGNORE';
1326   local $SIG{TSTP} = 'IGNORE';
1327   local $SIG{PIPE} = 'IGNORE';
1328
1329   my $oldAutoCommit = $FS::UID::AutoCommit;
1330   local $FS::UID::AutoCommit = 0;
1331   my $dbh = dbh;
1332
1333   foreach my $current ( $self->cust_pkg_detail($detailtype) ) {
1334     my $error = $current->delete;
1335     if ( $error ) {
1336       $dbh->rollback if $oldAutoCommit;
1337       return "error removing old detail: $error";
1338     }
1339   }
1340
1341   foreach my $detail ( @details ) {
1342     my $cust_pkg_detail = new FS::cust_pkg_detail {
1343       'pkgnum'     => $self->pkgnum,
1344       'detailtype' => $detailtype,
1345       'detail'     => $detail,
1346     };
1347     my $error = $cust_pkg_detail->insert;
1348     if ( $error ) {
1349       $dbh->rollback if $oldAutoCommit;
1350       return "error adding new detail: $error";
1351     }
1352
1353   }
1354
1355   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1356   '';
1357
1358 }
1359
1360 =item cust_event
1361
1362 Returns the new-style customer billing events (see L<FS::cust_event>) for this invoice.
1363
1364 =cut
1365
1366 #false laziness w/cust_bill.pm
1367 sub cust_event {
1368   my $self = shift;
1369   qsearch({
1370     'table'     => 'cust_event',
1371     'addl_from' => 'JOIN part_event USING ( eventpart )',
1372     'hashref'   => { 'tablenum' => $self->pkgnum },
1373     'extra_sql' => " AND eventtable = 'cust_pkg' ",
1374   });
1375 }
1376
1377 =item num_cust_event
1378
1379 Returns the number of new-style customer billing events (see L<FS::cust_event>) for this invoice.
1380
1381 =cut
1382
1383 #false laziness w/cust_bill.pm
1384 sub num_cust_event {
1385   my $self = shift;
1386   my $sql =
1387     "SELECT COUNT(*) FROM cust_event JOIN part_event USING ( eventpart ) ".
1388     "  WHERE tablenum = ? AND eventtable = 'cust_pkg'";
1389   my $sth = dbh->prepare($sql) or die  dbh->errstr. " preparing $sql";
1390   $sth->execute($self->pkgnum) or die $sth->errstr. " executing $sql";
1391   $sth->fetchrow_arrayref->[0];
1392 }
1393
1394 =item cust_svc [ SVCPART ]
1395
1396 Returns the services for this package, as FS::cust_svc objects (see
1397 L<FS::cust_svc>).  If a svcpart is specified, return only the matching
1398 services.
1399
1400 =cut
1401
1402 sub cust_svc {
1403   my $self = shift;
1404
1405   if ( @_ ) {
1406     return qsearch( 'cust_svc', { 'pkgnum'  => $self->pkgnum,
1407                                   'svcpart' => shift,          } );
1408   }
1409
1410   #if ( $self->{'_svcnum'} ) {
1411   #  values %{ $self->{'_svcnum'}->cache };
1412   #} else {
1413     $self->_sort_cust_svc(
1414       [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
1415     );
1416   #}
1417
1418 }
1419
1420 =item overlimit [ SVCPART ]
1421
1422 Returns the services for this package which have exceeded their
1423 usage limit as FS::cust_svc objects (see L<FS::cust_svc>).  If a svcpart
1424 is specified, return only the matching services.
1425
1426 =cut
1427
1428 sub overlimit {
1429   my $self = shift;
1430   grep { $_->overlimit } $self->cust_svc;
1431 }
1432
1433 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ]
1434
1435 Returns historical services for this package created before END TIMESTAMP and
1436 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
1437 (see L<FS::h_cust_svc>).
1438
1439 =cut
1440
1441 sub h_cust_svc {
1442   my $self = shift;
1443
1444   $self->_sort_cust_svc(
1445     [ qsearch( 'h_cust_svc',
1446                { 'pkgnum' => $self->pkgnum, },
1447                FS::h_cust_svc->sql_h_search(@_),
1448              )
1449     ]
1450   );
1451 }
1452
1453 sub _sort_cust_svc {
1454   my( $self, $arrayref ) = @_;
1455
1456   map  { $_->[0] }
1457   sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
1458   map {
1459         my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
1460                                              'svcpart' => $_->svcpart     } );
1461         [ $_,
1462           $pkg_svc ? $pkg_svc->primary_svc : '',
1463           $pkg_svc ? $pkg_svc->quantity : 0,
1464         ];
1465       }
1466   @$arrayref;
1467
1468 }
1469
1470 =item num_cust_svc [ SVCPART ]
1471
1472 Returns the number of provisioned services for this package.  If a svcpart is
1473 specified, counts only the matching services.
1474
1475 =cut
1476
1477 sub num_cust_svc {
1478   my $self = shift;
1479   my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
1480   $sql .= ' AND svcpart = ?' if @_;
1481   my $sth = dbh->prepare($sql) or die dbh->errstr;
1482   $sth->execute($self->pkgnum, @_) or die $sth->errstr;
1483   $sth->fetchrow_arrayref->[0];
1484 }
1485
1486 =item available_part_svc
1487
1488 Returns a list of FS::part_svc objects representing services included in this
1489 package but not yet provisioned.  Each FS::part_svc object also has an extra
1490 field, I<num_avail>, which specifies the number of available services.
1491
1492 =cut
1493
1494 sub available_part_svc {
1495   my $self = shift;
1496   grep { $_->num_avail > 0 }
1497     map {
1498           my $part_svc = $_->part_svc;
1499           $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
1500             $_->quantity - $self->num_cust_svc($_->svcpart);
1501           $part_svc;
1502         }
1503       $self->part_pkg->pkg_svc;
1504 }
1505
1506 =item part_svc
1507
1508 Returns a list of FS::part_svc objects representing provisioned and available
1509 services included in this package.  Each FS::part_svc object also has the
1510 following extra fields:
1511
1512 =over 4
1513
1514 =item num_cust_svc  (count)
1515
1516 =item num_avail     (quantity - count)
1517
1518 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
1519
1520 svcnum
1521 label -> ($cust_svc->label)[1]
1522
1523 =back
1524
1525 =cut
1526
1527 sub part_svc {
1528   my $self = shift;
1529
1530   #XXX some sort of sort order besides numeric by svcpart...
1531   my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
1532     my $pkg_svc = $_;
1533     my $part_svc = $pkg_svc->part_svc;
1534     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1535     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
1536     $part_svc->{'Hash'}{'num_avail'}    =
1537       max( 0, $pkg_svc->quantity - $num_cust_svc );
1538     $part_svc->{'Hash'}{'cust_pkg_svc'} = [ $self->cust_svc($part_svc->svcpart) ];
1539     $part_svc;
1540   } $self->part_pkg->pkg_svc;
1541
1542   #extras
1543   push @part_svc, map {
1544     my $part_svc = $_;
1545     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1546     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
1547     $part_svc->{'Hash'}{'num_avail'}    = 0; #0-$num_cust_svc ?
1548     $part_svc->{'Hash'}{'cust_pkg_svc'} = [ $self->cust_svc($part_svc->svcpart) ];
1549     $part_svc;
1550   } $self->extra_part_svc;
1551
1552   @part_svc;
1553
1554 }
1555
1556 =item extra_part_svc
1557
1558 Returns a list of FS::part_svc objects corresponding to services in this
1559 package which are still provisioned but not (any longer) available in the
1560 package definition.
1561
1562 =cut
1563
1564 sub extra_part_svc {
1565   my $self = shift;
1566
1567   my $pkgnum  = $self->pkgnum;
1568   my $pkgpart = $self->pkgpart;
1569
1570   qsearch( {
1571     'table'     => 'part_svc',
1572     'hashref'   => {},
1573     'extra_sql' => "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
1574                                   WHERE pkg_svc.svcpart = part_svc.svcpart
1575                                     AND pkg_svc.pkgpart = $pkgpart
1576                                     AND quantity > 0
1577                               )
1578                       AND 0 < ( SELECT count(*)
1579                                   FROM cust_svc
1580                                     LEFT JOIN cust_pkg using ( pkgnum )
1581                                   WHERE cust_svc.svcpart = part_svc.svcpart
1582                                     AND pkgnum = $pkgnum
1583                               )",
1584   } );
1585 }
1586
1587 =item status
1588
1589 Returns a short status string for this package, currently:
1590
1591 =over 4
1592
1593 =item not yet billed
1594
1595 =item one-time charge
1596
1597 =item active
1598
1599 =item suspended
1600
1601 =item cancelled
1602
1603 =back
1604
1605 =cut
1606
1607 sub status {
1608   my $self = shift;
1609
1610   my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
1611
1612   return 'cancelled' if $self->get('cancel');
1613   return 'suspended' if $self->susp;
1614   return 'not yet billed' unless $self->setup;
1615   return 'one-time charge' if $freq =~ /^(0|$)/;
1616   return 'active';
1617 }
1618
1619 =item statuses
1620
1621 Class method that returns the list of possible status strings for packages
1622 (see L<the status method|/status>).  For example:
1623
1624   @statuses = FS::cust_pkg->statuses();
1625
1626 =cut
1627
1628 tie my %statuscolor, 'Tie::IxHash',
1629   'not yet billed'  => '000000',
1630   'one-time charge' => '000000',
1631   'active'          => '00CC00',
1632   'suspended'       => 'FF9900',
1633   'cancelled'       => 'FF0000',
1634 ;
1635
1636 sub statuses {
1637   my $self = shift; #could be class...
1638   grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
1639                                       # mayble split btw one-time vs. recur
1640     keys %statuscolor;
1641 }
1642
1643 =item statuscolor
1644
1645 Returns a hex triplet color string for this package's status.
1646
1647 =cut
1648
1649 sub statuscolor {
1650   my $self = shift;
1651   $statuscolor{$self->status};
1652 }
1653
1654 =item labels
1655
1656 Returns a list of lists, calling the label method for all services
1657 (see L<FS::cust_svc>) of this billing item.
1658
1659 =cut
1660
1661 sub labels {
1662   my $self = shift;
1663   map { [ $_->label ] } $self->cust_svc;
1664 }
1665
1666 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
1667
1668 Like the labels method, but returns historical information on services that
1669 were active as of END_TIMESTAMP and (optionally) not cancelled before
1670 START_TIMESTAMP.
1671
1672 Returns a list of lists, calling the label method for all (historical) services
1673 (see L<FS::h_cust_svc>) of this billing item.
1674
1675 =cut
1676
1677 sub h_labels {
1678   my $self = shift;
1679   map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
1680 }
1681
1682 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
1683
1684 Like h_labels, except returns a simple flat list, and shortens long
1685 (currently >5 or the cust_bill-max_same_services configuration value) lists of
1686 identical services to one line that lists the service label and the number of
1687 individual services rather than individual items.
1688
1689 =cut
1690
1691 sub h_labels_short {
1692   my $self = shift;
1693
1694   my $conf = new FS::Conf;
1695   my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
1696
1697   my %labels;
1698   #tie %labels, 'Tie::IxHash';
1699   push @{ $labels{$_->[0]} }, $_->[1]
1700     foreach $self->h_labels(@_);
1701   my @labels;
1702   foreach my $label ( keys %labels ) {
1703     my %seen = ();
1704     my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
1705     my $num = scalar(@values);
1706     if ( $num > $max_same_services ) {
1707       push @labels, "$label ($num)";
1708     } else {
1709       push @labels, map { "$label: $_" } @values;
1710     }
1711   }
1712
1713  @labels;
1714
1715 }
1716
1717 =item cust_main
1718
1719 Returns the parent customer object (see L<FS::cust_main>).
1720
1721 =cut
1722
1723 sub cust_main {
1724   my $self = shift;
1725   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
1726 }
1727
1728 =item cust_location
1729
1730 Returns the location object, if any (see L<FS::cust_location>).
1731
1732 =cut
1733
1734 sub cust_location {
1735   my $self = shift;
1736   return '' unless $self->locationnum;
1737   qsearchs( 'cust_location', { 'locationnum' => $self->locationnum } );
1738 }
1739
1740 =item cust_location_or_main
1741
1742 If this package is associated with a location, returns the locaiton (see
1743 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
1744
1745 =cut
1746
1747 sub cust_location_or_main {
1748   my $self = shift;
1749   $self->cust_location || $self->cust_main;
1750 }
1751
1752 =item seconds_since TIMESTAMP
1753
1754 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
1755 package have been online since TIMESTAMP, according to the session monitor.
1756
1757 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1758 L<Time::Local> and L<Date::Parse> for conversion functions.
1759
1760 =cut
1761
1762 sub seconds_since {
1763   my($self, $since) = @_;
1764   my $seconds = 0;
1765
1766   foreach my $cust_svc (
1767     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
1768   ) {
1769     $seconds += $cust_svc->seconds_since($since);
1770   }
1771
1772   $seconds;
1773
1774 }
1775
1776 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1777
1778 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
1779 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
1780 (exclusive).
1781
1782 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1783 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1784 functions.
1785
1786
1787 =cut
1788
1789 sub seconds_since_sqlradacct {
1790   my($self, $start, $end) = @_;
1791
1792   my $seconds = 0;
1793
1794   foreach my $cust_svc (
1795     grep {
1796       my $part_svc = $_->part_svc;
1797       $part_svc->svcdb eq 'svc_acct'
1798         && scalar($part_svc->part_export('sqlradius'));
1799     } $self->cust_svc
1800   ) {
1801     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
1802   }
1803
1804   $seconds;
1805
1806 }
1807
1808 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1809
1810 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1811 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1812 TIMESTAMP_END
1813 (exclusive).
1814
1815 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1816 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1817 functions.
1818
1819 =cut
1820
1821 sub attribute_since_sqlradacct {
1822   my($self, $start, $end, $attrib) = @_;
1823
1824   my $sum = 0;
1825
1826   foreach my $cust_svc (
1827     grep {
1828       my $part_svc = $_->part_svc;
1829       $part_svc->svcdb eq 'svc_acct'
1830         && scalar($part_svc->part_export('sqlradius'));
1831     } $self->cust_svc
1832   ) {
1833     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
1834   }
1835
1836   $sum;
1837
1838 }
1839
1840 =item quantity
1841
1842 =cut
1843
1844 sub quantity {
1845   my( $self, $value ) = @_;
1846   if ( defined($value) ) {
1847     $self->setfield('quantity', $value);
1848   }
1849   $self->getfield('quantity') || 1;
1850 }
1851
1852 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
1853
1854 Transfers as many services as possible from this package to another package.
1855
1856 The destination package can be specified by pkgnum by passing an FS::cust_pkg
1857 object.  The destination package must already exist.
1858
1859 Services are moved only if the destination allows services with the correct
1860 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
1861 this option with caution!  No provision is made for export differences
1862 between the old and new service definitions.  Probably only should be used
1863 when your exports for all service definitions of a given svcdb are identical.
1864 (attempt a transfer without it first, to move all possible svcpart-matching
1865 services)
1866
1867 Any services that can't be moved remain in the original package.
1868
1869 Returns an error, if there is one; otherwise, returns the number of services
1870 that couldn't be moved.
1871
1872 =cut
1873
1874 sub transfer {
1875   my ($self, $dest_pkgnum, %opt) = @_;
1876
1877   my $remaining = 0;
1878   my $dest;
1879   my %target;
1880
1881   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
1882     $dest = $dest_pkgnum;
1883     $dest_pkgnum = $dest->pkgnum;
1884   } else {
1885     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
1886   }
1887
1888   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
1889
1890   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
1891     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
1892   }
1893
1894   foreach my $cust_svc ($dest->cust_svc) {
1895     $target{$cust_svc->svcpart}--;
1896   }
1897
1898   my %svcpart2svcparts = ();
1899   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1900     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
1901     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
1902       next if exists $svcpart2svcparts{$svcpart};
1903       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
1904       $svcpart2svcparts{$svcpart} = [
1905         map  { $_->[0] }
1906         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
1907         map {
1908               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
1909                                                    'svcpart' => $_          } );
1910               [ $_,
1911                 $pkg_svc ? $pkg_svc->primary_svc : '',
1912                 $pkg_svc ? $pkg_svc->quantity : 0,
1913               ];
1914             }
1915
1916         grep { $_ != $svcpart }
1917         map  { $_->svcpart }
1918         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
1919       ];
1920       warn "alternates for svcpart $svcpart: ".
1921            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
1922         if $DEBUG;
1923     }
1924   }
1925
1926   foreach my $cust_svc ($self->cust_svc) {
1927     if($target{$cust_svc->svcpart} > 0) {
1928       $target{$cust_svc->svcpart}--;
1929       my $new = new FS::cust_svc { $cust_svc->hash };
1930       $new->pkgnum($dest_pkgnum);
1931       my $error = $new->replace($cust_svc);
1932       return $error if $error;
1933     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1934       if ( $DEBUG ) {
1935         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
1936         warn "alternates to consider: ".
1937              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
1938       }
1939       my @alternate = grep {
1940                              warn "considering alternate svcpart $_: ".
1941                                   "$target{$_} available in new package\n"
1942                                if $DEBUG;
1943                              $target{$_} > 0;
1944                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
1945       if ( @alternate ) {
1946         warn "alternate(s) found\n" if $DEBUG;
1947         my $change_svcpart = $alternate[0];
1948         $target{$change_svcpart}--;
1949         my $new = new FS::cust_svc { $cust_svc->hash };
1950         $new->svcpart($change_svcpart);
1951         $new->pkgnum($dest_pkgnum);
1952         my $error = $new->replace($cust_svc);
1953         return $error if $error;
1954       } else {
1955         $remaining++;
1956       }
1957     } else {
1958       $remaining++
1959     }
1960   }
1961   return $remaining;
1962 }
1963
1964 =item reexport
1965
1966 This method is deprecated.  See the I<depend_jobnum> option to the insert and
1967 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
1968
1969 =cut
1970
1971 sub reexport {
1972   my $self = shift;
1973
1974   local $SIG{HUP} = 'IGNORE';
1975   local $SIG{INT} = 'IGNORE';
1976   local $SIG{QUIT} = 'IGNORE';
1977   local $SIG{TERM} = 'IGNORE';
1978   local $SIG{TSTP} = 'IGNORE';
1979   local $SIG{PIPE} = 'IGNORE';
1980
1981   my $oldAutoCommit = $FS::UID::AutoCommit;
1982   local $FS::UID::AutoCommit = 0;
1983   my $dbh = dbh;
1984
1985   foreach my $cust_svc ( $self->cust_svc ) {
1986     #false laziness w/svc_Common::insert
1987     my $svc_x = $cust_svc->svc_x;
1988     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
1989       my $error = $part_export->export_insert($svc_x);
1990       if ( $error ) {
1991         $dbh->rollback if $oldAutoCommit;
1992         return $error;
1993       }
1994     }
1995   }
1996
1997   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1998   '';
1999
2000 }
2001
2002 =back
2003
2004 =head1 CLASS METHODS
2005
2006 =over 4
2007
2008 =item recurring_sql
2009
2010 Returns an SQL expression identifying recurring packages.
2011
2012 =cut
2013
2014 sub recurring_sql { "
2015   '0' != ( select freq from part_pkg
2016              where cust_pkg.pkgpart = part_pkg.pkgpart )
2017 "; }
2018
2019 =item onetime_sql
2020
2021 Returns an SQL expression identifying one-time packages.
2022
2023 =cut
2024
2025 sub onetime_sql { "
2026   '0' = ( select freq from part_pkg
2027             where cust_pkg.pkgpart = part_pkg.pkgpart )
2028 "; }
2029
2030 =item active_sql
2031
2032 Returns an SQL expression identifying active packages.
2033
2034 =cut
2035
2036 sub active_sql { "
2037   ". $_[0]->recurring_sql(). "
2038   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2039   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2040 "; }
2041
2042 =item inactive_sql
2043
2044 Returns an SQL expression identifying inactive packages (one-time packages
2045 that are otherwise unsuspended/uncancelled).
2046
2047 =cut
2048
2049 sub inactive_sql { "
2050   ". $_[0]->onetime_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 susp_sql
2056 =item suspended_sql
2057
2058 Returns an SQL expression identifying suspended packages.
2059
2060 =cut
2061
2062 sub suspended_sql { susp_sql(@_); }
2063 sub susp_sql {
2064   #$_[0]->recurring_sql(). ' AND '.
2065   "
2066         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
2067     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
2068   ";
2069 }
2070
2071 =item cancel_sql
2072 =item cancelled_sql
2073
2074 Returns an SQL exprression identifying cancelled packages.
2075
2076 =cut
2077
2078 sub cancelled_sql { cancel_sql(@_); }
2079 sub cancel_sql {
2080   #$_[0]->recurring_sql(). ' AND '.
2081   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
2082 }
2083
2084 =item search_sql HASHREF
2085
2086 (Class method)
2087
2088 Returns a qsearch hash expression to search for parameters specified in HASHREF.
2089 Valid parameters are
2090
2091 =over 4
2092
2093 =item agentnum
2094
2095 =item magic
2096
2097 active, inactive, suspended, cancel (or cancelled)
2098
2099 =item status
2100
2101 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
2102
2103 =item classnum
2104
2105 =item pkgpart
2106
2107 list specified how?
2108
2109 =item setup
2110
2111 arrayref of beginning and ending epoch date
2112
2113 =item last_bill
2114
2115 arrayref of beginning and ending epoch date
2116
2117 =item bill
2118
2119 arrayref of beginning and ending epoch date
2120
2121 =item adjourn
2122
2123 arrayref of beginning and ending epoch date
2124
2125 =item susp
2126
2127 arrayref of beginning and ending epoch date
2128
2129 =item expire
2130
2131 arrayref of beginning and ending epoch date
2132
2133 =item cancel
2134
2135 arrayref of beginning and ending epoch date
2136
2137 =item query
2138
2139 pkgnum or APKG_pkgnum
2140
2141 =item cust_fields
2142
2143 a value suited to passing to FS::UI::Web::cust_header
2144
2145 =item CurrentUser
2146
2147 specifies the user for agent virtualization
2148
2149 =back
2150
2151 =cut
2152
2153 sub search_sql {
2154   my ($class, $params) = @_;
2155   my @where = ();
2156
2157   ##
2158   # parse agent
2159   ##
2160
2161   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2162     push @where,
2163       "cust_main.agentnum = $1";
2164   }
2165
2166   ##
2167   # parse status
2168   ##
2169
2170   if (    $params->{'magic'}  eq 'active'
2171        || $params->{'status'} eq 'active' ) {
2172
2173     push @where, FS::cust_pkg->active_sql();
2174
2175   } elsif (    $params->{'magic'}  eq 'inactive'
2176             || $params->{'status'} eq 'inactive' ) {
2177
2178     push @where, FS::cust_pkg->inactive_sql();
2179
2180   } elsif (    $params->{'magic'}  eq 'suspended'
2181             || $params->{'status'} eq 'suspended'  ) {
2182
2183     push @where, FS::cust_pkg->suspended_sql();
2184
2185   } elsif (    $params->{'magic'}  =~ /^cancell?ed$/
2186             || $params->{'status'} =~ /^cancell?ed$/ ) {
2187
2188     push @where, FS::cust_pkg->cancelled_sql();
2189
2190   } elsif ( $params->{'status'} =~ /^(one-time charge|inactive)$/ ) {
2191
2192     push @where, FS::cust_pkg->inactive_sql();
2193
2194   }
2195
2196   ###
2197   # parse package class
2198   ###
2199
2200   #false lazinessish w/graph/cust_bill_pkg.cgi
2201   my $classnum = 0;
2202   my @pkg_class = ();
2203   if ( exists($params->{'classnum'})
2204        && $params->{'classnum'} =~ /^(\d*)$/
2205      )
2206   {
2207     $classnum = $1;
2208     if ( $classnum ) { #a specific class
2209       push @where, "classnum = $classnum";
2210
2211       #@pkg_class = ( qsearchs('pkg_class', { 'classnum' => $classnum } ) );
2212       #die "classnum $classnum not found!" unless $pkg_class[0];
2213       #$title .= $pkg_class[0]->classname.' ';
2214
2215     } elsif ( $classnum eq '' ) { #the empty class
2216
2217       push @where, "classnum IS NULL";
2218       #$title .= 'Empty class ';
2219       #@pkg_class = ( '(empty class)' );
2220     } elsif ( $classnum eq '0' ) {
2221       #@pkg_class = qsearch('pkg_class', {} ); # { 'disabled' => '' } );
2222       #push @pkg_class, '(empty class)';
2223     } else {
2224       die "illegal classnum";
2225     }
2226   }
2227   #eslaf
2228
2229   ###
2230   # parse part_pkg
2231   ###
2232
2233   my $pkgpart = join (' OR pkgpart=',
2234                       grep {$_} map { /^(\d+)$/; } ($params->{'pkgpart'}));
2235   push @where,  '(pkgpart=' . $pkgpart . ')' if $pkgpart;
2236
2237   ###
2238   # parse dates
2239   ###
2240
2241   my $orderby = '';
2242
2243   #false laziness w/report_cust_pkg.html
2244   my %disable = (
2245     'all'             => {},
2246     'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
2247     'active'          => { 'susp'=>1, 'cancel'=>1 },
2248     'suspended'       => { 'cancel' => 1 },
2249     'cancelled'       => {},
2250     ''                => {},
2251   );
2252
2253   foreach my $field (qw( setup last_bill bill adjourn susp expire cancel )) {
2254
2255     next unless exists($params->{$field});
2256
2257     my($beginning, $ending) = @{$params->{$field}};
2258
2259     next if $beginning == 0 && $ending == 4294967295;
2260
2261     push @where,
2262       "cust_pkg.$field IS NOT NULL",
2263       "cust_pkg.$field >= $beginning",
2264       "cust_pkg.$field <= $ending";
2265
2266     $orderby ||= "ORDER BY cust_pkg.$field";
2267
2268   }
2269
2270   $orderby ||= 'ORDER BY bill';
2271
2272   ###
2273   # parse magic, legacy, etc.
2274   ###
2275
2276   if ( $params->{'magic'} &&
2277        $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
2278   ) {
2279
2280     $orderby = 'ORDER BY pkgnum';
2281
2282     if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
2283       push @where, "pkgpart = $1";
2284     }
2285
2286   } elsif ( $params->{'query'} eq 'pkgnum' ) {
2287
2288     $orderby = 'ORDER BY pkgnum';
2289
2290   } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
2291
2292     $orderby = 'ORDER BY pkgnum';
2293
2294     push @where, '0 < (
2295       SELECT count(*) FROM pkg_svc
2296        WHERE pkg_svc.pkgpart =  cust_pkg.pkgpart
2297          AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
2298                                    WHERE cust_svc.pkgnum  = cust_pkg.pkgnum
2299                                      AND cust_svc.svcpart = pkg_svc.svcpart
2300                                 )
2301     )';
2302
2303   }
2304
2305   ##
2306   # setup queries, links, subs, etc. for the search
2307   ##
2308
2309   # here is the agent virtualization
2310   if ($params->{CurrentUser}) {
2311     my $access_user =
2312       qsearchs('access_user', { username => $params->{CurrentUser} });
2313
2314     if ($access_user) {
2315       push @where, $access_user->agentnums_sql('table'=>'cust_main');
2316     }else{
2317       push @where, "1=0";
2318     }
2319   }else{
2320     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
2321   }
2322
2323   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
2324
2325   my $addl_from = 'LEFT JOIN cust_main USING ( custnum  ) '.
2326                   'LEFT JOIN part_pkg  USING ( pkgpart  ) '.
2327                   'LEFT JOIN pkg_class USING ( classnum ) ';
2328
2329   my $count_query = "SELECT COUNT(*) FROM cust_pkg $addl_from $extra_sql";
2330
2331   my $sql_query = {
2332     'table'       => 'cust_pkg',
2333     'hashref'     => {},
2334     'select'      => join(', ',
2335                                 'cust_pkg.*',
2336                                 ( map "part_pkg.$_", qw( pkg freq ) ),
2337                                 'pkg_class.classname',
2338                                 'cust_main.custnum as cust_main_custnum',
2339                                 FS::UI::Web::cust_sql_fields(
2340                                   $params->{'cust_fields'}
2341                                 ),
2342                      ),
2343     'extra_sql'   => "$extra_sql $orderby",
2344     'addl_from'   => $addl_from,
2345     'count_query' => $count_query,
2346   };
2347
2348 }
2349
2350 =item location_sql
2351
2352 Returns a list: the first item is an SQL fragment identifying matching
2353 packages/customers via location (taking into account shipping and package
2354 address taxation, if enabled), and subsequent items are the parameters to
2355 substitute for the placeholders in that fragment.
2356
2357 =cut
2358
2359 sub location_sql {
2360   my($class, %opt) = @_;
2361   my $ornull = $opt{'ornull'};
2362
2363   my $conf = new FS::Conf;
2364
2365   # '?' placeholders in _location_sql_where
2366   my @bill_param;
2367   if ( $ornull ) {
2368     @bill_param = qw( county county state state state country );
2369   } else {
2370     @bill_param = qw( county state state country );
2371   }
2372   unshift @bill_param, 'county'; # unless $nec;
2373
2374   my $main_where;
2375   my @main_param;
2376   if ( $conf->exists('tax-ship_address') ) {
2377
2378     $main_where = "(
2379          (     ( ship_last IS NULL     OR  ship_last  = '' )
2380            AND ". _location_sql_where('cust_main', '', $ornull ). "
2381          )
2382       OR (       ship_last IS NOT NULL AND ship_last != ''
2383            AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
2384          )
2385     )";
2386     #    AND payby != 'COMP'
2387
2388     @main_param = ( @bill_param, @bill_param );
2389
2390   } else {
2391
2392     $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
2393     @main_param = @bill_param;
2394
2395   }
2396
2397   my $where;
2398   my @param;
2399   if ( $conf->exists('tax-pkg_address') ) {
2400
2401     my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
2402
2403     $where = " (
2404                     ( cust_pkg.locationnum IS     NULL AND $main_where )
2405                  OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where  )
2406                )
2407              ";
2408     @param = ( @main_param, @bill_param );
2409
2410   } else {
2411
2412     $where = $main_where;
2413     @param = @main_param;
2414
2415   }
2416
2417   ( $where, @param );
2418
2419 }
2420
2421 #subroutine, helper for location_sql
2422 sub _location_sql_where {
2423   my $table  = shift;
2424   my $prefix = @_ ? shift : '';
2425   my $ornull = @_ ? shift : '';
2426
2427 #  $ornull             = $ornull          ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
2428
2429   $ornull = $ornull ? ' OR ? IS NULL ' : '';
2430
2431   my $or_empty_county = " OR ( ? = '' AND $table.${prefix}county IS NULL ) ";
2432   my $or_empty_state =  " OR ( ? = '' AND $table.${prefix}state  IS NULL ) ";
2433
2434   "
2435         ( $table.${prefix}county  = ? $or_empty_county $ornull )
2436     AND ( $table.${prefix}state   = ? $or_empty_state  $ornull )
2437     AND   $table.${prefix}country = ?
2438   ";
2439 }
2440
2441 =head1 SUBROUTINES
2442
2443 =over 4
2444
2445 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
2446
2447 CUSTNUM is a customer (see L<FS::cust_main>)
2448
2449 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
2450 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
2451 permitted.
2452
2453 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
2454 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
2455 new billing items.  An error is returned if this is not possible (see
2456 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
2457 parameter.
2458
2459 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
2460 newly-created cust_pkg objects.
2461
2462 REFNUM, if specified, will specify the FS::pkg_referral record to be created
2463 and inserted.  Multiple FS::pkg_referral records can be created by
2464 setting I<refnum> to an array reference of refnums or a hash reference with
2465 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
2466 record will be created corresponding to cust_main.refnum.
2467
2468 =cut
2469
2470 sub order {
2471   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
2472
2473   my $conf = new FS::Conf;
2474
2475   # Transactionize this whole mess
2476   local $SIG{HUP} = 'IGNORE';
2477   local $SIG{INT} = 'IGNORE';
2478   local $SIG{QUIT} = 'IGNORE';
2479   local $SIG{TERM} = 'IGNORE';
2480   local $SIG{TSTP} = 'IGNORE';
2481   local $SIG{PIPE} = 'IGNORE';
2482
2483   my $oldAutoCommit = $FS::UID::AutoCommit;
2484   local $FS::UID::AutoCommit = 0;
2485   my $dbh = dbh;
2486
2487   my $error;
2488 #  my $cust_main = qsearchs('cust_main', { custnum => $custnum });
2489 #  return "Customer not found: $custnum" unless $cust_main;
2490
2491   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
2492                          @$remove_pkgnum;
2493
2494   my $change = scalar(@old_cust_pkg) != 0;
2495
2496   my %hash = ();
2497   if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
2498
2499     my $err_or_cust_pkg =
2500       $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
2501                                 'refnum'  => $refnum,
2502                               );
2503
2504     unless (ref($err_or_cust_pkg)) {
2505       $dbh->rollback if $oldAutoCommit;
2506       return $err_or_cust_pkg;
2507     }
2508
2509     push @$return_cust_pkg, $err_or_cust_pkg;
2510     return '';
2511
2512   }
2513
2514   # Create the new packages.
2515   foreach my $pkgpart (@$pkgparts) {
2516     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
2517                                       pkgpart => $pkgpart,
2518                                       refnum  => $refnum,
2519                                       %hash,
2520                                     };
2521     $error = $cust_pkg->insert( 'change' => $change );
2522     if ($error) {
2523       $dbh->rollback if $oldAutoCommit;
2524       return $error;
2525     }
2526     push @$return_cust_pkg, $cust_pkg;
2527   }
2528   # $return_cust_pkg now contains refs to all of the newly
2529   # created packages.
2530
2531   # Transfer services and cancel old packages.
2532   foreach my $old_pkg (@old_cust_pkg) {
2533
2534     foreach my $new_pkg (@$return_cust_pkg) {
2535       $error = $old_pkg->transfer($new_pkg);
2536       if ($error and $error == 0) {
2537         # $old_pkg->transfer failed.
2538         $dbh->rollback if $oldAutoCommit;
2539         return $error;
2540       }
2541     }
2542
2543     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
2544       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
2545       foreach my $new_pkg (@$return_cust_pkg) {
2546         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
2547         if ($error and $error == 0) {
2548           # $old_pkg->transfer failed.
2549         $dbh->rollback if $oldAutoCommit;
2550         return $error;
2551         }
2552       }
2553     }
2554
2555     if ($error > 0) {
2556       # Transfers were successful, but we went through all of the
2557       # new packages and still had services left on the old package.
2558       # We can't cancel the package under the circumstances, so abort.
2559       $dbh->rollback if $oldAutoCommit;
2560       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
2561     }
2562     $error = $old_pkg->cancel( quiet=>1 );
2563     if ($error) {
2564       $dbh->rollback;
2565       return $error;
2566     }
2567   }
2568   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2569   '';
2570 }
2571
2572 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
2573
2574 A bulk change method to change packages for multiple customers.
2575
2576 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
2577 L<FS::part_pkg>) to order for each customer.  Duplicates are of course
2578 permitted.
2579
2580 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
2581 replace.  The services (see L<FS::cust_svc>) are moved to the
2582 new billing items.  An error is returned if this is not possible (see
2583 L<FS::pkg_svc>).
2584
2585 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
2586 newly-created cust_pkg objects.
2587
2588 =cut
2589
2590 sub bulk_change {
2591   my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
2592
2593   # Transactionize this whole mess
2594   local $SIG{HUP} = 'IGNORE';
2595   local $SIG{INT} = 'IGNORE';
2596   local $SIG{QUIT} = 'IGNORE';
2597   local $SIG{TERM} = 'IGNORE';
2598   local $SIG{TSTP} = 'IGNORE';
2599   local $SIG{PIPE} = 'IGNORE';
2600
2601   my $oldAutoCommit = $FS::UID::AutoCommit;
2602   local $FS::UID::AutoCommit = 0;
2603   my $dbh = dbh;
2604
2605   my @errors;
2606   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
2607                          @$remove_pkgnum;
2608
2609   while(scalar(@old_cust_pkg)) {
2610     my @return = ();
2611     my $custnum = $old_cust_pkg[0]->custnum;
2612     my (@remove) = map { $_->pkgnum }
2613                    grep { $_->custnum == $custnum } @old_cust_pkg;
2614     @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
2615
2616     my $error = order $custnum, $pkgparts, \@remove, \@return;
2617
2618     push @errors, $error
2619       if $error;
2620     push @$return_cust_pkg, @return;
2621   }
2622
2623   if (scalar(@errors)) {
2624     $dbh->rollback if $oldAutoCommit;
2625     return join(' / ', @errors);
2626   }
2627
2628   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2629   '';
2630 }
2631
2632 =item insert_reason
2633
2634 Associates this package with a (suspension or cancellation) reason (see
2635 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
2636 L<FS::reason>).
2637
2638 Available options are:
2639
2640 =over 4
2641
2642 =item reason
2643
2644 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.
2645
2646 =item reason_otaker
2647
2648 the access_user (see L<FS::access_user>) providing the reason
2649
2650 =item date
2651
2652 a unix timestamp
2653
2654 =item action
2655
2656 the action (cancel, susp, adjourn, expire) associated with the reason
2657
2658 =back
2659
2660 If there is an error, returns the error, otherwise returns false.
2661
2662 =cut
2663
2664 sub insert_reason {
2665   my ($self, %options) = @_;
2666
2667   my $otaker = $options{reason_otaker} ||
2668                $FS::CurrentUser::CurrentUser->username;
2669
2670   my $reasonnum;
2671   if ( $options{'reason'} =~ /^(\d+)$/ ) {
2672
2673     $reasonnum = $1;
2674
2675   } elsif ( ref($options{'reason'}) ) {
2676
2677     return 'Enter a new reason (or select an existing one)'
2678       unless $options{'reason'}->{'reason'} !~ /^\s*$/;
2679
2680     my $reason = new FS::reason({
2681       'reason_type' => $options{'reason'}->{'typenum'},
2682       'reason'      => $options{'reason'}->{'reason'},
2683     });
2684     my $error = $reason->insert;
2685     return $error if $error;
2686
2687     $reasonnum = $reason->reasonnum;
2688
2689   } else {
2690     return "Unparsable reason: ". $options{'reason'};
2691   }
2692
2693   my $cust_pkg_reason =
2694     new FS::cust_pkg_reason({ 'pkgnum'    => $self->pkgnum,
2695                               'reasonnum' => $reasonnum,
2696                               'otaker'    => $otaker,
2697                               'action'    => substr(uc($options{'action'}),0,1),
2698                               'date'      => $options{'date'}
2699                                                ? $options{'date'}
2700                                                : time,
2701                             });
2702
2703   $cust_pkg_reason->insert;
2704 }
2705
2706 =item set_usage USAGE_VALUE_HASHREF
2707
2708 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2709 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
2710 upbytes, downbytes, and totalbytes are appropriate keys.
2711
2712 All svc_accts which are part of this package have their values reset.
2713
2714 =cut
2715
2716 sub set_usage {
2717   my ($self, $valueref) = @_;
2718
2719   foreach my $cust_svc ($self->cust_svc){
2720     my $svc_x = $cust_svc->svc_x;
2721     $svc_x->set_usage($valueref)
2722       if $svc_x->can("set_usage");
2723   }
2724 }
2725
2726 =item recharge USAGE_VALUE_HASHREF
2727
2728 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2729 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
2730 upbytes, downbytes, and totalbytes are appropriate keys.
2731
2732 All svc_accts which are part of this package have their values incremented.
2733
2734 =cut
2735
2736 sub recharge {
2737   my ($self, $valueref) = @_;
2738
2739   foreach my $cust_svc ($self->cust_svc){
2740     my $svc_x = $cust_svc->svc_x;
2741     $svc_x->recharge($valueref)
2742       if $svc_x->can("recharge");
2743   }
2744 }
2745
2746 =back
2747
2748 =head1 BUGS
2749
2750 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
2751
2752 In sub order, the @pkgparts array (passed by reference) is clobbered.
2753
2754 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
2755 method to pass dates to the recur_prog expression, it should do so.
2756
2757 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
2758 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
2759 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
2760 configuration values.  Probably need a subroutine which decides what to do
2761 based on whether or not we've fetched the user yet, rather than a hash.  See
2762 FS::UID and the TODO.
2763
2764 Now that things are transactional should the check in the insert method be
2765 moved to check ?
2766
2767 =head1 SEE ALSO
2768
2769 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
2770 L<FS::pkg_svc>, schema.html from the base documentation
2771
2772 =cut
2773
2774 1;
2775