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       my $pkgpart_href = $agent->pkgpart_hashref;
 484       return "agent ". $agent->agentnum.
 485              " can't purchase pkgpart ". $self->pkgpart
 486         unless $pkgpart_href->{ $self->pkgpart };
 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   cluck "cust_pkg->cust_svc called" if $DEBUG > 1;
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   return () unless $self->num_cust_svc(@_);
1446   grep { $_->overlimit } $self->cust_svc(@_);
1447 }
1448
1449 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ]
1450
1451 Returns historical services for this package created before END TIMESTAMP and
1452 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
1453 (see L<FS::h_cust_svc>).
1454
1455 =cut
1456
1457 sub h_cust_svc {
1458   my $self = shift;
1459
1460   $self->_sort_cust_svc(
1461     [ qsearch( 'h_cust_svc',
1462                { 'pkgnum' => $self->pkgnum, },
1463                FS::h_cust_svc->sql_h_search(@_),
1464              )
1465     ]
1466   );
1467 }
1468
1469 sub _sort_cust_svc {
1470   my( $self, $arrayref ) = @_;
1471
1472   map  { $_->[0] }
1473   sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
1474   map {
1475         my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
1476                                              'svcpart' => $_->svcpart     } );
1477         [ $_,
1478           $pkg_svc ? $pkg_svc->primary_svc : '',
1479           $pkg_svc ? $pkg_svc->quantity : 0,
1480         ];
1481       }
1482   @$arrayref;
1483
1484 }
1485
1486 =item num_cust_svc [ SVCPART ]
1487
1488 Returns the number of provisioned services for this package.  If a svcpart is
1489 specified, counts only the matching services.
1490
1491 =cut
1492
1493 sub num_cust_svc {
1494   my $self = shift;
1495
1496   return $self->{'_num_cust_svc'}
1497     if !@_ && exists($self->{'_num_cust_svc'})
1498            && $self->{'_num_cust_svc'} =~ /\d/;
1499
1500   my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
1501   $sql .= ' AND svcpart = ?' if @_;
1502
1503   my $sth = dbh->prepare($sql)     or die  dbh->errstr;
1504   $sth->execute($self->pkgnum, @_) or die $sth->errstr;
1505   $sth->fetchrow_arrayref->[0];
1506 }
1507
1508 =item available_part_svc
1509
1510 Returns a list of FS::part_svc objects representing services included in this
1511 package but not yet provisioned.  Each FS::part_svc object also has an extra
1512 field, I<num_avail>, which specifies the number of available services.
1513
1514 =cut
1515
1516 sub available_part_svc {
1517   my $self = shift;
1518   grep { $_->num_avail > 0 }
1519     map {
1520           my $part_svc = $_->part_svc;
1521           $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
1522             $_->quantity - $self->num_cust_svc($_->svcpart);
1523           $part_svc;
1524         }
1525       $self->part_pkg->pkg_svc;
1526 }
1527
1528 =item part_svc
1529
1530 Returns a list of FS::part_svc objects representing provisioned and available
1531 services included in this package.  Each FS::part_svc object also has the
1532 following extra fields:
1533
1534 =over 4
1535
1536 =item num_cust_svc  (count)
1537
1538 =item num_avail     (quantity - count)
1539
1540 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
1541
1542 svcnum
1543 label -> ($cust_svc->label)[1]
1544
1545 =back
1546
1547 =cut
1548
1549 sub part_svc {
1550   my $self = shift;
1551
1552   #XXX some sort of sort order besides numeric by svcpart...
1553   my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
1554     my $pkg_svc = $_;
1555     my $part_svc = $pkg_svc->part_svc;
1556     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1557     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
1558     $part_svc->{'Hash'}{'num_avail'}    =
1559       max( 0, $pkg_svc->quantity - $num_cust_svc );
1560     $part_svc->{'Hash'}{'cust_pkg_svc'} =
1561       $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
1562     $part_svc;
1563   } $self->part_pkg->pkg_svc;
1564
1565   #extras
1566   push @part_svc, map {
1567     my $part_svc = $_;
1568     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1569     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
1570     $part_svc->{'Hash'}{'num_avail'}    = 0; #0-$num_cust_svc ?
1571     $part_svc->{'Hash'}{'cust_pkg_svc'} =
1572       $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
1573     $part_svc;
1574   } $self->extra_part_svc;
1575
1576   @part_svc;
1577
1578 }
1579
1580 =item extra_part_svc
1581
1582 Returns a list of FS::part_svc objects corresponding to services in this
1583 package which are still provisioned but not (any longer) available in the
1584 package definition.
1585
1586 =cut
1587
1588 sub extra_part_svc {
1589   my $self = shift;
1590
1591   my $pkgnum  = $self->pkgnum;
1592   my $pkgpart = $self->pkgpart;
1593
1594 #  qsearch( {
1595 #    'table'     => 'part_svc',
1596 #    'hashref'   => {},
1597 #    'extra_sql' =>
1598 #      "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
1599 #                     WHERE pkg_svc.svcpart = part_svc.svcpart
1600 #                       AND pkg_svc.pkgpart = ?
1601 #                       AND quantity > 0
1602 #                 )
1603 #        AND 0 < ( SELECT COUNT(*) FROM cust_svc
1604 #                       LEFT JOIN cust_pkg USING ( pkgnum )
1605 #                     WHERE cust_svc.svcpart = part_svc.svcpart
1606 #                       AND pkgnum = ?
1607 #                 )",
1608 #    'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
1609 #  } );
1610
1611 #seems to benchmark slightly faster...
1612   qsearch( {
1613     'select'      => 'DISTINCT ON (svcpart) part_svc.*',
1614     'table'       => 'part_svc',
1615     'addl_from'   =>
1616       'LEFT JOIN pkg_svc  ON (     pkg_svc.svcpart   = part_svc.svcpart
1617                                AND pkg_svc.pkgpart   = ?
1618                                AND quantity > 0
1619                              )
1620        LEFT JOIN cust_svc ON (     cust_svc.svcpart = part_svc.svcpart )
1621        LEFT JOIN cust_pkg USING ( pkgnum )
1622       ',
1623     'hashref'     => {},
1624     'extra_sql'   => "WHERE pkgsvcnum IS NULL AND cust_pkg.pkgnum = ? ",
1625     'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
1626   } );
1627 }
1628
1629 =item status
1630
1631 Returns a short status string for this package, currently:
1632
1633 =over 4
1634
1635 =item not yet billed
1636
1637 =item one-time charge
1638
1639 =item active
1640
1641 =item suspended
1642
1643 =item cancelled
1644
1645 =back
1646
1647 =cut
1648
1649 sub status {
1650   my $self = shift;
1651
1652   my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
1653
1654   return 'cancelled' if $self->get('cancel');
1655   return 'suspended' if $self->susp;
1656   return 'not yet billed' unless $self->setup;
1657   return 'one-time charge' if $freq =~ /^(0|$)/;
1658   return 'active';
1659 }
1660
1661 =item statuses
1662
1663 Class method that returns the list of possible status strings for packages
1664 (see L<the status method|/status>).  For example:
1665
1666   @statuses = FS::cust_pkg->statuses();
1667
1668 =cut
1669
1670 tie my %statuscolor, 'Tie::IxHash',
1671   'not yet billed'  => '000000',
1672   'one-time charge' => '000000',
1673   'active'          => '00CC00',
1674   'suspended'       => 'FF9900',
1675   'cancelled'       => 'FF0000',
1676 ;
1677
1678 sub statuses {
1679   my $self = shift; #could be class...
1680   grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
1681                                       # mayble split btw one-time vs. recur
1682     keys %statuscolor;
1683 }
1684
1685 =item statuscolor
1686
1687 Returns a hex triplet color string for this package's status.
1688
1689 =cut
1690
1691 sub statuscolor {
1692   my $self = shift;
1693   $statuscolor{$self->status};
1694 }
1695
1696 =item labels
1697
1698 Returns a list of lists, calling the label method for all services
1699 (see L<FS::cust_svc>) of this billing item.
1700
1701 =cut
1702
1703 sub labels {
1704   my $self = shift;
1705   map { [ $_->label ] } $self->cust_svc;
1706 }
1707
1708 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
1709
1710 Like the labels method, but returns historical information on services that
1711 were active as of END_TIMESTAMP and (optionally) not cancelled before
1712 START_TIMESTAMP.
1713
1714 Returns a list of lists, calling the label method for all (historical) services
1715 (see L<FS::h_cust_svc>) of this billing item.
1716
1717 =cut
1718
1719 sub h_labels {
1720   my $self = shift;
1721   map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
1722 }
1723
1724 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
1725
1726 Like h_labels, except returns a simple flat list, and shortens long
1727 (currently >5 or the cust_bill-max_same_services configuration value) lists of
1728 identical services to one line that lists the service label and the number of
1729 individual services rather than individual items.
1730
1731 =cut
1732
1733 sub h_labels_short {
1734   my $self = shift;
1735
1736   my $conf = new FS::Conf;
1737   my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
1738
1739   my %labels;
1740   #tie %labels, 'Tie::IxHash';
1741   push @{ $labels{$_->[0]} }, $_->[1]
1742     foreach $self->h_labels(@_);
1743   my @labels;
1744   foreach my $label ( keys %labels ) {
1745     my %seen = ();
1746     my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
1747     my $num = scalar(@values);
1748     if ( $num > $max_same_services ) {
1749       push @labels, "$label ($num)";
1750     } else {
1751       push @labels, map { "$label: $_" } @values;
1752     }
1753   }
1754
1755  @labels;
1756
1757 }
1758
1759 =item cust_main
1760
1761 Returns the parent customer object (see L<FS::cust_main>).
1762
1763 =cut
1764
1765 sub cust_main {
1766   my $self = shift;
1767   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
1768 }
1769
1770 =item cust_location
1771
1772 Returns the location object, if any (see L<FS::cust_location>).
1773
1774 =cut
1775
1776 sub cust_location {
1777   my $self = shift;
1778   return '' unless $self->locationnum;
1779   qsearchs( 'cust_location', { 'locationnum' => $self->locationnum } );
1780 }
1781
1782 =item cust_location_or_main
1783
1784 If this package is associated with a location, returns the locaiton (see
1785 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
1786
1787 =cut
1788
1789 sub cust_location_or_main {
1790   my $self = shift;
1791   $self->cust_location || $self->cust_main;
1792 }
1793
1794 =item seconds_since TIMESTAMP
1795
1796 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
1797 package have been online since TIMESTAMP, according to the session monitor.
1798
1799 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1800 L<Time::Local> and L<Date::Parse> for conversion functions.
1801
1802 =cut
1803
1804 sub seconds_since {
1805   my($self, $since) = @_;
1806   my $seconds = 0;
1807
1808   foreach my $cust_svc (
1809     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
1810   ) {
1811     $seconds += $cust_svc->seconds_since($since);
1812   }
1813
1814   $seconds;
1815
1816 }
1817
1818 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1819
1820 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
1821 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
1822 (exclusive).
1823
1824 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1825 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1826 functions.
1827
1828
1829 =cut
1830
1831 sub seconds_since_sqlradacct {
1832   my($self, $start, $end) = @_;
1833
1834   my $seconds = 0;
1835
1836   foreach my $cust_svc (
1837     grep {
1838       my $part_svc = $_->part_svc;
1839       $part_svc->svcdb eq 'svc_acct'
1840         && scalar($part_svc->part_export('sqlradius'));
1841     } $self->cust_svc
1842   ) {
1843     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
1844   }
1845
1846   $seconds;
1847
1848 }
1849
1850 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1851
1852 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1853 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1854 TIMESTAMP_END
1855 (exclusive).
1856
1857 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1858 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1859 functions.
1860
1861 =cut
1862
1863 sub attribute_since_sqlradacct {
1864   my($self, $start, $end, $attrib) = @_;
1865
1866   my $sum = 0;
1867
1868   foreach my $cust_svc (
1869     grep {
1870       my $part_svc = $_->part_svc;
1871       $part_svc->svcdb eq 'svc_acct'
1872         && scalar($part_svc->part_export('sqlradius'));
1873     } $self->cust_svc
1874   ) {
1875     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
1876   }
1877
1878   $sum;
1879
1880 }
1881
1882 =item quantity
1883
1884 =cut
1885
1886 sub quantity {
1887   my( $self, $value ) = @_;
1888   if ( defined($value) ) {
1889     $self->setfield('quantity', $value);
1890   }
1891   $self->getfield('quantity') || 1;
1892 }
1893
1894 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
1895
1896 Transfers as many services as possible from this package to another package.
1897
1898 The destination package can be specified by pkgnum by passing an FS::cust_pkg
1899 object.  The destination package must already exist.
1900
1901 Services are moved only if the destination allows services with the correct
1902 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
1903 this option with caution!  No provision is made for export differences
1904 between the old and new service definitions.  Probably only should be used
1905 when your exports for all service definitions of a given svcdb are identical.
1906 (attempt a transfer without it first, to move all possible svcpart-matching
1907 services)
1908
1909 Any services that can't be moved remain in the original package.
1910
1911 Returns an error, if there is one; otherwise, returns the number of services
1912 that couldn't be moved.
1913
1914 =cut
1915
1916 sub transfer {
1917   my ($self, $dest_pkgnum, %opt) = @_;
1918
1919   my $remaining = 0;
1920   my $dest;
1921   my %target;
1922
1923   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
1924     $dest = $dest_pkgnum;
1925     $dest_pkgnum = $dest->pkgnum;
1926   } else {
1927     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
1928   }
1929
1930   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
1931
1932   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
1933     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
1934   }
1935
1936   foreach my $cust_svc ($dest->cust_svc) {
1937     $target{$cust_svc->svcpart}--;
1938   }
1939
1940   my %svcpart2svcparts = ();
1941   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1942     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
1943     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
1944       next if exists $svcpart2svcparts{$svcpart};
1945       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
1946       $svcpart2svcparts{$svcpart} = [
1947         map  { $_->[0] }
1948         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
1949         map {
1950               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
1951                                                    'svcpart' => $_          } );
1952               [ $_,
1953                 $pkg_svc ? $pkg_svc->primary_svc : '',
1954                 $pkg_svc ? $pkg_svc->quantity : 0,
1955               ];
1956             }
1957
1958         grep { $_ != $svcpart }
1959         map  { $_->svcpart }
1960         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
1961       ];
1962       warn "alternates for svcpart $svcpart: ".
1963            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
1964         if $DEBUG;
1965     }
1966   }
1967
1968   foreach my $cust_svc ($self->cust_svc) {
1969     if($target{$cust_svc->svcpart} > 0) {
1970       $target{$cust_svc->svcpart}--;
1971       my $new = new FS::cust_svc { $cust_svc->hash };
1972       $new->pkgnum($dest_pkgnum);
1973       my $error = $new->replace($cust_svc);
1974       return $error if $error;
1975     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1976       if ( $DEBUG ) {
1977         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
1978         warn "alternates to consider: ".
1979              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
1980       }
1981       my @alternate = grep {
1982                              warn "considering alternate svcpart $_: ".
1983                                   "$target{$_} available in new package\n"
1984                                if $DEBUG;
1985                              $target{$_} > 0;
1986                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
1987       if ( @alternate ) {
1988         warn "alternate(s) found\n" if $DEBUG;
1989         my $change_svcpart = $alternate[0];
1990         $target{$change_svcpart}--;
1991         my $new = new FS::cust_svc { $cust_svc->hash };
1992         $new->svcpart($change_svcpart);
1993         $new->pkgnum($dest_pkgnum);
1994         my $error = $new->replace($cust_svc);
1995         return $error if $error;
1996       } else {
1997         $remaining++;
1998       }
1999     } else {
2000       $remaining++
2001     }
2002   }
2003   return $remaining;
2004 }
2005
2006 =item reexport
2007
2008 This method is deprecated.  See the I<depend_jobnum> option to the insert and
2009 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
2010
2011 =cut
2012
2013 sub reexport {
2014   my $self = shift;
2015
2016   local $SIG{HUP} = 'IGNORE';
2017   local $SIG{INT} = 'IGNORE';
2018   local $SIG{QUIT} = 'IGNORE';
2019   local $SIG{TERM} = 'IGNORE';
2020   local $SIG{TSTP} = 'IGNORE';
2021   local $SIG{PIPE} = 'IGNORE';
2022
2023   my $oldAutoCommit = $FS::UID::AutoCommit;
2024   local $FS::UID::AutoCommit = 0;
2025   my $dbh = dbh;
2026
2027   foreach my $cust_svc ( $self->cust_svc ) {
2028     #false laziness w/svc_Common::insert
2029     my $svc_x = $cust_svc->svc_x;
2030     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
2031       my $error = $part_export->export_insert($svc_x);
2032       if ( $error ) {
2033         $dbh->rollback if $oldAutoCommit;
2034         return $error;
2035       }
2036     }
2037   }
2038
2039   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2040   '';
2041
2042 }
2043
2044 =back
2045
2046 =head1 CLASS METHODS
2047
2048 =over 4
2049
2050 =item recurring_sql
2051
2052 Returns an SQL expression identifying recurring packages.
2053
2054 =cut
2055
2056 sub recurring_sql { "
2057   '0' != ( select freq from part_pkg
2058              where cust_pkg.pkgpart = part_pkg.pkgpart )
2059 "; }
2060
2061 =item onetime_sql
2062
2063 Returns an SQL expression identifying one-time packages.
2064
2065 =cut
2066
2067 sub onetime_sql { "
2068   '0' = ( select freq from part_pkg
2069             where cust_pkg.pkgpart = part_pkg.pkgpart )
2070 "; }
2071
2072 =item active_sql
2073
2074 Returns an SQL expression identifying active packages.
2075
2076 =cut
2077
2078 sub active_sql { "
2079   ". $_[0]->recurring_sql(). "
2080   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2081   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2082 "; }
2083
2084 =item inactive_sql
2085
2086 Returns an SQL expression identifying inactive packages (one-time packages
2087 that are otherwise unsuspended/uncancelled).
2088
2089 =cut
2090
2091 sub inactive_sql { "
2092   ". $_[0]->onetime_sql(). "
2093   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2094   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2095 "; }
2096
2097 =item susp_sql
2098 =item suspended_sql
2099
2100 Returns an SQL expression identifying suspended packages.
2101
2102 =cut
2103
2104 sub suspended_sql { susp_sql(@_); }
2105 sub susp_sql {
2106   #$_[0]->recurring_sql(). ' AND '.
2107   "
2108         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
2109     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
2110   ";
2111 }
2112
2113 =item cancel_sql
2114 =item cancelled_sql
2115
2116 Returns an SQL exprression identifying cancelled packages.
2117
2118 =cut
2119
2120 sub cancelled_sql { cancel_sql(@_); }
2121 sub cancel_sql {
2122   #$_[0]->recurring_sql(). ' AND '.
2123   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
2124 }
2125
2126 =item search_sql HASHREF
2127
2128 (Class method)
2129
2130 Returns a qsearch hash expression to search for parameters specified in HASHREF.
2131 Valid parameters are
2132
2133 =over 4
2134
2135 =item agentnum
2136
2137 =item magic
2138
2139 active, inactive, suspended, cancel (or cancelled)
2140
2141 =item status
2142
2143 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
2144
2145 =item classnum
2146
2147 =item pkgpart
2148
2149 list specified how?
2150
2151 =item setup
2152
2153 arrayref of beginning and ending epoch date
2154
2155 =item last_bill
2156
2157 arrayref of beginning and ending epoch date
2158
2159 =item bill
2160
2161 arrayref of beginning and ending epoch date
2162
2163 =item adjourn
2164
2165 arrayref of beginning and ending epoch date
2166
2167 =item susp
2168
2169 arrayref of beginning and ending epoch date
2170
2171 =item expire
2172
2173 arrayref of beginning and ending epoch date
2174
2175 =item cancel
2176
2177 arrayref of beginning and ending epoch date
2178
2179 =item query
2180
2181 pkgnum or APKG_pkgnum
2182
2183 =item cust_fields
2184
2185 a value suited to passing to FS::UI::Web::cust_header
2186
2187 =item CurrentUser
2188
2189 specifies the user for agent virtualization
2190
2191 =back
2192
2193 =cut
2194
2195 sub search_sql {
2196   my ($class, $params) = @_;
2197   my @where = ();
2198
2199   ##
2200   # parse agent
2201   ##
2202
2203   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2204     push @where,
2205       "cust_main.agentnum = $1";
2206   }
2207
2208   ##
2209   # parse status
2210   ##
2211
2212   if (    $params->{'magic'}  eq 'active'
2213        || $params->{'status'} eq 'active' ) {
2214
2215     push @where, FS::cust_pkg->active_sql();
2216
2217   } elsif (    $params->{'magic'}  eq 'inactive'
2218             || $params->{'status'} eq 'inactive' ) {
2219
2220     push @where, FS::cust_pkg->inactive_sql();
2221
2222   } elsif (    $params->{'magic'}  eq 'suspended'
2223             || $params->{'status'} eq 'suspended'  ) {
2224
2225     push @where, FS::cust_pkg->suspended_sql();
2226
2227   } elsif (    $params->{'magic'}  =~ /^cancell?ed$/
2228             || $params->{'status'} =~ /^cancell?ed$/ ) {
2229
2230     push @where, FS::cust_pkg->cancelled_sql();
2231
2232   } elsif ( $params->{'status'} =~ /^(one-time charge|inactive)$/ ) {
2233
2234     push @where, FS::cust_pkg->inactive_sql();
2235
2236   }
2237
2238   ###
2239   # parse package class
2240   ###
2241
2242   #false lazinessish w/graph/cust_bill_pkg.cgi
2243   my $classnum = 0;
2244   my @pkg_class = ();
2245   if ( exists($params->{'classnum'})
2246        && $params->{'classnum'} =~ /^(\d*)$/
2247      )
2248   {
2249     $classnum = $1;
2250     if ( $classnum ) { #a specific class
2251       push @where, "classnum = $classnum";
2252
2253       #@pkg_class = ( qsearchs('pkg_class', { 'classnum' => $classnum } ) );
2254       #die "classnum $classnum not found!" unless $pkg_class[0];
2255       #$title .= $pkg_class[0]->classname.' ';
2256
2257     } elsif ( $classnum eq '' ) { #the empty class
2258
2259       push @where, "classnum IS NULL";
2260       #$title .= 'Empty class ';
2261       #@pkg_class = ( '(empty class)' );
2262     } elsif ( $classnum eq '0' ) {
2263       #@pkg_class = qsearch('pkg_class', {} ); # { 'disabled' => '' } );
2264       #push @pkg_class, '(empty class)';
2265     } else {
2266       die "illegal classnum";
2267     }
2268   }
2269   #eslaf
2270
2271   ###
2272   # parse part_pkg
2273   ###
2274
2275   my $pkgpart = join (' OR pkgpart=',
2276                       grep {$_} map { /^(\d+)$/; } ($params->{'pkgpart'}));
2277   push @where,  '(pkgpart=' . $pkgpart . ')' if $pkgpart;
2278
2279   ###
2280   # parse dates
2281   ###
2282
2283   my $orderby = '';
2284
2285   #false laziness w/report_cust_pkg.html
2286   my %disable = (
2287     'all'             => {},
2288     'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
2289     'active'          => { 'susp'=>1, 'cancel'=>1 },
2290     'suspended'       => { 'cancel' => 1 },
2291     'cancelled'       => {},
2292     ''                => {},
2293   );
2294
2295   foreach my $field (qw( setup last_bill bill adjourn susp expire cancel )) {
2296
2297     next unless exists($params->{$field});
2298
2299     my($beginning, $ending) = @{$params->{$field}};
2300
2301     next if $beginning == 0 && $ending == 4294967295;
2302
2303     push @where,
2304       "cust_pkg.$field IS NOT NULL",
2305       "cust_pkg.$field >= $beginning",
2306       "cust_pkg.$field <= $ending";
2307
2308     $orderby ||= "ORDER BY cust_pkg.$field";
2309
2310   }
2311
2312   $orderby ||= 'ORDER BY bill';
2313
2314   ###
2315   # parse magic, legacy, etc.
2316   ###
2317
2318   if ( $params->{'magic'} &&
2319        $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
2320   ) {
2321
2322     $orderby = 'ORDER BY pkgnum';
2323
2324     if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
2325       push @where, "pkgpart = $1";
2326     }
2327
2328   } elsif ( $params->{'query'} eq 'pkgnum' ) {
2329
2330     $orderby = 'ORDER BY pkgnum';
2331
2332   } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
2333
2334     $orderby = 'ORDER BY pkgnum';
2335
2336     push @where, '0 < (
2337       SELECT count(*) FROM pkg_svc
2338        WHERE pkg_svc.pkgpart =  cust_pkg.pkgpart
2339          AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
2340                                    WHERE cust_svc.pkgnum  = cust_pkg.pkgnum
2341                                      AND cust_svc.svcpart = pkg_svc.svcpart
2342                                 )
2343     )';
2344
2345   }
2346
2347   ##
2348   # setup queries, links, subs, etc. for the search
2349   ##
2350
2351   # here is the agent virtualization
2352   if ($params->{CurrentUser}) {
2353     my $access_user =
2354       qsearchs('access_user', { username => $params->{CurrentUser} });
2355
2356     if ($access_user) {
2357       push @where, $access_user->agentnums_sql('table'=>'cust_main');
2358     }else{
2359       push @where, "1=0";
2360     }
2361   }else{
2362     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
2363   }
2364
2365   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
2366
2367   my $addl_from = 'LEFT JOIN cust_main USING ( custnum  ) '.
2368                   'LEFT JOIN part_pkg  USING ( pkgpart  ) '.
2369                   'LEFT JOIN pkg_class USING ( classnum ) ';
2370
2371   my $count_query = "SELECT COUNT(*) FROM cust_pkg $addl_from $extra_sql";
2372
2373   my $sql_query = {
2374     'table'       => 'cust_pkg',
2375     'hashref'     => {},
2376     'select'      => join(', ',
2377                                 'cust_pkg.*',
2378                                 ( map "part_pkg.$_", qw( pkg freq ) ),
2379                                 'pkg_class.classname',
2380                                 'cust_main.custnum as cust_main_custnum',
2381                                 FS::UI::Web::cust_sql_fields(
2382                                   $params->{'cust_fields'}
2383                                 ),
2384                      ),
2385     'extra_sql'   => "$extra_sql $orderby",
2386     'addl_from'   => $addl_from,
2387     'count_query' => $count_query,
2388   };
2389
2390 }
2391
2392 =item location_sql
2393
2394 Returns a list: the first item is an SQL fragment identifying matching
2395 packages/customers via location (taking into account shipping and package
2396 address taxation, if enabled), and subsequent items are the parameters to
2397 substitute for the placeholders in that fragment.
2398
2399 =cut
2400
2401 sub location_sql {
2402   my($class, %opt) = @_;
2403   my $ornull = $opt{'ornull'};
2404
2405   my $conf = new FS::Conf;
2406
2407   # '?' placeholders in _location_sql_where
2408   my @bill_param;
2409   if ( $ornull ) {
2410     @bill_param = qw( county county state state state country );
2411   } else {
2412     @bill_param = qw( county state state country );
2413   }
2414   unshift @bill_param, 'county'; # unless $nec;
2415
2416   my $main_where;
2417   my @main_param;
2418   if ( $conf->exists('tax-ship_address') ) {
2419
2420     $main_where = "(
2421          (     ( ship_last IS NULL     OR  ship_last  = '' )
2422            AND ". _location_sql_where('cust_main', '', $ornull ). "
2423          )
2424       OR (       ship_last IS NOT NULL AND ship_last != ''
2425            AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
2426          )
2427     )";
2428     #    AND payby != 'COMP'
2429
2430     @main_param = ( @bill_param, @bill_param );
2431
2432   } else {
2433
2434     $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
2435     @main_param = @bill_param;
2436
2437   }
2438
2439   my $where;
2440   my @param;
2441   if ( $conf->exists('tax-pkg_address') ) {
2442
2443     my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
2444
2445     $where = " (
2446                     ( cust_pkg.locationnum IS     NULL AND $main_where )
2447                  OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where  )
2448                )
2449              ";
2450     @param = ( @main_param, @bill_param );
2451
2452   } else {
2453
2454     $where = $main_where;
2455     @param = @main_param;
2456
2457   }
2458
2459   ( $where, @param );
2460
2461 }
2462
2463 #subroutine, helper for location_sql
2464 sub _location_sql_where {
2465   my $table  = shift;
2466   my $prefix = @_ ? shift : '';
2467   my $ornull = @_ ? shift : '';
2468
2469 #  $ornull             = $ornull          ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
2470
2471   $ornull = $ornull ? ' OR ? IS NULL ' : '';
2472
2473   my $or_empty_county = " OR ( ? = '' AND $table.${prefix}county IS NULL ) ";
2474   my $or_empty_state =  " OR ( ? = '' AND $table.${prefix}state  IS NULL ) ";
2475
2476   "
2477         ( $table.${prefix}county  = ? $or_empty_county $ornull )
2478     AND ( $table.${prefix}state   = ? $or_empty_state  $ornull )
2479     AND   $table.${prefix}country = ?
2480   ";
2481 }
2482
2483 =head1 SUBROUTINES
2484
2485 =over 4
2486
2487 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
2488
2489 CUSTNUM is a customer (see L<FS::cust_main>)
2490
2491 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
2492 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
2493 permitted.
2494
2495 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
2496 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
2497 new billing items.  An error is returned if this is not possible (see
2498 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
2499 parameter.
2500
2501 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
2502 newly-created cust_pkg objects.
2503
2504 REFNUM, if specified, will specify the FS::pkg_referral record to be created
2505 and inserted.  Multiple FS::pkg_referral records can be created by
2506 setting I<refnum> to an array reference of refnums or a hash reference with
2507 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
2508 record will be created corresponding to cust_main.refnum.
2509
2510 =cut
2511
2512 sub order {
2513   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
2514
2515   my $conf = new FS::Conf;
2516
2517   # Transactionize this whole mess
2518   local $SIG{HUP} = 'IGNORE';
2519   local $SIG{INT} = 'IGNORE';
2520   local $SIG{QUIT} = 'IGNORE';
2521   local $SIG{TERM} = 'IGNORE';
2522   local $SIG{TSTP} = 'IGNORE';
2523   local $SIG{PIPE} = 'IGNORE';
2524
2525   my $oldAutoCommit = $FS::UID::AutoCommit;
2526   local $FS::UID::AutoCommit = 0;
2527   my $dbh = dbh;
2528
2529   my $error;
2530 #  my $cust_main = qsearchs('cust_main', { custnum => $custnum });
2531 #  return "Customer not found: $custnum" unless $cust_main;
2532
2533   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
2534                          @$remove_pkgnum;
2535
2536   my $change = scalar(@old_cust_pkg) != 0;
2537
2538   my %hash = ();
2539   if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
2540
2541     my $err_or_cust_pkg =
2542       $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
2543                                 'refnum'  => $refnum,
2544                               );
2545
2546     unless (ref($err_or_cust_pkg)) {
2547       $dbh->rollback if $oldAutoCommit;
2548       return $err_or_cust_pkg;
2549     }
2550
2551     push @$return_cust_pkg, $err_or_cust_pkg;
2552     return '';
2553
2554   }
2555
2556   # Create the new packages.
2557   foreach my $pkgpart (@$pkgparts) {
2558     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
2559                                       pkgpart => $pkgpart,
2560                                       refnum  => $refnum,
2561                                       %hash,
2562                                     };
2563     $error = $cust_pkg->insert( 'change' => $change );
2564     if ($error) {
2565       $dbh->rollback if $oldAutoCommit;
2566       return $error;
2567     }
2568     push @$return_cust_pkg, $cust_pkg;
2569   }
2570   # $return_cust_pkg now contains refs to all of the newly
2571   # created packages.
2572
2573   # Transfer services and cancel old packages.
2574   foreach my $old_pkg (@old_cust_pkg) {
2575
2576     foreach my $new_pkg (@$return_cust_pkg) {
2577       $error = $old_pkg->transfer($new_pkg);
2578       if ($error and $error == 0) {
2579         # $old_pkg->transfer failed.
2580         $dbh->rollback if $oldAutoCommit;
2581         return $error;
2582       }
2583     }
2584
2585     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
2586       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
2587       foreach my $new_pkg (@$return_cust_pkg) {
2588         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
2589         if ($error and $error == 0) {
2590           # $old_pkg->transfer failed.
2591         $dbh->rollback if $oldAutoCommit;
2592         return $error;
2593         }
2594       }
2595     }
2596
2597     if ($error > 0) {
2598       # Transfers were successful, but we went through all of the
2599       # new packages and still had services left on the old package.
2600       # We can't cancel the package under the circumstances, so abort.
2601       $dbh->rollback if $oldAutoCommit;
2602       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
2603     }
2604     $error = $old_pkg->cancel( quiet=>1 );
2605     if ($error) {
2606       $dbh->rollback;
2607       return $error;
2608     }
2609   }
2610   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2611   '';
2612 }
2613
2614 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
2615
2616 A bulk change method to change packages for multiple customers.
2617
2618 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
2619 L<FS::part_pkg>) to order for each customer.  Duplicates are of course
2620 permitted.
2621
2622 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
2623 replace.  The services (see L<FS::cust_svc>) are moved to the
2624 new billing items.  An error is returned if this is not possible (see
2625 L<FS::pkg_svc>).
2626
2627 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
2628 newly-created cust_pkg objects.
2629
2630 =cut
2631
2632 sub bulk_change {
2633   my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
2634
2635   # Transactionize this whole mess
2636   local $SIG{HUP} = 'IGNORE';
2637   local $SIG{INT} = 'IGNORE';
2638   local $SIG{QUIT} = 'IGNORE';
2639   local $SIG{TERM} = 'IGNORE';
2640   local $SIG{TSTP} = 'IGNORE';
2641   local $SIG{PIPE} = 'IGNORE';
2642
2643   my $oldAutoCommit = $FS::UID::AutoCommit;
2644   local $FS::UID::AutoCommit = 0;
2645   my $dbh = dbh;
2646
2647   my @errors;
2648   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
2649                          @$remove_pkgnum;
2650
2651   while(scalar(@old_cust_pkg)) {
2652     my @return = ();
2653     my $custnum = $old_cust_pkg[0]->custnum;
2654     my (@remove) = map { $_->pkgnum }
2655                    grep { $_->custnum == $custnum } @old_cust_pkg;
2656     @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
2657
2658     my $error = order $custnum, $pkgparts, \@remove, \@return;
2659
2660     push @errors, $error
2661       if $error;
2662     push @$return_cust_pkg, @return;
2663   }
2664
2665   if (scalar(@errors)) {
2666     $dbh->rollback if $oldAutoCommit;
2667     return join(' / ', @errors);
2668   }
2669
2670   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2671   '';
2672 }
2673
2674 =item insert_reason
2675
2676 Associates this package with a (suspension or cancellation) reason (see
2677 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
2678 L<FS::reason>).
2679
2680 Available options are:
2681
2682 =over 4
2683
2684 =item reason
2685
2686 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.
2687
2688 =item reason_otaker
2689
2690 the access_user (see L<FS::access_user>) providing the reason
2691
2692 =item date
2693
2694 a unix timestamp
2695
2696 =item action
2697
2698 the action (cancel, susp, adjourn, expire) associated with the reason
2699
2700 =back
2701
2702 If there is an error, returns the error, otherwise returns false.
2703
2704 =cut
2705
2706 sub insert_reason {
2707   my ($self, %options) = @_;
2708
2709   my $otaker = $options{reason_otaker} ||
2710                $FS::CurrentUser::CurrentUser->username;
2711
2712   my $reasonnum;
2713   if ( $options{'reason'} =~ /^(\d+)$/ ) {
2714
2715     $reasonnum = $1;
2716
2717   } elsif ( ref($options{'reason'}) ) {
2718
2719     return 'Enter a new reason (or select an existing one)'
2720       unless $options{'reason'}->{'reason'} !~ /^\s*$/;
2721
2722     my $reason = new FS::reason({
2723       'reason_type' => $options{'reason'}->{'typenum'},
2724       'reason'      => $options{'reason'}->{'reason'},
2725     });
2726     my $error = $reason->insert;
2727     return $error if $error;
2728
2729     $reasonnum = $reason->reasonnum;
2730
2731   } else {
2732     return "Unparsable reason: ". $options{'reason'};
2733   }
2734
2735   my $cust_pkg_reason =
2736     new FS::cust_pkg_reason({ 'pkgnum'    => $self->pkgnum,
2737                               'reasonnum' => $reasonnum,
2738                               'otaker'    => $otaker,
2739                               'action'    => substr(uc($options{'action'}),0,1),
2740                               'date'      => $options{'date'}
2741                                                ? $options{'date'}
2742                                                : time,
2743                             });
2744
2745   $cust_pkg_reason->insert;
2746 }
2747
2748 =item set_usage USAGE_VALUE_HASHREF
2749
2750 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2751 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
2752 upbytes, downbytes, and totalbytes are appropriate keys.
2753
2754 All svc_accts which are part of this package have their values reset.
2755
2756 =cut
2757
2758 sub set_usage {
2759   my ($self, $valueref, %opt) = @_;
2760
2761   foreach my $cust_svc ($self->cust_svc){
2762     my $svc_x = $cust_svc->svc_x;
2763     $svc_x->set_usage($valueref, %opt)
2764       if $svc_x->can("set_usage");
2765   }
2766 }
2767
2768 =item recharge USAGE_VALUE_HASHREF
2769
2770 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2771 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
2772 upbytes, downbytes, and totalbytes are appropriate keys.
2773
2774 All svc_accts which are part of this package have their values incremented.
2775
2776 =cut
2777
2778 sub recharge {
2779   my ($self, $valueref) = @_;
2780
2781   foreach my $cust_svc ($self->cust_svc){
2782     my $svc_x = $cust_svc->svc_x;
2783     $svc_x->recharge($valueref)
2784       if $svc_x->can("recharge");
2785   }
2786 }
2787
2788 =back
2789
2790 =head1 BUGS
2791
2792 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
2793
2794 In sub order, the @pkgparts array (passed by reference) is clobbered.
2795
2796 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
2797 method to pass dates to the recur_prog expression, it should do so.
2798
2799 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
2800 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
2801 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
2802 configuration values.  Probably need a subroutine which decides what to do
2803 based on whether or not we've fetched the user yet, rather than a hash.  See
2804 FS::UID and the TODO.
2805
2806 Now that things are transactional should the check in the insert method be
2807 moved to check ?
2808
2809 =head1 SEE ALSO
2810
2811 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
2812 L<FS::pkg_svc>, schema.html from the base documentation
2813
2814 =cut
2815
2816 1;
2817