FS/FS/cust_pkg.pm

   1 package FS::cust_pkg;
   2
   3 use strict;
   4 use vars qw(@ISA $disable_agentcheck $DEBUG);
   5 use List::Util qw(max);
   6 use Tie::IxHash;
   7 use FS::UID qw( getotaker dbh );
   8 use FS::Misc qw( send_email );
   9 use FS::Record qw( qsearch qsearchs );
  10 use FS::cust_main_Mixin;
  11 use FS::cust_svc;
  12 use FS::part_pkg;
  13 use FS::cust_main;
  14 use FS::type_pkgs;
  15 use FS::pkg_svc;
  16 use FS::cust_bill_pkg;
  17 use FS::h_cust_svc;
  18 use FS::reg_code;
  19 use FS::part_svc;
  20 use FS::cust_pkg_reason;
  21 use FS::reason;
  22
  23 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
  24 # setup }
  25 # because they load configuration by setting FS::UID::callback (see TODO)
  26 use FS::svc_acct;
  27 use FS::svc_domain;
  28 use FS::svc_www;
  29 use FS::svc_forward;
  30
  31 # for sending cancel emails in sub cancel
  32 use FS::Conf;
  33
  34 @ISA = qw( FS::cust_main_Mixin FS::option_Common FS::Record );
  35
  36 $DEBUG = 0;
  37
  38 $disable_agentcheck = 0;
  39
  40 sub _cache {
  41   my $self = shift;
  42   my ( $hashref, $cache ) = @_;
  43   #if ( $hashref->{'pkgpart'} ) {
  44   if ( $hashref->{'pkg'} ) {
  45     # #@{ $self->{'_pkgnum'} } = ();
  46     # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
  47     # $self->{'_pkgpart'} = $subcache;
  48     # #push @{ $self->{'_pkgnum'} },
  49     #   FS::part_pkg->new_or_cached($hashref, $subcache);
  50     $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
  51   }
  52   if ( exists $hashref->{'svcnum'} ) {
  53     #@{ $self->{'_pkgnum'} } = ();
  54     my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
  55     $self->{'_svcnum'} = $subcache;
  56     #push @{ $self->{'_pkgnum'} },
  57     FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
  58   }
  59 }
  60
  61 =head1 NAME
  62
  63 FS::cust_pkg - Object methods for cust_pkg objects
  64
  65 =head1 SYNOPSIS
  66
  67   use FS::cust_pkg;
  68
  69   $record = new FS::cust_pkg \%hash;
  70   $record = new FS::cust_pkg { 'column' => 'value' };
  71
  72   $error = $record->insert;
  73
  74   $error = $new_record->replace($old_record);
  75
  76   $error = $record->delete;
  77
  78   $error = $record->check;
  79
  80   $error = $record->cancel;
  81
  82   $error = $record->suspend;
  83
  84   $error = $record->unsuspend;
  85
  86   $part_pkg = $record->part_pkg;
  87
  88   @labels = $record->labels;
  89
  90   $seconds = $record->seconds_since($timestamp);
  91
  92   $error = FS::cust_pkg::order( $custnum, \@pkgparts );
  93   $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
  94
  95 =head1 DESCRIPTION
  96
  97 An FS::cust_pkg object represents a customer billing item.  FS::cust_pkg
  98 inherits from FS::Record.  The following fields are currently supported:
  99
 100 =over 4
 101
 102 =item pkgnum - primary key (assigned automatically for new billing items)
 103
 104 =item custnum - Customer (see L<FS::cust_main>)
 105
 106 =item pkgpart - Billing item definition (see L<FS::part_pkg>)
 107
 108 =item setup - date
 109
 110 =item bill - date (next bill date)
 111
 112 =item last_bill - last bill date
 113
 114 =item adjourn - date
 115
 116 =item susp - date
 117
 118 =item expire - date
 119
 120 =item cancel - date
 121
 122 =item otaker - order taker (assigned automatically if null, see L<FS::UID>)
 123
 124 =item manual_flag - If this field is set to 1, disables the automatic
 125 unsuspension of this package when using the B<unsuspendauto> config file.
 126
 127 =back
 128
 129 Note: setup, bill, adjourn, susp, expire and cancel are specified as UNIX timestamps;
 130 see L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for
 131 conversion functions.
 132
 133 =head1 METHODS
 134
 135 =over 4
 136
 137 =item new HASHREF
 138
 139 Create a new billing item.  To add the item to the database, see L<"insert">.
 140
 141 =cut
 142
 143 sub table { 'cust_pkg'; }
 144 sub cust_linked { $_[0]->cust_main_custnum; }
 145 sub cust_unlinked_msg {
 146   my $self = shift;
 147   "WARNING: can't find cust_main.custnum ". $self->custnum.
 148   ' (cust_pkg.pkgnum '. $self->pkgnum. ')';
 149 }
 150
 151 =item insert [ OPTION => VALUE ... ]
 152
 153 Adds this billing item to the database ("Orders" the item).  If there is an
 154 error, returns the error, otherwise returns false.
 155
 156 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
 157 will be used to look up the package definition and agent restrictions will be
 158 ignored.
 159
 160 The following options are available: I<change>
 161
 162 I<change>, if set true, supresses any referral credit to a referring customer.
 163
 164 =cut
 165
 166 sub insert {
 167   my( $self, %options ) = @_;
 168
 169   local $SIG{HUP} = 'IGNORE';
 170   local $SIG{INT} = 'IGNORE';
 171   local $SIG{QUIT} = 'IGNORE';
 172   local $SIG{TERM} = 'IGNORE';
 173   local $SIG{TSTP} = 'IGNORE';
 174   local $SIG{PIPE} = 'IGNORE';
 175
 176   my $oldAutoCommit = $FS::UID::AutoCommit;
 177   local $FS::UID::AutoCommit = 0;
 178   my $dbh = dbh;
 179
 180   my $error = $self->SUPER::insert($options{options} ? %{$options{options}} : ());
 181   if ( $error ) {
 182     $dbh->rollback if $oldAutoCommit;
 183     return $error;
 184   }
 185
 186   #if ( $self->reg_code ) {
 187   #  my $reg_code = qsearchs('reg_code', { 'code' => $self->reg_code } );
 188   #  $error = $reg_code->delete;
 189   #  if ( $error ) {
 190   #    $dbh->rollback if $oldAutoCommit;
 191   #    return $error;
 192   #  }
 193   #}
 194
 195   my $conf = new FS::Conf;
 196   my $cust_main = $self->cust_main;
 197   my $part_pkg = $self->part_pkg;
 198   if ( $conf->exists('referral_credit')
 199        && $cust_main->referral_custnum
 200        && ! $options{'change'}
 201        && $part_pkg->freq !~ /^0\D?$/
 202      )
 203   {
 204     my $referring_cust_main = $cust_main->referring_cust_main;
 205     if ( $referring_cust_main->status ne 'cancelled' ) {
 206       my $error;
 207       if ( $part_pkg->freq !~ /^\d+$/ ) {
 208         warn 'WARNING: Not crediting customer '. $cust_main->referral_custnum.
 209              ' for package '. $self->pkgnum.
 210              ' ( customer '. $self->custnum. ')'.
 211              ' - One-time referral credits not (yet) available for '.
 212              ' packages with '. $part_pkg->freq_pretty. ' frequency';
 213       } else {
 214
 215         my $amount = sprintf( "%.2f", $part_pkg->base_recur / $part_pkg->freq );
 216         my $error =
 217           $referring_cust_main->
 218             credit( $amount,
 219                     'Referral credit for '.$cust_main->name,
 220                     'reason_type' => $conf->config('referral_credit_type')
 221                   );
 222         if ( $error ) {
 223           $dbh->rollback if $oldAutoCommit;
 224           return "Error crediting customer ". $cust_main->referral_custnum.
 225                " for referral: $error";
 226         }
 227
 228       }
 229
 230     }
 231   }
 232
 233   if ($conf->config('welcome_letter') && $self->cust_main->num_pkgs == 1) {
 234     my $queue = new FS::queue {
 235       'job'     => 'FS::cust_main::queueable_print',
 236     };
 237     $error = $queue->insert(
 238       'custnum'  => $self->custnum,
 239       'template' => 'welcome_letter',
 240     );
 241
 242     if ($error) {
 243       warn "can't send welcome letter: $error";
 244     }
 245
 246   }
 247
 248   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 249   '';
 250
 251 }
 252
 253 =item delete
 254
 255 This method now works but you probably shouldn't use it.
 256
 257 You don't want to delete billing items, because there would then be no record
 258 the customer ever purchased the item.  Instead, see the cancel method.
 259
 260 =cut
 261
 262 #sub delete {
 263 #  return "Can't delete cust_pkg records!";
 264 #}
 265
 266 =item replace OLD_RECORD
 267
 268 Replaces the OLD_RECORD with this one in the database.  If there is an error,
 269 returns the error, otherwise returns false.
 270
 271 Currently, custnum, setup, bill, adjourn, susp, expire, and cancel may be changed.
 272
 273 Changing pkgpart may have disasterous effects.  See the order subroutine.
 274
 275 setup and bill are normally updated by calling the bill method of a customer
 276 object (see L<FS::cust_main>).
 277
 278 suspend is normally updated by the suspend and unsuspend methods.
 279
 280 cancel is normally updated by the cancel method (and also the order subroutine
 281 in some cases).
 282
 283 Calls
 284
 285 =cut
 286
 287 sub replace {
 288   my( $new, $old, %options ) = @_;
 289
 290   # We absolutely have to have an old vs. new record to make this work.
 291   if (!defined($old)) {
 292     $old = qsearchs( 'cust_pkg', { 'pkgnum' => $new->pkgnum } );
 293   }
 294   #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
 295   return "Can't change otaker!" if $old->otaker ne $new->otaker;
 296
 297   #allow this *sigh*
 298   #return "Can't change setup once it exists!"
 299   #  if $old->getfield('setup') &&
 300   #     $old->getfield('setup') != $new->getfield('setup');
 301
 302   #some logic for bill, susp, cancel?
 303
 304   local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
 305
 306   local $SIG{HUP} = 'IGNORE';
 307   local $SIG{INT} = 'IGNORE';
 308   local $SIG{QUIT} = 'IGNORE';
 309   local $SIG{TERM} = 'IGNORE';
 310   local $SIG{TSTP} = 'IGNORE';
 311   local $SIG{PIPE} = 'IGNORE';
 312
 313   my $oldAutoCommit = $FS::UID::AutoCommit;
 314   local $FS::UID::AutoCommit = 0;
 315   my $dbh = dbh;
 316
 317   foreach my $method ( qw(adjourn expire) ) {  # How many reasons?
 318     if ($options{'reason'} && $new->$method && $old->$method ne $new->$method) {
 319       my $error = $new->insert_reason( 'reason' => $options{'reason'},
 320                                        'date'      => $new->$method,
 321                                      );
 322       if ( $error ) {
 323         dbh->rollback if $oldAutoCommit;
 324         return "Error inserting cust_pkg_reason: $error";
 325       }
 326     }
 327   }
 328
 329   #save off and freeze RADIUS attributes for any associated svc_acct records
 330   my @svc_acct = ();
 331   if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
 332
 333                 #also check for specific exports?
 334                 # to avoid spurious modify export events
 335     @svc_acct = map  { $_->svc_x }
 336                 grep { $_->part_svc->svcdb eq 'svc_acct' }
 337                      $old->cust_svc;
 338
 339     $_->snapshot foreach @svc_acct;
 340
 341   }
 342
 343   my $error = $new->SUPER::replace($old,
 344                                    $options{options} ? ${options{options}} : ()
 345                                   );
 346   if ( $error ) {
 347     $dbh->rollback if $oldAutoCommit;
 348     return $error;
 349   }
 350
 351   #for prepaid packages,
 352   #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
 353   foreach my $old_svc_acct ( @svc_acct ) {
 354     my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
 355     my $s_error = $new_svc_acct->replace($old_svc_acct);
 356     if ( $s_error ) {
 357       $dbh->rollback if $oldAutoCommit;
 358       return $s_error;
 359     }
 360   }
 361
 362   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 363   '';
 364
 365 }
 366
 367 =item check
 368
 369 Checks all fields to make sure this is a valid billing item.  If there is an
 370 error, returns the error, otherwise returns false.  Called by the insert and
 371 replace methods.
 372
 373 =cut
 374
 375 sub check {
 376   my $self = shift;
 377
 378   my $error =
 379     $self->ut_numbern('pkgnum')
 380     || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
 381     || $self->ut_numbern('pkgpart')
 382     || $self->ut_numbern('setup')
 383     || $self->ut_numbern('bill')
 384     || $self->ut_numbern('susp')
 385     || $self->ut_numbern('cancel')
 386     || $self->ut_numbern('adjourn')
 387     || $self->ut_numbern('expire')
 388   ;
 389   return $error if $error;
 390
 391   if ( $self->reg_code ) {
 392
 393     unless ( grep { $self->pkgpart == $_->pkgpart }
 394              map  { $_->reg_code_pkg }
 395              qsearchs( 'reg_code', { 'code'     => $self->reg_code,
 396                                      'agentnum' => $self->cust_main->agentnum })
 397            ) {
 398       return "Unknown registration code";
 399     }
 400
 401   } elsif ( $self->promo_code ) {
 402
 403     my $promo_part_pkg =
 404       qsearchs('part_pkg', {
 405         'pkgpart'    => $self->pkgpart,
 406         'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
 407       } );
 408     return 'Unknown promotional code' unless $promo_part_pkg;
 409
 410   } else {
 411
 412     unless ( $disable_agentcheck ) {
 413       my $agent =
 414         qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
 415       my $pkgpart_href = $agent->pkgpart_hashref;
 416       return "agent ". $agent->agentnum.
 417              " can't purchase pkgpart ". $self->pkgpart
 418         unless $pkgpart_href->{ $self->pkgpart };
 419     }
 420
 421     $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
 422     return $error if $error;
 423
 424   }
 425
 426   $self->otaker(getotaker) unless $self->otaker;
 427   $self->otaker =~ /^(\w{1,32})$/ or return "Illegal otaker";
 428   $self->otaker($1);
 429
 430   if ( $self->dbdef_table->column('manual_flag') ) {
 431     $self->manual_flag('') if $self->manual_flag eq ' ';
 432     $self->manual_flag =~ /^([01]?)$/
 433       or return "Illegal manual_flag ". $self->manual_flag;
 434     $self->manual_flag($1);
 435   }
 436
 437   $self->SUPER::check;
 438 }
 439
 440 =item cancel [ OPTION => VALUE ... ]
 441
 442 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
 443 in this package, then cancels the package itself (sets the cancel field to
 444 now).
 445
 446 Available options are: I<quiet>
 447
 448 I<quiet> can be set true to supress email cancellation notices.
 449
 450 If there is an error, returns the error, otherwise returns false.
 451
 452 =cut
 453
 454 sub cancel {
 455   my( $self, %options ) = @_;
 456   my $error;
 457
 458   local $SIG{HUP} = 'IGNORE';
 459   local $SIG{INT} = 'IGNORE';
 460   local $SIG{QUIT} = 'IGNORE';
 461   local $SIG{TERM} = 'IGNORE';
 462   local $SIG{TSTP} = 'IGNORE';
 463   local $SIG{PIPE} = 'IGNORE';
 464
 465   my $oldAutoCommit = $FS::UID::AutoCommit;
 466   local $FS::UID::AutoCommit = 0;
 467   my $dbh = dbh;
 468
 469   if ($options{'reason'}) {
 470     $error = $self->insert_reason( 'reason' => $options{'reason'} );
 471     if ( $error ) {
 472       dbh->rollback if $oldAutoCommit;
 473       return "Error inserting cust_pkg_reason: $error";
 474     }
 475   }
 476
 477   my %svc;
 478   foreach my $cust_svc (
 479     #schwartz
 480     map  { $_->[0] }
 481     sort { $a->[1] <=> $b->[1] }
 482     map  { [ $_, $_->svc_x->table_info->{'cancel_weight'} ]; }
 483     qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 484   ) {
 485
 486     my $error = $cust_svc->cancel;
 487
 488     if ( $error ) {
 489       $dbh->rollback if $oldAutoCommit;
 490       return "Error cancelling cust_svc: $error";
 491     }
 492   }
 493
 494   # Add a credit for remaining service
 495   my $remaining_value = $self->calc_remain();
 496   if ( $remaining_value > 0 ) {
 497     my $conf = new FS::Conf;
 498     my $error = $self->cust_main->credit(
 499       $remaining_value,
 500       'Credit for unused time on '. $self->part_pkg->pkg,
 501       'reason_type' => $conf->config('cancel_credit_type'),
 502     );
 503     if ($error) {
 504       $dbh->rollback if $oldAutoCommit;
 505       return "Error crediting customer \$$remaining_value for unused time on".
 506              $self->part_pkg->pkg. ": $error";
 507     }
 508   }
 509
 510   unless ( $self->getfield('cancel') ) {
 511     my %hash = $self->hash;
 512     $hash{'cancel'} = time;
 513     my $new = new FS::cust_pkg ( \%hash );
 514     $error = $new->replace( $self, options => { $self->options } );
 515     if ( $error ) {
 516       $dbh->rollback if $oldAutoCommit;
 517       return $error;
 518     }
 519   }
 520
 521   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 522
 523   my $conf = new FS::Conf;
 524   my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
 525   if ( !$options{'quiet'} && $conf->exists('emailcancel') && @invoicing_list ) {
 526     my $conf = new FS::Conf;
 527     my $error = send_email(
 528       'from'    => $conf->config('invoice_from'),
 529       'to'      => \@invoicing_list,
 530       'subject' => ( $conf->config('cancelsubject') || 'Cancellation Notice' ),
 531       'body'    => [ map "$_\n", $conf->config('cancelmessage') ],
 532     );
 533     #should this do something on errors?
 534   }
 535
 536   ''; #no errors
 537
 538 }
 539
 540 =item suspend
 541
 542 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 543 package, then suspends the package itself (sets the susp field to now).
 544
 545 If there is an error, returns the error, otherwise returns false.
 546
 547 =cut
 548
 549 sub suspend {
 550   my( $self, %options ) = @_;
 551   my $error ;
 552
 553   local $SIG{HUP} = 'IGNORE';
 554   local $SIG{INT} = 'IGNORE';
 555   local $SIG{QUIT} = 'IGNORE';
 556   local $SIG{TERM} = 'IGNORE';
 557   local $SIG{TSTP} = 'IGNORE';
 558   local $SIG{PIPE} = 'IGNORE';
 559
 560   my $oldAutoCommit = $FS::UID::AutoCommit;
 561   local $FS::UID::AutoCommit = 0;
 562   my $dbh = dbh;
 563
 564   if ($options{'reason'}) {
 565     $error = $self->insert_reason( 'reason' => $options{'reason'} );
 566     if ( $error ) {
 567       dbh->rollback if $oldAutoCommit;
 568       return "Error inserting cust_pkg_reason: $error";
 569     }
 570   }
 571
 572   foreach my $cust_svc (
 573     qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 574   ) {
 575     my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 576
 577     $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 578       $dbh->rollback if $oldAutoCommit;
 579       return "Illegal svcdb value in part_svc!";
 580     };
 581     my $svcdb = $1;
 582     require "FS/$svcdb.pm";
 583
 584     my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
 585     if ($svc) {
 586       $error = $svc->suspend;
 587       if ( $error ) {
 588         $dbh->rollback if $oldAutoCommit;
 589         return $error;
 590       }
 591     }
 592
 593   }
 594
 595   unless ( $self->getfield('susp') ) {
 596     my %hash = $self->hash;
 597     $hash{'susp'} = time;
 598     my $new = new FS::cust_pkg ( \%hash );
 599     $error = $new->replace( $self, options => { $self->options } );
 600     if ( $error ) {
 601       $dbh->rollback if $oldAutoCommit;
 602       return $error;
 603     }
 604   }
 605
 606   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 607
 608   ''; #no errors
 609 }
 610
 611 =item unsuspend [ OPTION => VALUE ... ]
 612
 613 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 614 package, then unsuspends the package itself (clears the susp field and the
 615 adjourn field if it is in the past).
 616
 617 Available options are: I<adjust_next_bill>.
 618
 619 I<adjust_next_bill> can be set true to adjust the next bill date forward by
 620 the amount of time the account was inactive.  This was set true by default
 621 since 1.4.2 and 1.5.0pre6; however, starting with 1.7.0 this needs to be
 622 explicitly requested.  Price plans for which this makes sense (anniversary-date
 623 based than prorate or subscription) could have an option to enable this
 624 behaviour?
 625
 626 If there is an error, returns the error, otherwise returns false.
 627
 628 =cut
 629
 630 sub unsuspend {
 631   my( $self, %opt ) = @_;
 632   my $error;
 633
 634   local $SIG{HUP} = 'IGNORE';
 635   local $SIG{INT} = 'IGNORE';
 636   local $SIG{QUIT} = 'IGNORE';
 637   local $SIG{TERM} = 'IGNORE';
 638   local $SIG{TSTP} = 'IGNORE';
 639   local $SIG{PIPE} = 'IGNORE';
 640
 641   my $oldAutoCommit = $FS::UID::AutoCommit;
 642   local $FS::UID::AutoCommit = 0;
 643   my $dbh = dbh;
 644
 645   foreach my $cust_svc (
 646     qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
 647   ) {
 648     my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 649
 650     $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 651       $dbh->rollback if $oldAutoCommit;
 652       return "Illegal svcdb value in part_svc!";
 653     };
 654     my $svcdb = $1;
 655     require "FS/$svcdb.pm";
 656
 657     my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
 658     if ($svc) {
 659       $error = $svc->unsuspend;
 660       if ( $error ) {
 661         $dbh->rollback if $oldAutoCommit;
 662         return $error;
 663       }
 664     }
 665
 666   }
 667
 668   unless ( ! $self->getfield('susp') ) {
 669     my %hash = $self->hash;
 670     my $inactive = time - $hash{'susp'};
 671
 672     my $conf = new FS::Conf;
 673
 674     $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive
 675       if ( $opt{'adjust_next_bill'}
 676            || $conf->config('unsuspend-always_adjust_next_bill_date') )
 677       && $inactive > 0 && ( $hash{'bill'} || $hash{'setup'} );
 678
 679     $hash{'susp'} = '';
 680     $hash{'adjourn'} = '' if $hash{'adjourn'} < time;
 681     my $new = new FS::cust_pkg ( \%hash );
 682     $error = $new->replace( $self, options => { $self->options } );
 683     if ( $error ) {
 684       $dbh->rollback if $oldAutoCommit;
 685       return $error;
 686     }
 687   }
 688
 689   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 690
 691   ''; #no errors
 692 }
 693
 694 =item last_bill
 695
 696 Returns the last bill date, or if there is no last bill date, the setup date.
 697 Useful for billing metered services.
 698
 699 =cut
 700
 701 sub last_bill {
 702   my $self = shift;
 703   if ( $self->dbdef_table->column('last_bill') ) {
 704     return $self->setfield('last_bill', $_[0]) if @_;
 705     return $self->getfield('last_bill') if $self->getfield('last_bill');
 706   }
 707   my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
 708                                                   'edate'  => $self->bill,  } );
 709   $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
 710 }
 711
 712 =item last_reason
 713
 714 Returns the most recent FS::reason associated with the package.
 715
 716 =cut
 717
 718 sub last_reason {
 719   my $self = shift;
 720   my $cust_pkg_reason = qsearchs( {
 721                                     'table' => 'cust_pkg_reason',
 722                                     'hashref' => { 'pkgnum' => $self->pkgnum, },
 723                                     'extra_sql'=> 'ORDER BY date DESC LIMIT 1',
 724                                   } );
 725   qsearchs ( 'reason', { 'reasonnum' => $cust_pkg_reason->reasonnum } )
 726     if $cust_pkg_reason;
 727 }
 728
 729 =item part_pkg
 730
 731 Returns the definition for this billing item, as an FS::part_pkg object (see
 732 L<FS::part_pkg>).
 733
 734 =cut
 735
 736 sub part_pkg {
 737   my $self = shift;
 738   #exists( $self->{'_pkgpart'} )
 739   $self->{'_pkgpart'}
 740     ? $self->{'_pkgpart'}
 741     : qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
 742 }
 743
 744 =item old_cust_pkg
 745
 746 Returns the cancelled package this package was changed from, if any.
 747
 748 =cut
 749
 750 sub old_cust_pkg {
 751   my $self = shift;
 752   return '' unless $self->change_pkgnum;
 753   qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
 754 }
 755
 756 =item calc_setup
 757
 758 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
 759 item.
 760
 761 =cut
 762
 763 sub calc_setup {
 764   my $self = shift;
 765   $self->part_pkg->calc_setup($self, @_);
 766 }
 767
 768 =item calc_recur
 769
 770 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
 771 item.
 772
 773 =cut
 774
 775 sub calc_recur {
 776   my $self = shift;
 777   $self->part_pkg->calc_recur($self, @_);
 778 }
 779
 780 =item calc_remain
 781
 782 Calls the I<calc_remain> of the FS::part_pkg object associated with this
 783 billing item.
 784
 785 =cut
 786
 787 sub calc_remain {
 788   my $self = shift;
 789   $self->part_pkg->calc_remain($self, @_);
 790 }
 791
 792 =item calc_cancel
 793
 794 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
 795 billing item.
 796
 797 =cut
 798
 799 sub calc_cancel {
 800   my $self = shift;
 801   $self->part_pkg->calc_cancel($self, @_);
 802 }
 803
 804 =item cust_bill_pkg
 805
 806 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
 807
 808 =cut
 809
 810 sub cust_bill_pkg {
 811   my $self = shift;
 812   qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
 813 }
 814
 815 =item cust_svc [ SVCPART ]
 816
 817 Returns the services for this package, as FS::cust_svc objects (see
 818 L<FS::cust_svc>).  If a svcpart is specified, return only the matching
 819 services.
 820
 821 =cut
 822
 823 sub cust_svc {
 824   my $self = shift;
 825
 826   if ( @_ ) {
 827     return qsearch( 'cust_svc', { 'pkgnum'  => $self->pkgnum,
 828                                   'svcpart' => shift,          } );
 829   }
 830
 831   #if ( $self->{'_svcnum'} ) {
 832   #  values %{ $self->{'_svcnum'}->cache };
 833   #} else {
 834     $self->_sort_cust_svc(
 835       [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
 836     );
 837   #}
 838
 839 }
 840
 841 =item overlimit [ SVCPART ]
 842
 843 Returns the services for this package which have exceeded their
 844 usage limit as FS::cust_svc objects (see L<FS::cust_svc>).  If a svcpart
 845 is specified, return only the matching services.
 846
 847 =cut
 848
 849 sub overlimit {
 850   my $self = shift;
 851   grep { $_->overlimit } $self->cust_svc;
 852 }
 853
 854 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ]
 855
 856 Returns historical services for this package created before END TIMESTAMP and
 857 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
 858 (see L<FS::h_cust_svc>).
 859
 860 =cut
 861
 862 sub h_cust_svc {
 863   my $self = shift;
 864
 865   $self->_sort_cust_svc(
 866     [ qsearch( 'h_cust_svc',
 867                { 'pkgnum' => $self->pkgnum, },
 868                FS::h_cust_svc->sql_h_search(@_),
 869              )
 870     ]
 871   );
 872 }
 873
 874 sub _sort_cust_svc {
 875   my( $self, $arrayref ) = @_;
 876
 877   map  { $_->[0] }
 878   sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
 879   map {
 880         my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
 881                                              'svcpart' => $_->svcpart     } );
 882         [ $_,
 883           $pkg_svc ? $pkg_svc->primary_svc : '',
 884           $pkg_svc ? $pkg_svc->quantity : 0,
 885         ];
 886       }
 887   @$arrayref;
 888
 889 }
 890
 891 =item num_cust_svc [ SVCPART ]
 892
 893 Returns the number of provisioned services for this package.  If a svcpart is
 894 specified, counts only the matching services.
 895
 896 =cut
 897
 898 sub num_cust_svc {
 899   my $self = shift;
 900   my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
 901   $sql .= ' AND svcpart = ?' if @_;
 902   my $sth = dbh->prepare($sql) or die dbh->errstr;
 903   $sth->execute($self->pkgnum, @_) or die $sth->errstr;
 904   $sth->fetchrow_arrayref->[0];
 905 }
 906
 907 =item available_part_svc
 908
 909 Returns a list of FS::part_svc objects representing services included in this
 910 package but not yet provisioned.  Each FS::part_svc object also has an extra
 911 field, I<num_avail>, which specifies the number of available services.
 912
 913 =cut
 914
 915 sub available_part_svc {
 916   my $self = shift;
 917   grep { $_->num_avail > 0 }
 918     map {
 919           my $part_svc = $_->part_svc;
 920           $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
 921             $_->quantity - $self->num_cust_svc($_->svcpart);
 922           $part_svc;
 923         }
 924       $self->part_pkg->pkg_svc;
 925 }
 926
 927 =item part_svc
 928
 929 Returns a list of FS::part_svc objects representing provisioned and available
 930 services included in this package.  Each FS::part_svc object also has the
 931 following extra fields:
 932
 933 =over 4
 934
 935 =item num_cust_svc  (count)
 936
 937 =item num_avail     (quantity - count)
 938
 939 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
 940
 941 svcnum
 942 label -> ($cust_svc->label)[1]
 943
 944 =back
 945
 946 =cut
 947
 948 sub part_svc {
 949   my $self = shift;
 950
 951   #XXX some sort of sort order besides numeric by svcpart...
 952   my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
 953     my $pkg_svc = $_;
 954     my $part_svc = $pkg_svc->part_svc;
 955     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
 956     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
 957     $part_svc->{'Hash'}{'num_avail'}    =
 958       max( 0, $pkg_svc->quantity - $num_cust_svc );
 959     $part_svc->{'Hash'}{'cust_pkg_svc'} = [ $self->cust_svc($part_svc->svcpart) ];
 960     $part_svc;
 961   } $self->part_pkg->pkg_svc;
 962
 963   #extras
 964   push @part_svc, map {
 965     my $part_svc = $_;
 966     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
 967     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
 968     $part_svc->{'Hash'}{'num_avail'}    = 0; #0-$num_cust_svc ?
 969     $part_svc->{'Hash'}{'cust_pkg_svc'} = [ $self->cust_svc($part_svc->svcpart) ];
 970     $part_svc;
 971   } $self->extra_part_svc;
 972
 973   @part_svc;
 974
 975 }
 976
 977 =item extra_part_svc
 978
 979 Returns a list of FS::part_svc objects corresponding to services in this
 980 package which are still provisioned but not (any longer) available in the
 981 package definition.
 982
 983 =cut
 984
 985 sub extra_part_svc {
 986   my $self = shift;
 987
 988   my $pkgnum  = $self->pkgnum;
 989   my $pkgpart = $self->pkgpart;
 990
 991   qsearch( {
 992     'table'     => 'part_svc',
 993     'hashref'   => {},
 994     'extra_sql' => "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
 995                                   WHERE pkg_svc.svcpart = part_svc.svcpart
 996                                     AND pkg_svc.pkgpart = $pkgpart
 997                                     AND quantity > 0
 998                               )
 999                       AND 0 < ( SELECT count(*)
1000                                   FROM cust_svc
1001                                     LEFT JOIN cust_pkg using ( pkgnum )
1002                                   WHERE cust_svc.svcpart = part_svc.svcpart
1003                                     AND pkgnum = $pkgnum
1004                               )",
1005   } );
1006 }
1007
1008 =item status
1009
1010 Returns a short status string for this package, currently:
1011
1012 =over 4
1013
1014 =item not yet billed
1015
1016 =item one-time charge
1017
1018 =item active
1019
1020 =item suspended
1021
1022 =item cancelled
1023
1024 =back
1025
1026 =cut
1027
1028 sub status {
1029   my $self = shift;
1030
1031   my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
1032
1033   return 'cancelled' if $self->get('cancel');
1034   return 'suspended' if $self->susp;
1035   return 'not yet billed' unless $self->setup;
1036   return 'one-time charge' if $freq =~ /^(0|$)/;
1037   return 'active';
1038 }
1039
1040 =item statuses
1041
1042 Class method that returns the list of possible status strings for pacakges
1043 (see L<the status method|/status>).  For example:
1044
1045   @statuses = FS::cust_pkg->statuses();
1046
1047 =cut
1048
1049 tie my %statuscolor, 'Tie::IxHash',
1050   'not yet billed'  => '000000',
1051   'one-time charge' => '000000',
1052   'active'          => '00CC00',
1053   'suspended'       => 'FF9900',
1054   'cancelled'       => 'FF0000',
1055 ;
1056
1057 sub statuses {
1058   my $self = shift; #could be class...
1059   grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
1060                                       # mayble split btw one-time vs. recur
1061     keys %statuscolor;
1062 }
1063
1064 =item statuscolor
1065
1066 Returns a hex triplet color string for this package's status.
1067
1068 =cut
1069
1070 sub statuscolor {
1071   my $self = shift;
1072   $statuscolor{$self->status};
1073 }
1074
1075 =item labels
1076
1077 Returns a list of lists, calling the label method for all services
1078 (see L<FS::cust_svc>) of this billing item.
1079
1080 =cut
1081
1082 sub labels {
1083   my $self = shift;
1084   map { [ $_->label ] } $self->cust_svc;
1085 }
1086
1087 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
1088
1089 Like the labels method, but returns historical information on services that
1090 were active as of END_TIMESTAMP and (optionally) not cancelled before
1091 START_TIMESTAMP.
1092
1093 Returns a list of lists, calling the label method for all (historical) services
1094 (see L<FS::h_cust_svc>) of this billing item.
1095
1096 =cut
1097
1098 sub h_labels {
1099   my $self = shift;
1100   map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
1101 }
1102
1103 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
1104
1105 Like h_labels, except returns a simple flat list, and shortens long
1106 (currently >5) lists of identical services to one line that lists the service
1107 label and the number of individual services rather than individual items.
1108
1109 =cut
1110
1111 sub h_labels_short {
1112   my $self = shift;
1113
1114   my %labels;
1115   #tie %labels, 'Tie::IxHash';
1116   push @{ $labels{$_->[0]} }, $_->[1]
1117     foreach $self->h_labels(@_);
1118   my @labels;
1119   foreach my $label ( keys %labels ) {
1120     my @values = @{ $labels{$label} };
1121     my $num = scalar(@values);
1122     if ( $num > 5 ) {
1123       push @labels, "$label ($num)";
1124     } else {
1125       push @labels, map { "$label: $_" } @values;
1126     }
1127   }
1128
1129  @labels;
1130
1131 }
1132
1133 =item cust_main
1134
1135 Returns the parent customer object (see L<FS::cust_main>).
1136
1137 =cut
1138
1139 sub cust_main {
1140   my $self = shift;
1141   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
1142 }
1143
1144 =item seconds_since TIMESTAMP
1145
1146 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
1147 package have been online since TIMESTAMP, according to the session monitor.
1148
1149 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1150 L<Time::Local> and L<Date::Parse> for conversion functions.
1151
1152 =cut
1153
1154 sub seconds_since {
1155   my($self, $since) = @_;
1156   my $seconds = 0;
1157
1158   foreach my $cust_svc (
1159     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
1160   ) {
1161     $seconds += $cust_svc->seconds_since($since);
1162   }
1163
1164   $seconds;
1165
1166 }
1167
1168 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1169
1170 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
1171 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
1172 (exclusive).
1173
1174 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1175 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1176 functions.
1177
1178
1179 =cut
1180
1181 sub seconds_since_sqlradacct {
1182   my($self, $start, $end) = @_;
1183
1184   my $seconds = 0;
1185
1186   foreach my $cust_svc (
1187     grep {
1188       my $part_svc = $_->part_svc;
1189       $part_svc->svcdb eq 'svc_acct'
1190         && scalar($part_svc->part_export('sqlradius'));
1191     } $self->cust_svc
1192   ) {
1193     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
1194   }
1195
1196   $seconds;
1197
1198 }
1199
1200 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1201
1202 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1203 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1204 TIMESTAMP_END
1205 (exclusive).
1206
1207 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1208 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1209 functions.
1210
1211 =cut
1212
1213 sub attribute_since_sqlradacct {
1214   my($self, $start, $end, $attrib) = @_;
1215
1216   my $sum = 0;
1217
1218   foreach my $cust_svc (
1219     grep {
1220       my $part_svc = $_->part_svc;
1221       $part_svc->svcdb eq 'svc_acct'
1222         && scalar($part_svc->part_export('sqlradius'));
1223     } $self->cust_svc
1224   ) {
1225     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
1226   }
1227
1228   $sum;
1229
1230 }
1231
1232 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
1233
1234 Transfers as many services as possible from this package to another package.
1235
1236 The destination package can be specified by pkgnum by passing an FS::cust_pkg
1237 object.  The destination package must already exist.
1238
1239 Services are moved only if the destination allows services with the correct
1240 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
1241 this option with caution!  No provision is made for export differences
1242 between the old and new service definitions.  Probably only should be used
1243 when your exports for all service definitions of a given svcdb are identical.
1244 (attempt a transfer without it first, to move all possible svcpart-matching
1245 services)
1246
1247 Any services that can't be moved remain in the original package.
1248
1249 Returns an error, if there is one; otherwise, returns the number of services
1250 that couldn't be moved.
1251
1252 =cut
1253
1254 sub transfer {
1255   my ($self, $dest_pkgnum, %opt) = @_;
1256
1257   my $remaining = 0;
1258   my $dest;
1259   my %target;
1260
1261   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
1262     $dest = $dest_pkgnum;
1263     $dest_pkgnum = $dest->pkgnum;
1264   } else {
1265     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
1266   }
1267
1268   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
1269
1270   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
1271     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
1272   }
1273
1274   foreach my $cust_svc ($dest->cust_svc) {
1275     $target{$cust_svc->svcpart}--;
1276   }
1277
1278   my %svcpart2svcparts = ();
1279   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1280     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
1281     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
1282       next if exists $svcpart2svcparts{$svcpart};
1283       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
1284       $svcpart2svcparts{$svcpart} = [
1285         map  { $_->[0] }
1286         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
1287         map {
1288               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
1289                                                    'svcpart' => $_          } );
1290               [ $_,
1291                 $pkg_svc ? $pkg_svc->primary_svc : '',
1292                 $pkg_svc ? $pkg_svc->quantity : 0,
1293               ];
1294             }
1295
1296         grep { $_ != $svcpart }
1297         map  { $_->svcpart }
1298         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
1299       ];
1300       warn "alternates for svcpart $svcpart: ".
1301            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
1302         if $DEBUG;
1303     }
1304   }
1305
1306   foreach my $cust_svc ($self->cust_svc) {
1307     if($target{$cust_svc->svcpart} > 0) {
1308       $target{$cust_svc->svcpart}--;
1309       my $new = new FS::cust_svc { $cust_svc->hash };
1310       $new->pkgnum($dest_pkgnum);
1311       my $error = $new->replace($cust_svc);
1312       return $error if $error;
1313     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1314       if ( $DEBUG ) {
1315         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
1316         warn "alternates to consider: ".
1317              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
1318       }
1319       my @alternate = grep {
1320                              warn "considering alternate svcpart $_: ".
1321                                   "$target{$_} available in new package\n"
1322                                if $DEBUG;
1323                              $target{$_} > 0;
1324                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
1325       if ( @alternate ) {
1326         warn "alternate(s) found\n" if $DEBUG;
1327         my $change_svcpart = $alternate[0];
1328         $target{$change_svcpart}--;
1329         my $new = new FS::cust_svc { $cust_svc->hash };
1330         $new->svcpart($change_svcpart);
1331         $new->pkgnum($dest_pkgnum);
1332         my $error = $new->replace($cust_svc);
1333         return $error if $error;
1334       } else {
1335         $remaining++;
1336       }
1337     } else {
1338       $remaining++
1339     }
1340   }
1341   return $remaining;
1342 }
1343
1344 =item reexport
1345
1346 This method is deprecated.  See the I<depend_jobnum> option to the insert and
1347 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
1348
1349 =cut
1350
1351 sub reexport {
1352   my $self = shift;
1353
1354   local $SIG{HUP} = 'IGNORE';
1355   local $SIG{INT} = 'IGNORE';
1356   local $SIG{QUIT} = 'IGNORE';
1357   local $SIG{TERM} = 'IGNORE';
1358   local $SIG{TSTP} = 'IGNORE';
1359   local $SIG{PIPE} = 'IGNORE';
1360
1361   my $oldAutoCommit = $FS::UID::AutoCommit;
1362   local $FS::UID::AutoCommit = 0;
1363   my $dbh = dbh;
1364
1365   foreach my $cust_svc ( $self->cust_svc ) {
1366     #false laziness w/svc_Common::insert
1367     my $svc_x = $cust_svc->svc_x;
1368     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
1369       my $error = $part_export->export_insert($svc_x);
1370       if ( $error ) {
1371         $dbh->rollback if $oldAutoCommit;
1372         return $error;
1373       }
1374     }
1375   }
1376
1377   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1378   '';
1379
1380 }
1381
1382 =back
1383
1384 =head1 CLASS METHODS
1385
1386 =over 4
1387
1388 =item recurring_sql
1389
1390 Returns an SQL expression identifying recurring packages.
1391
1392 =cut
1393
1394 sub recurring_sql { "
1395   '0' != ( select freq from part_pkg
1396              where cust_pkg.pkgpart = part_pkg.pkgpart )
1397 "; }
1398
1399 =item onetime_sql
1400
1401 Returns an SQL expression identifying one-time packages.
1402
1403 =cut
1404
1405 sub onetime_sql { "
1406   '0' = ( select freq from part_pkg
1407             where cust_pkg.pkgpart = part_pkg.pkgpart )
1408 "; }
1409
1410 =item active_sql
1411
1412 Returns an SQL expression identifying active packages.
1413
1414 =cut
1415
1416 sub active_sql { "
1417   ". $_[0]->recurring_sql(). "
1418   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1419   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
1420 "; }
1421
1422 =item inactive_sql
1423
1424 Returns an SQL expression identifying inactive packages (one-time packages
1425 that are otherwise unsuspended/uncancelled).
1426
1427 =cut
1428
1429 sub inactive_sql { "
1430   ". $_[0]->onetime_sql(). "
1431   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1432   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
1433 "; }
1434
1435 =item susp_sql
1436 =item suspended_sql
1437
1438 Returns an SQL expression identifying suspended packages.
1439
1440 =cut
1441
1442 sub suspended_sql { susp_sql(@_); }
1443 sub susp_sql {
1444   #$_[0]->recurring_sql(). ' AND '.
1445   "
1446         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
1447     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
1448   ";
1449 }
1450
1451 =item cancel_sql
1452 =item cancelled_sql
1453
1454 Returns an SQL exprression identifying cancelled packages.
1455
1456 =cut
1457
1458 sub cancelled_sql { cancel_sql(@_); }
1459 sub cancel_sql {
1460   #$_[0]->recurring_sql(). ' AND '.
1461   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
1462 }
1463
1464 =item search_sql HREF
1465
1466 Returns a qsearch hash expression to search for parameters specified in HREF.
1467 Valid parameters are
1468
1469 =over 4
1470 =item agentnum
1471 =item magic - /^(active|inactive|suspended|cancell?ed)$/
1472 =item status - /^(active|inactive|suspended|one-time charge|inactive|cancell?ed)$/
1473 =item classnum
1474 =item pkgpart - list specified how?
1475 =item setup     - arrayref of beginning and ending epoch date
1476 =item last_bill - arrayref of beginning and ending epoch date
1477 =item bill      - arrayref of beginning and ending epoch date
1478 =item adjourn   - arrayref of beginning and ending epoch date
1479 =item susp      - arrayref of beginning and ending epoch date
1480 =item expire    - arrayref of beginning and ending epoch date
1481 =item cancel    - arrayref of beginning and ending epoch date
1482 =item query - /^(pkgnum/APKG_pkgnum)$/
1483 =item cust_fields - a value suited to passing to FS::UI::Web::cust_header
1484 =item CurrentUser - specifies the user for agent virtualization
1485 =back
1486
1487 =cut
1488
1489 sub search_sql {
1490   my ($class, $params) = @_;
1491   my @where = ();
1492
1493   ##
1494   # parse agent
1495   ##
1496
1497   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
1498     push @where,
1499       "agentnum = $1";
1500   }
1501
1502   ##
1503   # parse status
1504   ##
1505
1506   if (    $params->{'magic'}  eq 'active'
1507        || $params->{'status'} eq 'active' ) {
1508
1509     push @where, FS::cust_pkg->active_sql();
1510
1511   } elsif (    $params->{'magic'}  eq 'inactive'
1512             || $params->{'status'} eq 'inactive' ) {
1513
1514     push @where, FS::cust_pkg->inactive_sql();
1515
1516   } elsif (    $params->{'magic'}  eq 'suspended'
1517             || $params->{'status'} eq 'suspended'  ) {
1518
1519     push @where, FS::cust_pkg->suspended_sql();
1520
1521   } elsif (    $params->{'magic'}  =~ /^cancell?ed$/
1522             || $params->{'status'} =~ /^cancell?ed$/ ) {
1523
1524     push @where, FS::cust_pkg->cancelled_sql();
1525
1526   } elsif ( $params->{'status'} =~ /^(one-time charge|inactive)$/ ) {
1527
1528     push @where, FS::cust_pkg->inactive_sql();
1529
1530   }
1531
1532   ###
1533   # parse package class
1534   ###
1535
1536   #false lazinessish w/graph/cust_bill_pkg.cgi
1537   my $classnum = 0;
1538   my @pkg_class = ();
1539   if ( exists($params->{'classnum'})
1540        && $params->{'classnum'} =~ /^(\d*)$/
1541      )
1542   {
1543     $classnum = $1;
1544     if ( $classnum ) { #a specific class
1545       push @where, "classnum = $classnum";
1546
1547       #@pkg_class = ( qsearchs('pkg_class', { 'classnum' => $classnum } ) );
1548       #die "classnum $classnum not found!" unless $pkg_class[0];
1549       #$title .= $pkg_class[0]->classname.' ';
1550
1551     } elsif ( $classnum eq '' ) { #the empty class
1552
1553       push @where, "classnum IS NULL";
1554       #$title .= 'Empty class ';
1555       #@pkg_class = ( '(empty class)' );
1556     } elsif ( $classnum eq '0' ) {
1557       #@pkg_class = qsearch('pkg_class', {} ); # { 'disabled' => '' } );
1558       #push @pkg_class, '(empty class)';
1559     } else {
1560       die "illegal classnum";
1561     }
1562   }
1563   #eslaf
1564
1565   ###
1566   # parse part_pkg
1567   ###
1568
1569   my $pkgpart = join (' OR pkgpart=',
1570                       grep {$_} map { /^(\d+)$/; } ($params->{'pkgpart'}));
1571   push @where,  '(pkgpart=' . $pkgpart . ')' if $pkgpart;
1572
1573   ###
1574   # parse dates
1575   ###
1576
1577   my $orderby = '';
1578
1579   #false laziness w/report_cust_pkg.html
1580   my %disable = (
1581     'all'             => {},
1582     'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
1583     'active'          => { 'susp'=>1, 'cancel'=>1 },
1584     'suspended'       => { 'cancel' => 1 },
1585     'cancelled'       => {},
1586     ''                => {},
1587   );
1588
1589   foreach my $field (qw( setup last_bill bill adjourn susp expire cancel )) {
1590
1591     next unless exists($params->{$field});
1592
1593     my($beginning, $ending) = @{$params->{$field}};
1594
1595     next if $beginning == 0 && $ending == 4294967295;
1596
1597     push @where,
1598       "cust_pkg.$field IS NOT NULL",
1599       "cust_pkg.$field >= $beginning",
1600       "cust_pkg.$field <= $ending";
1601
1602     $orderby ||= "ORDER BY cust_pkg.$field";
1603
1604   }
1605
1606   $orderby ||= 'ORDER BY bill';
1607
1608   ###
1609   # parse magic, legacy, etc.
1610   ###
1611
1612   if ( $params->{'magic'} &&
1613        $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
1614   ) {
1615
1616     $orderby = 'ORDER BY pkgnum';
1617
1618     if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
1619       push @where, "pkgpart = $1";
1620     }
1621
1622   } elsif ( $params->{'query'} eq 'pkgnum' ) {
1623
1624     $orderby = 'ORDER BY pkgnum';
1625
1626   } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
1627
1628     $orderby = 'ORDER BY pkgnum';
1629
1630     push @where, '0 < (
1631       SELECT count(*) FROM pkg_svc
1632        WHERE pkg_svc.pkgpart =  cust_pkg.pkgpart
1633          AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
1634                                    WHERE cust_svc.pkgnum  = cust_pkg.pkgnum
1635                                      AND cust_svc.svcpart = pkg_svc.svcpart
1636                                 )
1637     )';
1638
1639   }
1640
1641   ##
1642   # setup queries, links, subs, etc. for the search
1643   ##
1644
1645   # here is the agent virtualization
1646   if ($params->{CurrentUser}) {
1647     my $access_user =
1648       qsearchs('access_user', { username => $params->{CurrentUser} });
1649
1650     if ($access_user) {
1651       push @where, $access_user->agentnums_sql;
1652     }else{
1653       push @where, "1=0";
1654     }
1655   }else{
1656     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql;
1657   }
1658
1659   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
1660
1661   my $addl_from = 'LEFT JOIN cust_main USING ( custnum  ) '.
1662                   'LEFT JOIN part_pkg  USING ( pkgpart  ) '.
1663                   'LEFT JOIN pkg_class USING ( classnum ) ';
1664
1665   my $count_query = "SELECT COUNT(*) FROM cust_pkg $addl_from $extra_sql";
1666
1667   my $sql_query = {
1668     'table'       => 'cust_pkg',
1669     'hashref'     => {},
1670     'select'      => join(', ',
1671                                 'cust_pkg.*',
1672                                 ( map "part_pkg.$_", qw( pkg freq ) ),
1673                                 'pkg_class.classname',
1674                                 'cust_main.custnum as cust_main_custnum',
1675                                 FS::UI::Web::cust_sql_fields(
1676                                   $params->{'cust_fields'}
1677                                 ),
1678                      ),
1679     'extra_sql'   => "$extra_sql $orderby",
1680     'addl_from'   => $addl_from,
1681     'count_query' => $count_query,
1682   };
1683
1684 }
1685
1686 =head1 SUBROUTINES
1687
1688 =over 4
1689
1690 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ] ]
1691
1692 CUSTNUM is a customer (see L<FS::cust_main>)
1693
1694 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
1695 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
1696 permitted.
1697
1698 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
1699 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
1700 new billing items.  An error is returned if this is not possible (see
1701 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
1702 parameter.
1703
1704 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
1705 newly-created cust_pkg objects.
1706
1707 =cut
1708
1709 sub order {
1710   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
1711
1712   my $conf = new FS::Conf;
1713
1714   # Transactionize this whole mess
1715   local $SIG{HUP} = 'IGNORE';
1716   local $SIG{INT} = 'IGNORE';
1717   local $SIG{QUIT} = 'IGNORE';
1718   local $SIG{TERM} = 'IGNORE';
1719   local $SIG{TSTP} = 'IGNORE';
1720   local $SIG{PIPE} = 'IGNORE';
1721
1722   my $oldAutoCommit = $FS::UID::AutoCommit;
1723   local $FS::UID::AutoCommit = 0;
1724   my $dbh = dbh;
1725
1726   my $error;
1727   my $cust_main = qsearchs('cust_main', { custnum => $custnum });
1728   return "Customer not found: $custnum" unless $cust_main;
1729
1730   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
1731                          @$remove_pkgnum;
1732
1733   my $change = scalar(@old_cust_pkg) != 0;
1734
1735   my %hash = ();
1736   if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
1737
1738     my $time = time;
1739
1740     #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( last_bill bill );
1741
1742     #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( setup );
1743     $hash{'setup'} = $time if $old_cust_pkg[0]->setup;
1744
1745     $hash{'change_date'} = $time;
1746     $hash{"change_$_"}  = $old_cust_pkg[0]->$_() foreach qw( pkgnum pkgpart );
1747   }
1748
1749   # Create the new packages.
1750   foreach my $pkgpart (@$pkgparts) {
1751     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
1752                                       pkgpart => $pkgpart,
1753                                       %hash,
1754                                     };
1755     $error = $cust_pkg->insert( 'change' => $change );
1756     if ($error) {
1757       $dbh->rollback if $oldAutoCommit;
1758       return $error;
1759     }
1760     push @$return_cust_pkg, $cust_pkg;
1761   }
1762   # $return_cust_pkg now contains refs to all of the newly
1763   # created packages.
1764
1765   # Transfer services and cancel old packages.
1766   foreach my $old_pkg (@old_cust_pkg) {
1767
1768     foreach my $new_pkg (@$return_cust_pkg) {
1769       $error = $old_pkg->transfer($new_pkg);
1770       if ($error and $error == 0) {
1771         # $old_pkg->transfer failed.
1772         $dbh->rollback if $oldAutoCommit;
1773         return $error;
1774       }
1775     }
1776
1777     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1778       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1779       foreach my $new_pkg (@$return_cust_pkg) {
1780         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
1781         if ($error and $error == 0) {
1782           # $old_pkg->transfer failed.
1783         $dbh->rollback if $oldAutoCommit;
1784         return $error;
1785         }
1786       }
1787     }
1788
1789     if ($error > 0) {
1790       # Transfers were successful, but we went through all of the
1791       # new packages and still had services left on the old package.
1792       # We can't cancel the package under the circumstances, so abort.
1793       $dbh->rollback if $oldAutoCommit;
1794       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
1795     }
1796     $error = $old_pkg->cancel( quiet=>1 );
1797     if ($error) {
1798       $dbh->rollback;
1799       return $error;
1800     }
1801   }
1802   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1803   '';
1804 }
1805
1806 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
1807
1808 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
1809 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
1810 permitted.
1811
1812 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
1813 replace.  The services (see L<FS::cust_svc>) are moved to the
1814 new billing items.  An error is returned if this is not possible (see
1815 L<FS::pkg_svc>).
1816
1817 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
1818 newly-created cust_pkg objects.
1819
1820 =cut
1821
1822 sub bulk_change {
1823   my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
1824
1825   # Transactionize this whole mess
1826   local $SIG{HUP} = 'IGNORE';
1827   local $SIG{INT} = 'IGNORE';
1828   local $SIG{QUIT} = 'IGNORE';
1829   local $SIG{TERM} = 'IGNORE';
1830   local $SIG{TSTP} = 'IGNORE';
1831   local $SIG{PIPE} = 'IGNORE';
1832
1833   my $oldAutoCommit = $FS::UID::AutoCommit;
1834   local $FS::UID::AutoCommit = 0;
1835   my $dbh = dbh;
1836
1837   my @errors;
1838   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
1839                          @$remove_pkgnum;
1840
1841   while(scalar(@old_cust_pkg)) {
1842     my @return = ();
1843     my $custnum = $old_cust_pkg[0]->custnum;
1844     my (@remove) = map { $_->pkgnum }
1845                    grep { $_->custnum == $custnum } @old_cust_pkg;
1846     @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
1847
1848     my $error = order $custnum, $pkgparts, \@remove, \@return;
1849
1850     push @errors, $error
1851       if $error;
1852     push @$return_cust_pkg, @return;
1853   }
1854
1855   if (scalar(@errors)) {
1856     $dbh->rollback if $oldAutoCommit;
1857     return join(' / ', @errors);
1858   }
1859
1860   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1861   '';
1862 }
1863
1864 sub insert_reason {
1865   my ($self, %options) = @_;
1866
1867   my $otaker = $FS::CurrentUser::CurrentUser->username;
1868
1869   my $cust_pkg_reason =
1870     new FS::cust_pkg_reason({ 'pkgnum'    => $self->pkgnum,
1871                               'reasonnum' => $options{'reason'},
1872                               'otaker'    => $otaker,
1873                               'date'      => $options{'date'}
1874                                                ? $options{'date'}
1875                                                : time,
1876                             });
1877   return $cust_pkg_reason->insert;
1878 }
1879
1880 =item set_usage USAGE_VALUE_HASHREF
1881
1882 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
1883 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
1884 upbytes, downbytes, and totalbytes are appropriate keys.
1885
1886 All svc_accts which are part of this package have their values reset.
1887
1888 =cut
1889
1890 sub set_usage {
1891   my ($self, $valueref) = @_;
1892
1893   foreach my $cust_svc ($self->cust_svc){
1894     my $svc_x = $cust_svc->svc_x;
1895     $svc_x->set_usage($valueref)
1896       if $svc_x->can("set_usage");
1897   }
1898 }
1899
1900 =back
1901
1902 =head1 BUGS
1903
1904 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
1905
1906 In sub order, the @pkgparts array (passed by reference) is clobbered.
1907
1908 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
1909 method to pass dates to the recur_prog expression, it should do so.
1910
1911 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
1912 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
1913 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
1914 configuration values.  Probably need a subroutine which decides what to do
1915 based on whether or not we've fetched the user yet, rather than a hash.  See
1916 FS::UID and the TODO.
1917
1918 Now that things are transactional should the check in the insert method be
1919 moved to check ?
1920
1921 =head1 SEE ALSO
1922
1923 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
1924 L<FS::pkg_svc>, schema.html from the base documentation
1925
1926 =cut
1927
1928 1;
1929