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