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