FS/FS/cust_pkg.pm

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