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