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