FS/FS/cust_pkg.pm

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