FS/FS/cust_pkg.pm

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