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