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