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