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) lists of identical services to one line that lists the service
1490 label and the number of individual services rather than individual items.
1491
1492 =cut
1493
1494 sub h_labels_short {
1495   my $self = shift;
1496
1497   my %labels;
1498   #tie %labels, 'Tie::IxHash';
1499   push @{ $labels{$_->[0]} }, $_->[1]
1500     foreach $self->h_labels(@_);
1501   my @labels;
1502   foreach my $label ( keys %labels ) {
1503     my @values = @{ $labels{$label} };
1504     my $num = scalar(@values);
1505     if ( $num > 5 ) {
1506       push @labels, "$label ($num)";
1507     } else {
1508       push @labels, map { "$label: $_" } @values;
1509     }
1510   }
1511
1512  @labels;
1513
1514 }
1515
1516 =item cust_main
1517
1518 Returns the parent customer object (see L<FS::cust_main>).
1519
1520 =cut
1521
1522 sub cust_main {
1523   my $self = shift;
1524   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
1525 }
1526
1527 =item seconds_since TIMESTAMP
1528
1529 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
1530 package have been online since TIMESTAMP, according to the session monitor.
1531
1532 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1533 L<Time::Local> and L<Date::Parse> for conversion functions.
1534
1535 =cut
1536
1537 sub seconds_since {
1538   my($self, $since) = @_;
1539   my $seconds = 0;
1540
1541   foreach my $cust_svc (
1542     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
1543   ) {
1544     $seconds += $cust_svc->seconds_since($since);
1545   }
1546
1547   $seconds;
1548
1549 }
1550
1551 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1552
1553 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
1554 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
1555 (exclusive).
1556
1557 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1558 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1559 functions.
1560
1561
1562 =cut
1563
1564 sub seconds_since_sqlradacct {
1565   my($self, $start, $end) = @_;
1566
1567   my $seconds = 0;
1568
1569   foreach my $cust_svc (
1570     grep {
1571       my $part_svc = $_->part_svc;
1572       $part_svc->svcdb eq 'svc_acct'
1573         && scalar($part_svc->part_export('sqlradius'));
1574     } $self->cust_svc
1575   ) {
1576     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
1577   }
1578
1579   $seconds;
1580
1581 }
1582
1583 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1584
1585 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1586 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1587 TIMESTAMP_END
1588 (exclusive).
1589
1590 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1591 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1592 functions.
1593
1594 =cut
1595
1596 sub attribute_since_sqlradacct {
1597   my($self, $start, $end, $attrib) = @_;
1598
1599   my $sum = 0;
1600
1601   foreach my $cust_svc (
1602     grep {
1603       my $part_svc = $_->part_svc;
1604       $part_svc->svcdb eq 'svc_acct'
1605         && scalar($part_svc->part_export('sqlradius'));
1606     } $self->cust_svc
1607   ) {
1608     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
1609   }
1610
1611   $sum;
1612
1613 }
1614
1615 =item quantity
1616
1617 =cut
1618
1619 sub quantity {
1620   my( $self, $value ) = @_;
1621   if ( defined($value) ) {
1622     $self->setfield('quantity', $value);
1623   }
1624   $self->getfield('quantity') || 1;
1625 }
1626
1627 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
1628
1629 Transfers as many services as possible from this package to another package.
1630
1631 The destination package can be specified by pkgnum by passing an FS::cust_pkg
1632 object.  The destination package must already exist.
1633
1634 Services are moved only if the destination allows services with the correct
1635 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
1636 this option with caution!  No provision is made for export differences
1637 between the old and new service definitions.  Probably only should be used
1638 when your exports for all service definitions of a given svcdb are identical.
1639 (attempt a transfer without it first, to move all possible svcpart-matching
1640 services)
1641
1642 Any services that can't be moved remain in the original package.
1643
1644 Returns an error, if there is one; otherwise, returns the number of services
1645 that couldn't be moved.
1646
1647 =cut
1648
1649 sub transfer {
1650   my ($self, $dest_pkgnum, %opt) = @_;
1651
1652   my $remaining = 0;
1653   my $dest;
1654   my %target;
1655
1656   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
1657     $dest = $dest_pkgnum;
1658     $dest_pkgnum = $dest->pkgnum;
1659   } else {
1660     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
1661   }
1662
1663   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
1664
1665   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
1666     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
1667   }
1668
1669   foreach my $cust_svc ($dest->cust_svc) {
1670     $target{$cust_svc->svcpart}--;
1671   }
1672
1673   my %svcpart2svcparts = ();
1674   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1675     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
1676     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
1677       next if exists $svcpart2svcparts{$svcpart};
1678       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
1679       $svcpart2svcparts{$svcpart} = [
1680         map  { $_->[0] }
1681         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
1682         map {
1683               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
1684                                                    'svcpart' => $_          } );
1685               [ $_,
1686                 $pkg_svc ? $pkg_svc->primary_svc : '',
1687                 $pkg_svc ? $pkg_svc->quantity : 0,
1688               ];
1689             }
1690
1691         grep { $_ != $svcpart }
1692         map  { $_->svcpart }
1693         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
1694       ];
1695       warn "alternates for svcpart $svcpart: ".
1696            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
1697         if $DEBUG;
1698     }
1699   }
1700
1701   foreach my $cust_svc ($self->cust_svc) {
1702     if($target{$cust_svc->svcpart} > 0) {
1703       $target{$cust_svc->svcpart}--;
1704       my $new = new FS::cust_svc { $cust_svc->hash };
1705       $new->pkgnum($dest_pkgnum);
1706       my $error = $new->replace($cust_svc);
1707       return $error if $error;
1708     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1709       if ( $DEBUG ) {
1710         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
1711         warn "alternates to consider: ".
1712              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
1713       }
1714       my @alternate = grep {
1715                              warn "considering alternate svcpart $_: ".
1716                                   "$target{$_} available in new package\n"
1717                                if $DEBUG;
1718                              $target{$_} > 0;
1719                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
1720       if ( @alternate ) {
1721         warn "alternate(s) found\n" if $DEBUG;
1722         my $change_svcpart = $alternate[0];
1723         $target{$change_svcpart}--;
1724         my $new = new FS::cust_svc { $cust_svc->hash };
1725         $new->svcpart($change_svcpart);
1726         $new->pkgnum($dest_pkgnum);
1727         my $error = $new->replace($cust_svc);
1728         return $error if $error;
1729       } else {
1730         $remaining++;
1731       }
1732     } else {
1733       $remaining++
1734     }
1735   }
1736   return $remaining;
1737 }
1738
1739 =item reexport
1740
1741 This method is deprecated.  See the I<depend_jobnum> option to the insert and
1742 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
1743
1744 =cut
1745
1746 sub reexport {
1747   my $self = shift;
1748
1749   local $SIG{HUP} = 'IGNORE';
1750   local $SIG{INT} = 'IGNORE';
1751   local $SIG{QUIT} = 'IGNORE';
1752   local $SIG{TERM} = 'IGNORE';
1753   local $SIG{TSTP} = 'IGNORE';
1754   local $SIG{PIPE} = 'IGNORE';
1755
1756   my $oldAutoCommit = $FS::UID::AutoCommit;
1757   local $FS::UID::AutoCommit = 0;
1758   my $dbh = dbh;
1759
1760   foreach my $cust_svc ( $self->cust_svc ) {
1761     #false laziness w/svc_Common::insert
1762     my $svc_x = $cust_svc->svc_x;
1763     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
1764       my $error = $part_export->export_insert($svc_x);
1765       if ( $error ) {
1766         $dbh->rollback if $oldAutoCommit;
1767         return $error;
1768       }
1769     }
1770   }
1771
1772   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1773   '';
1774
1775 }
1776
1777 =back
1778
1779 =head1 CLASS METHODS
1780
1781 =over 4
1782
1783 =item recurring_sql
1784
1785 Returns an SQL expression identifying recurring packages.
1786
1787 =cut
1788
1789 sub recurring_sql { "
1790   '0' != ( select freq from part_pkg
1791              where cust_pkg.pkgpart = part_pkg.pkgpart )
1792 "; }
1793
1794 =item onetime_sql
1795
1796 Returns an SQL expression identifying one-time packages.
1797
1798 =cut
1799
1800 sub onetime_sql { "
1801   '0' = ( select freq from part_pkg
1802             where cust_pkg.pkgpart = part_pkg.pkgpart )
1803 "; }
1804
1805 =item active_sql
1806
1807 Returns an SQL expression identifying active packages.
1808
1809 =cut
1810
1811 sub active_sql { "
1812   ". $_[0]->recurring_sql(). "
1813   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1814   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
1815 "; }
1816
1817 =item inactive_sql
1818
1819 Returns an SQL expression identifying inactive packages (one-time packages
1820 that are otherwise unsuspended/uncancelled).
1821
1822 =cut
1823
1824 sub inactive_sql { "
1825   ". $_[0]->onetime_sql(). "
1826   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1827   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
1828 "; }
1829
1830 =item susp_sql
1831 =item suspended_sql
1832
1833 Returns an SQL expression identifying suspended packages.
1834
1835 =cut
1836
1837 sub suspended_sql { susp_sql(@_); }
1838 sub susp_sql {
1839   #$_[0]->recurring_sql(). ' AND '.
1840   "
1841         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
1842     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
1843   ";
1844 }
1845
1846 =item cancel_sql
1847 =item cancelled_sql
1848
1849 Returns an SQL exprression identifying cancelled packages.
1850
1851 =cut
1852
1853 sub cancelled_sql { cancel_sql(@_); }
1854 sub cancel_sql {
1855   #$_[0]->recurring_sql(). ' AND '.
1856   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
1857 }
1858
1859 =item search_sql HASHREF
1860
1861 (Class method)
1862
1863 Returns a qsearch hash expression to search for parameters specified in HASHREF.
1864 Valid parameters are
1865
1866 =over 4
1867
1868 =item agentnum
1869
1870 =item magic
1871
1872 active, inactive, suspended, cancel (or cancelled)
1873
1874 =item status
1875
1876 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
1877
1878 =item classnum
1879
1880 =item pkgpart
1881
1882 list specified how?
1883
1884 =item setup
1885
1886 arrayref of beginning and ending epoch date
1887
1888 =item last_bill
1889
1890 arrayref of beginning and ending epoch date
1891
1892 =item bill
1893
1894 arrayref of beginning and ending epoch date
1895
1896 =item adjourn
1897
1898 arrayref of beginning and ending epoch date
1899
1900 =item susp
1901
1902 arrayref of beginning and ending epoch date
1903
1904 =item expire
1905
1906 arrayref of beginning and ending epoch date
1907
1908 =item cancel
1909
1910 arrayref of beginning and ending epoch date
1911
1912 =item query
1913
1914 pkgnum or APKG_pkgnum
1915
1916 =item cust_fields
1917
1918 a value suited to passing to FS::UI::Web::cust_header
1919
1920 =item CurrentUser
1921
1922 specifies the user for agent virtualization
1923
1924 =back
1925
1926 =cut
1927
1928 sub search_sql {
1929   my ($class, $params) = @_;
1930   my @where = ();
1931
1932   ##
1933   # parse agent
1934   ##
1935
1936   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
1937     push @where,
1938       "cust_main.agentnum = $1";
1939   }
1940
1941   ##
1942   # parse status
1943   ##
1944
1945   if (    $params->{'magic'}  eq 'active'
1946        || $params->{'status'} eq 'active' ) {
1947
1948     push @where, FS::cust_pkg->active_sql();
1949
1950   } elsif (    $params->{'magic'}  eq 'inactive'
1951             || $params->{'status'} eq 'inactive' ) {
1952
1953     push @where, FS::cust_pkg->inactive_sql();
1954
1955   } elsif (    $params->{'magic'}  eq 'suspended'
1956             || $params->{'status'} eq 'suspended'  ) {
1957
1958     push @where, FS::cust_pkg->suspended_sql();
1959
1960   } elsif (    $params->{'magic'}  =~ /^cancell?ed$/
1961             || $params->{'status'} =~ /^cancell?ed$/ ) {
1962
1963     push @where, FS::cust_pkg->cancelled_sql();
1964
1965   } elsif ( $params->{'status'} =~ /^(one-time charge|inactive)$/ ) {
1966
1967     push @where, FS::cust_pkg->inactive_sql();
1968
1969   }
1970
1971   ###
1972   # parse package class
1973   ###
1974
1975   #false lazinessish w/graph/cust_bill_pkg.cgi
1976   my $classnum = 0;
1977   my @pkg_class = ();
1978   if ( exists($params->{'classnum'})
1979        && $params->{'classnum'} =~ /^(\d*)$/
1980      )
1981   {
1982     $classnum = $1;
1983     if ( $classnum ) { #a specific class
1984       push @where, "classnum = $classnum";
1985
1986       #@pkg_class = ( qsearchs('pkg_class', { 'classnum' => $classnum } ) );
1987       #die "classnum $classnum not found!" unless $pkg_class[0];
1988       #$title .= $pkg_class[0]->classname.' ';
1989
1990     } elsif ( $classnum eq '' ) { #the empty class
1991
1992       push @where, "classnum IS NULL";
1993       #$title .= 'Empty class ';
1994       #@pkg_class = ( '(empty class)' );
1995     } elsif ( $classnum eq '0' ) {
1996       #@pkg_class = qsearch('pkg_class', {} ); # { 'disabled' => '' } );
1997       #push @pkg_class, '(empty class)';
1998     } else {
1999       die "illegal classnum";
2000     }
2001   }
2002   #eslaf
2003
2004   ###
2005   # parse part_pkg
2006   ###
2007
2008   my $pkgpart = join (' OR pkgpart=',
2009                       grep {$_} map { /^(\d+)$/; } ($params->{'pkgpart'}));
2010   push @where,  '(pkgpart=' . $pkgpart . ')' if $pkgpart;
2011
2012   ###
2013   # parse dates
2014   ###
2015
2016   my $orderby = '';
2017
2018   #false laziness w/report_cust_pkg.html
2019   my %disable = (
2020     'all'             => {},
2021     'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
2022     'active'          => { 'susp'=>1, 'cancel'=>1 },
2023     'suspended'       => { 'cancel' => 1 },
2024     'cancelled'       => {},
2025     ''                => {},
2026   );
2027
2028   foreach my $field (qw( setup last_bill bill adjourn susp expire cancel )) {
2029
2030     next unless exists($params->{$field});
2031
2032     my($beginning, $ending) = @{$params->{$field}};
2033
2034     next if $beginning == 0 && $ending == 4294967295;
2035
2036     push @where,
2037       "cust_pkg.$field IS NOT NULL",
2038       "cust_pkg.$field >= $beginning",
2039       "cust_pkg.$field <= $ending";
2040
2041     $orderby ||= "ORDER BY cust_pkg.$field";
2042
2043   }
2044
2045   $orderby ||= 'ORDER BY bill';
2046
2047   ###
2048   # parse magic, legacy, etc.
2049   ###
2050
2051   if ( $params->{'magic'} &&
2052        $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
2053   ) {
2054
2055     $orderby = 'ORDER BY pkgnum';
2056
2057     if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
2058       push @where, "pkgpart = $1";
2059     }
2060
2061   } elsif ( $params->{'query'} eq 'pkgnum' ) {
2062
2063     $orderby = 'ORDER BY pkgnum';
2064
2065   } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
2066
2067     $orderby = 'ORDER BY pkgnum';
2068
2069     push @where, '0 < (
2070       SELECT count(*) FROM pkg_svc
2071        WHERE pkg_svc.pkgpart =  cust_pkg.pkgpart
2072          AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
2073                                    WHERE cust_svc.pkgnum  = cust_pkg.pkgnum
2074                                      AND cust_svc.svcpart = pkg_svc.svcpart
2075                                 )
2076     )';
2077
2078   }
2079
2080   ##
2081   # setup queries, links, subs, etc. for the search
2082   ##
2083
2084   # here is the agent virtualization
2085   if ($params->{CurrentUser}) {
2086     my $access_user =
2087       qsearchs('access_user', { username => $params->{CurrentUser} });
2088
2089     if ($access_user) {
2090       push @where, $access_user->agentnums_sql('table'=>'cust_main');
2091     }else{
2092       push @where, "1=0";
2093     }
2094   }else{
2095     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
2096   }
2097
2098   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
2099
2100   my $addl_from = 'LEFT JOIN cust_main USING ( custnum  ) '.
2101                   'LEFT JOIN part_pkg  USING ( pkgpart  ) '.
2102                   'LEFT JOIN pkg_class USING ( classnum ) ';
2103
2104   my $count_query = "SELECT COUNT(*) FROM cust_pkg $addl_from $extra_sql";
2105
2106   my $sql_query = {
2107     'table'       => 'cust_pkg',
2108     'hashref'     => {},
2109     'select'      => join(', ',
2110                                 'cust_pkg.*',
2111                                 ( map "part_pkg.$_", qw( pkg freq ) ),
2112                                 'pkg_class.classname',
2113                                 'cust_main.custnum as cust_main_custnum',
2114                                 FS::UI::Web::cust_sql_fields(
2115                                   $params->{'cust_fields'}
2116                                 ),
2117                      ),
2118     'extra_sql'   => "$extra_sql $orderby",
2119     'addl_from'   => $addl_from,
2120     'count_query' => $count_query,
2121   };
2122
2123 }
2124
2125 =head1 SUBROUTINES
2126
2127 =over 4
2128
2129 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
2130
2131 CUSTNUM is a customer (see L<FS::cust_main>)
2132
2133 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
2134 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
2135 permitted.
2136
2137 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
2138 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
2139 new billing items.  An error is returned if this is not possible (see
2140 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
2141 parameter.
2142
2143 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
2144 newly-created cust_pkg objects.
2145
2146 REFNUM, if specified, will specify the FS::pkg_referral record to be created
2147 and inserted.  Multiple FS::pkg_referral records can be created by
2148 setting I<refnum> to an array reference of refnums or a hash reference with
2149 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
2150 record will be created corresponding to cust_main.refnum.
2151
2152 =cut
2153
2154 sub order {
2155   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
2156
2157   my $conf = new FS::Conf;
2158
2159   # Transactionize this whole mess
2160   local $SIG{HUP} = 'IGNORE';
2161   local $SIG{INT} = 'IGNORE';
2162   local $SIG{QUIT} = 'IGNORE';
2163   local $SIG{TERM} = 'IGNORE';
2164   local $SIG{TSTP} = 'IGNORE';
2165   local $SIG{PIPE} = 'IGNORE';
2166
2167   my $oldAutoCommit = $FS::UID::AutoCommit;
2168   local $FS::UID::AutoCommit = 0;
2169   my $dbh = dbh;
2170
2171   my $error;
2172   my $cust_main = qsearchs('cust_main', { custnum => $custnum });
2173   return "Customer not found: $custnum" unless $cust_main;
2174
2175   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
2176                          @$remove_pkgnum;
2177
2178   my $change = scalar(@old_cust_pkg) != 0;
2179
2180   my %hash = ();
2181   if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
2182
2183     my $time = time;
2184
2185     #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( last_bill bill );
2186
2187     #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( setup );
2188     $hash{'setup'} = $time if $old_cust_pkg[0]->setup;
2189
2190     $hash{'change_date'} = $time;
2191     $hash{"change_$_"}  = $old_cust_pkg[0]->$_() foreach qw( pkgnum pkgpart );
2192   }
2193
2194   # Create the new packages.
2195   foreach my $pkgpart (@$pkgparts) {
2196     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
2197                                       pkgpart => $pkgpart,
2198                                       refnum  => $refnum,
2199                                       %hash,
2200                                     };
2201     $error = $cust_pkg->insert( 'change' => $change );
2202     if ($error) {
2203       $dbh->rollback if $oldAutoCommit;
2204       return $error;
2205     }
2206     push @$return_cust_pkg, $cust_pkg;
2207   }
2208   # $return_cust_pkg now contains refs to all of the newly
2209   # created packages.
2210
2211   # Transfer services and cancel old packages.
2212   foreach my $old_pkg (@old_cust_pkg) {
2213
2214     foreach my $new_pkg (@$return_cust_pkg) {
2215       $error = $old_pkg->transfer($new_pkg);
2216       if ($error and $error == 0) {
2217         # $old_pkg->transfer failed.
2218         $dbh->rollback if $oldAutoCommit;
2219         return $error;
2220       }
2221     }
2222
2223     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
2224       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
2225       foreach my $new_pkg (@$return_cust_pkg) {
2226         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
2227         if ($error and $error == 0) {
2228           # $old_pkg->transfer failed.
2229         $dbh->rollback if $oldAutoCommit;
2230         return $error;
2231         }
2232       }
2233     }
2234
2235     if ($error > 0) {
2236       # Transfers were successful, but we went through all of the
2237       # new packages and still had services left on the old package.
2238       # We can't cancel the package under the circumstances, so abort.
2239       $dbh->rollback if $oldAutoCommit;
2240       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
2241     }
2242     $error = $old_pkg->cancel( quiet=>1 );
2243     if ($error) {
2244       $dbh->rollback;
2245       return $error;
2246     }
2247   }
2248   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2249   '';
2250 }
2251
2252 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
2253
2254 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
2255 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
2256 permitted.
2257
2258 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
2259 replace.  The services (see L<FS::cust_svc>) are moved to the
2260 new billing items.  An error is returned if this is not possible (see
2261 L<FS::pkg_svc>).
2262
2263 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
2264 newly-created cust_pkg objects.
2265
2266 =cut
2267
2268 sub bulk_change {
2269   my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
2270
2271   # Transactionize this whole mess
2272   local $SIG{HUP} = 'IGNORE';
2273   local $SIG{INT} = 'IGNORE';
2274   local $SIG{QUIT} = 'IGNORE';
2275   local $SIG{TERM} = 'IGNORE';
2276   local $SIG{TSTP} = 'IGNORE';
2277   local $SIG{PIPE} = 'IGNORE';
2278
2279   my $oldAutoCommit = $FS::UID::AutoCommit;
2280   local $FS::UID::AutoCommit = 0;
2281   my $dbh = dbh;
2282
2283   my @errors;
2284   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
2285                          @$remove_pkgnum;
2286
2287   while(scalar(@old_cust_pkg)) {
2288     my @return = ();
2289     my $custnum = $old_cust_pkg[0]->custnum;
2290     my (@remove) = map { $_->pkgnum }
2291                    grep { $_->custnum == $custnum } @old_cust_pkg;
2292     @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
2293
2294     my $error = order $custnum, $pkgparts, \@remove, \@return;
2295
2296     push @errors, $error
2297       if $error;
2298     push @$return_cust_pkg, @return;
2299   }
2300
2301   if (scalar(@errors)) {
2302     $dbh->rollback if $oldAutoCommit;
2303     return join(' / ', @errors);
2304   }
2305
2306   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2307   '';
2308 }
2309
2310 =item insert_reason
2311
2312 Associates this package with a (suspension or cancellation) reason (see
2313 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
2314 L<FS::reason>).
2315
2316 Available options are:
2317
2318 =over 4
2319
2320 =item reason
2321
2322 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.
2323
2324 =item reason_otaker
2325
2326 the access_user (see L<FS::access_user>) providing the reason
2327
2328 =item date
2329
2330 a unix timestamp
2331
2332 =item action
2333
2334 the action (cancel, susp, adjourn, expire) associated with the reason
2335
2336 =back
2337
2338 If there is an error, returns the error, otherwise returns false.
2339
2340 =cut
2341
2342 sub insert_reason {
2343   my ($self, %options) = @_;
2344
2345   my $otaker = $options{reason_otaker} ||
2346                $FS::CurrentUser::CurrentUser->username;
2347
2348   my $reasonnum;
2349   if ( $options{'reason'} =~ /^(\d+)$/ ) {
2350
2351     $reasonnum = $1;
2352
2353   } elsif ( ref($options{'reason'}) ) {
2354
2355     return 'Enter a new reason (or select an existing one)'
2356       unless $options{'reason'}->{'reason'} !~ /^\s*$/;
2357
2358     my $reason = new FS::reason({
2359       'reason_type' => $options{'reason'}->{'typenum'},
2360       'reason'      => $options{'reason'}->{'reason'},
2361     });
2362     my $error = $reason->insert;
2363     return $error if $error;
2364
2365     $reasonnum = $reason->reasonnum;
2366
2367   } else {
2368     return "Unparsable reason: ". $options{'reason'};
2369   }
2370
2371   my $cust_pkg_reason =
2372     new FS::cust_pkg_reason({ 'pkgnum'    => $self->pkgnum,
2373                               'reasonnum' => $reasonnum,
2374                               'otaker'    => $otaker,
2375                               'action'    => substr(uc($options{'action'}),0,1),
2376                               'date'      => $options{'date'}
2377                                                ? $options{'date'}
2378                                                : time,
2379                             });
2380
2381   $cust_pkg_reason->insert;
2382 }
2383
2384 =item set_usage USAGE_VALUE_HASHREF
2385
2386 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2387 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
2388 upbytes, downbytes, and totalbytes are appropriate keys.
2389
2390 All svc_accts which are part of this package have their values reset.
2391
2392 =cut
2393
2394 sub set_usage {
2395   my ($self, $valueref) = @_;
2396
2397   foreach my $cust_svc ($self->cust_svc){
2398     my $svc_x = $cust_svc->svc_x;
2399     $svc_x->set_usage($valueref)
2400       if $svc_x->can("set_usage");
2401   }
2402 }
2403
2404 =item recharge USAGE_VALUE_HASHREF
2405
2406 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2407 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
2408 upbytes, downbytes, and totalbytes are appropriate keys.
2409
2410 All svc_accts which are part of this package have their values incremented.
2411
2412 =cut
2413
2414 sub recharge {
2415   my ($self, $valueref) = @_;
2416
2417   foreach my $cust_svc ($self->cust_svc){
2418     my $svc_x = $cust_svc->svc_x;
2419     $svc_x->recharge($valueref)
2420       if $svc_x->can("recharge");
2421   }
2422 }
2423
2424 =back
2425
2426 =head1 BUGS
2427
2428 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
2429
2430 In sub order, the @pkgparts array (passed by reference) is clobbered.
2431
2432 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
2433 method to pass dates to the recur_prog expression, it should do so.
2434
2435 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
2436 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
2437 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
2438 configuration values.  Probably need a subroutine which decides what to do
2439 based on whether or not we've fetched the user yet, rather than a hash.  See
2440 FS::UID and the TODO.
2441
2442 Now that things are transactional should the check in the insert method be
2443 moved to check ?
2444
2445 =head1 SEE ALSO
2446
2447 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
2448 L<FS::pkg_svc>, schema.html from the base documentation
2449
2450 =cut
2451
2452 1;
2453