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