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