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',
 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 h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ]
 803
 804 Returns historical services for this package created before END TIMESTAMP and
 805 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
 806 (see L<FS::h_cust_svc>).
 807
 808 =cut
 809
 810 sub h_cust_svc {
 811   my $self = shift;
 812
 813   $self->_sort_cust_svc(
 814     [ qsearch( 'h_cust_svc',
 815                { 'pkgnum' => $self->pkgnum, },
 816                FS::h_cust_svc->sql_h_search(@_),
 817              )
 818     ]
 819   );
 820 }
 821
 822 sub _sort_cust_svc {
 823   my( $self, $arrayref ) = @_;
 824
 825   map  { $_->[0] }
 826   sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
 827   map {
 828         my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
 829                                              'svcpart' => $_->svcpart     } );
 830         [ $_,
 831           $pkg_svc ? $pkg_svc->primary_svc : '',
 832           $pkg_svc ? $pkg_svc->quantity : 0,
 833         ];
 834       }
 835   @$arrayref;
 836
 837 }
 838
 839 =item num_cust_svc [ SVCPART ]
 840
 841 Returns the number of provisioned services for this package.  If a svcpart is
 842 specified, counts only the matching services.
 843
 844 =cut
 845
 846 sub num_cust_svc {
 847   my $self = shift;
 848   my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
 849   $sql .= ' AND svcpart = ?' if @_;
 850   my $sth = dbh->prepare($sql) or die dbh->errstr;
 851   $sth->execute($self->pkgnum, @_) or die $sth->errstr;
 852   $sth->fetchrow_arrayref->[0];
 853 }
 854
 855 =item available_part_svc
 856
 857 Returns a list of FS::part_svc objects representing services included in this
 858 package but not yet provisioned.  Each FS::part_svc object also has an extra
 859 field, I<num_avail>, which specifies the number of available services.
 860
 861 =cut
 862
 863 sub available_part_svc {
 864   my $self = shift;
 865   grep { $_->num_avail > 0 }
 866     map {
 867           my $part_svc = $_->part_svc;
 868           $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
 869             $_->quantity - $self->num_cust_svc($_->svcpart);
 870           $part_svc;
 871         }
 872       $self->part_pkg->pkg_svc;
 873 }
 874
 875 =item
 876
 877 Returns a list of FS::part_svc objects representing provisioned and available
 878 services included in this package.  Each FS::part_svc object also has the
 879 following extra fields:
 880
 881 =over 4
 882
 883 =item num_cust_svc  (count)
 884
 885 =item num_avail     (quantity - count)
 886
 887 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
 888
 889 svcnum
 890 label -> ($cust_svc->label)[1]
 891
 892 =back
 893
 894 =cut
 895
 896 sub part_svc {
 897   my $self = shift;
 898
 899   #XXX some sort of sort order besides numeric by svcpart...
 900   my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
 901     my $pkg_svc = $_;
 902     my $part_svc = $pkg_svc->part_svc;
 903     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
 904     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
 905     $part_svc->{'Hash'}{'num_avail'}    =
 906       max( 0, $pkg_svc->quantity - $num_cust_svc );
 907     $part_svc->{'Hash'}{'cust_pkg_svc'} = [ $self->cust_svc($part_svc->svcpart) ];
 908     $part_svc;
 909   } $self->part_pkg->pkg_svc;
 910
 911   #extras
 912   push @part_svc, map {
 913     my $part_svc = $_;
 914     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
 915     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
 916     $part_svc->{'Hash'}{'num_avail'}    = 0; #0-$num_cust_svc ?
 917     $part_svc->{'Hash'}{'cust_pkg_svc'} = [ $self->cust_svc($part_svc->svcpart) ];
 918     $part_svc;
 919   } $self->extra_part_svc;
 920
 921   @part_svc;
 922
 923 }
 924
 925 =item extra_part_svc
 926
 927 Returns a list of FS::part_svc objects corresponding to services in this
 928 package which are still provisioned but not (any longer) available in the
 929 package definition.
 930
 931 =cut
 932
 933 sub extra_part_svc {
 934   my $self = shift;
 935
 936   my $pkgnum  = $self->pkgnum;
 937   my $pkgpart = $self->pkgpart;
 938
 939   qsearch( {
 940     'table'     => 'part_svc',
 941     'hashref'   => {},
 942     'extra_sql' => "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
 943                                   WHERE pkg_svc.svcpart = part_svc.svcpart
 944                                     AND pkg_svc.pkgpart = $pkgpart
 945                                     AND quantity > 0
 946                               )
 947                       AND 0 < ( SELECT count(*)
 948                                   FROM cust_svc
 949                                     LEFT JOIN cust_pkg using ( pkgnum )
 950                                   WHERE cust_svc.svcpart = part_svc.svcpart
 951                                     AND pkgnum = $pkgnum
 952                               )",
 953   } );
 954 }
 955
 956 =item status
 957
 958 Returns a short status string for this package, currently:
 959
 960 =over 4
 961
 962 =item not yet billed
 963
 964 =item one-time charge
 965
 966 =item active
 967
 968 =item suspended
 969
 970 =item cancelled
 971
 972 =back
 973
 974 =cut
 975
 976 sub status {
 977   my $self = shift;
 978
 979   my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
 980
 981   return 'cancelled' if $self->get('cancel');
 982   return 'suspended' if $self->susp;
 983   return 'not yet billed' unless $self->setup;
 984   return 'one-time charge' if $freq =~ /^(0|$)/;
 985   return 'active';
 986 }
 987
 988 =item statuses
 989
 990 Class method that returns the list of possible status strings for pacakges
 991 (see L<the status method|/status>).  For example:
 992
 993   @statuses = FS::cust_pkg->statuses();
 994
 995 =cut
 996
 997 tie my %statuscolor, 'Tie::IxHash',
 998   'not yet billed'  => '000000',
 999   'one-time charge' => '000000',
1000   'active'          => '00CC00',
1001   'suspended'       => 'FF9900',
1002   'cancelled'       => 'FF0000',
1003 ;
1004
1005 sub statuses {
1006   my $self = shift; #could be class...
1007   grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
1008                                       # mayble split btw one-time vs. recur
1009     keys %statuscolor;
1010 }
1011
1012 =item statuscolor
1013
1014 Returns a hex triplet color string for this package's status.
1015
1016 =cut
1017
1018 sub statuscolor {
1019   my $self = shift;
1020   $statuscolor{$self->status};
1021 }
1022
1023 =item labels
1024
1025 Returns a list of lists, calling the label method for all services
1026 (see L<FS::cust_svc>) of this billing item.
1027
1028 =cut
1029
1030 sub labels {
1031   my $self = shift;
1032   map { [ $_->label ] } $self->cust_svc;
1033 }
1034
1035 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
1036
1037 Like the labels method, but returns historical information on services that
1038 were active as of END_TIMESTAMP and (optionally) not cancelled before
1039 START_TIMESTAMP.
1040
1041 Returns a list of lists, calling the label method for all (historical) services
1042 (see L<FS::h_cust_svc>) of this billing item.
1043
1044 =cut
1045
1046 sub h_labels {
1047   my $self = shift;
1048   map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
1049 }
1050
1051 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
1052
1053 Like h_labels, except returns a simple flat list, and shortens long
1054 (currently >5) lists of identical services to one line that lists the service
1055 label and the number of individual services rather than individual items.
1056
1057 =cut
1058
1059 sub h_labels_short {
1060   my $self = shift;
1061
1062   my %labels;
1063   #tie %labels, 'Tie::IxHash';
1064   push @{ $labels{$_->[0]} }, $_->[1]
1065     foreach $self->h_labels(@_);
1066   my @labels;
1067   foreach my $label ( keys %labels ) {
1068     my @values = @{ $labels{$label} };
1069     my $num = scalar(@values);
1070     if ( $num > 5 ) {
1071       push @labels, "$label ($num)";
1072     } else {
1073       push @labels, map { "$label: $_" } @values;
1074     }
1075   }
1076
1077  @labels;
1078
1079 }
1080
1081 =item cust_main
1082
1083 Returns the parent customer object (see L<FS::cust_main>).
1084
1085 =cut
1086
1087 sub cust_main {
1088   my $self = shift;
1089   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
1090 }
1091
1092 =item seconds_since TIMESTAMP
1093
1094 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
1095 package have been online since TIMESTAMP, according to the session monitor.
1096
1097 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1098 L<Time::Local> and L<Date::Parse> for conversion functions.
1099
1100 =cut
1101
1102 sub seconds_since {
1103   my($self, $since) = @_;
1104   my $seconds = 0;
1105
1106   foreach my $cust_svc (
1107     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
1108   ) {
1109     $seconds += $cust_svc->seconds_since($since);
1110   }
1111
1112   $seconds;
1113
1114 }
1115
1116 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1117
1118 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
1119 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
1120 (exclusive).
1121
1122 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1123 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1124 functions.
1125
1126
1127 =cut
1128
1129 sub seconds_since_sqlradacct {
1130   my($self, $start, $end) = @_;
1131
1132   my $seconds = 0;
1133
1134   foreach my $cust_svc (
1135     grep {
1136       my $part_svc = $_->part_svc;
1137       $part_svc->svcdb eq 'svc_acct'
1138         && scalar($part_svc->part_export('sqlradius'));
1139     } $self->cust_svc
1140   ) {
1141     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
1142   }
1143
1144   $seconds;
1145
1146 }
1147
1148 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1149
1150 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1151 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1152 TIMESTAMP_END
1153 (exclusive).
1154
1155 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1156 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1157 functions.
1158
1159 =cut
1160
1161 sub attribute_since_sqlradacct {
1162   my($self, $start, $end, $attrib) = @_;
1163
1164   my $sum = 0;
1165
1166   foreach my $cust_svc (
1167     grep {
1168       my $part_svc = $_->part_svc;
1169       $part_svc->svcdb eq 'svc_acct'
1170         && scalar($part_svc->part_export('sqlradius'));
1171     } $self->cust_svc
1172   ) {
1173     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
1174   }
1175
1176   $sum;
1177
1178 }
1179
1180 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
1181
1182 Transfers as many services as possible from this package to another package.
1183
1184 The destination package can be specified by pkgnum by passing an FS::cust_pkg
1185 object.  The destination package must already exist.
1186
1187 Services are moved only if the destination allows services with the correct
1188 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
1189 this option with caution!  No provision is made for export differences
1190 between the old and new service definitions.  Probably only should be used
1191 when your exports for all service definitions of a given svcdb are identical.
1192 (attempt a transfer without it first, to move all possible svcpart-matching
1193 services)
1194
1195 Any services that can't be moved remain in the original package.
1196
1197 Returns an error, if there is one; otherwise, returns the number of services
1198 that couldn't be moved.
1199
1200 =cut
1201
1202 sub transfer {
1203   my ($self, $dest_pkgnum, %opt) = @_;
1204
1205   my $remaining = 0;
1206   my $dest;
1207   my %target;
1208
1209   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
1210     $dest = $dest_pkgnum;
1211     $dest_pkgnum = $dest->pkgnum;
1212   } else {
1213     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
1214   }
1215
1216   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
1217
1218   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
1219     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
1220   }
1221
1222   foreach my $cust_svc ($dest->cust_svc) {
1223     $target{$cust_svc->svcpart}--;
1224   }
1225
1226   my %svcpart2svcparts = ();
1227   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1228     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
1229     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
1230       next if exists $svcpart2svcparts{$svcpart};
1231       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
1232       $svcpart2svcparts{$svcpart} = [
1233         map  { $_->[0] }
1234         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
1235         map {
1236               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
1237                                                    'svcpart' => $_          } );
1238               [ $_,
1239                 $pkg_svc ? $pkg_svc->primary_svc : '',
1240                 $pkg_svc ? $pkg_svc->quantity : 0,
1241               ];
1242             }
1243
1244         grep { $_ != $svcpart }
1245         map  { $_->svcpart }
1246         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
1247       ];
1248       warn "alternates for svcpart $svcpart: ".
1249            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
1250         if $DEBUG;
1251     }
1252   }
1253
1254   foreach my $cust_svc ($self->cust_svc) {
1255     if($target{$cust_svc->svcpart} > 0) {
1256       $target{$cust_svc->svcpart}--;
1257       my $new = new FS::cust_svc {
1258         svcnum  => $cust_svc->svcnum,
1259         svcpart => $cust_svc->svcpart,
1260         pkgnum  => $dest_pkgnum,
1261       };
1262       my $error = $new->replace($cust_svc);
1263       return $error if $error;
1264     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1265       if ( $DEBUG ) {
1266         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
1267         warn "alternates to consider: ".
1268              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
1269       }
1270       my @alternate = grep {
1271                              warn "considering alternate svcpart $_: ".
1272                                   "$target{$_} available in new package\n"
1273                                if $DEBUG;
1274                              $target{$_} > 0;
1275                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
1276       if ( @alternate ) {
1277         warn "alternate(s) found\n" if $DEBUG;
1278         my $change_svcpart = $alternate[0];
1279         $target{$change_svcpart}--;
1280         my $new = new FS::cust_svc {
1281           svcnum  => $cust_svc->svcnum,
1282           svcpart => $change_svcpart,
1283           pkgnum  => $dest_pkgnum,
1284         };
1285         my $error = $new->replace($cust_svc);
1286         return $error if $error;
1287       } else {
1288         $remaining++;
1289       }
1290     } else {
1291       $remaining++
1292     }
1293   }
1294   return $remaining;
1295 }
1296
1297 =item reexport
1298
1299 This method is deprecated.  See the I<depend_jobnum> option to the insert and
1300 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
1301
1302 =cut
1303
1304 sub reexport {
1305   my $self = shift;
1306
1307   local $SIG{HUP} = 'IGNORE';
1308   local $SIG{INT} = 'IGNORE';
1309   local $SIG{QUIT} = 'IGNORE';
1310   local $SIG{TERM} = 'IGNORE';
1311   local $SIG{TSTP} = 'IGNORE';
1312   local $SIG{PIPE} = 'IGNORE';
1313
1314   my $oldAutoCommit = $FS::UID::AutoCommit;
1315   local $FS::UID::AutoCommit = 0;
1316   my $dbh = dbh;
1317
1318   foreach my $cust_svc ( $self->cust_svc ) {
1319     #false laziness w/svc_Common::insert
1320     my $svc_x = $cust_svc->svc_x;
1321     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
1322       my $error = $part_export->export_insert($svc_x);
1323       if ( $error ) {
1324         $dbh->rollback if $oldAutoCommit;
1325         return $error;
1326       }
1327     }
1328   }
1329
1330   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1331   '';
1332
1333 }
1334
1335 =back
1336
1337 =head1 CLASS METHODS
1338
1339 =over 4
1340
1341 =item recurring_sql
1342
1343 Returns an SQL expression identifying recurring packages.
1344
1345 =cut
1346
1347 sub recurring_sql { "
1348   '0' != ( select freq from part_pkg
1349              where cust_pkg.pkgpart = part_pkg.pkgpart )
1350 "; }
1351
1352 =item onetime_sql
1353
1354 Returns an SQL expression identifying one-time packages.
1355
1356 =cut
1357
1358 sub onetime_sql { "
1359   '0' = ( select freq from part_pkg
1360             where cust_pkg.pkgpart = part_pkg.pkgpart )
1361 "; }
1362
1363 =item active_sql
1364
1365 Returns an SQL expression identifying active packages.
1366
1367 =cut
1368
1369 sub active_sql { "
1370   ". $_[0]->recurring_sql(). "
1371   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1372   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
1373 "; }
1374
1375 =item inactive_sql
1376
1377 Returns an SQL expression identifying inactive packages (one-time packages
1378 that are otherwise unsuspended/uncancelled).
1379
1380 =cut
1381
1382 sub inactive_sql { "
1383   ". $_[0]->onetime_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 susp_sql
1389 =item suspended_sql
1390
1391 Returns an SQL expression identifying suspended packages.
1392
1393 =cut
1394
1395 sub suspended_sql { susp_sql(@_); }
1396 sub susp_sql {
1397   #$_[0]->recurring_sql(). ' AND '.
1398   "
1399         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
1400     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
1401   ";
1402 }
1403
1404 =item cancel_sql
1405 =item cancelled_sql
1406
1407 Returns an SQL exprression identifying cancelled packages.
1408
1409 =cut
1410
1411 sub cancelled_sql { cancel_sql(@_); }
1412 sub cancel_sql {
1413   #$_[0]->recurring_sql(). ' AND '.
1414   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
1415 }
1416
1417 =head1 SUBROUTINES
1418
1419 =over 4
1420
1421 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ] ]
1422
1423 CUSTNUM is a customer (see L<FS::cust_main>)
1424
1425 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
1426 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
1427 permitted.
1428
1429 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
1430 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
1431 new billing items.  An error is returned if this is not possible (see
1432 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
1433 parameter.
1434
1435 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
1436 newly-created cust_pkg objects.
1437
1438 =cut
1439
1440 sub order {
1441   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
1442
1443   my $conf = new FS::Conf;
1444
1445   # Transactionize this whole mess
1446   local $SIG{HUP} = 'IGNORE';
1447   local $SIG{INT} = 'IGNORE';
1448   local $SIG{QUIT} = 'IGNORE';
1449   local $SIG{TERM} = 'IGNORE';
1450   local $SIG{TSTP} = 'IGNORE';
1451   local $SIG{PIPE} = 'IGNORE';
1452
1453   my $oldAutoCommit = $FS::UID::AutoCommit;
1454   local $FS::UID::AutoCommit = 0;
1455   my $dbh = dbh;
1456
1457   my $error;
1458   my $cust_main = qsearchs('cust_main', { custnum => $custnum });
1459   return "Customer not found: $custnum" unless $cust_main;
1460
1461   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
1462                          @$remove_pkgnum;
1463
1464   my $change = scalar(@old_cust_pkg) != 0;
1465
1466   my %hash = ();
1467   if ( scalar(@old_cust_pkg) == 1 ) {
1468     #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( last_bill bill );
1469     $hash{'setup'} = time;
1470   }
1471
1472   # Create the new packages.
1473   foreach my $pkgpart (@$pkgparts) {
1474     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
1475                                       pkgpart => $pkgpart,
1476                                       %hash,
1477                                     };
1478     $error = $cust_pkg->insert( 'change' => $change );
1479     if ($error) {
1480       $dbh->rollback if $oldAutoCommit;
1481       return $error;
1482     }
1483     push @$return_cust_pkg, $cust_pkg;
1484   }
1485   # $return_cust_pkg now contains refs to all of the newly
1486   # created packages.
1487
1488   # Transfer services and cancel old packages.
1489   foreach my $old_pkg (@old_cust_pkg) {
1490
1491     foreach my $new_pkg (@$return_cust_pkg) {
1492       $error = $old_pkg->transfer($new_pkg);
1493       if ($error and $error == 0) {
1494         # $old_pkg->transfer failed.
1495         $dbh->rollback if $oldAutoCommit;
1496         return $error;
1497       }
1498     }
1499
1500     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1501       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1502       foreach my $new_pkg (@$return_cust_pkg) {
1503         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
1504         if ($error and $error == 0) {
1505           # $old_pkg->transfer failed.
1506         $dbh->rollback if $oldAutoCommit;
1507         return $error;
1508         }
1509       }
1510     }
1511
1512     if ($error > 0) {
1513       # Transfers were successful, but we went through all of the
1514       # new packages and still had services left on the old package.
1515       # We can't cancel the package under the circumstances, so abort.
1516       $dbh->rollback if $oldAutoCommit;
1517       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
1518     }
1519     $error = $old_pkg->cancel( quiet=>1 );
1520     if ($error) {
1521       $dbh->rollback;
1522       return $error;
1523     }
1524   }
1525   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1526   '';
1527 }
1528
1529 sub insert_reason {
1530   my ($self, %options) = @_;
1531
1532   my $otaker = $FS::CurrentUser::CurrentUser->name;
1533   $otaker = $FS::CurrentUser::CurrentUser->username
1534     if (($otaker) eq "User, Legacy");
1535
1536   my $cust_pkg_reason =
1537     new FS::cust_pkg_reason({ 'pkgnum'    => $self->pkgnum,
1538                               'reasonnum' => $options{'reason'},
1539                               'otaker'    => $otaker,
1540                               'date'      => $options{'date'}
1541                                                ? $options{'date'}
1542                                                : time,
1543                             });
1544   return $cust_pkg_reason->insert;
1545 }
1546
1547 =item set_usage USAGE_VALUE_HASHREF
1548
1549 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
1550 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
1551 upbytes, downbytes, and totalbytes are appropriate keys.
1552
1553 All svc_accts which are part of this package have their values reset.
1554
1555 =cut
1556
1557 sub set_usage {
1558   my ($self, $valueref) = @_;
1559
1560   foreach my $cust_svc ($self->cust_svc){
1561     my $svc_x = $cust_svc->svc_x;
1562     $svc_x->set_usage($valueref)
1563       if $svc_x->can("set_usage");
1564   }
1565 }
1566
1567 =back
1568
1569 =head1 BUGS
1570
1571 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
1572
1573 In sub order, the @pkgparts array (passed by reference) is clobbered.
1574
1575 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
1576 method to pass dates to the recur_prog expression, it should do so.
1577
1578 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
1579 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
1580 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
1581 configuration values.  Probably need a subroutine which decides what to do
1582 based on whether or not we've fetched the user yet, rather than a hash.  See
1583 FS::UID and the TODO.
1584
1585 Now that things are transactional should the check in the insert method be
1586 moved to check ?
1587
1588 =head1 SEE ALSO
1589
1590 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
1591 L<FS::pkg_svc>, schema.html from the base documentation
1592
1593 =cut
1594
1595 1;
1596