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