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->credit( $amount,
 218                                         'Referral credit for '. $cust_main->name
 219                                       );
 220         if ( $error ) {
 221           $dbh->rollback if $oldAutoCommit;
 222           return "Error crediting customer ". $cust_main->referral_custnum.
 223                " for referral: $error";
 224         }
 225
 226       }
 227
 228     }
 229   }
 230
 231   if ($conf->config('welcome_letter') && $self->cust_main->num_pkgs == 1) {
 232     my $queue = new FS::queue {
 233       'job'     => 'FS::cust_main::queueable_print',
 234     };
 235     $error = $queue->insert(
 236       'custnum'  => $self->custnum,
 237       'template' => 'welcome_letter',
 238     );
 239
 240     if ($error) {
 241       warn "can't send welcome letter: $error";
 242     }
 243
 244   }
 245
 246   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 247   '';
 248
 249 }
 250
 251 =item delete
 252
 253 This method now works but you probably shouldn't use it.
 254
 255 You don't want to delete billing items, because there would then be no record
 256 the customer ever purchased the item.  Instead, see the cancel method.
 257
 258 =cut
 259
 260 #sub delete {
 261 #  return "Can't delete cust_pkg records!";
 262 #}
 263
 264 =item replace OLD_RECORD
 265
 266 Replaces the OLD_RECORD with this one in the database.  If there is an error,
 267 returns the error, otherwise returns false.
 268
 269 Currently, custnum, setup, bill, adjourn, susp, expire, and cancel may be changed.
 270
 271 Changing pkgpart may have disasterous effects.  See the order subroutine.
 272
 273 setup and bill are normally updated by calling the bill method of a customer
 274 object (see L<FS::cust_main>).
 275
 276 suspend is normally updated by the suspend and unsuspend methods.
 277
 278 cancel is normally updated by the cancel method (and also the order subroutine
 279 in some cases).
 280
 281 Calls
 282
 283 =cut
 284
 285 sub replace {
 286   my( $new, $old, %options ) = @_;
 287
 288   # We absolutely have to have an old vs. new record to make this work.
 289   if (!defined($old)) {
 290     $old = qsearchs( 'cust_pkg', { 'pkgnum' => $new->pkgnum } );
 291   }
 292   #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
 293   return "Can't change otaker!" if $old->otaker ne $new->otaker;
 294
 295   #allow this *sigh*
 296   #return "Can't change setup once it exists!"
 297   #  if $old->getfield('setup') &&
 298   #     $old->getfield('setup') != $new->getfield('setup');
 299
 300   #some logic for bill, susp, cancel?
 301
 302   local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
 303
 304   local $SIG{HUP} = 'IGNORE';
 305   local $SIG{INT} = 'IGNORE';
 306   local $SIG{QUIT} = 'IGNORE';
 307   local $SIG{TERM} = 'IGNORE';
 308   local $SIG{TSTP} = 'IGNORE';
 309   local $SIG{PIPE} = 'IGNORE';
 310
 311   my $oldAutoCommit = $FS::UID::AutoCommit;
 312   local $FS::UID::AutoCommit = 0;
 313   my $dbh = dbh;
 314
 315   foreach my $method ( qw(adjourn expire) ) {  # How many reasons?
 316     if ($options{'reason'} && $new->$method && $old->$method ne $new->$method) {
 317       my $error = $new->insert_reason( 'reason' => $options{'reason'},
 318                                        'date'      => $new->$method,
 319                                      );
 320       if ( $error ) {
 321         dbh->rollback if $oldAutoCommit;
 322         return "Error inserting cust_pkg_reason: $error";
 323       }
 324     }
 325   }
 326
 327   #save off and freeze RADIUS attributes for any associated svc_acct records
 328   my @svc_acct = ();
 329   if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
 330
 331                 #also check for specific exports?
 332                 # to avoid spurious modify export events
 333     @svc_acct = map  { $_->svc_x }
 334                 grep { $_->part_svc->svcdb eq 'svc_acct' }
 335                      $old->cust_svc;
 336
 337     $_->snapshot foreach @svc_acct;
 338
 339   }
 340
 341   my $error = $new->SUPER::replace($old,
 342                                    $options{options} ? ${options{options}} : ()
 343                                   );
 344   if ( $error ) {
 345     $dbh->rollback if $oldAutoCommit;
 346     return $error;
 347   }
 348
 349   #for prepaid packages,
 350   #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
 351   foreach my $old_svc_acct ( @svc_acct ) {
 352     my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
 353     my $s_error = $new_svc_acct->replace($old_svc_acct);
 354     if ( $s_error ) {
 355       $dbh->rollback if $oldAutoCommit;
 356       return $s_error;
 357     }
 358   }
 359
 360   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 361   '';
 362
 363 }
 364
 365 =item check
 366
 367 Checks all fields to make sure this is a valid billing item.  If there is an
 368 error, returns the error, otherwise returns false.  Called by the insert and
 369 replace methods.
 370
 371 =cut
 372
 373 sub check {
 374   my $self = shift;
 375
 376   my $error =
 377     $self->ut_numbern('pkgnum')
 378     || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
 379     || $self->ut_numbern('pkgpart')
 380     || $self->ut_numbern('setup')
 381     || $self->ut_numbern('bill')
 382     || $self->ut_numbern('susp')
 383     || $self->ut_numbern('cancel')
 384     || $self->ut_numbern('adjourn')
 385     || $self->ut_numbern('expire')
 386   ;
 387   return $error if $error;
 388
 389   if ( $self->reg_code ) {
 390
 391     unless ( grep { $self->pkgpart == $_->pkgpart }
 392              map  { $_->reg_code_pkg }
 393              qsearchs( 'reg_code', { 'code'     => $self->reg_code,
 394                                      'agentnum' => $self->cust_main->agentnum })
 395            ) {
 396       return "Unknown registration code";
 397     }
 398
 399   } elsif ( $self->promo_code ) {
 400
 401     my $promo_part_pkg =
 402       qsearchs('part_pkg', {
 403         'pkgpart'    => $self->pkgpart,
 404         'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
 405       } );
 406     return 'Unknown promotional code' unless $promo_part_pkg;
 407
 408   } else {
 409
 410     unless ( $disable_agentcheck ) {
 411       my $agent =
 412         qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
 413       my $pkgpart_href = $agent->pkgpart_hashref;
 414       return "agent ". $agent->agentnum.
 415              " can't purchase pkgpart ". $self->pkgpart
 416         unless $pkgpart_href->{ $self->pkgpart };
 417     }
 418
 419     $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
 420     return $error if $error;
 421
 422   }
 423
 424   $self->otaker(getotaker) unless $self->otaker;
 425   $self->otaker =~ /^(\w{1,32})$/ or return "Illegal otaker";
 426   $self->otaker($1);
 427
 428   if ( $self->dbdef_table->column('manual_flag') ) {
 429     $self->manual_flag('') if $self->manual_flag eq ' ';
 430     $self->manual_flag =~ /^([01]?)$/
 431       or return "Illegal manual_flag ". $self->manual_flag;
 432     $self->manual_flag($1);
 433   }
 434
 435   $self->SUPER::check;
 436 }
 437
 438 =item cancel [ OPTION => VALUE ... ]
 439
 440 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
 441 in this package, then cancels the package itself (sets the cancel field to
 442 now).
 443
 444 Available options are: I<quiet>
 445
 446 I<quiet> can be set true to supress email cancellation notices.
 447
 448 If there is an error, returns the error, otherwise returns false.
 449
 450 =cut
 451
 452 sub cancel {
 453   my( $self, %options ) = @_;
 454   my $error;
 455
 456   local $SIG{HUP} = 'IGNORE';
 457   local $SIG{INT} = 'IGNORE';
 458   local $SIG{QUIT} = 'IGNORE';
 459   local $SIG{TERM} = 'IGNORE';
 460   local $SIG{TSTP} = 'IGNORE';
 461   local $SIG{PIPE} = 'IGNORE';
 462
 463   my $oldAutoCommit = $FS::UID::AutoCommit;
 464   local $FS::UID::AutoCommit = 0;
 465   my $dbh = dbh;
 466
 467   if ($options{'reason'}) {
 468     $error = $self->insert_reason( 'reason' => $options{'reason'} );
 469     if ( $error ) {
 470       dbh->rollback if $oldAutoCommit;
 471       return "Error inserting cust_pkg_reason: $error";
 472     }
 473   }
 474
 475   my %svc;
 476   foreach my $cust_svc (
 477     #schwartz
 478     map  { $_->[0] }
 479     sort { $a->[1] <=> $b->[1] }
 480     map  { [ $_, $_->svc_x->table_info->{'cancel_weight'} ]; }
 481     qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 482   ) {
 483
 484     my $error = $cust_svc->cancel;
 485
 486     if ( $error ) {
 487       $dbh->rollback if $oldAutoCommit;
 488       return "Error cancelling cust_svc: $error";
 489     }
 490   }
 491
 492   # Add a credit for remaining service
 493   my $remaining_value = $self->calc_remain();
 494   if ( $remaining_value > 0 ) {
 495     my $error = $self->cust_main->credit(
 496       $remaining_value,
 497       'Credit for unused time on '. $self->part_pkg->pkg,
 498     );
 499     if ($error) {
 500       $dbh->rollback if $oldAutoCommit;
 501       return "Error crediting customer \$$remaining_value for unused time on".
 502              $self->part_pkg->pkg. ": $error";
 503     }
 504   }
 505
 506   unless ( $self->getfield('cancel') ) {
 507     my %hash = $self->hash;
 508     $hash{'cancel'} = time;
 509     my $new = new FS::cust_pkg ( \%hash );
 510     $error = $new->replace( $self, options => { $self->options } );
 511     if ( $error ) {
 512       $dbh->rollback if $oldAutoCommit;
 513       return $error;
 514     }
 515   }
 516
 517   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 518
 519   my $conf = new FS::Conf;
 520   my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
 521   if ( !$options{'quiet'} && $conf->exists('emailcancel') && @invoicing_list ) {
 522     my $conf = new FS::Conf;
 523     my $error = send_email(
 524       'from'    => $conf->config('invoice_from'),
 525       'to'      => \@invoicing_list,
 526       'subject' => $conf->config('cancelsubject'),
 527       'body'    => [ map "$_\n", $conf->config('cancelmessage') ],
 528     );
 529     #should this do something on errors?
 530   }
 531
 532   ''; #no errors
 533
 534 }
 535
 536 =item suspend
 537
 538 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 539 package, then suspends the package itself (sets the susp field to now).
 540
 541 If there is an error, returns the error, otherwise returns false.
 542
 543 =cut
 544
 545 sub suspend {
 546   my( $self, %options ) = @_;
 547   my $error ;
 548
 549   local $SIG{HUP} = 'IGNORE';
 550   local $SIG{INT} = 'IGNORE';
 551   local $SIG{QUIT} = 'IGNORE';
 552   local $SIG{TERM} = 'IGNORE';
 553   local $SIG{TSTP} = 'IGNORE';
 554   local $SIG{PIPE} = 'IGNORE';
 555
 556   my $oldAutoCommit = $FS::UID::AutoCommit;
 557   local $FS::UID::AutoCommit = 0;
 558   my $dbh = dbh;
 559
 560   if ($options{'reason'}) {
 561     $error = $self->insert_reason( 'reason' => $options{'reason'} );
 562     if ( $error ) {
 563       dbh->rollback if $oldAutoCommit;
 564       return "Error inserting cust_pkg_reason: $error";
 565     }
 566   }
 567
 568   foreach my $cust_svc (
 569     qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 570   ) {
 571     my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 572
 573     $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 574       $dbh->rollback if $oldAutoCommit;
 575       return "Illegal svcdb value in part_svc!";
 576     };
 577     my $svcdb = $1;
 578     require "FS/$svcdb.pm";
 579
 580     my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
 581     if ($svc) {
 582       $error = $svc->suspend;
 583       if ( $error ) {
 584         $dbh->rollback if $oldAutoCommit;
 585         return $error;
 586       }
 587     }
 588
 589   }
 590
 591   unless ( $self->getfield('susp') ) {
 592     my %hash = $self->hash;
 593     $hash{'susp'} = time;
 594     my $new = new FS::cust_pkg ( \%hash );
 595     $error = $new->replace( $self, options => { $self->options } );
 596     if ( $error ) {
 597       $dbh->rollback if $oldAutoCommit;
 598       return $error;
 599     }
 600   }
 601
 602   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 603
 604   ''; #no errors
 605 }
 606
 607 =item unsuspend [ OPTION => VALUE ... ]
 608
 609 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 610 package, then unsuspends the package itself (clears the susp field and the
 611 adjourn field if it is in the past).
 612
 613 Available options are: I<adjust_next_bill>.
 614
 615 I<adjust_next_bill> can be set true to adjust the next bill date forward by
 616 the amount of time the account was inactive.  This was set true by default
 617 since 1.4.2 and 1.5.0pre6; however, starting with 1.7.0 this needs to be
 618 explicitly requested.  Price plans for which this makes sense (anniversary-date
 619 based than prorate or subscription) could have an option to enable this
 620 behaviour?
 621
 622 If there is an error, returns the error, otherwise returns false.
 623
 624 =cut
 625
 626 sub unsuspend {
 627   my( $self, %opt ) = @_;
 628   my $error;
 629
 630   local $SIG{HUP} = 'IGNORE';
 631   local $SIG{INT} = 'IGNORE';
 632   local $SIG{QUIT} = 'IGNORE';
 633   local $SIG{TERM} = 'IGNORE';
 634   local $SIG{TSTP} = 'IGNORE';
 635   local $SIG{PIPE} = 'IGNORE';
 636
 637   my $oldAutoCommit = $FS::UID::AutoCommit;
 638   local $FS::UID::AutoCommit = 0;
 639   my $dbh = dbh;
 640
 641   foreach my $cust_svc (
 642     qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
 643   ) {
 644     my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 645
 646     $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 647       $dbh->rollback if $oldAutoCommit;
 648       return "Illegal svcdb value in part_svc!";
 649     };
 650     my $svcdb = $1;
 651     require "FS/$svcdb.pm";
 652
 653     my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
 654     if ($svc) {
 655       $error = $svc->unsuspend;
 656       if ( $error ) {
 657         $dbh->rollback if $oldAutoCommit;
 658         return $error;
 659       }
 660     }
 661
 662   }
 663
 664   unless ( ! $self->getfield('susp') ) {
 665     my %hash = $self->hash;
 666     my $inactive = time - $hash{'susp'};
 667
 668     my $conf = new FS::Conf;
 669
 670     $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive
 671       if ( $opt{'adjust_next_bill'}
 672            || $conf->config('unsuspend-always_adjust_next_bill_date') )
 673       && $inactive > 0 && ( $hash{'bill'} || $hash{'setup'} );
 674
 675     $hash{'susp'} = '';
 676     $hash{'adjourn'} = '' if $hash{'adjourn'} < time;
 677     my $new = new FS::cust_pkg ( \%hash );
 678     $error = $new->replace( $self, options => { $self->options } );
 679     if ( $error ) {
 680       $dbh->rollback if $oldAutoCommit;
 681       return $error;
 682     }
 683   }
 684
 685   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 686
 687   ''; #no errors
 688 }
 689
 690 =item last_bill
 691
 692 Returns the last bill date, or if there is no last bill date, the setup date.
 693 Useful for billing metered services.
 694
 695 =cut
 696
 697 sub last_bill {
 698   my $self = shift;
 699   if ( $self->dbdef_table->column('last_bill') ) {
 700     return $self->setfield('last_bill', $_[0]) if @_;
 701     return $self->getfield('last_bill') if $self->getfield('last_bill');
 702   }
 703   my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
 704                                                   'edate'  => $self->bill,  } );
 705   $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
 706 }
 707
 708 =item last_reason
 709
 710 Returns the most recent FS::reason associated with the package.
 711
 712 =cut
 713
 714 sub last_reason {
 715   my $self = shift;
 716   my $cust_pkg_reason = qsearchs( {
 717                                     'table' => 'cust_pkg_reason',
 718                                     'hashref' => { 'pkgnum' => $self->pkgnum, },
 719                                     'extra_sql'=> 'ORDER BY date DESC LIMIT 1',
 720                                   } );
 721   qsearchs ( 'reason', { 'reasonnum' => $cust_pkg_reason->reasonnum } )
 722     if $cust_pkg_reason;
 723 }
 724
 725 =item part_pkg
 726
 727 Returns the definition for this billing item, as an FS::part_pkg object (see
 728 L<FS::part_pkg>).
 729
 730 =cut
 731
 732 sub part_pkg {
 733   my $self = shift;
 734   #exists( $self->{'_pkgpart'} )
 735   $self->{'_pkgpart'}
 736     ? $self->{'_pkgpart'}
 737     : qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
 738 }
 739
 740 =item old_cust_pkg
 741
 742 Returns the cancelled package this package was changed from, if any.
 743
 744 =cut
 745
 746 sub old_cust_pkg {
 747   my $self = shift;
 748   return '' unless $self->change_pkgnum;
 749   qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
 750 }
 751
 752 =item calc_setup
 753
 754 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
 755 item.
 756
 757 =cut
 758
 759 sub calc_setup {
 760   my $self = shift;
 761   $self->part_pkg->calc_setup($self, @_);
 762 }
 763
 764 =item calc_recur
 765
 766 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
 767 item.
 768
 769 =cut
 770
 771 sub calc_recur {
 772   my $self = shift;
 773   $self->part_pkg->calc_recur($self, @_);
 774 }
 775
 776 =item calc_remain
 777
 778 Calls the I<calc_remain> of the FS::part_pkg object associated with this
 779 billing item.
 780
 781 =cut
 782
 783 sub calc_remain {
 784   my $self = shift;
 785   $self->part_pkg->calc_remain($self, @_);
 786 }
 787
 788 =item calc_cancel
 789
 790 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
 791 billing item.
 792
 793 =cut
 794
 795 sub calc_cancel {
 796   my $self = shift;
 797   $self->part_pkg->calc_cancel($self, @_);
 798 }
 799
 800 =item cust_bill_pkg
 801
 802 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
 803
 804 =cut
 805
 806 sub cust_bill_pkg {
 807   my $self = shift;
 808   qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
 809 }
 810
 811 =item cust_svc [ SVCPART ]
 812
 813 Returns the services for this package, as FS::cust_svc objects (see
 814 L<FS::cust_svc>).  If a svcpart is specified, return only the matching
 815 services.
 816
 817 =cut
 818
 819 sub cust_svc {
 820   my $self = shift;
 821
 822   if ( @_ ) {
 823     return qsearch( 'cust_svc', { 'pkgnum'  => $self->pkgnum,
 824                                   'svcpart' => shift,          } );
 825   }
 826
 827   #if ( $self->{'_svcnum'} ) {
 828   #  values %{ $self->{'_svcnum'}->cache };
 829   #} else {
 830     $self->_sort_cust_svc(
 831       [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
 832     );
 833   #}
 834
 835 }
 836
 837 =item overlimit [ SVCPART ]
 838
 839 Returns the services for this package which have exceeded their
 840 usage limit as FS::cust_svc objects (see L<FS::cust_svc>).  If a svcpart
 841 is specified, return only the matching services.
 842
 843 =cut
 844
 845 sub overlimit {
 846   my $self = shift;
 847   grep { $_->overlimit } $self->cust_svc;
 848 }
 849
 850 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ]
 851
 852 Returns historical services for this package created before END TIMESTAMP and
 853 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
 854 (see L<FS::h_cust_svc>).
 855
 856 =cut
 857
 858 sub h_cust_svc {
 859   my $self = shift;
 860
 861   $self->_sort_cust_svc(
 862     [ qsearch( 'h_cust_svc',
 863                { 'pkgnum' => $self->pkgnum, },
 864                FS::h_cust_svc->sql_h_search(@_),
 865              )
 866     ]
 867   );
 868 }
 869
 870 sub _sort_cust_svc {
 871   my( $self, $arrayref ) = @_;
 872
 873   map  { $_->[0] }
 874   sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
 875   map {
 876         my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
 877                                              'svcpart' => $_->svcpart     } );
 878         [ $_,
 879           $pkg_svc ? $pkg_svc->primary_svc : '',
 880           $pkg_svc ? $pkg_svc->quantity : 0,
 881         ];
 882       }
 883   @$arrayref;
 884
 885 }
 886
 887 =item num_cust_svc [ SVCPART ]
 888
 889 Returns the number of provisioned services for this package.  If a svcpart is
 890 specified, counts only the matching services.
 891
 892 =cut
 893
 894 sub num_cust_svc {
 895   my $self = shift;
 896   my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
 897   $sql .= ' AND svcpart = ?' if @_;
 898   my $sth = dbh->prepare($sql) or die dbh->errstr;
 899   $sth->execute($self->pkgnum, @_) or die $sth->errstr;
 900   $sth->fetchrow_arrayref->[0];
 901 }
 902
 903 =item available_part_svc
 904
 905 Returns a list of FS::part_svc objects representing services included in this
 906 package but not yet provisioned.  Each FS::part_svc object also has an extra
 907 field, I<num_avail>, which specifies the number of available services.
 908
 909 =cut
 910
 911 sub available_part_svc {
 912   my $self = shift;
 913   grep { $_->num_avail > 0 }
 914     map {
 915           my $part_svc = $_->part_svc;
 916           $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
 917             $_->quantity - $self->num_cust_svc($_->svcpart);
 918           $part_svc;
 919         }
 920       $self->part_pkg->pkg_svc;
 921 }
 922
 923 =item part_svc
 924
 925 Returns a list of FS::part_svc objects representing provisioned and available
 926 services included in this package.  Each FS::part_svc object also has the
 927 following extra fields:
 928
 929 =over 4
 930
 931 =item num_cust_svc  (count)
 932
 933 =item num_avail     (quantity - count)
 934
 935 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
 936
 937 svcnum
 938 label -> ($cust_svc->label)[1]
 939
 940 =back
 941
 942 =cut
 943
 944 sub part_svc {
 945   my $self = shift;
 946
 947   #XXX some sort of sort order besides numeric by svcpart...
 948   my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
 949     my $pkg_svc = $_;
 950     my $part_svc = $pkg_svc->part_svc;
 951     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
 952     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
 953     $part_svc->{'Hash'}{'num_avail'}    =
 954       max( 0, $pkg_svc->quantity - $num_cust_svc );
 955     $part_svc->{'Hash'}{'cust_pkg_svc'} = [ $self->cust_svc($part_svc->svcpart) ];
 956     $part_svc;
 957   } $self->part_pkg->pkg_svc;
 958
 959   #extras
 960   push @part_svc, map {
 961     my $part_svc = $_;
 962     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
 963     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
 964     $part_svc->{'Hash'}{'num_avail'}    = 0; #0-$num_cust_svc ?
 965     $part_svc->{'Hash'}{'cust_pkg_svc'} = [ $self->cust_svc($part_svc->svcpart) ];
 966     $part_svc;
 967   } $self->extra_part_svc;
 968
 969   @part_svc;
 970
 971 }
 972
 973 =item extra_part_svc
 974
 975 Returns a list of FS::part_svc objects corresponding to services in this
 976 package which are still provisioned but not (any longer) available in the
 977 package definition.
 978
 979 =cut
 980
 981 sub extra_part_svc {
 982   my $self = shift;
 983
 984   my $pkgnum  = $self->pkgnum;
 985   my $pkgpart = $self->pkgpart;
 986
 987   qsearch( {
 988     'table'     => 'part_svc',
 989     'hashref'   => {},
 990     'extra_sql' => "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
 991                                   WHERE pkg_svc.svcpart = part_svc.svcpart
 992                                     AND pkg_svc.pkgpart = $pkgpart
 993                                     AND quantity > 0
 994                               )
 995                       AND 0 < ( SELECT count(*)
 996                                   FROM cust_svc
 997                                     LEFT JOIN cust_pkg using ( pkgnum )
 998                                   WHERE cust_svc.svcpart = part_svc.svcpart
 999                                     AND pkgnum = $pkgnum
1000                               )",
1001   } );
1002 }
1003
1004 =item status
1005
1006 Returns a short status string for this package, currently:
1007
1008 =over 4
1009
1010 =item not yet billed
1011
1012 =item one-time charge
1013
1014 =item active
1015
1016 =item suspended
1017
1018 =item cancelled
1019
1020 =back
1021
1022 =cut
1023
1024 sub status {
1025   my $self = shift;
1026
1027   my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
1028
1029   return 'cancelled' if $self->get('cancel');
1030   return 'suspended' if $self->susp;
1031   return 'not yet billed' unless $self->setup;
1032   return 'one-time charge' if $freq =~ /^(0|$)/;
1033   return 'active';
1034 }
1035
1036 =item statuses
1037
1038 Class method that returns the list of possible status strings for pacakges
1039 (see L<the status method|/status>).  For example:
1040
1041   @statuses = FS::cust_pkg->statuses();
1042
1043 =cut
1044
1045 tie my %statuscolor, 'Tie::IxHash',
1046   'not yet billed'  => '000000',
1047   'one-time charge' => '000000',
1048   'active'          => '00CC00',
1049   'suspended'       => 'FF9900',
1050   'cancelled'       => 'FF0000',
1051 ;
1052
1053 sub statuses {
1054   my $self = shift; #could be class...
1055   grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
1056                                       # mayble split btw one-time vs. recur
1057     keys %statuscolor;
1058 }
1059
1060 =item statuscolor
1061
1062 Returns a hex triplet color string for this package's status.
1063
1064 =cut
1065
1066 sub statuscolor {
1067   my $self = shift;
1068   $statuscolor{$self->status};
1069 }
1070
1071 =item labels
1072
1073 Returns a list of lists, calling the label method for all services
1074 (see L<FS::cust_svc>) of this billing item.
1075
1076 =cut
1077
1078 sub labels {
1079   my $self = shift;
1080   map { [ $_->label ] } $self->cust_svc;
1081 }
1082
1083 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
1084
1085 Like the labels method, but returns historical information on services that
1086 were active as of END_TIMESTAMP and (optionally) not cancelled before
1087 START_TIMESTAMP.
1088
1089 Returns a list of lists, calling the label method for all (historical) services
1090 (see L<FS::h_cust_svc>) of this billing item.
1091
1092 =cut
1093
1094 sub h_labels {
1095   my $self = shift;
1096   map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
1097 }
1098
1099 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
1100
1101 Like h_labels, except returns a simple flat list, and shortens long
1102 (currently >5) lists of identical services to one line that lists the service
1103 label and the number of individual services rather than individual items.
1104
1105 =cut
1106
1107 sub h_labels_short {
1108   my $self = shift;
1109
1110   my %labels;
1111   #tie %labels, 'Tie::IxHash';
1112   push @{ $labels{$_->[0]} }, $_->[1]
1113     foreach $self->h_labels(@_);
1114   my @labels;
1115   foreach my $label ( keys %labels ) {
1116     my @values = @{ $labels{$label} };
1117     my $num = scalar(@values);
1118     if ( $num > 5 ) {
1119       push @labels, "$label ($num)";
1120     } else {
1121       push @labels, map { "$label: $_" } @values;
1122     }
1123   }
1124
1125  @labels;
1126
1127 }
1128
1129 =item cust_main
1130
1131 Returns the parent customer object (see L<FS::cust_main>).
1132
1133 =cut
1134
1135 sub cust_main {
1136   my $self = shift;
1137   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
1138 }
1139
1140 =item seconds_since TIMESTAMP
1141
1142 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
1143 package have been online since TIMESTAMP, according to the session monitor.
1144
1145 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1146 L<Time::Local> and L<Date::Parse> for conversion functions.
1147
1148 =cut
1149
1150 sub seconds_since {
1151   my($self, $since) = @_;
1152   my $seconds = 0;
1153
1154   foreach my $cust_svc (
1155     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
1156   ) {
1157     $seconds += $cust_svc->seconds_since($since);
1158   }
1159
1160   $seconds;
1161
1162 }
1163
1164 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1165
1166 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
1167 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
1168 (exclusive).
1169
1170 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1171 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1172 functions.
1173
1174
1175 =cut
1176
1177 sub seconds_since_sqlradacct {
1178   my($self, $start, $end) = @_;
1179
1180   my $seconds = 0;
1181
1182   foreach my $cust_svc (
1183     grep {
1184       my $part_svc = $_->part_svc;
1185       $part_svc->svcdb eq 'svc_acct'
1186         && scalar($part_svc->part_export('sqlradius'));
1187     } $self->cust_svc
1188   ) {
1189     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
1190   }
1191
1192   $seconds;
1193
1194 }
1195
1196 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1197
1198 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1199 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1200 TIMESTAMP_END
1201 (exclusive).
1202
1203 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1204 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1205 functions.
1206
1207 =cut
1208
1209 sub attribute_since_sqlradacct {
1210   my($self, $start, $end, $attrib) = @_;
1211
1212   my $sum = 0;
1213
1214   foreach my $cust_svc (
1215     grep {
1216       my $part_svc = $_->part_svc;
1217       $part_svc->svcdb eq 'svc_acct'
1218         && scalar($part_svc->part_export('sqlradius'));
1219     } $self->cust_svc
1220   ) {
1221     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
1222   }
1223
1224   $sum;
1225
1226 }
1227
1228 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
1229
1230 Transfers as many services as possible from this package to another package.
1231
1232 The destination package can be specified by pkgnum by passing an FS::cust_pkg
1233 object.  The destination package must already exist.
1234
1235 Services are moved only if the destination allows services with the correct
1236 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
1237 this option with caution!  No provision is made for export differences
1238 between the old and new service definitions.  Probably only should be used
1239 when your exports for all service definitions of a given svcdb are identical.
1240 (attempt a transfer without it first, to move all possible svcpart-matching
1241 services)
1242
1243 Any services that can't be moved remain in the original package.
1244
1245 Returns an error, if there is one; otherwise, returns the number of services
1246 that couldn't be moved.
1247
1248 =cut
1249
1250 sub transfer {
1251   my ($self, $dest_pkgnum, %opt) = @_;
1252
1253   my $remaining = 0;
1254   my $dest;
1255   my %target;
1256
1257   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
1258     $dest = $dest_pkgnum;
1259     $dest_pkgnum = $dest->pkgnum;
1260   } else {
1261     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
1262   }
1263
1264   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
1265
1266   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
1267     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
1268   }
1269
1270   foreach my $cust_svc ($dest->cust_svc) {
1271     $target{$cust_svc->svcpart}--;
1272   }
1273
1274   my %svcpart2svcparts = ();
1275   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1276     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
1277     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
1278       next if exists $svcpart2svcparts{$svcpart};
1279       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
1280       $svcpart2svcparts{$svcpart} = [
1281         map  { $_->[0] }
1282         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
1283         map {
1284               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
1285                                                    'svcpart' => $_          } );
1286               [ $_,
1287                 $pkg_svc ? $pkg_svc->primary_svc : '',
1288                 $pkg_svc ? $pkg_svc->quantity : 0,
1289               ];
1290             }
1291
1292         grep { $_ != $svcpart }
1293         map  { $_->svcpart }
1294         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
1295       ];
1296       warn "alternates for svcpart $svcpart: ".
1297            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
1298         if $DEBUG;
1299     }
1300   }
1301
1302   foreach my $cust_svc ($self->cust_svc) {
1303     if($target{$cust_svc->svcpart} > 0) {
1304       $target{$cust_svc->svcpart}--;
1305       my $new = new FS::cust_svc { $cust_svc->hash };
1306       $new->pkgnum($dest_pkgnum);
1307       my $error = $new->replace($cust_svc);
1308       return $error if $error;
1309     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1310       if ( $DEBUG ) {
1311         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
1312         warn "alternates to consider: ".
1313              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
1314       }
1315       my @alternate = grep {
1316                              warn "considering alternate svcpart $_: ".
1317                                   "$target{$_} available in new package\n"
1318                                if $DEBUG;
1319                              $target{$_} > 0;
1320                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
1321       if ( @alternate ) {
1322         warn "alternate(s) found\n" if $DEBUG;
1323         my $change_svcpart = $alternate[0];
1324         $target{$change_svcpart}--;
1325         my $new = new FS::cust_svc { $cust_svc->hash };
1326         $new->svcpart($change_svcpart);
1327         $new->pkgnum($dest_pkgnum);
1328         my $error = $new->replace($cust_svc);
1329         return $error if $error;
1330       } else {
1331         $remaining++;
1332       }
1333     } else {
1334       $remaining++
1335     }
1336   }
1337   return $remaining;
1338 }
1339
1340 =item reexport
1341
1342 This method is deprecated.  See the I<depend_jobnum> option to the insert and
1343 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
1344
1345 =cut
1346
1347 sub reexport {
1348   my $self = shift;
1349
1350   local $SIG{HUP} = 'IGNORE';
1351   local $SIG{INT} = 'IGNORE';
1352   local $SIG{QUIT} = 'IGNORE';
1353   local $SIG{TERM} = 'IGNORE';
1354   local $SIG{TSTP} = 'IGNORE';
1355   local $SIG{PIPE} = 'IGNORE';
1356
1357   my $oldAutoCommit = $FS::UID::AutoCommit;
1358   local $FS::UID::AutoCommit = 0;
1359   my $dbh = dbh;
1360
1361   foreach my $cust_svc ( $self->cust_svc ) {
1362     #false laziness w/svc_Common::insert
1363     my $svc_x = $cust_svc->svc_x;
1364     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
1365       my $error = $part_export->export_insert($svc_x);
1366       if ( $error ) {
1367         $dbh->rollback if $oldAutoCommit;
1368         return $error;
1369       }
1370     }
1371   }
1372
1373   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1374   '';
1375
1376 }
1377
1378 =back
1379
1380 =head1 CLASS METHODS
1381
1382 =over 4
1383
1384 =item recurring_sql
1385
1386 Returns an SQL expression identifying recurring packages.
1387
1388 =cut
1389
1390 sub recurring_sql { "
1391   '0' != ( select freq from part_pkg
1392              where cust_pkg.pkgpart = part_pkg.pkgpart )
1393 "; }
1394
1395 =item onetime_sql
1396
1397 Returns an SQL expression identifying one-time packages.
1398
1399 =cut
1400
1401 sub onetime_sql { "
1402   '0' = ( select freq from part_pkg
1403             where cust_pkg.pkgpart = part_pkg.pkgpart )
1404 "; }
1405
1406 =item active_sql
1407
1408 Returns an SQL expression identifying active packages.
1409
1410 =cut
1411
1412 sub active_sql { "
1413   ". $_[0]->recurring_sql(). "
1414   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1415   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
1416 "; }
1417
1418 =item inactive_sql
1419
1420 Returns an SQL expression identifying inactive packages (one-time packages
1421 that are otherwise unsuspended/uncancelled).
1422
1423 =cut
1424
1425 sub inactive_sql { "
1426   ". $_[0]->onetime_sql(). "
1427   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1428   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
1429 "; }
1430
1431 =item susp_sql
1432 =item suspended_sql
1433
1434 Returns an SQL expression identifying suspended packages.
1435
1436 =cut
1437
1438 sub suspended_sql { susp_sql(@_); }
1439 sub susp_sql {
1440   #$_[0]->recurring_sql(). ' AND '.
1441   "
1442         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
1443     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
1444   ";
1445 }
1446
1447 =item cancel_sql
1448 =item cancelled_sql
1449
1450 Returns an SQL exprression identifying cancelled packages.
1451
1452 =cut
1453
1454 sub cancelled_sql { cancel_sql(@_); }
1455 sub cancel_sql {
1456   #$_[0]->recurring_sql(). ' AND '.
1457   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
1458 }
1459
1460 =head1 SUBROUTINES
1461
1462 =over 4
1463
1464 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ] ]
1465
1466 CUSTNUM is a customer (see L<FS::cust_main>)
1467
1468 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
1469 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
1470 permitted.
1471
1472 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
1473 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
1474 new billing items.  An error is returned if this is not possible (see
1475 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
1476 parameter.
1477
1478 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
1479 newly-created cust_pkg objects.
1480
1481 =cut
1482
1483 sub order {
1484   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
1485
1486   my $conf = new FS::Conf;
1487
1488   # Transactionize this whole mess
1489   local $SIG{HUP} = 'IGNORE';
1490   local $SIG{INT} = 'IGNORE';
1491   local $SIG{QUIT} = 'IGNORE';
1492   local $SIG{TERM} = 'IGNORE';
1493   local $SIG{TSTP} = 'IGNORE';
1494   local $SIG{PIPE} = 'IGNORE';
1495
1496   my $oldAutoCommit = $FS::UID::AutoCommit;
1497   local $FS::UID::AutoCommit = 0;
1498   my $dbh = dbh;
1499
1500   my $error;
1501   my $cust_main = qsearchs('cust_main', { custnum => $custnum });
1502   return "Customer not found: $custnum" unless $cust_main;
1503
1504   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
1505                          @$remove_pkgnum;
1506
1507   my $change = scalar(@old_cust_pkg) != 0;
1508
1509   my %hash = ();
1510   if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
1511
1512     my $time = time;
1513
1514     #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( last_bill bill );
1515
1516     #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( setup );
1517     $hash{'setup'} = $time if $old_cust_pkg[0]->setup;
1518
1519     $hash{'change_date'} = $time;
1520     $hash{"change_$_"}  = $old_cust_pkg[0]->$_() foreach qw( pkgnum pkgpart );
1521   }
1522
1523   # Create the new packages.
1524   foreach my $pkgpart (@$pkgparts) {
1525     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
1526                                       pkgpart => $pkgpart,
1527                                       %hash,
1528                                     };
1529     $error = $cust_pkg->insert( 'change' => $change );
1530     if ($error) {
1531       $dbh->rollback if $oldAutoCommit;
1532       return $error;
1533     }
1534     push @$return_cust_pkg, $cust_pkg;
1535   }
1536   # $return_cust_pkg now contains refs to all of the newly
1537   # created packages.
1538
1539   # Transfer services and cancel old packages.
1540   foreach my $old_pkg (@old_cust_pkg) {
1541
1542     foreach my $new_pkg (@$return_cust_pkg) {
1543       $error = $old_pkg->transfer($new_pkg);
1544       if ($error and $error == 0) {
1545         # $old_pkg->transfer failed.
1546         $dbh->rollback if $oldAutoCommit;
1547         return $error;
1548       }
1549     }
1550
1551     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1552       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1553       foreach my $new_pkg (@$return_cust_pkg) {
1554         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
1555         if ($error and $error == 0) {
1556           # $old_pkg->transfer failed.
1557         $dbh->rollback if $oldAutoCommit;
1558         return $error;
1559         }
1560       }
1561     }
1562
1563     if ($error > 0) {
1564       # Transfers were successful, but we went through all of the
1565       # new packages and still had services left on the old package.
1566       # We can't cancel the package under the circumstances, so abort.
1567       $dbh->rollback if $oldAutoCommit;
1568       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
1569     }
1570     $error = $old_pkg->cancel( quiet=>1 );
1571     if ($error) {
1572       $dbh->rollback;
1573       return $error;
1574     }
1575   }
1576   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1577   '';
1578 }
1579
1580 sub insert_reason {
1581   my ($self, %options) = @_;
1582
1583   my $otaker = $FS::CurrentUser::CurrentUser->username;
1584
1585   my $cust_pkg_reason =
1586     new FS::cust_pkg_reason({ 'pkgnum'    => $self->pkgnum,
1587                               'reasonnum' => $options{'reason'},
1588                               'otaker'    => $otaker,
1589                               'date'      => $options{'date'}
1590                                                ? $options{'date'}
1591                                                : time,
1592                             });
1593   return $cust_pkg_reason->insert;
1594 }
1595
1596 =item set_usage USAGE_VALUE_HASHREF
1597
1598 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
1599 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
1600 upbytes, downbytes, and totalbytes are appropriate keys.
1601
1602 All svc_accts which are part of this package have their values reset.
1603
1604 =cut
1605
1606 sub set_usage {
1607   my ($self, $valueref) = @_;
1608
1609   foreach my $cust_svc ($self->cust_svc){
1610     my $svc_x = $cust_svc->svc_x;
1611     $svc_x->set_usage($valueref)
1612       if $svc_x->can("set_usage");
1613   }
1614 }
1615
1616 =back
1617
1618 =head1 BUGS
1619
1620 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
1621
1622 In sub order, the @pkgparts array (passed by reference) is clobbered.
1623
1624 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
1625 method to pass dates to the recur_prog expression, it should do so.
1626
1627 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
1628 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
1629 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
1630 configuration values.  Probably need a subroutine which decides what to do
1631 based on whether or not we've fetched the user yet, rather than a hash.  See
1632 FS::UID and the TODO.
1633
1634 Now that things are transactional should the check in the insert method be
1635 moved to check ?
1636
1637 =head1 SEE ALSO
1638
1639 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
1640 L<FS::pkg_svc>, schema.html from the base documentation
1641
1642 =cut
1643
1644 1;
1645