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