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