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_cust_pkg_reason
 714
 715 Returns the most recent FS::reason associated with the package.
 716
 717 =cut
 718
 719 sub last_cust_pkg_reason {
 720   my $self = shift;
 721   qsearchs( {
 722               'table' => 'cust_pkg_reason',
 723               'hashref' => { 'pkgnum' => $self->pkgnum, },
 724               'extra_sql'=> "AND date <= ". time,
 725               'order_by' => 'ORDER BY date DESC LIMIT 1',
 726            } );
 727 }
 728
 729 =item last_reason
 730
 731 Returns the most recent FS::reason associated with the package.
 732
 733 =cut
 734
 735 sub last_reason {
 736   my $cust_pkg_reason = shift->last_cust_pkg_reason;
 737   $cust_pkg_reason->reason
 738     if $cust_pkg_reason;
 739 }
 740
 741 =item part_pkg
 742
 743 Returns the definition for this billing item, as an FS::part_pkg object (see
 744 L<FS::part_pkg>).
 745
 746 =cut
 747
 748 sub part_pkg {
 749   my $self = shift;
 750   #exists( $self->{'_pkgpart'} )
 751   $self->{'_pkgpart'}
 752     ? $self->{'_pkgpart'}
 753     : qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
 754 }
 755
 756 =item old_cust_pkg
 757
 758 Returns the cancelled package this package was changed from, if any.
 759
 760 =cut
 761
 762 sub old_cust_pkg {
 763   my $self = shift;
 764   return '' unless $self->change_pkgnum;
 765   qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
 766 }
 767
 768 =item calc_setup
 769
 770 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
 771 item.
 772
 773 =cut
 774
 775 sub calc_setup {
 776   my $self = shift;
 777   $self->part_pkg->calc_setup($self, @_);
 778 }
 779
 780 =item calc_recur
 781
 782 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
 783 item.
 784
 785 =cut
 786
 787 sub calc_recur {
 788   my $self = shift;
 789   $self->part_pkg->calc_recur($self, @_);
 790 }
 791
 792 =item calc_remain
 793
 794 Calls the I<calc_remain> of the FS::part_pkg object associated with this
 795 billing item.
 796
 797 =cut
 798
 799 sub calc_remain {
 800   my $self = shift;
 801   $self->part_pkg->calc_remain($self, @_);
 802 }
 803
 804 =item calc_cancel
 805
 806 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
 807 billing item.
 808
 809 =cut
 810
 811 sub calc_cancel {
 812   my $self = shift;
 813   $self->part_pkg->calc_cancel($self, @_);
 814 }
 815
 816 =item cust_bill_pkg
 817
 818 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
 819
 820 =cut
 821
 822 sub cust_bill_pkg {
 823   my $self = shift;
 824   qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
 825 }
 826
 827 =item cust_svc [ SVCPART ]
 828
 829 Returns the services for this package, as FS::cust_svc objects (see
 830 L<FS::cust_svc>).  If a svcpart is specified, return only the matching
 831 services.
 832
 833 =cut
 834
 835 sub cust_svc {
 836   my $self = shift;
 837
 838   if ( @_ ) {
 839     return qsearch( 'cust_svc', { 'pkgnum'  => $self->pkgnum,
 840                                   'svcpart' => shift,          } );
 841   }
 842
 843   #if ( $self->{'_svcnum'} ) {
 844   #  values %{ $self->{'_svcnum'}->cache };
 845   #} else {
 846     $self->_sort_cust_svc(
 847       [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
 848     );
 849   #}
 850
 851 }
 852
 853 =item overlimit [ SVCPART ]
 854
 855 Returns the services for this package which have exceeded their
 856 usage limit as FS::cust_svc objects (see L<FS::cust_svc>).  If a svcpart
 857 is specified, return only the matching services.
 858
 859 =cut
 860
 861 sub overlimit {
 862   my $self = shift;
 863   grep { $_->overlimit } $self->cust_svc;
 864 }
 865
 866 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ]
 867
 868 Returns historical services for this package created before END TIMESTAMP and
 869 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
 870 (see L<FS::h_cust_svc>).
 871
 872 =cut
 873
 874 sub h_cust_svc {
 875   my $self = shift;
 876
 877   $self->_sort_cust_svc(
 878     [ qsearch( 'h_cust_svc',
 879                { 'pkgnum' => $self->pkgnum, },
 880                FS::h_cust_svc->sql_h_search(@_),
 881              )
 882     ]
 883   );
 884 }
 885
 886 sub _sort_cust_svc {
 887   my( $self, $arrayref ) = @_;
 888
 889   map  { $_->[0] }
 890   sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
 891   map {
 892         my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
 893                                              'svcpart' => $_->svcpart     } );
 894         [ $_,
 895           $pkg_svc ? $pkg_svc->primary_svc : '',
 896           $pkg_svc ? $pkg_svc->quantity : 0,
 897         ];
 898       }
 899   @$arrayref;
 900
 901 }
 902
 903 =item num_cust_svc [ SVCPART ]
 904
 905 Returns the number of provisioned services for this package.  If a svcpart is
 906 specified, counts only the matching services.
 907
 908 =cut
 909
 910 sub num_cust_svc {
 911   my $self = shift;
 912   my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
 913   $sql .= ' AND svcpart = ?' if @_;
 914   my $sth = dbh->prepare($sql) or die dbh->errstr;
 915   $sth->execute($self->pkgnum, @_) or die $sth->errstr;
 916   $sth->fetchrow_arrayref->[0];
 917 }
 918
 919 =item available_part_svc
 920
 921 Returns a list of FS::part_svc objects representing services included in this
 922 package but not yet provisioned.  Each FS::part_svc object also has an extra
 923 field, I<num_avail>, which specifies the number of available services.
 924
 925 =cut
 926
 927 sub available_part_svc {
 928   my $self = shift;
 929   grep { $_->num_avail > 0 }
 930     map {
 931           my $part_svc = $_->part_svc;
 932           $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
 933             $_->quantity - $self->num_cust_svc($_->svcpart);
 934           $part_svc;
 935         }
 936       $self->part_pkg->pkg_svc;
 937 }
 938
 939 =item part_svc
 940
 941 Returns a list of FS::part_svc objects representing provisioned and available
 942 services included in this package.  Each FS::part_svc object also has the
 943 following extra fields:
 944
 945 =over 4
 946
 947 =item num_cust_svc  (count)
 948
 949 =item num_avail     (quantity - count)
 950
 951 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
 952
 953 svcnum
 954 label -> ($cust_svc->label)[1]
 955
 956 =back
 957
 958 =cut
 959
 960 sub part_svc {
 961   my $self = shift;
 962
 963   #XXX some sort of sort order besides numeric by svcpart...
 964   my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
 965     my $pkg_svc = $_;
 966     my $part_svc = $pkg_svc->part_svc;
 967     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
 968     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
 969     $part_svc->{'Hash'}{'num_avail'}    =
 970       max( 0, $pkg_svc->quantity - $num_cust_svc );
 971     $part_svc->{'Hash'}{'cust_pkg_svc'} = [ $self->cust_svc($part_svc->svcpart) ];
 972     $part_svc;
 973   } $self->part_pkg->pkg_svc;
 974
 975   #extras
 976   push @part_svc, map {
 977     my $part_svc = $_;
 978     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
 979     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
 980     $part_svc->{'Hash'}{'num_avail'}    = 0; #0-$num_cust_svc ?
 981     $part_svc->{'Hash'}{'cust_pkg_svc'} = [ $self->cust_svc($part_svc->svcpart) ];
 982     $part_svc;
 983   } $self->extra_part_svc;
 984
 985   @part_svc;
 986
 987 }
 988
 989 =item extra_part_svc
 990
 991 Returns a list of FS::part_svc objects corresponding to services in this
 992 package which are still provisioned but not (any longer) available in the
 993 package definition.
 994
 995 =cut
 996
 997 sub extra_part_svc {
 998   my $self = shift;
 999
1000   my $pkgnum  = $self->pkgnum;
1001   my $pkgpart = $self->pkgpart;
1002
1003   qsearch( {
1004     'table'     => 'part_svc',
1005     'hashref'   => {},
1006     'extra_sql' => "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
1007                                   WHERE pkg_svc.svcpart = part_svc.svcpart
1008                                     AND pkg_svc.pkgpart = $pkgpart
1009                                     AND quantity > 0
1010                               )
1011                       AND 0 < ( SELECT count(*)
1012                                   FROM cust_svc
1013                                     LEFT JOIN cust_pkg using ( pkgnum )
1014                                   WHERE cust_svc.svcpart = part_svc.svcpart
1015                                     AND pkgnum = $pkgnum
1016                               )",
1017   } );
1018 }
1019
1020 =item status
1021
1022 Returns a short status string for this package, currently:
1023
1024 =over 4
1025
1026 =item not yet billed
1027
1028 =item one-time charge
1029
1030 =item active
1031
1032 =item suspended
1033
1034 =item cancelled
1035
1036 =back
1037
1038 =cut
1039
1040 sub status {
1041   my $self = shift;
1042
1043   my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
1044
1045   return 'cancelled' if $self->get('cancel');
1046   return 'suspended' if $self->susp;
1047   return 'not yet billed' unless $self->setup;
1048   return 'one-time charge' if $freq =~ /^(0|$)/;
1049   return 'active';
1050 }
1051
1052 =item statuses
1053
1054 Class method that returns the list of possible status strings for pacakges
1055 (see L<the status method|/status>).  For example:
1056
1057   @statuses = FS::cust_pkg->statuses();
1058
1059 =cut
1060
1061 tie my %statuscolor, 'Tie::IxHash',
1062   'not yet billed'  => '000000',
1063   'one-time charge' => '000000',
1064   'active'          => '00CC00',
1065   'suspended'       => 'FF9900',
1066   'cancelled'       => 'FF0000',
1067 ;
1068
1069 sub statuses {
1070   my $self = shift; #could be class...
1071   grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
1072                                       # mayble split btw one-time vs. recur
1073     keys %statuscolor;
1074 }
1075
1076 =item statuscolor
1077
1078 Returns a hex triplet color string for this package's status.
1079
1080 =cut
1081
1082 sub statuscolor {
1083   my $self = shift;
1084   $statuscolor{$self->status};
1085 }
1086
1087 =item labels
1088
1089 Returns a list of lists, calling the label method for all services
1090 (see L<FS::cust_svc>) of this billing item.
1091
1092 =cut
1093
1094 sub labels {
1095   my $self = shift;
1096   map { [ $_->label ] } $self->cust_svc;
1097 }
1098
1099 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
1100
1101 Like the labels method, but returns historical information on services that
1102 were active as of END_TIMESTAMP and (optionally) not cancelled before
1103 START_TIMESTAMP.
1104
1105 Returns a list of lists, calling the label method for all (historical) services
1106 (see L<FS::h_cust_svc>) of this billing item.
1107
1108 =cut
1109
1110 sub h_labels {
1111   my $self = shift;
1112   map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
1113 }
1114
1115 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
1116
1117 Like h_labels, except returns a simple flat list, and shortens long
1118 (currently >5) lists of identical services to one line that lists the service
1119 label and the number of individual services rather than individual items.
1120
1121 =cut
1122
1123 sub h_labels_short {
1124   my $self = shift;
1125
1126   my %labels;
1127   #tie %labels, 'Tie::IxHash';
1128   push @{ $labels{$_->[0]} }, $_->[1]
1129     foreach $self->h_labels(@_);
1130   my @labels;
1131   foreach my $label ( keys %labels ) {
1132     my @values = @{ $labels{$label} };
1133     my $num = scalar(@values);
1134     if ( $num > 5 ) {
1135       push @labels, "$label ($num)";
1136     } else {
1137       push @labels, map { "$label: $_" } @values;
1138     }
1139   }
1140
1141  @labels;
1142
1143 }
1144
1145 =item cust_main
1146
1147 Returns the parent customer object (see L<FS::cust_main>).
1148
1149 =cut
1150
1151 sub cust_main {
1152   my $self = shift;
1153   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
1154 }
1155
1156 =item seconds_since TIMESTAMP
1157
1158 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
1159 package have been online since TIMESTAMP, according to the session monitor.
1160
1161 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1162 L<Time::Local> and L<Date::Parse> for conversion functions.
1163
1164 =cut
1165
1166 sub seconds_since {
1167   my($self, $since) = @_;
1168   my $seconds = 0;
1169
1170   foreach my $cust_svc (
1171     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
1172   ) {
1173     $seconds += $cust_svc->seconds_since($since);
1174   }
1175
1176   $seconds;
1177
1178 }
1179
1180 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1181
1182 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
1183 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
1184 (exclusive).
1185
1186 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1187 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1188 functions.
1189
1190
1191 =cut
1192
1193 sub seconds_since_sqlradacct {
1194   my($self, $start, $end) = @_;
1195
1196   my $seconds = 0;
1197
1198   foreach my $cust_svc (
1199     grep {
1200       my $part_svc = $_->part_svc;
1201       $part_svc->svcdb eq 'svc_acct'
1202         && scalar($part_svc->part_export('sqlradius'));
1203     } $self->cust_svc
1204   ) {
1205     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
1206   }
1207
1208   $seconds;
1209
1210 }
1211
1212 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1213
1214 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1215 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1216 TIMESTAMP_END
1217 (exclusive).
1218
1219 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1220 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1221 functions.
1222
1223 =cut
1224
1225 sub attribute_since_sqlradacct {
1226   my($self, $start, $end, $attrib) = @_;
1227
1228   my $sum = 0;
1229
1230   foreach my $cust_svc (
1231     grep {
1232       my $part_svc = $_->part_svc;
1233       $part_svc->svcdb eq 'svc_acct'
1234         && scalar($part_svc->part_export('sqlradius'));
1235     } $self->cust_svc
1236   ) {
1237     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
1238   }
1239
1240   $sum;
1241
1242 }
1243
1244 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
1245
1246 Transfers as many services as possible from this package to another package.
1247
1248 The destination package can be specified by pkgnum by passing an FS::cust_pkg
1249 object.  The destination package must already exist.
1250
1251 Services are moved only if the destination allows services with the correct
1252 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
1253 this option with caution!  No provision is made for export differences
1254 between the old and new service definitions.  Probably only should be used
1255 when your exports for all service definitions of a given svcdb are identical.
1256 (attempt a transfer without it first, to move all possible svcpart-matching
1257 services)
1258
1259 Any services that can't be moved remain in the original package.
1260
1261 Returns an error, if there is one; otherwise, returns the number of services
1262 that couldn't be moved.
1263
1264 =cut
1265
1266 sub transfer {
1267   my ($self, $dest_pkgnum, %opt) = @_;
1268
1269   my $remaining = 0;
1270   my $dest;
1271   my %target;
1272
1273   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
1274     $dest = $dest_pkgnum;
1275     $dest_pkgnum = $dest->pkgnum;
1276   } else {
1277     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
1278   }
1279
1280   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
1281
1282   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
1283     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
1284   }
1285
1286   foreach my $cust_svc ($dest->cust_svc) {
1287     $target{$cust_svc->svcpart}--;
1288   }
1289
1290   my %svcpart2svcparts = ();
1291   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1292     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
1293     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
1294       next if exists $svcpart2svcparts{$svcpart};
1295       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
1296       $svcpart2svcparts{$svcpart} = [
1297         map  { $_->[0] }
1298         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
1299         map {
1300               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
1301                                                    'svcpart' => $_          } );
1302               [ $_,
1303                 $pkg_svc ? $pkg_svc->primary_svc : '',
1304                 $pkg_svc ? $pkg_svc->quantity : 0,
1305               ];
1306             }
1307
1308         grep { $_ != $svcpart }
1309         map  { $_->svcpart }
1310         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
1311       ];
1312       warn "alternates for svcpart $svcpart: ".
1313            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
1314         if $DEBUG;
1315     }
1316   }
1317
1318   foreach my $cust_svc ($self->cust_svc) {
1319     if($target{$cust_svc->svcpart} > 0) {
1320       $target{$cust_svc->svcpart}--;
1321       my $new = new FS::cust_svc { $cust_svc->hash };
1322       $new->pkgnum($dest_pkgnum);
1323       my $error = $new->replace($cust_svc);
1324       return $error if $error;
1325     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1326       if ( $DEBUG ) {
1327         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
1328         warn "alternates to consider: ".
1329              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
1330       }
1331       my @alternate = grep {
1332                              warn "considering alternate svcpart $_: ".
1333                                   "$target{$_} available in new package\n"
1334                                if $DEBUG;
1335                              $target{$_} > 0;
1336                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
1337       if ( @alternate ) {
1338         warn "alternate(s) found\n" if $DEBUG;
1339         my $change_svcpart = $alternate[0];
1340         $target{$change_svcpart}--;
1341         my $new = new FS::cust_svc { $cust_svc->hash };
1342         $new->svcpart($change_svcpart);
1343         $new->pkgnum($dest_pkgnum);
1344         my $error = $new->replace($cust_svc);
1345         return $error if $error;
1346       } else {
1347         $remaining++;
1348       }
1349     } else {
1350       $remaining++
1351     }
1352   }
1353   return $remaining;
1354 }
1355
1356 =item reexport
1357
1358 This method is deprecated.  See the I<depend_jobnum> option to the insert and
1359 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
1360
1361 =cut
1362
1363 sub reexport {
1364   my $self = shift;
1365
1366   local $SIG{HUP} = 'IGNORE';
1367   local $SIG{INT} = 'IGNORE';
1368   local $SIG{QUIT} = 'IGNORE';
1369   local $SIG{TERM} = 'IGNORE';
1370   local $SIG{TSTP} = 'IGNORE';
1371   local $SIG{PIPE} = 'IGNORE';
1372
1373   my $oldAutoCommit = $FS::UID::AutoCommit;
1374   local $FS::UID::AutoCommit = 0;
1375   my $dbh = dbh;
1376
1377   foreach my $cust_svc ( $self->cust_svc ) {
1378     #false laziness w/svc_Common::insert
1379     my $svc_x = $cust_svc->svc_x;
1380     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
1381       my $error = $part_export->export_insert($svc_x);
1382       if ( $error ) {
1383         $dbh->rollback if $oldAutoCommit;
1384         return $error;
1385       }
1386     }
1387   }
1388
1389   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1390   '';
1391
1392 }
1393
1394 =back
1395
1396 =head1 CLASS METHODS
1397
1398 =over 4
1399
1400 =item recurring_sql
1401
1402 Returns an SQL expression identifying recurring packages.
1403
1404 =cut
1405
1406 sub recurring_sql { "
1407   '0' != ( select freq from part_pkg
1408              where cust_pkg.pkgpart = part_pkg.pkgpart )
1409 "; }
1410
1411 =item onetime_sql
1412
1413 Returns an SQL expression identifying one-time packages.
1414
1415 =cut
1416
1417 sub onetime_sql { "
1418   '0' = ( select freq from part_pkg
1419             where cust_pkg.pkgpart = part_pkg.pkgpart )
1420 "; }
1421
1422 =item active_sql
1423
1424 Returns an SQL expression identifying active packages.
1425
1426 =cut
1427
1428 sub active_sql { "
1429   ". $_[0]->recurring_sql(). "
1430   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1431   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
1432 "; }
1433
1434 =item inactive_sql
1435
1436 Returns an SQL expression identifying inactive packages (one-time packages
1437 that are otherwise unsuspended/uncancelled).
1438
1439 =cut
1440
1441 sub inactive_sql { "
1442   ". $_[0]->onetime_sql(). "
1443   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1444   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
1445 "; }
1446
1447 =item susp_sql
1448 =item suspended_sql
1449
1450 Returns an SQL expression identifying suspended packages.
1451
1452 =cut
1453
1454 sub suspended_sql { susp_sql(@_); }
1455 sub susp_sql {
1456   #$_[0]->recurring_sql(). ' AND '.
1457   "
1458         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
1459     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
1460   ";
1461 }
1462
1463 =item cancel_sql
1464 =item cancelled_sql
1465
1466 Returns an SQL exprression identifying cancelled packages.
1467
1468 =cut
1469
1470 sub cancelled_sql { cancel_sql(@_); }
1471 sub cancel_sql {
1472   #$_[0]->recurring_sql(). ' AND '.
1473   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
1474 }
1475
1476 =item search_sql HREF
1477
1478 Returns a qsearch hash expression to search for parameters specified in HREF.
1479 Valid parameters are
1480
1481 =over 4
1482 =item agentnum
1483 =item magic - /^(active|inactive|suspended|cancell?ed)$/
1484 =item status - /^(active|inactive|suspended|one-time charge|inactive|cancell?ed)$/
1485 =item classnum
1486 =item pkgpart - list specified how?
1487 =item setup     - arrayref of beginning and ending epoch date
1488 =item last_bill - arrayref of beginning and ending epoch date
1489 =item bill      - arrayref of beginning and ending epoch date
1490 =item adjourn   - arrayref of beginning and ending epoch date
1491 =item susp      - arrayref of beginning and ending epoch date
1492 =item expire    - arrayref of beginning and ending epoch date
1493 =item cancel    - arrayref of beginning and ending epoch date
1494 =item query - /^(pkgnum/APKG_pkgnum)$/
1495 =item cust_fields - a value suited to passing to FS::UI::Web::cust_header
1496 =item CurrentUser - specifies the user for agent virtualization
1497 =back
1498
1499 =cut
1500
1501 sub search_sql {
1502   my ($class, $params) = @_;
1503   my @where = ();
1504
1505   ##
1506   # parse agent
1507   ##
1508
1509   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
1510     push @where,
1511       "agentnum = $1";
1512   }
1513
1514   ##
1515   # parse status
1516   ##
1517
1518   if (    $params->{'magic'}  eq 'active'
1519        || $params->{'status'} eq 'active' ) {
1520
1521     push @where, FS::cust_pkg->active_sql();
1522
1523   } elsif (    $params->{'magic'}  eq 'inactive'
1524             || $params->{'status'} eq 'inactive' ) {
1525
1526     push @where, FS::cust_pkg->inactive_sql();
1527
1528   } elsif (    $params->{'magic'}  eq 'suspended'
1529             || $params->{'status'} eq 'suspended'  ) {
1530
1531     push @where, FS::cust_pkg->suspended_sql();
1532
1533   } elsif (    $params->{'magic'}  =~ /^cancell?ed$/
1534             || $params->{'status'} =~ /^cancell?ed$/ ) {
1535
1536     push @where, FS::cust_pkg->cancelled_sql();
1537
1538   } elsif ( $params->{'status'} =~ /^(one-time charge|inactive)$/ ) {
1539
1540     push @where, FS::cust_pkg->inactive_sql();
1541
1542   }
1543
1544   ###
1545   # parse package class
1546   ###
1547
1548   #false lazinessish w/graph/cust_bill_pkg.cgi
1549   my $classnum = 0;
1550   my @pkg_class = ();
1551   if ( exists($params->{'classnum'})
1552        && $params->{'classnum'} =~ /^(\d*)$/
1553      )
1554   {
1555     $classnum = $1;
1556     if ( $classnum ) { #a specific class
1557       push @where, "classnum = $classnum";
1558
1559       #@pkg_class = ( qsearchs('pkg_class', { 'classnum' => $classnum } ) );
1560       #die "classnum $classnum not found!" unless $pkg_class[0];
1561       #$title .= $pkg_class[0]->classname.' ';
1562
1563     } elsif ( $classnum eq '' ) { #the empty class
1564
1565       push @where, "classnum IS NULL";
1566       #$title .= 'Empty class ';
1567       #@pkg_class = ( '(empty class)' );
1568     } elsif ( $classnum eq '0' ) {
1569       #@pkg_class = qsearch('pkg_class', {} ); # { 'disabled' => '' } );
1570       #push @pkg_class, '(empty class)';
1571     } else {
1572       die "illegal classnum";
1573     }
1574   }
1575   #eslaf
1576
1577   ###
1578   # parse part_pkg
1579   ###
1580
1581   my $pkgpart = join (' OR pkgpart=',
1582                       grep {$_} map { /^(\d+)$/; } ($params->{'pkgpart'}));
1583   push @where,  '(pkgpart=' . $pkgpart . ')' if $pkgpart;
1584
1585   ###
1586   # parse dates
1587   ###
1588
1589   my $orderby = '';
1590
1591   #false laziness w/report_cust_pkg.html
1592   my %disable = (
1593     'all'             => {},
1594     'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
1595     'active'          => { 'susp'=>1, 'cancel'=>1 },
1596     'suspended'       => { 'cancel' => 1 },
1597     'cancelled'       => {},
1598     ''                => {},
1599   );
1600
1601   foreach my $field (qw( setup last_bill bill adjourn susp expire cancel )) {
1602
1603     next unless exists($params->{$field});
1604
1605     my($beginning, $ending) = @{$params->{$field}};
1606
1607     next if $beginning == 0 && $ending == 4294967295;
1608
1609     push @where,
1610       "cust_pkg.$field IS NOT NULL",
1611       "cust_pkg.$field >= $beginning",
1612       "cust_pkg.$field <= $ending";
1613
1614     $orderby ||= "ORDER BY cust_pkg.$field";
1615
1616   }
1617
1618   $orderby ||= 'ORDER BY bill';
1619
1620   ###
1621   # parse magic, legacy, etc.
1622   ###
1623
1624   if ( $params->{'magic'} &&
1625        $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
1626   ) {
1627
1628     $orderby = 'ORDER BY pkgnum';
1629
1630     if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
1631       push @where, "pkgpart = $1";
1632     }
1633
1634   } elsif ( $params->{'query'} eq 'pkgnum' ) {
1635
1636     $orderby = 'ORDER BY pkgnum';
1637
1638   } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
1639
1640     $orderby = 'ORDER BY pkgnum';
1641
1642     push @where, '0 < (
1643       SELECT count(*) FROM pkg_svc
1644        WHERE pkg_svc.pkgpart =  cust_pkg.pkgpart
1645          AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
1646                                    WHERE cust_svc.pkgnum  = cust_pkg.pkgnum
1647                                      AND cust_svc.svcpart = pkg_svc.svcpart
1648                                 )
1649     )';
1650
1651   }
1652
1653   ##
1654   # setup queries, links, subs, etc. for the search
1655   ##
1656
1657   # here is the agent virtualization
1658   if ($params->{CurrentUser}) {
1659     my $access_user =
1660       qsearchs('access_user', { username => $params->{CurrentUser} });
1661
1662     if ($access_user) {
1663       push @where, $access_user->agentnums_sql;
1664     }else{
1665       push @where, "1=0";
1666     }
1667   }else{
1668     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql;
1669   }
1670
1671   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
1672
1673   my $addl_from = 'LEFT JOIN cust_main USING ( custnum  ) '.
1674                   'LEFT JOIN part_pkg  USING ( pkgpart  ) '.
1675                   'LEFT JOIN pkg_class USING ( classnum ) ';
1676
1677   my $count_query = "SELECT COUNT(*) FROM cust_pkg $addl_from $extra_sql";
1678
1679   my $sql_query = {
1680     'table'       => 'cust_pkg',
1681     'hashref'     => {},
1682     'select'      => join(', ',
1683                                 'cust_pkg.*',
1684                                 ( map "part_pkg.$_", qw( pkg freq ) ),
1685                                 'pkg_class.classname',
1686                                 'cust_main.custnum as cust_main_custnum',
1687                                 FS::UI::Web::cust_sql_fields(
1688                                   $params->{'cust_fields'}
1689                                 ),
1690                      ),
1691     'extra_sql'   => "$extra_sql $orderby",
1692     'addl_from'   => $addl_from,
1693     'count_query' => $count_query,
1694   };
1695
1696 }
1697
1698 =head1 SUBROUTINES
1699
1700 =over 4
1701
1702 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ] ]
1703
1704 CUSTNUM is a customer (see L<FS::cust_main>)
1705
1706 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
1707 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
1708 permitted.
1709
1710 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
1711 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
1712 new billing items.  An error is returned if this is not possible (see
1713 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
1714 parameter.
1715
1716 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
1717 newly-created cust_pkg objects.
1718
1719 =cut
1720
1721 sub order {
1722   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
1723
1724   my $conf = new FS::Conf;
1725
1726   # Transactionize this whole mess
1727   local $SIG{HUP} = 'IGNORE';
1728   local $SIG{INT} = 'IGNORE';
1729   local $SIG{QUIT} = 'IGNORE';
1730   local $SIG{TERM} = 'IGNORE';
1731   local $SIG{TSTP} = 'IGNORE';
1732   local $SIG{PIPE} = 'IGNORE';
1733
1734   my $oldAutoCommit = $FS::UID::AutoCommit;
1735   local $FS::UID::AutoCommit = 0;
1736   my $dbh = dbh;
1737
1738   my $error;
1739   my $cust_main = qsearchs('cust_main', { custnum => $custnum });
1740   return "Customer not found: $custnum" unless $cust_main;
1741
1742   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
1743                          @$remove_pkgnum;
1744
1745   my $change = scalar(@old_cust_pkg) != 0;
1746
1747   my %hash = ();
1748   if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
1749
1750     my $time = time;
1751
1752     #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( last_bill bill );
1753
1754     #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( setup );
1755     $hash{'setup'} = $time if $old_cust_pkg[0]->setup;
1756
1757     $hash{'change_date'} = $time;
1758     $hash{"change_$_"}  = $old_cust_pkg[0]->$_() foreach qw( pkgnum pkgpart );
1759   }
1760
1761   # Create the new packages.
1762   foreach my $pkgpart (@$pkgparts) {
1763     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
1764                                       pkgpart => $pkgpart,
1765                                       %hash,
1766                                     };
1767     $error = $cust_pkg->insert( 'change' => $change );
1768     if ($error) {
1769       $dbh->rollback if $oldAutoCommit;
1770       return $error;
1771     }
1772     push @$return_cust_pkg, $cust_pkg;
1773   }
1774   # $return_cust_pkg now contains refs to all of the newly
1775   # created packages.
1776
1777   # Transfer services and cancel old packages.
1778   foreach my $old_pkg (@old_cust_pkg) {
1779
1780     foreach my $new_pkg (@$return_cust_pkg) {
1781       $error = $old_pkg->transfer($new_pkg);
1782       if ($error and $error == 0) {
1783         # $old_pkg->transfer failed.
1784         $dbh->rollback if $oldAutoCommit;
1785         return $error;
1786       }
1787     }
1788
1789     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1790       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1791       foreach my $new_pkg (@$return_cust_pkg) {
1792         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
1793         if ($error and $error == 0) {
1794           # $old_pkg->transfer failed.
1795         $dbh->rollback if $oldAutoCommit;
1796         return $error;
1797         }
1798       }
1799     }
1800
1801     if ($error > 0) {
1802       # Transfers were successful, but we went through all of the
1803       # new packages and still had services left on the old package.
1804       # We can't cancel the package under the circumstances, so abort.
1805       $dbh->rollback if $oldAutoCommit;
1806       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
1807     }
1808     $error = $old_pkg->cancel( quiet=>1 );
1809     if ($error) {
1810       $dbh->rollback;
1811       return $error;
1812     }
1813   }
1814   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1815   '';
1816 }
1817
1818 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
1819
1820 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
1821 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
1822 permitted.
1823
1824 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
1825 replace.  The services (see L<FS::cust_svc>) are moved to the
1826 new billing items.  An error is returned if this is not possible (see
1827 L<FS::pkg_svc>).
1828
1829 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
1830 newly-created cust_pkg objects.
1831
1832 =cut
1833
1834 sub bulk_change {
1835   my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
1836
1837   # Transactionize this whole mess
1838   local $SIG{HUP} = 'IGNORE';
1839   local $SIG{INT} = 'IGNORE';
1840   local $SIG{QUIT} = 'IGNORE';
1841   local $SIG{TERM} = 'IGNORE';
1842   local $SIG{TSTP} = 'IGNORE';
1843   local $SIG{PIPE} = 'IGNORE';
1844
1845   my $oldAutoCommit = $FS::UID::AutoCommit;
1846   local $FS::UID::AutoCommit = 0;
1847   my $dbh = dbh;
1848
1849   my @errors;
1850   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
1851                          @$remove_pkgnum;
1852
1853   while(scalar(@old_cust_pkg)) {
1854     my @return = ();
1855     my $custnum = $old_cust_pkg[0]->custnum;
1856     my (@remove) = map { $_->pkgnum }
1857                    grep { $_->custnum == $custnum } @old_cust_pkg;
1858     @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
1859
1860     my $error = order $custnum, $pkgparts, \@remove, \@return;
1861
1862     push @errors, $error
1863       if $error;
1864     push @$return_cust_pkg, @return;
1865   }
1866
1867   if (scalar(@errors)) {
1868     $dbh->rollback if $oldAutoCommit;
1869     return join(' / ', @errors);
1870   }
1871
1872   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1873   '';
1874 }
1875
1876 sub insert_reason {
1877   my ($self, %options) = @_;
1878
1879   my $otaker = $FS::CurrentUser::CurrentUser->username;
1880
1881   my $cust_pkg_reason =
1882     new FS::cust_pkg_reason({ 'pkgnum'    => $self->pkgnum,
1883                               'reasonnum' => $options{'reason'},
1884                               'otaker'    => $otaker,
1885                               'date'      => $options{'date'}
1886                                                ? $options{'date'}
1887                                                : time,
1888                             });
1889   return $cust_pkg_reason->insert;
1890 }
1891
1892 =item set_usage USAGE_VALUE_HASHREF
1893
1894 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
1895 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
1896 upbytes, downbytes, and totalbytes are appropriate keys.
1897
1898 All svc_accts which are part of this package have their values reset.
1899
1900 =cut
1901
1902 sub set_usage {
1903   my ($self, $valueref) = @_;
1904
1905   foreach my $cust_svc ($self->cust_svc){
1906     my $svc_x = $cust_svc->svc_x;
1907     $svc_x->set_usage($valueref)
1908       if $svc_x->can("set_usage");
1909   }
1910 }
1911
1912 =back
1913
1914 =head1 BUGS
1915
1916 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
1917
1918 In sub order, the @pkgparts array (passed by reference) is clobbered.
1919
1920 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
1921 method to pass dates to the recur_prog expression, it should do so.
1922
1923 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
1924 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
1925 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
1926 configuration values.  Probably need a subroutine which decides what to do
1927 based on whether or not we've fetched the user yet, rather than a hash.  See
1928 FS::UID and the TODO.
1929
1930 Now that things are transactional should the check in the insert method be
1931 moved to check ?
1932
1933 =head1 SEE ALSO
1934
1935 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
1936 L<FS::pkg_svc>, schema.html from the base documentation
1937
1938 =cut
1939
1940 1;
1941