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