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