FS/FS/cust_pkg.pm

   1 package FS::cust_pkg;
   2
   3 use strict;
   4 use vars qw(@ISA $disable_agentcheck $DEBUG);
   5 use List::Util qw(max);
   6 use Tie::IxHash;
   7 use FS::UID qw( getotaker dbh );
   8 use FS::Misc qw( send_email );
   9 use FS::Record qw( qsearch qsearchs );
  10 use FS::cust_main_Mixin;
  11 use FS::cust_svc;
  12 use FS::part_pkg;
  13 use FS::cust_main;
  14 use FS::type_pkgs;
  15 use FS::pkg_svc;
  16 use FS::cust_bill_pkg;
  17 use FS::h_cust_svc;
  18 use FS::reg_code;
  19 use FS::part_svc;
  20 use FS::cust_pkg_reason;
  21 use FS::reason;
  22 use FS::UI::Web;
  23
  24 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
  25 # setup }
  26 # because they load configuration by setting FS::UID::callback (see TODO)
  27 use FS::svc_acct;
  28 use FS::svc_domain;
  29 use FS::svc_www;
  30 use FS::svc_forward;
  31
  32 # for sending cancel emails in sub cancel
  33 use FS::Conf;
  34
  35 @ISA = qw( FS::cust_main_Mixin FS::option_Common FS::Record );
  36
  37 $DEBUG = 0;
  38
  39 $disable_agentcheck = 0;
  40
  41 sub _cache {
  42   my $self = shift;
  43   my ( $hashref, $cache ) = @_;
  44   #if ( $hashref->{'pkgpart'} ) {
  45   if ( $hashref->{'pkg'} ) {
  46     # #@{ $self->{'_pkgnum'} } = ();
  47     # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
  48     # $self->{'_pkgpart'} = $subcache;
  49     # #push @{ $self->{'_pkgnum'} },
  50     #   FS::part_pkg->new_or_cached($hashref, $subcache);
  51     $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
  52   }
  53   if ( exists $hashref->{'svcnum'} ) {
  54     #@{ $self->{'_pkgnum'} } = ();
  55     my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
  56     $self->{'_svcnum'} = $subcache;
  57     #push @{ $self->{'_pkgnum'} },
  58     FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
  59   }
  60 }
  61
  62 =head1 NAME
  63
  64 FS::cust_pkg - Object methods for cust_pkg objects
  65
  66 =head1 SYNOPSIS
  67
  68   use FS::cust_pkg;
  69
  70   $record = new FS::cust_pkg \%hash;
  71   $record = new FS::cust_pkg { 'column' => 'value' };
  72
  73   $error = $record->insert;
  74
  75   $error = $new_record->replace($old_record);
  76
  77   $error = $record->delete;
  78
  79   $error = $record->check;
  80
  81   $error = $record->cancel;
  82
  83   $error = $record->suspend;
  84
  85   $error = $record->unsuspend;
  86
  87   $part_pkg = $record->part_pkg;
  88
  89   @labels = $record->labels;
  90
  91   $seconds = $record->seconds_since($timestamp);
  92
  93   $error = FS::cust_pkg::order( $custnum, \@pkgparts );
  94   $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
  95
  96 =head1 DESCRIPTION
  97
  98 An FS::cust_pkg object represents a customer billing item.  FS::cust_pkg
  99 inherits from FS::Record.  The following fields are currently supported:
 100
 101 =over 4
 102
 103 =item pkgnum - primary key (assigned automatically for new billing items)
 104
 105 =item custnum - Customer (see L<FS::cust_main>)
 106
 107 =item pkgpart - Billing item definition (see L<FS::part_pkg>)
 108
 109 =item setup - date
 110
 111 =item bill - date (next bill date)
 112
 113 =item last_bill - last bill date
 114
 115 =item adjourn - date
 116
 117 =item susp - date
 118
 119 =item expire - date
 120
 121 =item cancel - date
 122
 123 =item otaker - order taker (assigned automatically if null, see L<FS::UID>)
 124
 125 =item manual_flag - If this field is set to 1, disables the automatic
 126 unsuspension of this package when using the B<unsuspendauto> config file.
 127
 128 =back
 129
 130 Note: setup, bill, adjourn, susp, expire and cancel are specified as UNIX timestamps;
 131 see L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for
 132 conversion functions.
 133
 134 =head1 METHODS
 135
 136 =over 4
 137
 138 =item new HASHREF
 139
 140 Create a new billing item.  To add the item to the database, see L<"insert">.
 141
 142 =cut
 143
 144 sub table { 'cust_pkg'; }
 145 sub cust_linked { $_[0]->cust_main_custnum; }
 146 sub cust_unlinked_msg {
 147   my $self = shift;
 148   "WARNING: can't find cust_main.custnum ". $self->custnum.
 149   ' (cust_pkg.pkgnum '. $self->pkgnum. ')';
 150 }
 151
 152 =item insert [ OPTION => VALUE ... ]
 153
 154 Adds this billing item to the database ("Orders" the item).  If there is an
 155 error, returns the error, otherwise returns false.
 156
 157 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
 158 will be used to look up the package definition and agent restrictions will be
 159 ignored.
 160
 161 The following options are available: I<change>
 162
 163 I<change>, if set true, supresses any referral credit to a referring customer.
 164
 165 =cut
 166
 167 sub insert {
 168   my( $self, %options ) = @_;
 169
 170   local $SIG{HUP} = 'IGNORE';
 171   local $SIG{INT} = 'IGNORE';
 172   local $SIG{QUIT} = 'IGNORE';
 173   local $SIG{TERM} = 'IGNORE';
 174   local $SIG{TSTP} = 'IGNORE';
 175   local $SIG{PIPE} = 'IGNORE';
 176
 177   my $oldAutoCommit = $FS::UID::AutoCommit;
 178   local $FS::UID::AutoCommit = 0;
 179   my $dbh = dbh;
 180
 181   my $error = $self->SUPER::insert($options{options} ? %{$options{options}} : ());
 182   if ( $error ) {
 183     $dbh->rollback if $oldAutoCommit;
 184     return $error;
 185   }
 186
 187   #if ( $self->reg_code ) {
 188   #  my $reg_code = qsearchs('reg_code', { 'code' => $self->reg_code } );
 189   #  $error = $reg_code->delete;
 190   #  if ( $error ) {
 191   #    $dbh->rollback if $oldAutoCommit;
 192   #    return $error;
 193   #  }
 194   #}
 195
 196   my $conf = new FS::Conf;
 197   my $cust_main = $self->cust_main;
 198   my $part_pkg = $self->part_pkg;
 199   if ( $conf->exists('referral_credit')
 200        && $cust_main->referral_custnum
 201        && ! $options{'change'}
 202        && $part_pkg->freq !~ /^0\D?$/
 203      )
 204   {
 205     my $referring_cust_main = $cust_main->referring_cust_main;
 206     if ( $referring_cust_main->status ne 'cancelled' ) {
 207       my $error;
 208       if ( $part_pkg->freq !~ /^\d+$/ ) {
 209         warn 'WARNING: Not crediting customer '. $cust_main->referral_custnum.
 210              ' for package '. $self->pkgnum.
 211              ' ( customer '. $self->custnum. ')'.
 212              ' - One-time referral credits not (yet) available for '.
 213              ' packages with '. $part_pkg->freq_pretty. ' frequency';
 214       } else {
 215
 216         my $amount = sprintf( "%.2f", $part_pkg->base_recur / $part_pkg->freq );
 217         my $error =
 218           $referring_cust_main->
 219             credit( $amount,
 220                     'Referral credit for '.$cust_main->name,
 221                     'reason_type' => $conf->config('referral_credit_type')
 222                   );
 223         if ( $error ) {
 224           $dbh->rollback if $oldAutoCommit;
 225           return "Error crediting customer ". $cust_main->referral_custnum.
 226                " for referral: $error";
 227         }
 228
 229       }
 230
 231     }
 232   }
 233
 234   if ($conf->config('welcome_letter') && $self->cust_main->num_pkgs == 1) {
 235     my $queue = new FS::queue {
 236       'job'     => 'FS::cust_main::queueable_print',
 237     };
 238     $error = $queue->insert(
 239       'custnum'  => $self->custnum,
 240       'template' => 'welcome_letter',
 241     );
 242
 243     if ($error) {
 244       warn "can't send welcome letter: $error";
 245     }
 246
 247   }
 248
 249   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 250   '';
 251
 252 }
 253
 254 =item delete
 255
 256 This method now works but you probably shouldn't use it.
 257
 258 You don't want to delete billing items, because there would then be no record
 259 the customer ever purchased the item.  Instead, see the cancel method.
 260
 261 =cut
 262
 263 #sub delete {
 264 #  return "Can't delete cust_pkg records!";
 265 #}
 266
 267 =item replace OLD_RECORD
 268
 269 Replaces the OLD_RECORD with this one in the database.  If there is an error,
 270 returns the error, otherwise returns false.
 271
 272 Currently, custnum, setup, bill, adjourn, susp, expire, and cancel may be changed.
 273
 274 Changing pkgpart may have disasterous effects.  See the order subroutine.
 275
 276 setup and bill are normally updated by calling the bill method of a customer
 277 object (see L<FS::cust_main>).
 278
 279 suspend is normally updated by the suspend and unsuspend methods.
 280
 281 cancel is normally updated by the cancel method (and also the order subroutine
 282 in some cases).
 283
 284 Calls
 285
 286 =cut
 287
 288 sub replace {
 289   my( $new, $old, %options ) = @_;
 290
 291   # We absolutely have to have an old vs. new record to make this work.
 292   if (!defined($old)) {
 293     $old = qsearchs( 'cust_pkg', { 'pkgnum' => $new->pkgnum } );
 294   }
 295   #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
 296   return "Can't change otaker!" if $old->otaker ne $new->otaker;
 297
 298   #allow this *sigh*
 299   #return "Can't change setup once it exists!"
 300   #  if $old->getfield('setup') &&
 301   #     $old->getfield('setup') != $new->getfield('setup');
 302
 303   #some logic for bill, susp, cancel?
 304
 305   local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
 306
 307   local $SIG{HUP} = 'IGNORE';
 308   local $SIG{INT} = 'IGNORE';
 309   local $SIG{QUIT} = 'IGNORE';
 310   local $SIG{TERM} = 'IGNORE';
 311   local $SIG{TSTP} = 'IGNORE';
 312   local $SIG{PIPE} = 'IGNORE';
 313
 314   my $oldAutoCommit = $FS::UID::AutoCommit;
 315   local $FS::UID::AutoCommit = 0;
 316   my $dbh = dbh;
 317
 318   foreach my $method ( qw(adjourn expire) ) {  # How many reasons?
 319     if ($options{'reason'} && $new->$method && $old->$method ne $new->$method) {
 320       my $error = $new->insert_reason( 'reason' => $options{'reason'},
 321                                        'date'      => $new->$method,
 322                                      );
 323       if ( $error ) {
 324         dbh->rollback if $oldAutoCommit;
 325         return "Error inserting cust_pkg_reason: $error";
 326       }
 327     }
 328   }
 329
 330   #save off and freeze RADIUS attributes for any associated svc_acct records
 331   my @svc_acct = ();
 332   if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
 333
 334                 #also check for specific exports?
 335                 # to avoid spurious modify export events
 336     @svc_acct = map  { $_->svc_x }
 337                 grep { $_->part_svc->svcdb eq 'svc_acct' }
 338                      $old->cust_svc;
 339
 340     $_->snapshot foreach @svc_acct;
 341
 342   }
 343
 344   my $error = $new->SUPER::replace($old,
 345                                    $options{options} ? ${options{options}} : ()
 346                                   );
 347   if ( $error ) {
 348     $dbh->rollback if $oldAutoCommit;
 349     return $error;
 350   }
 351
 352   #for prepaid packages,
 353   #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
 354   foreach my $old_svc_acct ( @svc_acct ) {
 355     my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
 356     my $s_error = $new_svc_acct->replace($old_svc_acct);
 357     if ( $s_error ) {
 358       $dbh->rollback if $oldAutoCommit;
 359       return $s_error;
 360     }
 361   }
 362
 363   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 364   '';
 365
 366 }
 367
 368 =item check
 369
 370 Checks all fields to make sure this is a valid billing item.  If there is an
 371 error, returns the error, otherwise returns false.  Called by the insert and
 372 replace methods.
 373
 374 =cut
 375
 376 sub check {
 377   my $self = shift;
 378
 379   my $error =
 380     $self->ut_numbern('pkgnum')
 381     || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
 382     || $self->ut_numbern('pkgpart')
 383     || $self->ut_numbern('setup')
 384     || $self->ut_numbern('bill')
 385     || $self->ut_numbern('susp')
 386     || $self->ut_numbern('cancel')
 387     || $self->ut_numbern('adjourn')
 388     || $self->ut_numbern('expire')
 389   ;
 390   return $error if $error;
 391
 392   if ( $self->reg_code ) {
 393
 394     unless ( grep { $self->pkgpart == $_->pkgpart }
 395              map  { $_->reg_code_pkg }
 396              qsearchs( 'reg_code', { 'code'     => $self->reg_code,
 397                                      'agentnum' => $self->cust_main->agentnum })
 398            ) {
 399       return "Unknown registration code";
 400     }
 401
 402   } elsif ( $self->promo_code ) {
 403
 404     my $promo_part_pkg =
 405       qsearchs('part_pkg', {
 406         'pkgpart'    => $self->pkgpart,
 407         'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
 408       } );
 409     return 'Unknown promotional code' unless $promo_part_pkg;
 410
 411   } else {
 412
 413     unless ( $disable_agentcheck ) {
 414       my $agent =
 415         qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
 416       my $pkgpart_href = $agent->pkgpart_hashref;
 417       return "agent ". $agent->agentnum.
 418              " can't purchase pkgpart ". $self->pkgpart
 419         unless $pkgpart_href->{ $self->pkgpart };
 420     }
 421
 422     $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
 423     return $error if $error;
 424
 425   }
 426
 427   $self->otaker(getotaker) unless $self->otaker;
 428   $self->otaker =~ /^(\w{1,32})$/ or return "Illegal otaker";
 429   $self->otaker($1);
 430
 431   if ( $self->dbdef_table->column('manual_flag') ) {
 432     $self->manual_flag('') if $self->manual_flag eq ' ';
 433     $self->manual_flag =~ /^([01]?)$/
 434       or return "Illegal manual_flag ". $self->manual_flag;
 435     $self->manual_flag($1);
 436   }
 437
 438   $self->SUPER::check;
 439 }
 440
 441 =item cancel [ OPTION => VALUE ... ]
 442
 443 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
 444 in this package, then cancels the package itself (sets the cancel field to
 445 now).
 446
 447 Available options are: I<quiet>
 448
 449 I<quiet> can be set true to supress email cancellation notices.
 450
 451 If there is an error, returns the error, otherwise returns false.
 452
 453 =cut
 454
 455 sub cancel {
 456   my( $self, %options ) = @_;
 457   my $error;
 458
 459   local $SIG{HUP} = 'IGNORE';
 460   local $SIG{INT} = 'IGNORE';
 461   local $SIG{QUIT} = 'IGNORE';
 462   local $SIG{TERM} = 'IGNORE';
 463   local $SIG{TSTP} = 'IGNORE';
 464   local $SIG{PIPE} = 'IGNORE';
 465
 466   my $oldAutoCommit = $FS::UID::AutoCommit;
 467   local $FS::UID::AutoCommit = 0;
 468   my $dbh = dbh;
 469
 470   if ($options{'reason'}) {
 471     $error = $self->insert_reason( 'reason' => $options{'reason'} );
 472     if ( $error ) {
 473       dbh->rollback if $oldAutoCommit;
 474       return "Error inserting cust_pkg_reason: $error";
 475     }
 476   }
 477
 478   my %svc;
 479   foreach my $cust_svc (
 480     #schwartz
 481     map  { $_->[0] }
 482     sort { $a->[1] <=> $b->[1] }
 483     map  { [ $_, $_->svc_x->table_info->{'cancel_weight'} ]; }
 484     qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 485   ) {
 486
 487     my $error = $cust_svc->cancel;
 488
 489     if ( $error ) {
 490       $dbh->rollback if $oldAutoCommit;
 491       return "Error cancelling cust_svc: $error";
 492     }
 493   }
 494
 495   # Add a credit for remaining service
 496   my $remaining_value = $self->calc_remain();
 497   if ( $remaining_value > 0 ) {
 498     my $conf = new FS::Conf;
 499     my $error = $self->cust_main->credit(
 500       $remaining_value,
 501       'Credit for unused time on '. $self->part_pkg->pkg,
 502       'reason_type' => $conf->config('cancel_credit_type'),
 503     );
 504     if ($error) {
 505       $dbh->rollback if $oldAutoCommit;
 506       return "Error crediting customer \$$remaining_value for unused time on".
 507              $self->part_pkg->pkg. ": $error";
 508     }
 509   }
 510
 511   unless ( $self->getfield('cancel') ) {
 512     my %hash = $self->hash;
 513     $hash{'cancel'} = time;
 514     my $new = new FS::cust_pkg ( \%hash );
 515     $error = $new->replace( $self, options => { $self->options } );
 516     if ( $error ) {
 517       $dbh->rollback if $oldAutoCommit;
 518       return $error;
 519     }
 520   }
 521
 522   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 523
 524   my $conf = new FS::Conf;
 525   my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
 526   if ( !$options{'quiet'} && $conf->exists('emailcancel') && @invoicing_list ) {
 527     my $conf = new FS::Conf;
 528     my $error = send_email(
 529       'from'    => $conf->config('invoice_from'),
 530       'to'      => \@invoicing_list,
 531       'subject' => ( $conf->config('cancelsubject') || 'Cancellation Notice' ),
 532       'body'    => [ map "$_\n", $conf->config('cancelmessage') ],
 533     );
 534     #should this do something on errors?
 535   }
 536
 537   ''; #no errors
 538
 539 }
 540
 541 =item suspend
 542
 543 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 544 package, then suspends the package itself (sets the susp field to now).
 545
 546 If there is an error, returns the error, otherwise returns false.
 547
 548 =cut
 549
 550 sub suspend {
 551   my( $self, %options ) = @_;
 552   my $error ;
 553
 554   local $SIG{HUP} = 'IGNORE';
 555   local $SIG{INT} = 'IGNORE';
 556   local $SIG{QUIT} = 'IGNORE';
 557   local $SIG{TERM} = 'IGNORE';
 558   local $SIG{TSTP} = 'IGNORE';
 559   local $SIG{PIPE} = 'IGNORE';
 560
 561   my $oldAutoCommit = $FS::UID::AutoCommit;
 562   local $FS::UID::AutoCommit = 0;
 563   my $dbh = dbh;
 564
 565   if ($options{'reason'}) {
 566     $error = $self->insert_reason( 'reason' => $options{'reason'} );
 567     if ( $error ) {
 568       dbh->rollback if $oldAutoCommit;
 569       return "Error inserting cust_pkg_reason: $error";
 570     }
 571   }
 572
 573   foreach my $cust_svc (
 574     qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 575   ) {
 576     my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 577
 578     $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 579       $dbh->rollback if $oldAutoCommit;
 580       return "Illegal svcdb value in part_svc!";
 581     };
 582     my $svcdb = $1;
 583     require "FS/$svcdb.pm";
 584
 585     my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
 586     if ($svc) {
 587       $error = $svc->suspend;
 588       if ( $error ) {
 589         $dbh->rollback if $oldAutoCommit;
 590         return $error;
 591       }
 592     }
 593
 594   }
 595
 596   unless ( $self->getfield('susp') ) {
 597     my %hash = $self->hash;
 598     $hash{'susp'} = time;
 599     my $new = new FS::cust_pkg ( \%hash );
 600     $error = $new->replace( $self, options => { $self->options } );
 601     if ( $error ) {
 602       $dbh->rollback if $oldAutoCommit;
 603       return $error;
 604     }
 605   }
 606
 607   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 608
 609   ''; #no errors
 610 }
 611
 612 =item unsuspend [ OPTION => VALUE ... ]
 613
 614 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 615 package, then unsuspends the package itself (clears the susp field and the
 616 adjourn field if it is in the past).
 617
 618 Available options are: I<adjust_next_bill>.
 619
 620 I<adjust_next_bill> can be set true to adjust the next bill date forward by
 621 the amount of time the account was inactive.  This was set true by default
 622 since 1.4.2 and 1.5.0pre6; however, starting with 1.7.0 this needs to be
 623 explicitly requested.  Price plans for which this makes sense (anniversary-date
 624 based than prorate or subscription) could have an option to enable this
 625 behaviour?
 626
 627 If there is an error, returns the error, otherwise returns false.
 628
 629 =cut
 630
 631 sub unsuspend {
 632   my( $self, %opt ) = @_;
 633   my $error;
 634
 635   local $SIG{HUP} = 'IGNORE';
 636   local $SIG{INT} = 'IGNORE';
 637   local $SIG{QUIT} = 'IGNORE';
 638   local $SIG{TERM} = 'IGNORE';
 639   local $SIG{TSTP} = 'IGNORE';
 640   local $SIG{PIPE} = 'IGNORE';
 641
 642   my $oldAutoCommit = $FS::UID::AutoCommit;
 643   local $FS::UID::AutoCommit = 0;
 644   my $dbh = dbh;
 645
 646   foreach my $cust_svc (
 647     qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
 648   ) {
 649     my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 650
 651     $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 652       $dbh->rollback if $oldAutoCommit;
 653       return "Illegal svcdb value in part_svc!";
 654     };
 655     my $svcdb = $1;
 656     require "FS/$svcdb.pm";
 657
 658     my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
 659     if ($svc) {
 660       $error = $svc->unsuspend;
 661       if ( $error ) {
 662         $dbh->rollback if $oldAutoCommit;
 663         return $error;
 664       }
 665     }
 666
 667   }
 668
 669   unless ( ! $self->getfield('susp') ) {
 670     my %hash = $self->hash;
 671     my $inactive = time - $hash{'susp'};
 672
 673     my $conf = new FS::Conf;
 674
 675     $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive
 676       if ( $opt{'adjust_next_bill'}
 677            || $conf->config('unsuspend-always_adjust_next_bill_date') )
 678       && $inactive > 0 && ( $hash{'bill'} || $hash{'setup'} );
 679
 680     $hash{'susp'} = '';
 681     $hash{'adjourn'} = '' if $hash{'adjourn'} < time;
 682     my $new = new FS::cust_pkg ( \%hash );
 683     $error = $new->replace( $self, options => { $self->options } );
 684     if ( $error ) {
 685       $dbh->rollback if $oldAutoCommit;
 686       return $error;
 687     }
 688   }
 689
 690   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 691
 692   ''; #no errors
 693 }
 694
 695 =item last_bill
 696
 697 Returns the last bill date, or if there is no last bill date, the setup date.
 698 Useful for billing metered services.
 699
 700 =cut
 701
 702 sub last_bill {
 703   my $self = shift;
 704   if ( $self->dbdef_table->column('last_bill') ) {
 705     return $self->setfield('last_bill', $_[0]) if @_;
 706     return $self->getfield('last_bill') if $self->getfield('last_bill');
 707   }
 708   my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
 709                                                   'edate'  => $self->bill,  } );
 710   $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
 711 }
 712
 713 =item last_reason
 714
 715 Returns the most recent FS::reason associated with the package.
 716
 717 =cut
 718
 719 sub last_reason {
 720   my $self = shift;
 721   my $cust_pkg_reason = qsearchs( {
 722                                     'table' => 'cust_pkg_reason',
 723                                     'hashref' => { 'pkgnum' => $self->pkgnum, },
 724                                     'extra_sql'=> 'ORDER BY date DESC LIMIT 1',
 725                                   } );
 726   qsearchs ( 'reason', { 'reasonnum' => $cust_pkg_reason->reasonnum } )
 727     if $cust_pkg_reason;
 728 }
 729
 730 =item part_pkg
 731
 732 Returns the definition for this billing item, as an FS::part_pkg object (see
 733 L<FS::part_pkg>).
 734
 735 =cut
 736
 737 sub part_pkg {
 738   my $self = shift;
 739   #exists( $self->{'_pkgpart'} )
 740   $self->{'_pkgpart'}
 741     ? $self->{'_pkgpart'}
 742     : qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
 743 }
 744
 745 =item old_cust_pkg
 746
 747 Returns the cancelled package this package was changed from, if any.
 748
 749 =cut
 750
 751 sub old_cust_pkg {
 752   my $self = shift;
 753   return '' unless $self->change_pkgnum;
 754   qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
 755 }
 756
 757 =item calc_setup
 758
 759 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
 760 item.
 761
 762 =cut
 763
 764 sub calc_setup {
 765   my $self = shift;
 766   $self->part_pkg->calc_setup($self, @_);
 767 }
 768
 769 =item calc_recur
 770
 771 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
 772 item.
 773
 774 =cut
 775
 776 sub calc_recur {
 777   my $self = shift;
 778   $self->part_pkg->calc_recur($self, @_);
 779 }
 780
 781 =item calc_remain
 782
 783 Calls the I<calc_remain> of the FS::part_pkg object associated with this
 784 billing item.
 785
 786 =cut
 787
 788 sub calc_remain {
 789   my $self = shift;
 790   $self->part_pkg->calc_remain($self, @_);
 791 }
 792
 793 =item calc_cancel
 794
 795 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
 796 billing item.
 797
 798 =cut
 799
 800 sub calc_cancel {
 801   my $self = shift;
 802   $self->part_pkg->calc_cancel($self, @_);
 803 }
 804
 805 =item cust_bill_pkg
 806
 807 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
 808
 809 =cut
 810
 811 sub cust_bill_pkg {
 812   my $self = shift;
 813   qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
 814 }
 815
 816 =item cust_svc [ SVCPART ]
 817
 818 Returns the services for this package, as FS::cust_svc objects (see
 819 L<FS::cust_svc>).  If a svcpart is specified, return only the matching
 820 services.
 821
 822 =cut
 823
 824 sub cust_svc {
 825   my $self = shift;
 826
 827   if ( @_ ) {
 828     return qsearch( 'cust_svc', { 'pkgnum'  => $self->pkgnum,
 829                                   'svcpart' => shift,          } );
 830   }
 831
 832   #if ( $self->{'_svcnum'} ) {
 833   #  values %{ $self->{'_svcnum'}->cache };
 834   #} else {
 835     $self->_sort_cust_svc(
 836       [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
 837     );
 838   #}
 839
 840 }
 841
 842 =item overlimit [ SVCPART ]
 843
 844 Returns the services for this package which have exceeded their
 845 usage limit as FS::cust_svc objects (see L<FS::cust_svc>).  If a svcpart
 846 is specified, return only the matching services.
 847
 848 =cut
 849
 850 sub overlimit {
 851   my $self = shift;
 852   grep { $_->overlimit } $self->cust_svc;
 853 }
 854
 855 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ]
 856
 857 Returns historical services for this package created before END TIMESTAMP and
 858 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
 859 (see L<FS::h_cust_svc>).
 860
 861 =cut
 862
 863 sub h_cust_svc {
 864   my $self = shift;
 865
 866   $self->_sort_cust_svc(
 867     [ qsearch( 'h_cust_svc',
 868                { 'pkgnum' => $self->pkgnum, },
 869                FS::h_cust_svc->sql_h_search(@_),
 870              )
 871     ]
 872   );
 873 }
 874
 875 sub _sort_cust_svc {
 876   my( $self, $arrayref ) = @_;
 877
 878   map  { $_->[0] }
 879   sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
 880   map {
 881         my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
 882                                              'svcpart' => $_->svcpart     } );
 883         [ $_,
 884           $pkg_svc ? $pkg_svc->primary_svc : '',
 885           $pkg_svc ? $pkg_svc->quantity : 0,
 886         ];
 887       }
 888   @$arrayref;
 889
 890 }
 891
 892 =item num_cust_svc [ SVCPART ]
 893
 894 Returns the number of provisioned services for this package.  If a svcpart is
 895 specified, counts only the matching services.
 896
 897 =cut
 898
 899 sub num_cust_svc {
 900   my $self = shift;
 901   my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
 902   $sql .= ' AND svcpart = ?' if @_;
 903   my $sth = dbh->prepare($sql) or die dbh->errstr;
 904   $sth->execute($self->pkgnum, @_) or die $sth->errstr;
 905   $sth->fetchrow_arrayref->[0];
 906 }
 907
 908 =item available_part_svc
 909
 910 Returns a list of FS::part_svc objects representing services included in this
 911 package but not yet provisioned.  Each FS::part_svc object also has an extra
 912 field, I<num_avail>, which specifies the number of available services.
 913
 914 =cut
 915
 916 sub available_part_svc {
 917   my $self = shift;
 918   grep { $_->num_avail > 0 }
 919     map {
 920           my $part_svc = $_->part_svc;
 921           $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
 922             $_->quantity - $self->num_cust_svc($_->svcpart);
 923           $part_svc;
 924         }
 925       $self->part_pkg->pkg_svc;
 926 }
 927
 928 =item part_svc
 929
 930 Returns a list of FS::part_svc objects representing provisioned and available
 931 services included in this package.  Each FS::part_svc object also has the
 932 following extra fields:
 933
 934 =over 4
 935
 936 =item num_cust_svc  (count)
 937
 938 =item num_avail     (quantity - count)
 939
 940 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
 941
 942 svcnum
 943 label -> ($cust_svc->label)[1]
 944
 945 =back
 946
 947 =cut
 948
 949 sub part_svc {
 950   my $self = shift;
 951
 952   #XXX some sort of sort order besides numeric by svcpart...
 953   my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
 954     my $pkg_svc = $_;
 955     my $part_svc = $pkg_svc->part_svc;
 956     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
 957     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
 958     $part_svc->{'Hash'}{'num_avail'}    =
 959       max( 0, $pkg_svc->quantity - $num_cust_svc );
 960     $part_svc->{'Hash'}{'cust_pkg_svc'} = [ $self->cust_svc($part_svc->svcpart) ];
 961     $part_svc;
 962   } $self->part_pkg->pkg_svc;
 963
 964   #extras
 965   push @part_svc, map {
 966     my $part_svc = $_;
 967     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
 968     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
 969     $part_svc->{'Hash'}{'num_avail'}    = 0; #0-$num_cust_svc ?
 970     $part_svc->{'Hash'}{'cust_pkg_svc'} = [ $self->cust_svc($part_svc->svcpart) ];
 971     $part_svc;
 972   } $self->extra_part_svc;
 973
 974   @part_svc;
 975
 976 }
 977
 978 =item extra_part_svc
 979
 980 Returns a list of FS::part_svc objects corresponding to services in this
 981 package which are still provisioned but not (any longer) available in the
 982 package definition.
 983
 984 =cut
 985
 986 sub extra_part_svc {
 987   my $self = shift;
 988
 989   my $pkgnum  = $self->pkgnum;
 990   my $pkgpart = $self->pkgpart;
 991
 992   qsearch( {
 993     'table'     => 'part_svc',
 994     'hashref'   => {},
 995     'extra_sql' => "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
 996                                   WHERE pkg_svc.svcpart = part_svc.svcpart
 997                                     AND pkg_svc.pkgpart = $pkgpart
 998                                     AND quantity > 0
 999                               )
1000                       AND 0 < ( SELECT count(*)
1001                                   FROM cust_svc
1002                                     LEFT JOIN cust_pkg using ( pkgnum )
1003                                   WHERE cust_svc.svcpart = part_svc.svcpart
1004                                     AND pkgnum = $pkgnum
1005                               )",
1006   } );
1007 }
1008
1009 =item status
1010
1011 Returns a short status string for this package, currently:
1012
1013 =over 4
1014
1015 =item not yet billed
1016
1017 =item one-time charge
1018
1019 =item active
1020
1021 =item suspended
1022
1023 =item cancelled
1024
1025 =back
1026
1027 =cut
1028
1029 sub status {
1030   my $self = shift;
1031
1032   my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
1033
1034   return 'cancelled' if $self->get('cancel');
1035   return 'suspended' if $self->susp;
1036   return 'not yet billed' unless $self->setup;
1037   return 'one-time charge' if $freq =~ /^(0|$)/;
1038   return 'active';
1039 }
1040
1041 =item statuses
1042
1043 Class method that returns the list of possible status strings for pacakges
1044 (see L<the status method|/status>).  For example:
1045
1046   @statuses = FS::cust_pkg->statuses();
1047
1048 =cut
1049
1050 tie my %statuscolor, 'Tie::IxHash',
1051   'not yet billed'  => '000000',
1052   'one-time charge' => '000000',
1053   'active'          => '00CC00',
1054   'suspended'       => 'FF9900',
1055   'cancelled'       => 'FF0000',
1056 ;
1057
1058 sub statuses {
1059   my $self = shift; #could be class...
1060   grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
1061                                       # mayble split btw one-time vs. recur
1062     keys %statuscolor;
1063 }
1064
1065 =item statuscolor
1066
1067 Returns a hex triplet color string for this package's status.
1068
1069 =cut
1070
1071 sub statuscolor {
1072   my $self = shift;
1073   $statuscolor{$self->status};
1074 }
1075
1076 =item labels
1077
1078 Returns a list of lists, calling the label method for all services
1079 (see L<FS::cust_svc>) of this billing item.
1080
1081 =cut
1082
1083 sub labels {
1084   my $self = shift;
1085   map { [ $_->label ] } $self->cust_svc;
1086 }
1087
1088 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
1089
1090 Like the labels method, but returns historical information on services that
1091 were active as of END_TIMESTAMP and (optionally) not cancelled before
1092 START_TIMESTAMP.
1093
1094 Returns a list of lists, calling the label method for all (historical) services
1095 (see L<FS::h_cust_svc>) of this billing item.
1096
1097 =cut
1098
1099 sub h_labels {
1100   my $self = shift;
1101   map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
1102 }
1103
1104 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
1105
1106 Like h_labels, except returns a simple flat list, and shortens long
1107 (currently >5) lists of identical services to one line that lists the service
1108 label and the number of individual services rather than individual items.
1109
1110 =cut
1111
1112 sub h_labels_short {
1113   my $self = shift;
1114
1115   my %labels;
1116   #tie %labels, 'Tie::IxHash';
1117   push @{ $labels{$_->[0]} }, $_->[1]
1118     foreach $self->h_labels(@_);
1119   my @labels;
1120   foreach my $label ( keys %labels ) {
1121     my @values = @{ $labels{$label} };
1122     my $num = scalar(@values);
1123     if ( $num > 5 ) {
1124       push @labels, "$label ($num)";
1125     } else {
1126       push @labels, map { "$label: $_" } @values;
1127     }
1128   }
1129
1130  @labels;
1131
1132 }
1133
1134 =item cust_main
1135
1136 Returns the parent customer object (see L<FS::cust_main>).
1137
1138 =cut
1139
1140 sub cust_main {
1141   my $self = shift;
1142   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
1143 }
1144
1145 =item seconds_since TIMESTAMP
1146
1147 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
1148 package have been online since TIMESTAMP, according to the session monitor.
1149
1150 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1151 L<Time::Local> and L<Date::Parse> for conversion functions.
1152
1153 =cut
1154
1155 sub seconds_since {
1156   my($self, $since) = @_;
1157   my $seconds = 0;
1158
1159   foreach my $cust_svc (
1160     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
1161   ) {
1162     $seconds += $cust_svc->seconds_since($since);
1163   }
1164
1165   $seconds;
1166
1167 }
1168
1169 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1170
1171 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
1172 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
1173 (exclusive).
1174
1175 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1176 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1177 functions.
1178
1179
1180 =cut
1181
1182 sub seconds_since_sqlradacct {
1183   my($self, $start, $end) = @_;
1184
1185   my $seconds = 0;
1186
1187   foreach my $cust_svc (
1188     grep {
1189       my $part_svc = $_->part_svc;
1190       $part_svc->svcdb eq 'svc_acct'
1191         && scalar($part_svc->part_export('sqlradius'));
1192     } $self->cust_svc
1193   ) {
1194     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
1195   }
1196
1197   $seconds;
1198
1199 }
1200
1201 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1202
1203 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1204 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1205 TIMESTAMP_END
1206 (exclusive).
1207
1208 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1209 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1210 functions.
1211
1212 =cut
1213
1214 sub attribute_since_sqlradacct {
1215   my($self, $start, $end, $attrib) = @_;
1216
1217   my $sum = 0;
1218
1219   foreach my $cust_svc (
1220     grep {
1221       my $part_svc = $_->part_svc;
1222       $part_svc->svcdb eq 'svc_acct'
1223         && scalar($part_svc->part_export('sqlradius'));
1224     } $self->cust_svc
1225   ) {
1226     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
1227   }
1228
1229   $sum;
1230
1231 }
1232
1233 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
1234
1235 Transfers as many services as possible from this package to another package.
1236
1237 The destination package can be specified by pkgnum by passing an FS::cust_pkg
1238 object.  The destination package must already exist.
1239
1240 Services are moved only if the destination allows services with the correct
1241 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
1242 this option with caution!  No provision is made for export differences
1243 between the old and new service definitions.  Probably only should be used
1244 when your exports for all service definitions of a given svcdb are identical.
1245 (attempt a transfer without it first, to move all possible svcpart-matching
1246 services)
1247
1248 Any services that can't be moved remain in the original package.
1249
1250 Returns an error, if there is one; otherwise, returns the number of services
1251 that couldn't be moved.
1252
1253 =cut
1254
1255 sub transfer {
1256   my ($self, $dest_pkgnum, %opt) = @_;
1257
1258   my $remaining = 0;
1259   my $dest;
1260   my %target;
1261
1262   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
1263     $dest = $dest_pkgnum;
1264     $dest_pkgnum = $dest->pkgnum;
1265   } else {
1266     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
1267   }
1268
1269   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
1270
1271   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
1272     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
1273   }
1274
1275   foreach my $cust_svc ($dest->cust_svc) {
1276     $target{$cust_svc->svcpart}--;
1277   }
1278
1279   my %svcpart2svcparts = ();
1280   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1281     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
1282     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
1283       next if exists $svcpart2svcparts{$svcpart};
1284       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
1285       $svcpart2svcparts{$svcpart} = [
1286         map  { $_->[0] }
1287         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
1288         map {
1289               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
1290                                                    'svcpart' => $_          } );
1291               [ $_,
1292                 $pkg_svc ? $pkg_svc->primary_svc : '',
1293                 $pkg_svc ? $pkg_svc->quantity : 0,
1294               ];
1295             }
1296
1297         grep { $_ != $svcpart }
1298         map  { $_->svcpart }
1299         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
1300       ];
1301       warn "alternates for svcpart $svcpart: ".
1302            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
1303         if $DEBUG;
1304     }
1305   }
1306
1307   foreach my $cust_svc ($self->cust_svc) {
1308     if($target{$cust_svc->svcpart} > 0) {
1309       $target{$cust_svc->svcpart}--;
1310       my $new = new FS::cust_svc { $cust_svc->hash };
1311       $new->pkgnum($dest_pkgnum);
1312       my $error = $new->replace($cust_svc);
1313       return $error if $error;
1314     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1315       if ( $DEBUG ) {
1316         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
1317         warn "alternates to consider: ".
1318              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
1319       }
1320       my @alternate = grep {
1321                              warn "considering alternate svcpart $_: ".
1322                                   "$target{$_} available in new package\n"
1323                                if $DEBUG;
1324                              $target{$_} > 0;
1325                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
1326       if ( @alternate ) {
1327         warn "alternate(s) found\n" if $DEBUG;
1328         my $change_svcpart = $alternate[0];
1329         $target{$change_svcpart}--;
1330         my $new = new FS::cust_svc { $cust_svc->hash };
1331         $new->svcpart($change_svcpart);
1332         $new->pkgnum($dest_pkgnum);
1333         my $error = $new->replace($cust_svc);
1334         return $error if $error;
1335       } else {
1336         $remaining++;
1337       }
1338     } else {
1339       $remaining++
1340     }
1341   }
1342   return $remaining;
1343 }
1344
1345 =item reexport
1346
1347 This method is deprecated.  See the I<depend_jobnum> option to the insert and
1348 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
1349
1350 =cut
1351
1352 sub reexport {
1353   my $self = shift;
1354
1355   local $SIG{HUP} = 'IGNORE';
1356   local $SIG{INT} = 'IGNORE';
1357   local $SIG{QUIT} = 'IGNORE';
1358   local $SIG{TERM} = 'IGNORE';
1359   local $SIG{TSTP} = 'IGNORE';
1360   local $SIG{PIPE} = 'IGNORE';
1361
1362   my $oldAutoCommit = $FS::UID::AutoCommit;
1363   local $FS::UID::AutoCommit = 0;
1364   my $dbh = dbh;
1365
1366   foreach my $cust_svc ( $self->cust_svc ) {
1367     #false laziness w/svc_Common::insert
1368     my $svc_x = $cust_svc->svc_x;
1369     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
1370       my $error = $part_export->export_insert($svc_x);
1371       if ( $error ) {
1372         $dbh->rollback if $oldAutoCommit;
1373         return $error;
1374       }
1375     }
1376   }
1377
1378   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1379   '';
1380
1381 }
1382
1383 =back
1384
1385 =head1 CLASS METHODS
1386
1387 =over 4
1388
1389 =item recurring_sql
1390
1391 Returns an SQL expression identifying recurring packages.
1392
1393 =cut
1394
1395 sub recurring_sql { "
1396   '0' != ( select freq from part_pkg
1397              where cust_pkg.pkgpart = part_pkg.pkgpart )
1398 "; }
1399
1400 =item onetime_sql
1401
1402 Returns an SQL expression identifying one-time packages.
1403
1404 =cut
1405
1406 sub onetime_sql { "
1407   '0' = ( select freq from part_pkg
1408             where cust_pkg.pkgpart = part_pkg.pkgpart )
1409 "; }
1410
1411 =item active_sql
1412
1413 Returns an SQL expression identifying active packages.
1414
1415 =cut
1416
1417 sub active_sql { "
1418   ". $_[0]->recurring_sql(). "
1419   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1420   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
1421 "; }
1422
1423 =item inactive_sql
1424
1425 Returns an SQL expression identifying inactive packages (one-time packages
1426 that are otherwise unsuspended/uncancelled).
1427
1428 =cut
1429
1430 sub inactive_sql { "
1431   ". $_[0]->onetime_sql(). "
1432   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1433   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
1434 "; }
1435
1436 =item susp_sql
1437 =item suspended_sql
1438
1439 Returns an SQL expression identifying suspended packages.
1440
1441 =cut
1442
1443 sub suspended_sql { susp_sql(@_); }
1444 sub susp_sql {
1445   #$_[0]->recurring_sql(). ' AND '.
1446   "
1447         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
1448     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
1449   ";
1450 }
1451
1452 =item cancel_sql
1453 =item cancelled_sql
1454
1455 Returns an SQL exprression identifying cancelled packages.
1456
1457 =cut
1458
1459 sub cancelled_sql { cancel_sql(@_); }
1460 sub cancel_sql {
1461   #$_[0]->recurring_sql(). ' AND '.
1462   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
1463 }
1464
1465 =item search_sql HREF
1466
1467 Returns a qsearch hash expression to search for parameters specified in HREF.
1468 Valid parameters are
1469
1470 =over 4
1471 =item agentnum
1472 =item magic - /^(active|inactive|suspended|cancell?ed)$/
1473 =item status - /^(active|inactive|suspended|one-time charge|inactive|cancell?ed)$/
1474 =item classnum
1475 =item pkgpart - list specified how?
1476 =item setup     - arrayref of beginning and ending epoch date
1477 =item last_bill - arrayref of beginning and ending epoch date
1478 =item bill      - arrayref of beginning and ending epoch date
1479 =item adjourn   - arrayref of beginning and ending epoch date
1480 =item susp      - arrayref of beginning and ending epoch date
1481 =item expire    - arrayref of beginning and ending epoch date
1482 =item cancel    - arrayref of beginning and ending epoch date
1483 =item query - /^(pkgnum/APKG_pkgnum)$/
1484 =item cust_fields - a value suited to passing to FS::UI::Web::cust_header
1485 =item CurrentUser - specifies the user for agent virtualization
1486 =back
1487
1488 =cut
1489
1490 sub search_sql {
1491   my ($class, $params) = @_;
1492   my @where = ();
1493
1494   ##
1495   # parse agent
1496   ##
1497
1498   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
1499     push @where,
1500       "agentnum = $1";
1501   }
1502
1503   ##
1504   # parse status
1505   ##
1506
1507   if (    $params->{'magic'}  eq 'active'
1508        || $params->{'status'} eq 'active' ) {
1509
1510     push @where, FS::cust_pkg->active_sql();
1511
1512   } elsif (    $params->{'magic'}  eq 'inactive'
1513             || $params->{'status'} eq 'inactive' ) {
1514
1515     push @where, FS::cust_pkg->inactive_sql();
1516
1517   } elsif (    $params->{'magic'}  eq 'suspended'
1518             || $params->{'status'} eq 'suspended'  ) {
1519
1520     push @where, FS::cust_pkg->suspended_sql();
1521
1522   } elsif (    $params->{'magic'}  =~ /^cancell?ed$/
1523             || $params->{'status'} =~ /^cancell?ed$/ ) {
1524
1525     push @where, FS::cust_pkg->cancelled_sql();
1526
1527   } elsif ( $params->{'status'} =~ /^(one-time charge|inactive)$/ ) {
1528
1529     push @where, FS::cust_pkg->inactive_sql();
1530
1531   }
1532
1533   ###
1534   # parse package class
1535   ###
1536
1537   #false lazinessish w/graph/cust_bill_pkg.cgi
1538   my $classnum = 0;
1539   my @pkg_class = ();
1540   if ( exists($params->{'classnum'})
1541        && $params->{'classnum'} =~ /^(\d*)$/
1542      )
1543   {
1544     $classnum = $1;
1545     if ( $classnum ) { #a specific class
1546       push @where, "classnum = $classnum";
1547
1548       #@pkg_class = ( qsearchs('pkg_class', { 'classnum' => $classnum } ) );
1549       #die "classnum $classnum not found!" unless $pkg_class[0];
1550       #$title .= $pkg_class[0]->classname.' ';
1551
1552     } elsif ( $classnum eq '' ) { #the empty class
1553
1554       push @where, "classnum IS NULL";
1555       #$title .= 'Empty class ';
1556       #@pkg_class = ( '(empty class)' );
1557     } elsif ( $classnum eq '0' ) {
1558       #@pkg_class = qsearch('pkg_class', {} ); # { 'disabled' => '' } );
1559       #push @pkg_class, '(empty class)';
1560     } else {
1561       die "illegal classnum";
1562     }
1563   }
1564   #eslaf
1565
1566   ###
1567   # parse part_pkg
1568   ###
1569
1570   my $pkgpart = join (' OR pkgpart=',
1571                       grep {$_} map { /^(\d+)$/; } ($params->{'pkgpart'}));
1572   push @where,  '(pkgpart=' . $pkgpart . ')' if $pkgpart;
1573
1574   ###
1575   # parse dates
1576   ###
1577
1578   my $orderby = '';
1579
1580   #false laziness w/report_cust_pkg.html
1581   my %disable = (
1582     'all'             => {},
1583     'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
1584     'active'          => { 'susp'=>1, 'cancel'=>1 },
1585     'suspended'       => { 'cancel' => 1 },
1586     'cancelled'       => {},
1587     ''                => {},
1588   );
1589
1590   foreach my $field (qw( setup last_bill bill adjourn susp expire cancel )) {
1591
1592     next unless exists($params->{$field});
1593
1594     my($beginning, $ending) = @{$params->{$field}};
1595
1596     next if $beginning == 0 && $ending == 4294967295;
1597
1598     push @where,
1599       "cust_pkg.$field IS NOT NULL",
1600       "cust_pkg.$field >= $beginning",
1601       "cust_pkg.$field <= $ending";
1602
1603     $orderby ||= "ORDER BY cust_pkg.$field";
1604
1605   }
1606
1607   $orderby ||= 'ORDER BY bill';
1608
1609   ###
1610   # parse magic, legacy, etc.
1611   ###
1612
1613   if ( $params->{'magic'} &&
1614        $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
1615   ) {
1616
1617     $orderby = 'ORDER BY pkgnum';
1618
1619     if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
1620       push @where, "pkgpart = $1";
1621     }
1622
1623   } elsif ( $params->{'query'} eq 'pkgnum' ) {
1624
1625     $orderby = 'ORDER BY pkgnum';
1626
1627   } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
1628
1629     $orderby = 'ORDER BY pkgnum';
1630
1631     push @where, '0 < (
1632       SELECT count(*) FROM pkg_svc
1633        WHERE pkg_svc.pkgpart =  cust_pkg.pkgpart
1634          AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
1635                                    WHERE cust_svc.pkgnum  = cust_pkg.pkgnum
1636                                      AND cust_svc.svcpart = pkg_svc.svcpart
1637                                 )
1638     )';
1639
1640   }
1641
1642   ##
1643   # setup queries, links, subs, etc. for the search
1644   ##
1645
1646   # here is the agent virtualization
1647   if ($params->{CurrentUser}) {
1648     my $access_user =
1649       qsearchs('access_user', { username => $params->{CurrentUser} });
1650
1651     if ($access_user) {
1652       push @where, $access_user->agentnums_sql;
1653     }else{
1654       push @where, "1=0";
1655     }
1656   }else{
1657     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql;
1658   }
1659
1660   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
1661
1662   my $addl_from = 'LEFT JOIN cust_main USING ( custnum  ) '.
1663                   'LEFT JOIN part_pkg  USING ( pkgpart  ) '.
1664                   'LEFT JOIN pkg_class USING ( classnum ) ';
1665
1666   my $count_query = "SELECT COUNT(*) FROM cust_pkg $addl_from $extra_sql";
1667
1668   my $sql_query = {
1669     'table'       => 'cust_pkg',
1670     'hashref'     => {},
1671     'select'      => join(', ',
1672                                 'cust_pkg.*',
1673                                 ( map "part_pkg.$_", qw( pkg freq ) ),
1674                                 'pkg_class.classname',
1675                                 'cust_main.custnum as cust_main_custnum',
1676                                 FS::UI::Web::cust_sql_fields(
1677                                   $params->{'cust_fields'}
1678                                 ),
1679                      ),
1680     'extra_sql'   => "$extra_sql $orderby",
1681     'addl_from'   => $addl_from,
1682     'count_query' => $count_query,
1683   };
1684
1685 }
1686
1687 =head1 SUBROUTINES
1688
1689 =over 4
1690
1691 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ] ]
1692
1693 CUSTNUM is a customer (see L<FS::cust_main>)
1694
1695 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
1696 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
1697 permitted.
1698
1699 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
1700 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
1701 new billing items.  An error is returned if this is not possible (see
1702 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
1703 parameter.
1704
1705 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
1706 newly-created cust_pkg objects.
1707
1708 =cut
1709
1710 sub order {
1711   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
1712
1713   my $conf = new FS::Conf;
1714
1715   # Transactionize this whole mess
1716   local $SIG{HUP} = 'IGNORE';
1717   local $SIG{INT} = 'IGNORE';
1718   local $SIG{QUIT} = 'IGNORE';
1719   local $SIG{TERM} = 'IGNORE';
1720   local $SIG{TSTP} = 'IGNORE';
1721   local $SIG{PIPE} = 'IGNORE';
1722
1723   my $oldAutoCommit = $FS::UID::AutoCommit;
1724   local $FS::UID::AutoCommit = 0;
1725   my $dbh = dbh;
1726
1727   my $error;
1728   my $cust_main = qsearchs('cust_main', { custnum => $custnum });
1729   return "Customer not found: $custnum" unless $cust_main;
1730
1731   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
1732                          @$remove_pkgnum;
1733
1734   my $change = scalar(@old_cust_pkg) != 0;
1735
1736   my %hash = ();
1737   if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
1738
1739     my $time = time;
1740
1741     #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( last_bill bill );
1742
1743     #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( setup );
1744     $hash{'setup'} = $time if $old_cust_pkg[0]->setup;
1745
1746     $hash{'change_date'} = $time;
1747     $hash{"change_$_"}  = $old_cust_pkg[0]->$_() foreach qw( pkgnum pkgpart );
1748   }
1749
1750   # Create the new packages.
1751   foreach my $pkgpart (@$pkgparts) {
1752     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
1753                                       pkgpart => $pkgpart,
1754                                       %hash,
1755                                     };
1756     $error = $cust_pkg->insert( 'change' => $change );
1757     if ($error) {
1758       $dbh->rollback if $oldAutoCommit;
1759       return $error;
1760     }
1761     push @$return_cust_pkg, $cust_pkg;
1762   }
1763   # $return_cust_pkg now contains refs to all of the newly
1764   # created packages.
1765
1766   # Transfer services and cancel old packages.
1767   foreach my $old_pkg (@old_cust_pkg) {
1768
1769     foreach my $new_pkg (@$return_cust_pkg) {
1770       $error = $old_pkg->transfer($new_pkg);
1771       if ($error and $error == 0) {
1772         # $old_pkg->transfer failed.
1773         $dbh->rollback if $oldAutoCommit;
1774         return $error;
1775       }
1776     }
1777
1778     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1779       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1780       foreach my $new_pkg (@$return_cust_pkg) {
1781         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
1782         if ($error and $error == 0) {
1783           # $old_pkg->transfer failed.
1784         $dbh->rollback if $oldAutoCommit;
1785         return $error;
1786         }
1787       }
1788     }
1789
1790     if ($error > 0) {
1791       # Transfers were successful, but we went through all of the
1792       # new packages and still had services left on the old package.
1793       # We can't cancel the package under the circumstances, so abort.
1794       $dbh->rollback if $oldAutoCommit;
1795       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
1796     }
1797     $error = $old_pkg->cancel( quiet=>1 );
1798     if ($error) {
1799       $dbh->rollback;
1800       return $error;
1801     }
1802   }
1803   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1804   '';
1805 }
1806
1807 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
1808
1809 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
1810 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
1811 permitted.
1812
1813 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
1814 replace.  The services (see L<FS::cust_svc>) are moved to the
1815 new billing items.  An error is returned if this is not possible (see
1816 L<FS::pkg_svc>).
1817
1818 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
1819 newly-created cust_pkg objects.
1820
1821 =cut
1822
1823 sub bulk_change {
1824   my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
1825
1826   # Transactionize this whole mess
1827   local $SIG{HUP} = 'IGNORE';
1828   local $SIG{INT} = 'IGNORE';
1829   local $SIG{QUIT} = 'IGNORE';
1830   local $SIG{TERM} = 'IGNORE';
1831   local $SIG{TSTP} = 'IGNORE';
1832   local $SIG{PIPE} = 'IGNORE';
1833
1834   my $oldAutoCommit = $FS::UID::AutoCommit;
1835   local $FS::UID::AutoCommit = 0;
1836   my $dbh = dbh;
1837
1838   my @errors;
1839   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
1840                          @$remove_pkgnum;
1841
1842   while(scalar(@old_cust_pkg)) {
1843     my @return = ();
1844     my $custnum = $old_cust_pkg[0]->custnum;
1845     my (@remove) = map { $_->pkgnum }
1846                    grep { $_->custnum == $custnum } @old_cust_pkg;
1847     @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
1848
1849     my $error = order $custnum, $pkgparts, \@remove, \@return;
1850
1851     push @errors, $error
1852       if $error;
1853     push @$return_cust_pkg, @return;
1854   }
1855
1856   if (scalar(@errors)) {
1857     $dbh->rollback if $oldAutoCommit;
1858     return join(' / ', @errors);
1859   }
1860
1861   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1862   '';
1863 }
1864
1865 sub insert_reason {
1866   my ($self, %options) = @_;
1867
1868   my $otaker = $FS::CurrentUser::CurrentUser->username;
1869
1870   my $cust_pkg_reason =
1871     new FS::cust_pkg_reason({ 'pkgnum'    => $self->pkgnum,
1872                               'reasonnum' => $options{'reason'},
1873                               'otaker'    => $otaker,
1874                               'date'      => $options{'date'}
1875                                                ? $options{'date'}
1876                                                : time,
1877                             });
1878   return $cust_pkg_reason->insert;
1879 }
1880
1881 =item set_usage USAGE_VALUE_HASHREF
1882
1883 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
1884 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
1885 upbytes, downbytes, and totalbytes are appropriate keys.
1886
1887 All svc_accts which are part of this package have their values reset.
1888
1889 =cut
1890
1891 sub set_usage {
1892   my ($self, $valueref) = @_;
1893
1894   foreach my $cust_svc ($self->cust_svc){
1895     my $svc_x = $cust_svc->svc_x;
1896     $svc_x->set_usage($valueref)
1897       if $svc_x->can("set_usage");
1898   }
1899 }
1900
1901 =back
1902
1903 =head1 BUGS
1904
1905 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
1906
1907 In sub order, the @pkgparts array (passed by reference) is clobbered.
1908
1909 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
1910 method to pass dates to the recur_prog expression, it should do so.
1911
1912 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
1913 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
1914 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
1915 configuration values.  Probably need a subroutine which decides what to do
1916 based on whether or not we've fetched the user yet, rather than a hash.  See
1917 FS::UID and the TODO.
1918
1919 Now that things are transactional should the check in the insert method be
1920 moved to check ?
1921
1922 =head1 SEE ALSO
1923
1924 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
1925 L<FS::pkg_svc>, schema.html from the base documentation
1926
1927 =cut
1928
1929 1;
1930