FS/FS/cust_pkg.pm

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