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