FS/FS/cust_pkg.pm

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