FS/FS/cust_pkg.pm

   1 package FS::cust_pkg;
   2
   3 use strict;
   4 use vars qw(@ISA $disable_agentcheck $DEBUG);
   5 use Scalar::Util qw( blessed );
   6 use List::Util qw(max);
   7 use Tie::IxHash;
   8 use FS::UID qw( getotaker dbh );
   9 use FS::Misc qw( send_email );
  10 use FS::Record qw( qsearch qsearchs );
  11 use FS::m2m_Common;
  12 use FS::cust_main_Mixin;
  13 use FS::cust_svc;
  14 use FS::part_pkg;
  15 use FS::cust_main;
  16 use FS::type_pkgs;
  17 use FS::pkg_svc;
  18 use FS::cust_bill_pkg;
  19 use FS::cust_event;
  20 use FS::h_cust_svc;
  21 use FS::reg_code;
  22 use FS::part_svc;
  23 use FS::cust_pkg_reason;
  24 use FS::reason;
  25 use FS::UI::Web;
  26
  27 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
  28 # setup }
  29 # because they load configuration by setting FS::UID::callback (see TODO)
  30 use FS::svc_acct;
  31 use FS::svc_domain;
  32 use FS::svc_www;
  33 use FS::svc_forward;
  34
  35 # for sending cancel emails in sub cancel
  36 use FS::Conf;
  37
  38 @ISA = qw( FS::m2m_Common FS::cust_main_Mixin FS::option_Common FS::Record );
  39
  40 $DEBUG = 0;
  41
  42 $disable_agentcheck = 0;
  43
  44 sub _cache {
  45   my $self = shift;
  46   my ( $hashref, $cache ) = @_;
  47   #if ( $hashref->{'pkgpart'} ) {
  48   if ( $hashref->{'pkg'} ) {
  49     # #@{ $self->{'_pkgnum'} } = ();
  50     # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
  51     # $self->{'_pkgpart'} = $subcache;
  52     # #push @{ $self->{'_pkgnum'} },
  53     #   FS::part_pkg->new_or_cached($hashref, $subcache);
  54     $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
  55   }
  56   if ( exists $hashref->{'svcnum'} ) {
  57     #@{ $self->{'_pkgnum'} } = ();
  58     my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
  59     $self->{'_svcnum'} = $subcache;
  60     #push @{ $self->{'_pkgnum'} },
  61     FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
  62   }
  63 }
  64
  65 =head1 NAME
  66
  67 FS::cust_pkg - Object methods for cust_pkg objects
  68
  69 =head1 SYNOPSIS
  70
  71   use FS::cust_pkg;
  72
  73   $record = new FS::cust_pkg \%hash;
  74   $record = new FS::cust_pkg { 'column' => 'value' };
  75
  76   $error = $record->insert;
  77
  78   $error = $new_record->replace($old_record);
  79
  80   $error = $record->delete;
  81
  82   $error = $record->check;
  83
  84   $error = $record->cancel;
  85
  86   $error = $record->suspend;
  87
  88   $error = $record->unsuspend;
  89
  90   $part_pkg = $record->part_pkg;
  91
  92   @labels = $record->labels;
  93
  94   $seconds = $record->seconds_since($timestamp);
  95
  96   $error = FS::cust_pkg::order( $custnum, \@pkgparts );
  97   $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
  98
  99 =head1 DESCRIPTION
 100
 101 An FS::cust_pkg object represents a customer billing item.  FS::cust_pkg
 102 inherits from FS::Record.  The following fields are currently supported:
 103
 104 =over 4
 105
 106 =item pkgnum - primary key (assigned automatically for new billing items)
 107
 108 =item custnum - Customer (see L<FS::cust_main>)
 109
 110 =item pkgpart - Billing item definition (see L<FS::part_pkg>)
 111
 112 =item setup - date
 113
 114 =item bill - date (next bill date)
 115
 116 =item last_bill - last bill date
 117
 118 =item adjourn - date
 119
 120 =item susp - date
 121
 122 =item expire - date
 123
 124 =item cancel - date
 125
 126 =item otaker - order taker (assigned automatically if null, see L<FS::UID>)
 127
 128 =item manual_flag - If this field is set to 1, disables the automatic
 129 unsuspension of this package when using the B<unsuspendauto> config file.
 130
 131 =item quantity - If not set, defaults to 1
 132
 133 =back
 134
 135 Note: setup, bill, adjourn, susp, expire and cancel are specified as UNIX timestamps;
 136 see L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for
 137 conversion functions.
 138
 139 =head1 METHODS
 140
 141 =over 4
 142
 143 =item new HASHREF
 144
 145 Create a new billing item.  To add the item to the database, see L<"insert">.
 146
 147 =cut
 148
 149 sub table { 'cust_pkg'; }
 150 sub cust_linked { $_[0]->cust_main_custnum; }
 151 sub cust_unlinked_msg {
 152   my $self = shift;
 153   "WARNING: can't find cust_main.custnum ". $self->custnum.
 154   ' (cust_pkg.pkgnum '. $self->pkgnum. ')';
 155 }
 156
 157 =item insert [ OPTION => VALUE ... ]
 158
 159 Adds this billing item to the database ("Orders" the item).  If there is an
 160 error, returns the error, otherwise returns false.
 161
 162 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
 163 will be used to look up the package definition and agent restrictions will be
 164 ignored.
 165
 166 If the additional field I<refnum> is defined, an FS::pkg_referral record will
 167 be created and inserted.  Multiple FS::pkg_referral records can be created by
 168 setting I<refnum> to an array reference of refnums or a hash reference with
 169 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
 170 record will be created corresponding to cust_main.refnum.
 171
 172 The following options are available: I<change>
 173
 174 I<change>, if set true, supresses any referral credit to a referring customer.
 175
 176 =cut
 177
 178 sub insert {
 179   my( $self, %options ) = @_;
 180
 181   local $SIG{HUP} = 'IGNORE';
 182   local $SIG{INT} = 'IGNORE';
 183   local $SIG{QUIT} = 'IGNORE';
 184   local $SIG{TERM} = 'IGNORE';
 185   local $SIG{TSTP} = 'IGNORE';
 186   local $SIG{PIPE} = 'IGNORE';
 187
 188   my $oldAutoCommit = $FS::UID::AutoCommit;
 189   local $FS::UID::AutoCommit = 0;
 190   my $dbh = dbh;
 191
 192   my $error = $self->SUPER::insert($options{options} ? %{$options{options}} : ());
 193   if ( $error ) {
 194     $dbh->rollback if $oldAutoCommit;
 195     return $error;
 196   }
 197
 198   $self->refnum($self->cust_main->refnum) unless $self->refnum;
 199   $self->refnum( [ $self->refnum ] ) unless ref($self->refnum);
 200   $self->process_m2m( 'link_table'   => 'pkg_referral',
 201                       'target_table' => 'part_referral',
 202                       'params'       => $self->refnum,
 203                     );
 204
 205   #if ( $self->reg_code ) {
 206   #  my $reg_code = qsearchs('reg_code', { 'code' => $self->reg_code } );
 207   #  $error = $reg_code->delete;
 208   #  if ( $error ) {
 209   #    $dbh->rollback if $oldAutoCommit;
 210   #    return $error;
 211   #  }
 212   #}
 213
 214   my $conf = new FS::Conf;
 215   my $cust_main = $self->cust_main;
 216   my $part_pkg = $self->part_pkg;
 217   if ( $conf->exists('referral_credit')
 218        && $cust_main->referral_custnum
 219        && ! $options{'change'}
 220        && $part_pkg->freq !~ /^0\D?$/
 221      )
 222   {
 223     my $referring_cust_main = $cust_main->referring_cust_main;
 224     if ( $referring_cust_main->status ne 'cancelled' ) {
 225       my $error;
 226       if ( $part_pkg->freq !~ /^\d+$/ ) {
 227         warn 'WARNING: Not crediting customer '. $cust_main->referral_custnum.
 228              ' for package '. $self->pkgnum.
 229              ' ( customer '. $self->custnum. ')'.
 230              ' - One-time referral credits not (yet) available for '.
 231              ' packages with '. $part_pkg->freq_pretty. ' frequency';
 232       } else {
 233
 234         my $amount = sprintf( "%.2f", $part_pkg->base_recur / $part_pkg->freq );
 235         my $error =
 236           $referring_cust_main->
 237             credit( $amount,
 238                     'Referral credit for '.$cust_main->name,
 239                     'reason_type' => $conf->config('referral_credit_type')
 240                   );
 241         if ( $error ) {
 242           $dbh->rollback if $oldAutoCommit;
 243           return "Error crediting customer ". $cust_main->referral_custnum.
 244                " for referral: $error";
 245         }
 246
 247       }
 248
 249     }
 250   }
 251
 252   if ($conf->config('welcome_letter') && $self->cust_main->num_pkgs == 1) {
 253     my $queue = new FS::queue {
 254       'job'     => 'FS::cust_main::queueable_print',
 255     };
 256     $error = $queue->insert(
 257       'custnum'  => $self->custnum,
 258       'template' => 'welcome_letter',
 259     );
 260
 261     if ($error) {
 262       warn "can't send welcome letter: $error";
 263     }
 264
 265   }
 266
 267   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 268   '';
 269
 270 }
 271
 272 =item delete
 273
 274 This method now works but you probably shouldn't use it.
 275
 276 You don't want to delete billing items, because there would then be no record
 277 the customer ever purchased the item.  Instead, see the cancel method.
 278
 279 =cut
 280
 281 #sub delete {
 282 #  return "Can't delete cust_pkg records!";
 283 #}
 284
 285 =item replace OLD_RECORD
 286
 287 Replaces the OLD_RECORD with this one in the database.  If there is an error,
 288 returns the error, otherwise returns false.
 289
 290 Currently, custnum, setup, bill, adjourn, susp, expire, and cancel may be changed.
 291
 292 Changing pkgpart may have disasterous effects.  See the order subroutine.
 293
 294 setup and bill are normally updated by calling the bill method of a customer
 295 object (see L<FS::cust_main>).
 296
 297 suspend is normally updated by the suspend and unsuspend methods.
 298
 299 cancel is normally updated by the cancel method (and also the order subroutine
 300 in some cases).
 301
 302 Calls
 303
 304 =cut
 305
 306 sub replace {
 307   my $new = shift;
 308
 309   my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
 310               ? shift
 311               : $new->replace_old;
 312
 313   my $options =
 314     ( ref($_[0]) eq 'HASH' )
 315       ? shift
 316       : { @_ };
 317
 318   #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
 319   return "Can't change otaker!" if $old->otaker ne $new->otaker;
 320
 321   #allow this *sigh*
 322   #return "Can't change setup once it exists!"
 323   #  if $old->getfield('setup') &&
 324   #     $old->getfield('setup') != $new->getfield('setup');
 325
 326   #some logic for bill, susp, cancel?
 327
 328   local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
 329
 330   local $SIG{HUP} = 'IGNORE';
 331   local $SIG{INT} = 'IGNORE';
 332   local $SIG{QUIT} = 'IGNORE';
 333   local $SIG{TERM} = 'IGNORE';
 334   local $SIG{TSTP} = 'IGNORE';
 335   local $SIG{PIPE} = 'IGNORE';
 336
 337   my $oldAutoCommit = $FS::UID::AutoCommit;
 338   local $FS::UID::AutoCommit = 0;
 339   my $dbh = dbh;
 340
 341   foreach my $method ( qw(adjourn expire) ) {  # How many reasons?
 342     if ($options->{'reason'} && $new->$method && $old->$method ne $new->$method) {
 343       my $error = $new->insert_reason( 'reason' => $options->{'reason'},
 344                                        'date'   => $new->$method,
 345                                        'action' => $method,
 346                                        'reason_otaker' => $options{'reason_otaker'},
 347                                      );
 348       if ( $error ) {
 349         dbh->rollback if $oldAutoCommit;
 350         return "Error inserting cust_pkg_reason: $error";
 351       }
 352     }
 353   }
 354
 355   #save off and freeze RADIUS attributes for any associated svc_acct records
 356   my @svc_acct = ();
 357   if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
 358
 359                 #also check for specific exports?
 360                 # to avoid spurious modify export events
 361     @svc_acct = map  { $_->svc_x }
 362                 grep { $_->part_svc->svcdb eq 'svc_acct' }
 363                      $old->cust_svc;
 364
 365     $_->snapshot foreach @svc_acct;
 366
 367   }
 368
 369   my $error = $new->SUPER::replace($old,
 370                                    $options->{options} ? $options->{options} : ()
 371                                   );
 372   if ( $error ) {
 373     $dbh->rollback if $oldAutoCommit;
 374     return $error;
 375   }
 376
 377   #for prepaid packages,
 378   #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
 379   foreach my $old_svc_acct ( @svc_acct ) {
 380     my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
 381     my $s_error = $new_svc_acct->replace($old_svc_acct);
 382     if ( $s_error ) {
 383       $dbh->rollback if $oldAutoCommit;
 384       return $s_error;
 385     }
 386   }
 387
 388   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 389   '';
 390
 391 }
 392
 393 =item check
 394
 395 Checks all fields to make sure this is a valid billing item.  If there is an
 396 error, returns the error, otherwise returns false.  Called by the insert and
 397 replace methods.
 398
 399 =cut
 400
 401 sub check {
 402   my $self = shift;
 403
 404   my $error =
 405     $self->ut_numbern('pkgnum')
 406     || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
 407     || $self->ut_numbern('pkgpart')
 408     || $self->ut_numbern('setup')
 409     || $self->ut_numbern('bill')
 410     || $self->ut_numbern('susp')
 411     || $self->ut_numbern('cancel')
 412     || $self->ut_numbern('adjourn')
 413     || $self->ut_numbern('expire')
 414   ;
 415   return $error if $error;
 416
 417   if ( $self->reg_code ) {
 418
 419     unless ( grep { $self->pkgpart == $_->pkgpart }
 420              map  { $_->reg_code_pkg }
 421              qsearchs( 'reg_code', { 'code'     => $self->reg_code,
 422                                      'agentnum' => $self->cust_main->agentnum })
 423            ) {
 424       return "Unknown registration code";
 425     }
 426
 427   } elsif ( $self->promo_code ) {
 428
 429     my $promo_part_pkg =
 430       qsearchs('part_pkg', {
 431         'pkgpart'    => $self->pkgpart,
 432         'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
 433       } );
 434     return 'Unknown promotional code' unless $promo_part_pkg;
 435
 436   } else {
 437
 438     unless ( $disable_agentcheck ) {
 439       my $agent =
 440         qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
 441       my $pkgpart_href = $agent->pkgpart_hashref;
 442       return "agent ". $agent->agentnum.
 443              " can't purchase pkgpart ". $self->pkgpart
 444         unless $pkgpart_href->{ $self->pkgpart };
 445     }
 446
 447     $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
 448     return $error if $error;
 449
 450   }
 451
 452   $self->otaker(getotaker) unless $self->otaker;
 453   $self->otaker =~ /^(\w{1,32})$/ or return "Illegal otaker";
 454   $self->otaker($1);
 455
 456   if ( $self->dbdef_table->column('manual_flag') ) {
 457     $self->manual_flag('') if $self->manual_flag eq ' ';
 458     $self->manual_flag =~ /^([01]?)$/
 459       or return "Illegal manual_flag ". $self->manual_flag;
 460     $self->manual_flag($1);
 461   }
 462
 463   $self->SUPER::check;
 464 }
 465
 466 =item cancel [ OPTION => VALUE ... ]
 467
 468 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
 469 in this package, then cancels the package itself (sets the cancel field to
 470 now).
 471
 472 Available options are:
 473
 474 =over 4
 475
 476 =item quiet - can be set true to supress email cancellation notices.
 477
 478 =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.
 479
 480 =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.
 481
 482 =item date - can be set to a unix style timestamp to specify when to cancel (expire)
 483
 484 =back
 485
 486 If there is an error, returns the error, otherwise returns false.
 487
 488 =cut
 489
 490 sub cancel {
 491   my( $self, %options ) = @_;
 492   my $error;
 493
 494   warn "cust_pkg::cancel called with options".
 495        join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
 496     if $DEBUG;
 497
 498   local $SIG{HUP} = 'IGNORE';
 499   local $SIG{INT} = 'IGNORE';
 500   local $SIG{QUIT} = 'IGNORE';
 501   local $SIG{TERM} = 'IGNORE';
 502   local $SIG{TSTP} = 'IGNORE';
 503   local $SIG{PIPE} = 'IGNORE';
 504
 505   my $oldAutoCommit = $FS::UID::AutoCommit;
 506   local $FS::UID::AutoCommit = 0;
 507   my $dbh = dbh;
 508
 509   my $old = $self->select_for_update;
 510
 511   if ( $old->get('cancel') || $self->get('cancel') ) {
 512     dbh->rollback if $oldAutoCommit;
 513     return "";  # no error
 514   }
 515
 516   my $date = $options{date} if $options{date}; # expire/cancel later
 517   $date = '' if ($date && $date <= time);      # complain instead?
 518
 519   my $cancel_time = $options{'time'} || time;
 520
 521   if ( $options{'reason'} ) {
 522     $error = $self->insert_reason( 'reason' => $options{'reason'},
 523                                    'action' => $date ? 'expire' : 'cancel',
 524                                    'reason_otaker' => $options{'reason_otaker'},
 525                                  );
 526     if ( $error ) {
 527       dbh->rollback if $oldAutoCommit;
 528       return "Error inserting cust_pkg_reason: $error";
 529     }
 530   }
 531
 532   my %svc;
 533   unless ( $date ) {
 534     foreach my $cust_svc (
 535       #schwartz
 536       map  { $_->[0] }
 537       sort { $a->[1] <=> $b->[1] }
 538       map  { [ $_, $_->svc_x->table_info->{'cancel_weight'} ]; }
 539       qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 540     ) {
 541
 542       my $error = $cust_svc->cancel;
 543
 544       if ( $error ) {
 545         $dbh->rollback if $oldAutoCommit;
 546         return "Error cancelling cust_svc: $error";
 547       }
 548     }
 549
 550     # Add a credit for remaining service
 551     my $remaining_value = $self->calc_remain(time=>$cancel_time);
 552     if ( $remaining_value > 0 && !$options{'no_credit'} ) {
 553       my $conf = new FS::Conf;
 554       my $error = $self->cust_main->credit(
 555         $remaining_value,
 556         'Credit for unused time on '. $self->part_pkg->pkg,
 557         'reason_type' => $conf->config('cancel_credit_type'),
 558       );
 559       if ($error) {
 560         $dbh->rollback if $oldAutoCommit;
 561         return "Error crediting customer \$$remaining_value for unused time on".
 562                $self->part_pkg->pkg. ": $error";
 563       }
 564     }
 565   }
 566
 567   my %hash = $self->hash;
 568   $date ? ($hash{'expire'} = $date) : ($hash{'cancel'} = $cancel_time);
 569   my $new = new FS::cust_pkg ( \%hash );
 570   $error = $new->replace( $self, options => { $self->options } );
 571   if ( $error ) {
 572     $dbh->rollback if $oldAutoCommit;
 573     return $error;
 574   }
 575
 576   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 577   return '' if $date; #no errors
 578
 579   my $conf = new FS::Conf;
 580   my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
 581   if ( !$options{'quiet'} && $conf->exists('emailcancel') && @invoicing_list ) {
 582     my $conf = new FS::Conf;
 583     my $error = send_email(
 584       'from'    => $conf->config('invoice_from'),
 585       'to'      => \@invoicing_list,
 586       'subject' => ( $conf->config('cancelsubject') || 'Cancellation Notice' ),
 587       'body'    => [ map "$_\n", $conf->config('cancelmessage') ],
 588     );
 589     #should this do something on errors?
 590   }
 591
 592   ''; #no errors
 593
 594 }
 595
 596 =item cancel_if_expired [ NOW_TIMESTAMP ]
 597
 598 Cancels this package if its expire date has been reached.
 599
 600 =cut
 601
 602 sub cancel_if_expired {
 603   my $self = shift;
 604   my $time = shift || time;
 605   return '' unless $self->expire && $self->expire <= $time;
 606   my $error = $self->cancel;
 607   if ( $error ) {
 608     return "Error cancelling expired pkg ". $self->pkgnum. " for custnum ".
 609            $self->custnum. ": $error";
 610   }
 611   '';
 612 }
 613
 614 =item unexpire
 615
 616 Cancels any pending expiration (sets the expire field to null).
 617
 618 If there is an error, returns the error, otherwise returns false.
 619
 620 =cut
 621
 622 sub unexpire {
 623   my( $self, %options ) = @_;
 624   my $error;
 625
 626   local $SIG{HUP} = 'IGNORE';
 627   local $SIG{INT} = 'IGNORE';
 628   local $SIG{QUIT} = 'IGNORE';
 629   local $SIG{TERM} = 'IGNORE';
 630   local $SIG{TSTP} = 'IGNORE';
 631   local $SIG{PIPE} = 'IGNORE';
 632
 633   my $oldAutoCommit = $FS::UID::AutoCommit;
 634   local $FS::UID::AutoCommit = 0;
 635   my $dbh = dbh;
 636
 637   my $old = $self->select_for_update;
 638
 639   my $pkgnum = $old->pkgnum;
 640   if ( $old->get('cancel') || $self->get('cancel') ) {
 641     dbh->rollback if $oldAutoCommit;
 642     return "Can't unexpire cancelled package $pkgnum";
 643     # or at least it's pointless
 644   }
 645
 646   unless ( $old->get('expire') && $self->get('expire') ) {
 647     dbh->rollback if $oldAutoCommit;
 648     return "";  # no error
 649   }
 650
 651   my %hash = $self->hash;
 652   $hash{'expire'} = '';
 653   my $new = new FS::cust_pkg ( \%hash );
 654   $error = $new->replace( $self, options => { $self->options } );
 655   if ( $error ) {
 656     $dbh->rollback if $oldAutoCommit;
 657     return $error;
 658   }
 659
 660   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 661
 662   ''; #no errors
 663
 664 }
 665
 666 =item suspend [ OPTION => VALUE ... ]
 667
 668 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 669 package, then suspends the package itself (sets the susp field to now).
 670
 671 Available options are:
 672
 673 =over 4
 674
 675 =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.
 676
 677 =item date - can be set to a unix style timestamp to specify when to suspend (adjourn)
 678
 679 =back
 680
 681 If there is an error, returns the error, otherwise returns false.
 682
 683 =cut
 684
 685 sub suspend {
 686   my( $self, %options ) = @_;
 687   my $error;
 688
 689   local $SIG{HUP} = 'IGNORE';
 690   local $SIG{INT} = 'IGNORE';
 691   local $SIG{QUIT} = 'IGNORE';
 692   local $SIG{TERM} = 'IGNORE';
 693   local $SIG{TSTP} = 'IGNORE';
 694   local $SIG{PIPE} = 'IGNORE';
 695
 696   my $oldAutoCommit = $FS::UID::AutoCommit;
 697   local $FS::UID::AutoCommit = 0;
 698   my $dbh = dbh;
 699
 700   my $old = $self->select_for_update;
 701
 702   my $pkgnum = $old->pkgnum;
 703   if ( $old->get('cancel') || $self->get('cancel') ) {
 704     dbh->rollback if $oldAutoCommit;
 705     return "Can't suspend cancelled package $pkgnum";
 706   }
 707
 708   if ( $old->get('susp') || $self->get('susp') ) {
 709     dbh->rollback if $oldAutoCommit;
 710     return "";  # no error                     # complain on adjourn?
 711   }
 712
 713   my $date = $options{date} if $options{date}; # adjourn/suspend later
 714   $date = '' if ($date && $date <= time);      # complain instead?
 715
 716   if ( $date && $old->get('expire') && $old->get('expire') < $date ) {
 717     dbh->rollback if $oldAutoCommit;
 718     return "Package $pkgnum expires before it would be suspended.";
 719   }
 720
 721   if ( $options{'reason'} ) {
 722     $error = $self->insert_reason( 'reason' => $options{'reason'},
 723                                    'action' => $date ? 'adjourn' : 'suspend',
 724                                    'reason_otaker' => $options{'reason_otaker'},
 725                                  );
 726     if ( $error ) {
 727       dbh->rollback if $oldAutoCommit;
 728       return "Error inserting cust_pkg_reason: $error";
 729     }
 730   }
 731
 732   unless ( $date ) {
 733     foreach my $cust_svc (
 734       qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 735     ) {
 736       my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 737
 738       $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 739         $dbh->rollback if $oldAutoCommit;
 740         return "Illegal svcdb value in part_svc!";
 741       };
 742       my $svcdb = $1;
 743       require "FS/$svcdb.pm";
 744
 745       my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
 746       if ($svc) {
 747         $error = $svc->suspend;
 748         if ( $error ) {
 749           $dbh->rollback if $oldAutoCommit;
 750           return $error;
 751         }
 752       }
 753     }
 754   }
 755
 756   my %hash = $self->hash;
 757   $date ? ($hash{'adjourn'} = $date) : ($hash{'susp'} = time);
 758   my $new = new FS::cust_pkg ( \%hash );
 759   $error = $new->replace( $self, options => { $self->options } );
 760   if ( $error ) {
 761     $dbh->rollback if $oldAutoCommit;
 762     return $error;
 763   }
 764
 765   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 766
 767   ''; #no errors
 768 }
 769
 770 =item unsuspend [ OPTION => VALUE ... ]
 771
 772 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 773 package, then unsuspends the package itself (clears the susp field and the
 774 adjourn field if it is in the past).
 775
 776 Available options are: I<adjust_next_bill>.
 777
 778 I<adjust_next_bill> can be set true to adjust the next bill date forward by
 779 the amount of time the account was inactive.  This was set true by default
 780 since 1.4.2 and 1.5.0pre6; however, starting with 1.7.0 this needs to be
 781 explicitly requested.  Price plans for which this makes sense (anniversary-date
 782 based than prorate or subscription) could have an option to enable this
 783 behaviour?
 784
 785 If there is an error, returns the error, otherwise returns false.
 786
 787 =cut
 788
 789 sub unsuspend {
 790   my( $self, %opt ) = @_;
 791   my $error;
 792
 793   local $SIG{HUP} = 'IGNORE';
 794   local $SIG{INT} = 'IGNORE';
 795   local $SIG{QUIT} = 'IGNORE';
 796   local $SIG{TERM} = 'IGNORE';
 797   local $SIG{TSTP} = 'IGNORE';
 798   local $SIG{PIPE} = 'IGNORE';
 799
 800   my $oldAutoCommit = $FS::UID::AutoCommit;
 801   local $FS::UID::AutoCommit = 0;
 802   my $dbh = dbh;
 803
 804   my $old = $self->select_for_update;
 805
 806   my $pkgnum = $old->pkgnum;
 807   if ( $old->get('cancel') || $self->get('cancel') ) {
 808     dbh->rollback if $oldAutoCommit;
 809     return "Can't unsuspend cancelled package $pkgnum";
 810   }
 811
 812   unless ( $old->get('susp') && $self->get('susp') ) {
 813     dbh->rollback if $oldAutoCommit;
 814     return "";  # no error                     # complain instead?
 815   }
 816
 817   foreach my $cust_svc (
 818     qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
 819   ) {
 820     my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 821
 822     $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 823       $dbh->rollback if $oldAutoCommit;
 824       return "Illegal svcdb value in part_svc!";
 825     };
 826     my $svcdb = $1;
 827     require "FS/$svcdb.pm";
 828
 829     my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
 830     if ($svc) {
 831       $error = $svc->unsuspend;
 832       if ( $error ) {
 833         $dbh->rollback if $oldAutoCommit;
 834         return $error;
 835       }
 836     }
 837
 838   }
 839
 840   my %hash = $self->hash;
 841   my $inactive = time - $hash{'susp'};
 842
 843   my $conf = new FS::Conf;
 844
 845   $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive
 846     if ( $opt{'adjust_next_bill'}
 847          || $conf->config('unsuspend-always_adjust_next_bill_date') )
 848     && $inactive > 0 && ( $hash{'bill'} || $hash{'setup'} );
 849
 850   $hash{'susp'} = '';
 851   $hash{'adjourn'} = '' if $hash{'adjourn'} < time;
 852   my $new = new FS::cust_pkg ( \%hash );
 853   $error = $new->replace( $self, options => { $self->options } );
 854   if ( $error ) {
 855     $dbh->rollback if $oldAutoCommit;
 856     return $error;
 857   }
 858
 859   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 860
 861   ''; #no errors
 862 }
 863
 864 =item unadjourn
 865
 866 Cancels any pending suspension (sets the adjourn field to null).
 867
 868 If there is an error, returns the error, otherwise returns false.
 869
 870 =cut
 871
 872 sub unadjourn {
 873   my( $self, %options ) = @_;
 874   my $error;
 875
 876   local $SIG{HUP} = 'IGNORE';
 877   local $SIG{INT} = 'IGNORE';
 878   local $SIG{QUIT} = 'IGNORE';
 879   local $SIG{TERM} = 'IGNORE';
 880   local $SIG{TSTP} = 'IGNORE';
 881   local $SIG{PIPE} = 'IGNORE';
 882
 883   my $oldAutoCommit = $FS::UID::AutoCommit;
 884   local $FS::UID::AutoCommit = 0;
 885   my $dbh = dbh;
 886
 887   my $old = $self->select_for_update;
 888
 889   my $pkgnum = $old->pkgnum;
 890   if ( $old->get('cancel') || $self->get('cancel') ) {
 891     dbh->rollback if $oldAutoCommit;
 892     return "Can't unadjourn cancelled package $pkgnum";
 893     # or at least it's pointless
 894   }
 895
 896   if ( $old->get('susp') || $self->get('susp') ) {
 897     dbh->rollback if $oldAutoCommit;
 898     return "Can't unadjourn suspended package $pkgnum";
 899     # perhaps this is arbitrary
 900   }
 901
 902   unless ( $old->get('adjourn') && $self->get('adjourn') ) {
 903     dbh->rollback if $oldAutoCommit;
 904     return "";  # no error
 905   }
 906
 907   my %hash = $self->hash;
 908   $hash{'adjourn'} = '';
 909   my $new = new FS::cust_pkg ( \%hash );
 910   $error = $new->replace( $self, options => { $self->options } );
 911   if ( $error ) {
 912     $dbh->rollback if $oldAutoCommit;
 913     return $error;
 914   }
 915
 916   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 917
 918   ''; #no errors
 919
 920 }
 921
 922 =item last_bill
 923
 924 Returns the last bill date, or if there is no last bill date, the setup date.
 925 Useful for billing metered services.
 926
 927 =cut
 928
 929 sub last_bill {
 930   my $self = shift;
 931   return $self->setfield('last_bill', $_[0]) if @_;
 932   return $self->getfield('last_bill') if $self->getfield('last_bill');
 933   my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
 934                                                   'edate'  => $self->bill,  } );
 935   $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
 936 }
 937
 938 =item last_cust_pkg_reason ACTION
 939
 940 Returns the most recent ACTION FS::cust_pkg_reason associated with the package.
 941 Returns false if there is no reason or the package is not currenly ACTION'd
 942 ACTION is one of adjourn, susp, cancel, or expire.
 943
 944 =cut
 945
 946 sub last_cust_pkg_reason {
 947   my ( $self, $action ) = ( shift, shift );
 948   my $date = $self->get($action);
 949   qsearchs( {
 950               'table' => 'cust_pkg_reason',
 951               'hashref' => { 'pkgnum' => $self->pkgnum,
 952                              'action' => substr(uc($action), 0, 1),
 953                              'date'   => $date,
 954                            },
 955               'order_by' => 'ORDER BY num DESC LIMIT 1',
 956            } );
 957 }
 958
 959 =item last_reason ACTION
 960
 961 Returns the most recent ACTION FS::reason associated with the package.
 962 Returns false if there is no reason or the package is not currenly ACTION'd
 963 ACTION is one of adjourn, susp, cancel, or expire.
 964
 965 =cut
 966
 967 sub last_reason {
 968   my $cust_pkg_reason = shift->last_cust_pkg_reason(@_);
 969   $cust_pkg_reason->reason
 970     if $cust_pkg_reason;
 971 }
 972
 973 =item part_pkg
 974
 975 Returns the definition for this billing item, as an FS::part_pkg object (see
 976 L<FS::part_pkg>).
 977
 978 =cut
 979
 980 sub part_pkg {
 981   my $self = shift;
 982   #exists( $self->{'_pkgpart'} )
 983   $self->{'_pkgpart'}
 984     ? $self->{'_pkgpart'}
 985     : qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
 986 }
 987
 988 =item old_cust_pkg
 989
 990 Returns the cancelled package this package was changed from, if any.
 991
 992 =cut
 993
 994 sub old_cust_pkg {
 995   my $self = shift;
 996   return '' unless $self->change_pkgnum;
 997   qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
 998 }
 999
1000 =item calc_setup
1001
1002 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
1003 item.
1004
1005 =cut
1006
1007 sub calc_setup {
1008   my $self = shift;
1009   $self->part_pkg->calc_setup($self, @_);
1010 }
1011
1012 =item calc_recur
1013
1014 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
1015 item.
1016
1017 =cut
1018
1019 sub calc_recur {
1020   my $self = shift;
1021   $self->part_pkg->calc_recur($self, @_);
1022 }
1023
1024 =item calc_remain
1025
1026 Calls the I<calc_remain> of the FS::part_pkg object associated with this
1027 billing item.
1028
1029 =cut
1030
1031 sub calc_remain {
1032   my $self = shift;
1033   $self->part_pkg->calc_remain($self, @_);
1034 }
1035
1036 =item calc_cancel
1037
1038 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
1039 billing item.
1040
1041 =cut
1042
1043 sub calc_cancel {
1044   my $self = shift;
1045   $self->part_pkg->calc_cancel($self, @_);
1046 }
1047
1048 =item cust_bill_pkg
1049
1050 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
1051
1052 =cut
1053
1054 sub cust_bill_pkg {
1055   my $self = shift;
1056   qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
1057 }
1058
1059 =item cust_event
1060
1061 Returns the new-style customer billing events (see L<FS::cust_event>) for this invoice.
1062
1063 =cut
1064
1065 #false laziness w/cust_bill.pm
1066 sub cust_event {
1067   my $self = shift;
1068   qsearch({
1069     'table'     => 'cust_event',
1070     'addl_from' => 'JOIN part_event USING ( eventpart )',
1071     'hashref'   => { 'tablenum' => $self->pkgnum },
1072     'extra_sql' => " AND eventtable = 'cust_pkg' ",
1073   });
1074 }
1075
1076 =item num_cust_event
1077
1078 Returns the number of new-style customer billing events (see L<FS::cust_event>) for this invoice.
1079
1080 =cut
1081
1082 #false laziness w/cust_bill.pm
1083 sub num_cust_event {
1084   my $self = shift;
1085   my $sql =
1086     "SELECT COUNT(*) FROM cust_event JOIN part_event USING ( eventpart ) ".
1087     "  WHERE tablenum = ? AND eventtable = 'cust_pkg'";
1088   my $sth = dbh->prepare($sql) or die  dbh->errstr. " preparing $sql";
1089   $sth->execute($self->pkgnum) or die $sth->errstr. " executing $sql";
1090   $sth->fetchrow_arrayref->[0];
1091 }
1092
1093 =item cust_svc [ SVCPART ]
1094
1095 Returns the services for this package, as FS::cust_svc objects (see
1096 L<FS::cust_svc>).  If a svcpart is specified, return only the matching
1097 services.
1098
1099 =cut
1100
1101 sub cust_svc {
1102   my $self = shift;
1103
1104   if ( @_ ) {
1105     return qsearch( 'cust_svc', { 'pkgnum'  => $self->pkgnum,
1106                                   'svcpart' => shift,          } );
1107   }
1108
1109   #if ( $self->{'_svcnum'} ) {
1110   #  values %{ $self->{'_svcnum'}->cache };
1111   #} else {
1112     $self->_sort_cust_svc(
1113       [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
1114     );
1115   #}
1116
1117 }
1118
1119 =item overlimit [ SVCPART ]
1120
1121 Returns the services for this package which have exceeded their
1122 usage limit as FS::cust_svc objects (see L<FS::cust_svc>).  If a svcpart
1123 is specified, return only the matching services.
1124
1125 =cut
1126
1127 sub overlimit {
1128   my $self = shift;
1129   grep { $_->overlimit } $self->cust_svc;
1130 }
1131
1132 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ]
1133
1134 Returns historical services for this package created before END TIMESTAMP and
1135 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
1136 (see L<FS::h_cust_svc>).
1137
1138 =cut
1139
1140 sub h_cust_svc {
1141   my $self = shift;
1142
1143   $self->_sort_cust_svc(
1144     [ qsearch( 'h_cust_svc',
1145                { 'pkgnum' => $self->pkgnum, },
1146                FS::h_cust_svc->sql_h_search(@_),
1147              )
1148     ]
1149   );
1150 }
1151
1152 sub _sort_cust_svc {
1153   my( $self, $arrayref ) = @_;
1154
1155   map  { $_->[0] }
1156   sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
1157   map {
1158         my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
1159                                              'svcpart' => $_->svcpart     } );
1160         [ $_,
1161           $pkg_svc ? $pkg_svc->primary_svc : '',
1162           $pkg_svc ? $pkg_svc->quantity : 0,
1163         ];
1164       }
1165   @$arrayref;
1166
1167 }
1168
1169 =item num_cust_svc [ SVCPART ]
1170
1171 Returns the number of provisioned services for this package.  If a svcpart is
1172 specified, counts only the matching services.
1173
1174 =cut
1175
1176 sub num_cust_svc {
1177   my $self = shift;
1178   my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
1179   $sql .= ' AND svcpart = ?' if @_;
1180   my $sth = dbh->prepare($sql) or die dbh->errstr;
1181   $sth->execute($self->pkgnum, @_) or die $sth->errstr;
1182   $sth->fetchrow_arrayref->[0];
1183 }
1184
1185 =item available_part_svc
1186
1187 Returns a list of FS::part_svc objects representing services included in this
1188 package but not yet provisioned.  Each FS::part_svc object also has an extra
1189 field, I<num_avail>, which specifies the number of available services.
1190
1191 =cut
1192
1193 sub available_part_svc {
1194   my $self = shift;
1195   grep { $_->num_avail > 0 }
1196     map {
1197           my $part_svc = $_->part_svc;
1198           $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
1199             $_->quantity - $self->num_cust_svc($_->svcpart);
1200           $part_svc;
1201         }
1202       $self->part_pkg->pkg_svc;
1203 }
1204
1205 =item part_svc
1206
1207 Returns a list of FS::part_svc objects representing provisioned and available
1208 services included in this package.  Each FS::part_svc object also has the
1209 following extra fields:
1210
1211 =over 4
1212
1213 =item num_cust_svc  (count)
1214
1215 =item num_avail     (quantity - count)
1216
1217 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
1218
1219 svcnum
1220 label -> ($cust_svc->label)[1]
1221
1222 =back
1223
1224 =cut
1225
1226 sub part_svc {
1227   my $self = shift;
1228
1229   #XXX some sort of sort order besides numeric by svcpart...
1230   my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
1231     my $pkg_svc = $_;
1232     my $part_svc = $pkg_svc->part_svc;
1233     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1234     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
1235     $part_svc->{'Hash'}{'num_avail'}    =
1236       max( 0, $pkg_svc->quantity - $num_cust_svc );
1237     $part_svc->{'Hash'}{'cust_pkg_svc'} = [ $self->cust_svc($part_svc->svcpart) ];
1238     $part_svc;
1239   } $self->part_pkg->pkg_svc;
1240
1241   #extras
1242   push @part_svc, map {
1243     my $part_svc = $_;
1244     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1245     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
1246     $part_svc->{'Hash'}{'num_avail'}    = 0; #0-$num_cust_svc ?
1247     $part_svc->{'Hash'}{'cust_pkg_svc'} = [ $self->cust_svc($part_svc->svcpart) ];
1248     $part_svc;
1249   } $self->extra_part_svc;
1250
1251   @part_svc;
1252
1253 }
1254
1255 =item extra_part_svc
1256
1257 Returns a list of FS::part_svc objects corresponding to services in this
1258 package which are still provisioned but not (any longer) available in the
1259 package definition.
1260
1261 =cut
1262
1263 sub extra_part_svc {
1264   my $self = shift;
1265
1266   my $pkgnum  = $self->pkgnum;
1267   my $pkgpart = $self->pkgpart;
1268
1269   qsearch( {
1270     'table'     => 'part_svc',
1271     'hashref'   => {},
1272     'extra_sql' => "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
1273                                   WHERE pkg_svc.svcpart = part_svc.svcpart
1274                                     AND pkg_svc.pkgpart = $pkgpart
1275                                     AND quantity > 0
1276                               )
1277                       AND 0 < ( SELECT count(*)
1278                                   FROM cust_svc
1279                                     LEFT JOIN cust_pkg using ( pkgnum )
1280                                   WHERE cust_svc.svcpart = part_svc.svcpart
1281                                     AND pkgnum = $pkgnum
1282                               )",
1283   } );
1284 }
1285
1286 =item status
1287
1288 Returns a short status string for this package, currently:
1289
1290 =over 4
1291
1292 =item not yet billed
1293
1294 =item one-time charge
1295
1296 =item active
1297
1298 =item suspended
1299
1300 =item cancelled
1301
1302 =back
1303
1304 =cut
1305
1306 sub status {
1307   my $self = shift;
1308
1309   my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
1310
1311   return 'cancelled' if $self->get('cancel');
1312   return 'suspended' if $self->susp;
1313   return 'not yet billed' unless $self->setup;
1314   return 'one-time charge' if $freq =~ /^(0|$)/;
1315   return 'active';
1316 }
1317
1318 =item statuses
1319
1320 Class method that returns the list of possible status strings for packages
1321 (see L<the status method|/status>).  For example:
1322
1323   @statuses = FS::cust_pkg->statuses();
1324
1325 =cut
1326
1327 tie my %statuscolor, 'Tie::IxHash',
1328   'not yet billed'  => '000000',
1329   'one-time charge' => '000000',
1330   'active'          => '00CC00',
1331   'suspended'       => 'FF9900',
1332   'cancelled'       => 'FF0000',
1333 ;
1334
1335 sub statuses {
1336   my $self = shift; #could be class...
1337   grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
1338                                       # mayble split btw one-time vs. recur
1339     keys %statuscolor;
1340 }
1341
1342 =item statuscolor
1343
1344 Returns a hex triplet color string for this package's status.
1345
1346 =cut
1347
1348 sub statuscolor {
1349   my $self = shift;
1350   $statuscolor{$self->status};
1351 }
1352
1353 =item labels
1354
1355 Returns a list of lists, calling the label method for all services
1356 (see L<FS::cust_svc>) of this billing item.
1357
1358 =cut
1359
1360 sub labels {
1361   my $self = shift;
1362   map { [ $_->label ] } $self->cust_svc;
1363 }
1364
1365 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
1366
1367 Like the labels method, but returns historical information on services that
1368 were active as of END_TIMESTAMP and (optionally) not cancelled before
1369 START_TIMESTAMP.
1370
1371 Returns a list of lists, calling the label method for all (historical) services
1372 (see L<FS::h_cust_svc>) of this billing item.
1373
1374 =cut
1375
1376 sub h_labels {
1377   my $self = shift;
1378   map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
1379 }
1380
1381 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
1382
1383 Like h_labels, except returns a simple flat list, and shortens long
1384 (currently >5) lists of identical services to one line that lists the service
1385 label and the number of individual services rather than individual items.
1386
1387 =cut
1388
1389 sub h_labels_short {
1390   my $self = shift;
1391
1392   my %labels;
1393   #tie %labels, 'Tie::IxHash';
1394   push @{ $labels{$_->[0]} }, $_->[1]
1395     foreach $self->h_labels(@_);
1396   my @labels;
1397   foreach my $label ( keys %labels ) {
1398     my @values = @{ $labels{$label} };
1399     my $num = scalar(@values);
1400     if ( $num > 5 ) {
1401       push @labels, "$label ($num)";
1402     } else {
1403       push @labels, map { "$label: $_" } @values;
1404     }
1405   }
1406
1407  @labels;
1408
1409 }
1410
1411 =item cust_main
1412
1413 Returns the parent customer object (see L<FS::cust_main>).
1414
1415 =cut
1416
1417 sub cust_main {
1418   my $self = shift;
1419   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
1420 }
1421
1422 =item seconds_since TIMESTAMP
1423
1424 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
1425 package have been online since TIMESTAMP, according to the session monitor.
1426
1427 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1428 L<Time::Local> and L<Date::Parse> for conversion functions.
1429
1430 =cut
1431
1432 sub seconds_since {
1433   my($self, $since) = @_;
1434   my $seconds = 0;
1435
1436   foreach my $cust_svc (
1437     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
1438   ) {
1439     $seconds += $cust_svc->seconds_since($since);
1440   }
1441
1442   $seconds;
1443
1444 }
1445
1446 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1447
1448 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
1449 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
1450 (exclusive).
1451
1452 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1453 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1454 functions.
1455
1456
1457 =cut
1458
1459 sub seconds_since_sqlradacct {
1460   my($self, $start, $end) = @_;
1461
1462   my $seconds = 0;
1463
1464   foreach my $cust_svc (
1465     grep {
1466       my $part_svc = $_->part_svc;
1467       $part_svc->svcdb eq 'svc_acct'
1468         && scalar($part_svc->part_export('sqlradius'));
1469     } $self->cust_svc
1470   ) {
1471     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
1472   }
1473
1474   $seconds;
1475
1476 }
1477
1478 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1479
1480 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1481 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1482 TIMESTAMP_END
1483 (exclusive).
1484
1485 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1486 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1487 functions.
1488
1489 =cut
1490
1491 sub attribute_since_sqlradacct {
1492   my($self, $start, $end, $attrib) = @_;
1493
1494   my $sum = 0;
1495
1496   foreach my $cust_svc (
1497     grep {
1498       my $part_svc = $_->part_svc;
1499       $part_svc->svcdb eq 'svc_acct'
1500         && scalar($part_svc->part_export('sqlradius'));
1501     } $self->cust_svc
1502   ) {
1503     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
1504   }
1505
1506   $sum;
1507
1508 }
1509
1510 =item quantity
1511
1512 =cut
1513
1514 sub quantity {
1515   my( $self, $value ) = @_;
1516   if ( defined($value) ) {
1517     $self->setfield('quantity', $value);
1518   }
1519   $self->getfield('quantity') || 1;
1520 }
1521
1522 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
1523
1524 Transfers as many services as possible from this package to another package.
1525
1526 The destination package can be specified by pkgnum by passing an FS::cust_pkg
1527 object.  The destination package must already exist.
1528
1529 Services are moved only if the destination allows services with the correct
1530 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
1531 this option with caution!  No provision is made for export differences
1532 between the old and new service definitions.  Probably only should be used
1533 when your exports for all service definitions of a given svcdb are identical.
1534 (attempt a transfer without it first, to move all possible svcpart-matching
1535 services)
1536
1537 Any services that can't be moved remain in the original package.
1538
1539 Returns an error, if there is one; otherwise, returns the number of services
1540 that couldn't be moved.
1541
1542 =cut
1543
1544 sub transfer {
1545   my ($self, $dest_pkgnum, %opt) = @_;
1546
1547   my $remaining = 0;
1548   my $dest;
1549   my %target;
1550
1551   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
1552     $dest = $dest_pkgnum;
1553     $dest_pkgnum = $dest->pkgnum;
1554   } else {
1555     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
1556   }
1557
1558   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
1559
1560   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
1561     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
1562   }
1563
1564   foreach my $cust_svc ($dest->cust_svc) {
1565     $target{$cust_svc->svcpart}--;
1566   }
1567
1568   my %svcpart2svcparts = ();
1569   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1570     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
1571     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
1572       next if exists $svcpart2svcparts{$svcpart};
1573       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
1574       $svcpart2svcparts{$svcpart} = [
1575         map  { $_->[0] }
1576         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
1577         map {
1578               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
1579                                                    'svcpart' => $_          } );
1580               [ $_,
1581                 $pkg_svc ? $pkg_svc->primary_svc : '',
1582                 $pkg_svc ? $pkg_svc->quantity : 0,
1583               ];
1584             }
1585
1586         grep { $_ != $svcpart }
1587         map  { $_->svcpart }
1588         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
1589       ];
1590       warn "alternates for svcpart $svcpart: ".
1591            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
1592         if $DEBUG;
1593     }
1594   }
1595
1596   foreach my $cust_svc ($self->cust_svc) {
1597     if($target{$cust_svc->svcpart} > 0) {
1598       $target{$cust_svc->svcpart}--;
1599       my $new = new FS::cust_svc { $cust_svc->hash };
1600       $new->pkgnum($dest_pkgnum);
1601       my $error = $new->replace($cust_svc);
1602       return $error if $error;
1603     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1604       if ( $DEBUG ) {
1605         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
1606         warn "alternates to consider: ".
1607              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
1608       }
1609       my @alternate = grep {
1610                              warn "considering alternate svcpart $_: ".
1611                                   "$target{$_} available in new package\n"
1612                                if $DEBUG;
1613                              $target{$_} > 0;
1614                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
1615       if ( @alternate ) {
1616         warn "alternate(s) found\n" if $DEBUG;
1617         my $change_svcpart = $alternate[0];
1618         $target{$change_svcpart}--;
1619         my $new = new FS::cust_svc { $cust_svc->hash };
1620         $new->svcpart($change_svcpart);
1621         $new->pkgnum($dest_pkgnum);
1622         my $error = $new->replace($cust_svc);
1623         return $error if $error;
1624       } else {
1625         $remaining++;
1626       }
1627     } else {
1628       $remaining++
1629     }
1630   }
1631   return $remaining;
1632 }
1633
1634 =item reexport
1635
1636 This method is deprecated.  See the I<depend_jobnum> option to the insert and
1637 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
1638
1639 =cut
1640
1641 sub reexport {
1642   my $self = shift;
1643
1644   local $SIG{HUP} = 'IGNORE';
1645   local $SIG{INT} = 'IGNORE';
1646   local $SIG{QUIT} = 'IGNORE';
1647   local $SIG{TERM} = 'IGNORE';
1648   local $SIG{TSTP} = 'IGNORE';
1649   local $SIG{PIPE} = 'IGNORE';
1650
1651   my $oldAutoCommit = $FS::UID::AutoCommit;
1652   local $FS::UID::AutoCommit = 0;
1653   my $dbh = dbh;
1654
1655   foreach my $cust_svc ( $self->cust_svc ) {
1656     #false laziness w/svc_Common::insert
1657     my $svc_x = $cust_svc->svc_x;
1658     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
1659       my $error = $part_export->export_insert($svc_x);
1660       if ( $error ) {
1661         $dbh->rollback if $oldAutoCommit;
1662         return $error;
1663       }
1664     }
1665   }
1666
1667   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1668   '';
1669
1670 }
1671
1672 =back
1673
1674 =head1 CLASS METHODS
1675
1676 =over 4
1677
1678 =item recurring_sql
1679
1680 Returns an SQL expression identifying recurring packages.
1681
1682 =cut
1683
1684 sub recurring_sql { "
1685   '0' != ( select freq from part_pkg
1686              where cust_pkg.pkgpart = part_pkg.pkgpart )
1687 "; }
1688
1689 =item onetime_sql
1690
1691 Returns an SQL expression identifying one-time packages.
1692
1693 =cut
1694
1695 sub onetime_sql { "
1696   '0' = ( select freq from part_pkg
1697             where cust_pkg.pkgpart = part_pkg.pkgpart )
1698 "; }
1699
1700 =item active_sql
1701
1702 Returns an SQL expression identifying active packages.
1703
1704 =cut
1705
1706 sub active_sql { "
1707   ". $_[0]->recurring_sql(). "
1708   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1709   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
1710 "; }
1711
1712 =item inactive_sql
1713
1714 Returns an SQL expression identifying inactive packages (one-time packages
1715 that are otherwise unsuspended/uncancelled).
1716
1717 =cut
1718
1719 sub inactive_sql { "
1720   ". $_[0]->onetime_sql(). "
1721   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1722   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
1723 "; }
1724
1725 =item susp_sql
1726 =item suspended_sql
1727
1728 Returns an SQL expression identifying suspended packages.
1729
1730 =cut
1731
1732 sub suspended_sql { susp_sql(@_); }
1733 sub susp_sql {
1734   #$_[0]->recurring_sql(). ' AND '.
1735   "
1736         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
1737     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
1738   ";
1739 }
1740
1741 =item cancel_sql
1742 =item cancelled_sql
1743
1744 Returns an SQL exprression identifying cancelled packages.
1745
1746 =cut
1747
1748 sub cancelled_sql { cancel_sql(@_); }
1749 sub cancel_sql {
1750   #$_[0]->recurring_sql(). ' AND '.
1751   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
1752 }
1753
1754 =item search_sql HASHREF
1755
1756 (Class method)
1757
1758 Returns a qsearch hash expression to search for parameters specified in HASHREF.
1759 Valid parameters are
1760
1761 =over 4
1762
1763 =item agentnum
1764
1765 =item magic
1766
1767 active, inactive, suspended, cancel (or cancelled)
1768
1769 =item status
1770
1771 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
1772
1773 =item classnum
1774
1775 =item pkgpart
1776
1777 list specified how?
1778
1779 =item setup
1780
1781 arrayref of beginning and ending epoch date
1782
1783 =item last_bill
1784
1785 arrayref of beginning and ending epoch date
1786
1787 =item bill
1788
1789 arrayref of beginning and ending epoch date
1790
1791 =item adjourn
1792
1793 arrayref of beginning and ending epoch date
1794
1795 =item susp
1796
1797 arrayref of beginning and ending epoch date
1798
1799 =item expire
1800
1801 arrayref of beginning and ending epoch date
1802
1803 =item cancel
1804
1805 arrayref of beginning and ending epoch date
1806
1807 =item query
1808
1809 pkgnum or APKG_pkgnum
1810
1811 =item cust_fields
1812
1813 a value suited to passing to FS::UI::Web::cust_header
1814
1815 =item CurrentUser
1816
1817 specifies the user for agent virtualization
1818
1819 =back
1820
1821 =cut
1822
1823 sub search_sql {
1824   my ($class, $params) = @_;
1825   my @where = ();
1826
1827   ##
1828   # parse agent
1829   ##
1830
1831   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
1832     push @where,
1833       "cust_main.agentnum = $1";
1834   }
1835
1836   ##
1837   # parse status
1838   ##
1839
1840   if (    $params->{'magic'}  eq 'active'
1841        || $params->{'status'} eq 'active' ) {
1842
1843     push @where, FS::cust_pkg->active_sql();
1844
1845   } elsif (    $params->{'magic'}  eq 'inactive'
1846             || $params->{'status'} eq 'inactive' ) {
1847
1848     push @where, FS::cust_pkg->inactive_sql();
1849
1850   } elsif (    $params->{'magic'}  eq 'suspended'
1851             || $params->{'status'} eq 'suspended'  ) {
1852
1853     push @where, FS::cust_pkg->suspended_sql();
1854
1855   } elsif (    $params->{'magic'}  =~ /^cancell?ed$/
1856             || $params->{'status'} =~ /^cancell?ed$/ ) {
1857
1858     push @where, FS::cust_pkg->cancelled_sql();
1859
1860   } elsif ( $params->{'status'} =~ /^(one-time charge|inactive)$/ ) {
1861
1862     push @where, FS::cust_pkg->inactive_sql();
1863
1864   }
1865
1866   ###
1867   # parse package class
1868   ###
1869
1870   #false lazinessish w/graph/cust_bill_pkg.cgi
1871   my $classnum = 0;
1872   my @pkg_class = ();
1873   if ( exists($params->{'classnum'})
1874        && $params->{'classnum'} =~ /^(\d*)$/
1875      )
1876   {
1877     $classnum = $1;
1878     if ( $classnum ) { #a specific class
1879       push @where, "classnum = $classnum";
1880
1881       #@pkg_class = ( qsearchs('pkg_class', { 'classnum' => $classnum } ) );
1882       #die "classnum $classnum not found!" unless $pkg_class[0];
1883       #$title .= $pkg_class[0]->classname.' ';
1884
1885     } elsif ( $classnum eq '' ) { #the empty class
1886
1887       push @where, "classnum IS NULL";
1888       #$title .= 'Empty class ';
1889       #@pkg_class = ( '(empty class)' );
1890     } elsif ( $classnum eq '0' ) {
1891       #@pkg_class = qsearch('pkg_class', {} ); # { 'disabled' => '' } );
1892       #push @pkg_class, '(empty class)';
1893     } else {
1894       die "illegal classnum";
1895     }
1896   }
1897   #eslaf
1898
1899   ###
1900   # parse part_pkg
1901   ###
1902
1903   my $pkgpart = join (' OR pkgpart=',
1904                       grep {$_} map { /^(\d+)$/; } ($params->{'pkgpart'}));
1905   push @where,  '(pkgpart=' . $pkgpart . ')' if $pkgpart;
1906
1907   ###
1908   # parse dates
1909   ###
1910
1911   my $orderby = '';
1912
1913   #false laziness w/report_cust_pkg.html
1914   my %disable = (
1915     'all'             => {},
1916     'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
1917     'active'          => { 'susp'=>1, 'cancel'=>1 },
1918     'suspended'       => { 'cancel' => 1 },
1919     'cancelled'       => {},
1920     ''                => {},
1921   );
1922
1923   foreach my $field (qw( setup last_bill bill adjourn susp expire cancel )) {
1924
1925     next unless exists($params->{$field});
1926
1927     my($beginning, $ending) = @{$params->{$field}};
1928
1929     next if $beginning == 0 && $ending == 4294967295;
1930
1931     push @where,
1932       "cust_pkg.$field IS NOT NULL",
1933       "cust_pkg.$field >= $beginning",
1934       "cust_pkg.$field <= $ending";
1935
1936     $orderby ||= "ORDER BY cust_pkg.$field";
1937
1938   }
1939
1940   $orderby ||= 'ORDER BY bill';
1941
1942   ###
1943   # parse magic, legacy, etc.
1944   ###
1945
1946   if ( $params->{'magic'} &&
1947        $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
1948   ) {
1949
1950     $orderby = 'ORDER BY pkgnum';
1951
1952     if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
1953       push @where, "pkgpart = $1";
1954     }
1955
1956   } elsif ( $params->{'query'} eq 'pkgnum' ) {
1957
1958     $orderby = 'ORDER BY pkgnum';
1959
1960   } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
1961
1962     $orderby = 'ORDER BY pkgnum';
1963
1964     push @where, '0 < (
1965       SELECT count(*) FROM pkg_svc
1966        WHERE pkg_svc.pkgpart =  cust_pkg.pkgpart
1967          AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
1968                                    WHERE cust_svc.pkgnum  = cust_pkg.pkgnum
1969                                      AND cust_svc.svcpart = pkg_svc.svcpart
1970                                 )
1971     )';
1972
1973   }
1974
1975   ##
1976   # setup queries, links, subs, etc. for the search
1977   ##
1978
1979   # here is the agent virtualization
1980   if ($params->{CurrentUser}) {
1981     my $access_user =
1982       qsearchs('access_user', { username => $params->{CurrentUser} });
1983
1984     if ($access_user) {
1985       push @where, $access_user->agentnums_sql('table'=>'cust_main');
1986     }else{
1987       push @where, "1=0";
1988     }
1989   }else{
1990     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
1991   }
1992
1993   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
1994
1995   my $addl_from = 'LEFT JOIN cust_main USING ( custnum  ) '.
1996                   'LEFT JOIN part_pkg  USING ( pkgpart  ) '.
1997                   'LEFT JOIN pkg_class USING ( classnum ) ';
1998
1999   my $count_query = "SELECT COUNT(*) FROM cust_pkg $addl_from $extra_sql";
2000
2001   my $sql_query = {
2002     'table'       => 'cust_pkg',
2003     'hashref'     => {},
2004     'select'      => join(', ',
2005                                 'cust_pkg.*',
2006                                 ( map "part_pkg.$_", qw( pkg freq ) ),
2007                                 'pkg_class.classname',
2008                                 'cust_main.custnum as cust_main_custnum',
2009                                 FS::UI::Web::cust_sql_fields(
2010                                   $params->{'cust_fields'}
2011                                 ),
2012                      ),
2013     'extra_sql'   => "$extra_sql $orderby",
2014     'addl_from'   => $addl_from,
2015     'count_query' => $count_query,
2016   };
2017
2018 }
2019
2020 =head1 SUBROUTINES
2021
2022 =over 4
2023
2024 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
2025
2026 CUSTNUM is a customer (see L<FS::cust_main>)
2027
2028 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
2029 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
2030 permitted.
2031
2032 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
2033 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
2034 new billing items.  An error is returned if this is not possible (see
2035 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
2036 parameter.
2037
2038 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
2039 newly-created cust_pkg objects.
2040
2041 REFNUM, if specified, will specify the FS::pkg_referral record to be created
2042 and inserted.  Multiple FS::pkg_referral records can be created by
2043 setting I<refnum> to an array reference of refnums or a hash reference with
2044 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
2045 record will be created corresponding to cust_main.refnum.
2046
2047 =cut
2048
2049 sub order {
2050   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
2051
2052   my $conf = new FS::Conf;
2053
2054   # Transactionize this whole mess
2055   local $SIG{HUP} = 'IGNORE';
2056   local $SIG{INT} = 'IGNORE';
2057   local $SIG{QUIT} = 'IGNORE';
2058   local $SIG{TERM} = 'IGNORE';
2059   local $SIG{TSTP} = 'IGNORE';
2060   local $SIG{PIPE} = 'IGNORE';
2061
2062   my $oldAutoCommit = $FS::UID::AutoCommit;
2063   local $FS::UID::AutoCommit = 0;
2064   my $dbh = dbh;
2065
2066   my $error;
2067   my $cust_main = qsearchs('cust_main', { custnum => $custnum });
2068   return "Customer not found: $custnum" unless $cust_main;
2069
2070   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
2071                          @$remove_pkgnum;
2072
2073   my $change = scalar(@old_cust_pkg) != 0;
2074
2075   my %hash = ();
2076   if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
2077
2078     my $time = time;
2079
2080     #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( last_bill bill );
2081
2082     #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( setup );
2083     $hash{'setup'} = $time if $old_cust_pkg[0]->setup;
2084
2085     $hash{'change_date'} = $time;
2086     $hash{"change_$_"}  = $old_cust_pkg[0]->$_() foreach qw( pkgnum pkgpart );
2087   }
2088
2089   # Create the new packages.
2090   foreach my $pkgpart (@$pkgparts) {
2091     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
2092                                       pkgpart => $pkgpart,
2093                                       refnum  => $refnum,
2094                                       %hash,
2095                                     };
2096     $error = $cust_pkg->insert( 'change' => $change );
2097     if ($error) {
2098       $dbh->rollback if $oldAutoCommit;
2099       return $error;
2100     }
2101     push @$return_cust_pkg, $cust_pkg;
2102   }
2103   # $return_cust_pkg now contains refs to all of the newly
2104   # created packages.
2105
2106   # Transfer services and cancel old packages.
2107   foreach my $old_pkg (@old_cust_pkg) {
2108
2109     foreach my $new_pkg (@$return_cust_pkg) {
2110       $error = $old_pkg->transfer($new_pkg);
2111       if ($error and $error == 0) {
2112         # $old_pkg->transfer failed.
2113         $dbh->rollback if $oldAutoCommit;
2114         return $error;
2115       }
2116     }
2117
2118     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
2119       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
2120       foreach my $new_pkg (@$return_cust_pkg) {
2121         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
2122         if ($error and $error == 0) {
2123           # $old_pkg->transfer failed.
2124         $dbh->rollback if $oldAutoCommit;
2125         return $error;
2126         }
2127       }
2128     }
2129
2130     if ($error > 0) {
2131       # Transfers were successful, but we went through all of the
2132       # new packages and still had services left on the old package.
2133       # We can't cancel the package under the circumstances, so abort.
2134       $dbh->rollback if $oldAutoCommit;
2135       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
2136     }
2137     $error = $old_pkg->cancel( quiet=>1 );
2138     if ($error) {
2139       $dbh->rollback;
2140       return $error;
2141     }
2142   }
2143   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2144   '';
2145 }
2146
2147 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
2148
2149 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
2150 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
2151 permitted.
2152
2153 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
2154 replace.  The services (see L<FS::cust_svc>) are moved to the
2155 new billing items.  An error is returned if this is not possible (see
2156 L<FS::pkg_svc>).
2157
2158 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
2159 newly-created cust_pkg objects.
2160
2161 =cut
2162
2163 sub bulk_change {
2164   my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
2165
2166   # Transactionize this whole mess
2167   local $SIG{HUP} = 'IGNORE';
2168   local $SIG{INT} = 'IGNORE';
2169   local $SIG{QUIT} = 'IGNORE';
2170   local $SIG{TERM} = 'IGNORE';
2171   local $SIG{TSTP} = 'IGNORE';
2172   local $SIG{PIPE} = 'IGNORE';
2173
2174   my $oldAutoCommit = $FS::UID::AutoCommit;
2175   local $FS::UID::AutoCommit = 0;
2176   my $dbh = dbh;
2177
2178   my @errors;
2179   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
2180                          @$remove_pkgnum;
2181
2182   while(scalar(@old_cust_pkg)) {
2183     my @return = ();
2184     my $custnum = $old_cust_pkg[0]->custnum;
2185     my (@remove) = map { $_->pkgnum }
2186                    grep { $_->custnum == $custnum } @old_cust_pkg;
2187     @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
2188
2189     my $error = order $custnum, $pkgparts, \@remove, \@return;
2190
2191     push @errors, $error
2192       if $error;
2193     push @$return_cust_pkg, @return;
2194   }
2195
2196   if (scalar(@errors)) {
2197     $dbh->rollback if $oldAutoCommit;
2198     return join(' / ', @errors);
2199   }
2200
2201   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2202   '';
2203 }
2204
2205 =item insert_reason
2206
2207 Associates this package with a (suspension or cancellation) reason (see
2208 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
2209 L<FS::reason>).
2210
2211 Available options are:
2212
2213 =over 4
2214
2215 =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.
2216
2217 =item otaker_reason - the access_user (see L<FS::access_user>) providing the reason
2218
2219 =item date - a unix timestamp
2220
2221 =item action - the action (cancel, susp, adjourn, expire) associated with the reason
2222
2223 =back
2224
2225 If there is an error, returns the error, otherwise returns false.
2226
2227 =cut
2228
2229 sub insert_reason {
2230   my ($self, %options) = @_;
2231
2232   my $otaker = $options{reason_otaker} ||
2233                $FS::CurrentUser::CurrentUser->username;
2234
2235   my $reasonnum;
2236   if ( $options{'reason'} =~ /^(\d+)$/ ) {
2237
2238     $reasonnum = $1;
2239
2240   } elsif ( ref($options{'reason'}) ) {
2241
2242     return 'Enter a new reason (or select an existing one)'
2243       unless $options{'reason'}->{'reason'} !~ /^\s*$/;
2244
2245     my $reason = new FS::reason({
2246       'reason_type' => $options{'reason'}->{'typenum'},
2247       'reason'      => $options{'reason'}->{'reason'},
2248     });
2249     my $error = $reason->insert;
2250     return $error if $error;
2251
2252     $reasonnum = $reason->reasonnum;
2253
2254   } else {
2255     return "Unparsable reason: ". $options{'reason'};
2256   }
2257
2258   my $cust_pkg_reason =
2259     new FS::cust_pkg_reason({ 'pkgnum'    => $self->pkgnum,
2260                               'reasonnum' => $reasonnum,
2261                               'otaker'    => $otaker,
2262                               'action'    => substr(uc($options{'action'}),0,1),
2263                               'date'      => $options{'date'}
2264                                                ? $options{'date'}
2265                                                : time,
2266                             });
2267
2268   $cust_pkg_reason->insert;
2269 }
2270
2271 =item set_usage USAGE_VALUE_HASHREF
2272
2273 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2274 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
2275 upbytes, downbytes, and totalbytes are appropriate keys.
2276
2277 All svc_accts which are part of this package have their values reset.
2278
2279 =cut
2280
2281 sub set_usage {
2282   my ($self, $valueref) = @_;
2283
2284   foreach my $cust_svc ($self->cust_svc){
2285     my $svc_x = $cust_svc->svc_x;
2286     $svc_x->set_usage($valueref)
2287       if $svc_x->can("set_usage");
2288   }
2289 }
2290
2291 =item recharge USAGE_VALUE_HASHREF
2292
2293 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2294 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
2295 upbytes, downbytes, and totalbytes are appropriate keys.
2296
2297 All svc_accts which are part of this package have their values incremented.
2298
2299 =cut
2300
2301 sub recharge {
2302   my ($self, $valueref) = @_;
2303
2304   foreach my $cust_svc ($self->cust_svc){
2305     my $svc_x = $cust_svc->svc_x;
2306     $svc_x->recharge($valueref)
2307       if $svc_x->can("recharge");
2308   }
2309 }
2310
2311 =back
2312
2313 =head1 BUGS
2314
2315 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
2316
2317 In sub order, the @pkgparts array (passed by reference) is clobbered.
2318
2319 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
2320 method to pass dates to the recur_prog expression, it should do so.
2321
2322 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
2323 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
2324 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
2325 configuration values.  Probably need a subroutine which decides what to do
2326 based on whether or not we've fetched the user yet, rather than a hash.  See
2327 FS::UID and the TODO.
2328
2329 Now that things are transactional should the check in the insert method be
2330 moved to check ?
2331
2332 =head1 SEE ALSO
2333
2334 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
2335 L<FS::pkg_svc>, schema.html from the base documentation
2336
2337 =cut
2338
2339 1;
2340