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