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\.\-]{0,16})$/ 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 calc_setup
 741
 742 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
 743 item.
 744
 745 =cut
 746
 747 sub calc_setup {
 748   my $self = shift;
 749   $self->part_pkg->calc_setup($self, @_);
 750 }
 751
 752 =item calc_recur
 753
 754 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
 755 item.
 756
 757 =cut
 758
 759 sub calc_recur {
 760   my $self = shift;
 761   $self->part_pkg->calc_recur($self, @_);
 762 }
 763
 764 =item calc_remain
 765
 766 Calls the I<calc_remain> of the FS::part_pkg object associated with this
 767 billing item.
 768
 769 =cut
 770
 771 sub calc_remain {
 772   my $self = shift;
 773   $self->part_pkg->calc_remain($self, @_);
 774 }
 775
 776 =item calc_cancel
 777
 778 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
 779 billing item.
 780
 781 =cut
 782
 783 sub calc_cancel {
 784   my $self = shift;
 785   $self->part_pkg->calc_cancel($self, @_);
 786 }
 787
 788 =item cust_bill_pkg
 789
 790 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
 791
 792 =cut
 793
 794 sub cust_bill_pkg {
 795   my $self = shift;
 796   qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
 797 }
 798
 799 =item cust_svc [ SVCPART ]
 800
 801 Returns the services for this package, as FS::cust_svc objects (see
 802 L<FS::cust_svc>).  If a svcpart is specified, return only the matching
 803 services.
 804
 805 =cut
 806
 807 sub cust_svc {
 808   my $self = shift;
 809
 810   if ( @_ ) {
 811     return qsearch( 'cust_svc', { 'pkgnum'  => $self->pkgnum,
 812                                   'svcpart' => shift,          } );
 813   }
 814
 815   #if ( $self->{'_svcnum'} ) {
 816   #  values %{ $self->{'_svcnum'}->cache };
 817   #} else {
 818     $self->_sort_cust_svc(
 819       [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
 820     );
 821   #}
 822
 823 }
 824
 825 =item overlimit [ SVCPART ]
 826
 827 Returns the services for this package which have exceeded their
 828 usage limit as FS::cust_svc objects (see L<FS::cust_svc>).  If a svcpart
 829 is specified, return only the matching services.
 830
 831 =cut
 832
 833 sub overlimit {
 834   my $self = shift;
 835   grep { $_->overlimit } $self->cust_svc;
 836 }
 837
 838 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ]
 839
 840 Returns historical services for this package created before END TIMESTAMP and
 841 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
 842 (see L<FS::h_cust_svc>).
 843
 844 =cut
 845
 846 sub h_cust_svc {
 847   my $self = shift;
 848
 849   $self->_sort_cust_svc(
 850     [ qsearch( 'h_cust_svc',
 851                { 'pkgnum' => $self->pkgnum, },
 852                FS::h_cust_svc->sql_h_search(@_),
 853              )
 854     ]
 855   );
 856 }
 857
 858 sub _sort_cust_svc {
 859   my( $self, $arrayref ) = @_;
 860
 861   map  { $_->[0] }
 862   sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
 863   map {
 864         my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
 865                                              'svcpart' => $_->svcpart     } );
 866         [ $_,
 867           $pkg_svc ? $pkg_svc->primary_svc : '',
 868           $pkg_svc ? $pkg_svc->quantity : 0,
 869         ];
 870       }
 871   @$arrayref;
 872
 873 }
 874
 875 =item num_cust_svc [ SVCPART ]
 876
 877 Returns the number of provisioned services for this package.  If a svcpart is
 878 specified, counts only the matching services.
 879
 880 =cut
 881
 882 sub num_cust_svc {
 883   my $self = shift;
 884   my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
 885   $sql .= ' AND svcpart = ?' if @_;
 886   my $sth = dbh->prepare($sql) or die dbh->errstr;
 887   $sth->execute($self->pkgnum, @_) or die $sth->errstr;
 888   $sth->fetchrow_arrayref->[0];
 889 }
 890
 891 =item available_part_svc
 892
 893 Returns a list of FS::part_svc objects representing services included in this
 894 package but not yet provisioned.  Each FS::part_svc object also has an extra
 895 field, I<num_avail>, which specifies the number of available services.
 896
 897 =cut
 898
 899 sub available_part_svc {
 900   my $self = shift;
 901   grep { $_->num_avail > 0 }
 902     map {
 903           my $part_svc = $_->part_svc;
 904           $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
 905             $_->quantity - $self->num_cust_svc($_->svcpart);
 906           $part_svc;
 907         }
 908       $self->part_pkg->pkg_svc;
 909 }
 910
 911 =item
 912
 913 Returns a list of FS::part_svc objects representing provisioned and available
 914 services included in this package.  Each FS::part_svc object also has the
 915 following extra fields:
 916
 917 =over 4
 918
 919 =item num_cust_svc  (count)
 920
 921 =item num_avail     (quantity - count)
 922
 923 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
 924
 925 svcnum
 926 label -> ($cust_svc->label)[1]
 927
 928 =back
 929
 930 =cut
 931
 932 sub part_svc {
 933   my $self = shift;
 934
 935   #XXX some sort of sort order besides numeric by svcpart...
 936   my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
 937     my $pkg_svc = $_;
 938     my $part_svc = $pkg_svc->part_svc;
 939     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
 940     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
 941     $part_svc->{'Hash'}{'num_avail'}    =
 942       max( 0, $pkg_svc->quantity - $num_cust_svc );
 943     $part_svc->{'Hash'}{'cust_pkg_svc'} = [ $self->cust_svc($part_svc->svcpart) ];
 944     $part_svc;
 945   } $self->part_pkg->pkg_svc;
 946
 947   #extras
 948   push @part_svc, map {
 949     my $part_svc = $_;
 950     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
 951     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
 952     $part_svc->{'Hash'}{'num_avail'}    = 0; #0-$num_cust_svc ?
 953     $part_svc->{'Hash'}{'cust_pkg_svc'} = [ $self->cust_svc($part_svc->svcpart) ];
 954     $part_svc;
 955   } $self->extra_part_svc;
 956
 957   @part_svc;
 958
 959 }
 960
 961 =item extra_part_svc
 962
 963 Returns a list of FS::part_svc objects corresponding to services in this
 964 package which are still provisioned but not (any longer) available in the
 965 package definition.
 966
 967 =cut
 968
 969 sub extra_part_svc {
 970   my $self = shift;
 971
 972   my $pkgnum  = $self->pkgnum;
 973   my $pkgpart = $self->pkgpart;
 974
 975   qsearch( {
 976     'table'     => 'part_svc',
 977     'hashref'   => {},
 978     'extra_sql' => "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
 979                                   WHERE pkg_svc.svcpart = part_svc.svcpart
 980                                     AND pkg_svc.pkgpart = $pkgpart
 981                                     AND quantity > 0
 982                               )
 983                       AND 0 < ( SELECT count(*)
 984                                   FROM cust_svc
 985                                     LEFT JOIN cust_pkg using ( pkgnum )
 986                                   WHERE cust_svc.svcpart = part_svc.svcpart
 987                                     AND pkgnum = $pkgnum
 988                               )",
 989   } );
 990 }
 991
 992 =item status
 993
 994 Returns a short status string for this package, currently:
 995
 996 =over 4
 997
 998 =item not yet billed
 999
1000 =item one-time charge
1001
1002 =item active
1003
1004 =item suspended
1005
1006 =item cancelled
1007
1008 =back
1009
1010 =cut
1011
1012 sub status {
1013   my $self = shift;
1014
1015   my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
1016
1017   return 'cancelled' if $self->get('cancel');
1018   return 'suspended' if $self->susp;
1019   return 'not yet billed' unless $self->setup;
1020   return 'one-time charge' if $freq =~ /^(0|$)/;
1021   return 'active';
1022 }
1023
1024 =item statuses
1025
1026 Class method that returns the list of possible status strings for pacakges
1027 (see L<the status method|/status>).  For example:
1028
1029   @statuses = FS::cust_pkg->statuses();
1030
1031 =cut
1032
1033 tie my %statuscolor, 'Tie::IxHash',
1034   'not yet billed'  => '000000',
1035   'one-time charge' => '000000',
1036   'active'          => '00CC00',
1037   'suspended'       => 'FF9900',
1038   'cancelled'       => 'FF0000',
1039 ;
1040
1041 sub statuses {
1042   my $self = shift; #could be class...
1043   grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
1044                                       # mayble split btw one-time vs. recur
1045     keys %statuscolor;
1046 }
1047
1048 =item statuscolor
1049
1050 Returns a hex triplet color string for this package's status.
1051
1052 =cut
1053
1054 sub statuscolor {
1055   my $self = shift;
1056   $statuscolor{$self->status};
1057 }
1058
1059 =item labels
1060
1061 Returns a list of lists, calling the label method for all services
1062 (see L<FS::cust_svc>) of this billing item.
1063
1064 =cut
1065
1066 sub labels {
1067   my $self = shift;
1068   map { [ $_->label ] } $self->cust_svc;
1069 }
1070
1071 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
1072
1073 Like the labels method, but returns historical information on services that
1074 were active as of END_TIMESTAMP and (optionally) not cancelled before
1075 START_TIMESTAMP.
1076
1077 Returns a list of lists, calling the label method for all (historical) services
1078 (see L<FS::h_cust_svc>) of this billing item.
1079
1080 =cut
1081
1082 sub h_labels {
1083   my $self = shift;
1084   map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
1085 }
1086
1087 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
1088
1089 Like h_labels, except returns a simple flat list, and shortens long
1090 (currently >5) lists of identical services to one line that lists the service
1091 label and the number of individual services rather than individual items.
1092
1093 =cut
1094
1095 sub h_labels_short {
1096   my $self = shift;
1097
1098   my %labels;
1099   #tie %labels, 'Tie::IxHash';
1100   push @{ $labels{$_->[0]} }, $_->[1]
1101     foreach $self->h_labels(@_);
1102   my @labels;
1103   foreach my $label ( keys %labels ) {
1104     my @values = @{ $labels{$label} };
1105     my $num = scalar(@values);
1106     if ( $num > 5 ) {
1107       push @labels, "$label ($num)";
1108     } else {
1109       push @labels, map { "$label: $_" } @values;
1110     }
1111   }
1112
1113  @labels;
1114
1115 }
1116
1117 =item cust_main
1118
1119 Returns the parent customer object (see L<FS::cust_main>).
1120
1121 =cut
1122
1123 sub cust_main {
1124   my $self = shift;
1125   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
1126 }
1127
1128 =item seconds_since TIMESTAMP
1129
1130 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
1131 package have been online since TIMESTAMP, according to the session monitor.
1132
1133 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1134 L<Time::Local> and L<Date::Parse> for conversion functions.
1135
1136 =cut
1137
1138 sub seconds_since {
1139   my($self, $since) = @_;
1140   my $seconds = 0;
1141
1142   foreach my $cust_svc (
1143     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
1144   ) {
1145     $seconds += $cust_svc->seconds_since($since);
1146   }
1147
1148   $seconds;
1149
1150 }
1151
1152 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1153
1154 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
1155 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
1156 (exclusive).
1157
1158 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1159 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1160 functions.
1161
1162
1163 =cut
1164
1165 sub seconds_since_sqlradacct {
1166   my($self, $start, $end) = @_;
1167
1168   my $seconds = 0;
1169
1170   foreach my $cust_svc (
1171     grep {
1172       my $part_svc = $_->part_svc;
1173       $part_svc->svcdb eq 'svc_acct'
1174         && scalar($part_svc->part_export('sqlradius'));
1175     } $self->cust_svc
1176   ) {
1177     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
1178   }
1179
1180   $seconds;
1181
1182 }
1183
1184 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1185
1186 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1187 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1188 TIMESTAMP_END
1189 (exclusive).
1190
1191 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1192 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1193 functions.
1194
1195 =cut
1196
1197 sub attribute_since_sqlradacct {
1198   my($self, $start, $end, $attrib) = @_;
1199
1200   my $sum = 0;
1201
1202   foreach my $cust_svc (
1203     grep {
1204       my $part_svc = $_->part_svc;
1205       $part_svc->svcdb eq 'svc_acct'
1206         && scalar($part_svc->part_export('sqlradius'));
1207     } $self->cust_svc
1208   ) {
1209     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
1210   }
1211
1212   $sum;
1213
1214 }
1215
1216 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
1217
1218 Transfers as many services as possible from this package to another package.
1219
1220 The destination package can be specified by pkgnum by passing an FS::cust_pkg
1221 object.  The destination package must already exist.
1222
1223 Services are moved only if the destination allows services with the correct
1224 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
1225 this option with caution!  No provision is made for export differences
1226 between the old and new service definitions.  Probably only should be used
1227 when your exports for all service definitions of a given svcdb are identical.
1228 (attempt a transfer without it first, to move all possible svcpart-matching
1229 services)
1230
1231 Any services that can't be moved remain in the original package.
1232
1233 Returns an error, if there is one; otherwise, returns the number of services
1234 that couldn't be moved.
1235
1236 =cut
1237
1238 sub transfer {
1239   my ($self, $dest_pkgnum, %opt) = @_;
1240
1241   my $remaining = 0;
1242   my $dest;
1243   my %target;
1244
1245   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
1246     $dest = $dest_pkgnum;
1247     $dest_pkgnum = $dest->pkgnum;
1248   } else {
1249     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
1250   }
1251
1252   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
1253
1254   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
1255     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
1256   }
1257
1258   foreach my $cust_svc ($dest->cust_svc) {
1259     $target{$cust_svc->svcpart}--;
1260   }
1261
1262   my %svcpart2svcparts = ();
1263   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1264     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
1265     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
1266       next if exists $svcpart2svcparts{$svcpart};
1267       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
1268       $svcpart2svcparts{$svcpart} = [
1269         map  { $_->[0] }
1270         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
1271         map {
1272               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
1273                                                    'svcpart' => $_          } );
1274               [ $_,
1275                 $pkg_svc ? $pkg_svc->primary_svc : '',
1276                 $pkg_svc ? $pkg_svc->quantity : 0,
1277               ];
1278             }
1279
1280         grep { $_ != $svcpart }
1281         map  { $_->svcpart }
1282         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
1283       ];
1284       warn "alternates for svcpart $svcpart: ".
1285            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
1286         if $DEBUG;
1287     }
1288   }
1289
1290   foreach my $cust_svc ($self->cust_svc) {
1291     if($target{$cust_svc->svcpart} > 0) {
1292       $target{$cust_svc->svcpart}--;
1293       my $new = new FS::cust_svc { $cust_svc->hash };
1294       $new->pkgnum($dest_pkgnum);
1295       my $error = $new->replace($cust_svc);
1296       return $error if $error;
1297     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1298       if ( $DEBUG ) {
1299         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
1300         warn "alternates to consider: ".
1301              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
1302       }
1303       my @alternate = grep {
1304                              warn "considering alternate svcpart $_: ".
1305                                   "$target{$_} available in new package\n"
1306                                if $DEBUG;
1307                              $target{$_} > 0;
1308                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
1309       if ( @alternate ) {
1310         warn "alternate(s) found\n" if $DEBUG;
1311         my $change_svcpart = $alternate[0];
1312         $target{$change_svcpart}--;
1313         my $new = new FS::cust_svc { $cust_svc->hash };
1314         $new->svcpart($change_svcpart);
1315         $new->pkgnum($dest_pkgnum);
1316         my $error = $new->replace($cust_svc);
1317         return $error if $error;
1318       } else {
1319         $remaining++;
1320       }
1321     } else {
1322       $remaining++
1323     }
1324   }
1325   return $remaining;
1326 }
1327
1328 =item reexport
1329
1330 This method is deprecated.  See the I<depend_jobnum> option to the insert and
1331 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
1332
1333 =cut
1334
1335 sub reexport {
1336   my $self = shift;
1337
1338   local $SIG{HUP} = 'IGNORE';
1339   local $SIG{INT} = 'IGNORE';
1340   local $SIG{QUIT} = 'IGNORE';
1341   local $SIG{TERM} = 'IGNORE';
1342   local $SIG{TSTP} = 'IGNORE';
1343   local $SIG{PIPE} = 'IGNORE';
1344
1345   my $oldAutoCommit = $FS::UID::AutoCommit;
1346   local $FS::UID::AutoCommit = 0;
1347   my $dbh = dbh;
1348
1349   foreach my $cust_svc ( $self->cust_svc ) {
1350     #false laziness w/svc_Common::insert
1351     my $svc_x = $cust_svc->svc_x;
1352     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
1353       my $error = $part_export->export_insert($svc_x);
1354       if ( $error ) {
1355         $dbh->rollback if $oldAutoCommit;
1356         return $error;
1357       }
1358     }
1359   }
1360
1361   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1362   '';
1363
1364 }
1365
1366 =back
1367
1368 =head1 CLASS METHODS
1369
1370 =over 4
1371
1372 =item recurring_sql
1373
1374 Returns an SQL expression identifying recurring packages.
1375
1376 =cut
1377
1378 sub recurring_sql { "
1379   '0' != ( select freq from part_pkg
1380              where cust_pkg.pkgpart = part_pkg.pkgpart )
1381 "; }
1382
1383 =item onetime_sql
1384
1385 Returns an SQL expression identifying one-time packages.
1386
1387 =cut
1388
1389 sub onetime_sql { "
1390   '0' = ( select freq from part_pkg
1391             where cust_pkg.pkgpart = part_pkg.pkgpart )
1392 "; }
1393
1394 =item active_sql
1395
1396 Returns an SQL expression identifying active packages.
1397
1398 =cut
1399
1400 sub active_sql { "
1401   ". $_[0]->recurring_sql(). "
1402   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1403   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
1404 "; }
1405
1406 =item inactive_sql
1407
1408 Returns an SQL expression identifying inactive packages (one-time packages
1409 that are otherwise unsuspended/uncancelled).
1410
1411 =cut
1412
1413 sub inactive_sql { "
1414   ". $_[0]->onetime_sql(). "
1415   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1416   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
1417 "; }
1418
1419 =item susp_sql
1420 =item suspended_sql
1421
1422 Returns an SQL expression identifying suspended packages.
1423
1424 =cut
1425
1426 sub suspended_sql { susp_sql(@_); }
1427 sub susp_sql {
1428   #$_[0]->recurring_sql(). ' AND '.
1429   "
1430         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
1431     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
1432   ";
1433 }
1434
1435 =item cancel_sql
1436 =item cancelled_sql
1437
1438 Returns an SQL exprression identifying cancelled packages.
1439
1440 =cut
1441
1442 sub cancelled_sql { cancel_sql(@_); }
1443 sub cancel_sql {
1444   #$_[0]->recurring_sql(). ' AND '.
1445   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
1446 }
1447
1448 =head1 SUBROUTINES
1449
1450 =over 4
1451
1452 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ] ]
1453
1454 CUSTNUM is a customer (see L<FS::cust_main>)
1455
1456 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
1457 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
1458 permitted.
1459
1460 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
1461 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
1462 new billing items.  An error is returned if this is not possible (see
1463 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
1464 parameter.
1465
1466 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
1467 newly-created cust_pkg objects.
1468
1469 =cut
1470
1471 sub order {
1472   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
1473
1474   my $conf = new FS::Conf;
1475
1476   # Transactionize this whole mess
1477   local $SIG{HUP} = 'IGNORE';
1478   local $SIG{INT} = 'IGNORE';
1479   local $SIG{QUIT} = 'IGNORE';
1480   local $SIG{TERM} = 'IGNORE';
1481   local $SIG{TSTP} = 'IGNORE';
1482   local $SIG{PIPE} = 'IGNORE';
1483
1484   my $oldAutoCommit = $FS::UID::AutoCommit;
1485   local $FS::UID::AutoCommit = 0;
1486   my $dbh = dbh;
1487
1488   my $error;
1489   my $cust_main = qsearchs('cust_main', { custnum => $custnum });
1490   return "Customer not found: $custnum" unless $cust_main;
1491
1492   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
1493                          @$remove_pkgnum;
1494
1495   my $change = scalar(@old_cust_pkg) != 0;
1496
1497   my %hash = ();
1498   if ( scalar(@old_cust_pkg) == 1 ) {
1499     #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( last_bill bill );
1500     $hash{'setup'} = time;
1501   }
1502
1503   # Create the new packages.
1504   foreach my $pkgpart (@$pkgparts) {
1505     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
1506                                       pkgpart => $pkgpart,
1507                                       %hash,
1508                                     };
1509     $error = $cust_pkg->insert( 'change' => $change );
1510     if ($error) {
1511       $dbh->rollback if $oldAutoCommit;
1512       return $error;
1513     }
1514     push @$return_cust_pkg, $cust_pkg;
1515   }
1516   # $return_cust_pkg now contains refs to all of the newly
1517   # created packages.
1518
1519   # Transfer services and cancel old packages.
1520   foreach my $old_pkg (@old_cust_pkg) {
1521
1522     foreach my $new_pkg (@$return_cust_pkg) {
1523       $error = $old_pkg->transfer($new_pkg);
1524       if ($error and $error == 0) {
1525         # $old_pkg->transfer failed.
1526         $dbh->rollback if $oldAutoCommit;
1527         return $error;
1528       }
1529     }
1530
1531     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1532       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1533       foreach my $new_pkg (@$return_cust_pkg) {
1534         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
1535         if ($error and $error == 0) {
1536           # $old_pkg->transfer failed.
1537         $dbh->rollback if $oldAutoCommit;
1538         return $error;
1539         }
1540       }
1541     }
1542
1543     if ($error > 0) {
1544       # Transfers were successful, but we went through all of the
1545       # new packages and still had services left on the old package.
1546       # We can't cancel the package under the circumstances, so abort.
1547       $dbh->rollback if $oldAutoCommit;
1548       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
1549     }
1550     $error = $old_pkg->cancel( quiet=>1 );
1551     if ($error) {
1552       $dbh->rollback;
1553       return $error;
1554     }
1555   }
1556   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1557   '';
1558 }
1559
1560 sub insert_reason {
1561   my ($self, %options) = @_;
1562
1563   my $otaker = $FS::CurrentUser::CurrentUser->username;
1564
1565   my $cust_pkg_reason =
1566     new FS::cust_pkg_reason({ 'pkgnum'    => $self->pkgnum,
1567                               'reasonnum' => $options{'reason'},
1568                               'otaker'    => $otaker,
1569                               'date'      => $options{'date'}
1570                                                ? $options{'date'}
1571                                                : time,
1572                             });
1573   return $cust_pkg_reason->insert;
1574 }
1575
1576 =item set_usage USAGE_VALUE_HASHREF
1577
1578 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
1579 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
1580 upbytes, downbytes, and totalbytes are appropriate keys.
1581
1582 All svc_accts which are part of this package have their values reset.
1583
1584 =cut
1585
1586 sub set_usage {
1587   my ($self, $valueref) = @_;
1588
1589   foreach my $cust_svc ($self->cust_svc){
1590     my $svc_x = $cust_svc->svc_x;
1591     $svc_x->set_usage($valueref)
1592       if $svc_x->can("set_usage");
1593   }
1594 }
1595
1596 =back
1597
1598 =head1 BUGS
1599
1600 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
1601
1602 In sub order, the @pkgparts array (passed by reference) is clobbered.
1603
1604 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
1605 method to pass dates to the recur_prog expression, it should do so.
1606
1607 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
1608 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
1609 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
1610 configuration values.  Probably need a subroutine which decides what to do
1611 based on whether or not we've fetched the user yet, rather than a hash.  See
1612 FS::UID and the TODO.
1613
1614 Now that things are transactional should the check in the insert method be
1615 moved to check ?
1616
1617 =head1 SEE ALSO
1618
1619 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
1620 L<FS::pkg_svc>, schema.html from the base documentation
1621
1622 =cut
1623
1624 1;
1625