FS/FS/cust_main/Billing.pm

   1 package FS::cust_main::Billing;
   2
   3 use strict;
   4 use feature 'state';
   5 use vars qw( $conf $DEBUG $me );
   6 use Carp;
   7 use Data::Dumper;
   8 use List::Util qw( min );
   9 use FS::UID qw( dbh );
  10 use FS::Record qw( qsearch qsearchs dbdef );
  11 use FS::Misc::DateTime qw( day_end );
  12 use Tie::RefHash;
  13 use FS::cust_bill;
  14 use FS::cust_bill_pkg;
  15 use FS::cust_bill_pkg_display;
  16 use FS::cust_bill_pay;
  17 use FS::cust_credit_bill;
  18 use FS::cust_tax_adjustment;
  19 use FS::tax_rate;
  20 use FS::tax_rate_location;
  21 use FS::cust_bill_pkg_tax_location;
  22 use FS::cust_bill_pkg_tax_rate_location;
  23 use FS::part_event;
  24 use FS::part_event_condition;
  25 use FS::pkg_category;
  26 use FS::FeeOrigin_Mixin;
  27 use FS::Log;
  28 use FS::TaxEngine;
  29 use FS::Misc::Savepoint;
  30
  31 # 1 is mostly method/subroutine entry and options
  32 # 2 traces progress of some operations
  33 # 3 is even more information including possibly sensitive data
  34 $DEBUG = 0;
  35 $me = '[FS::cust_main::Billing]';
  36
  37 install_callback FS::UID sub {
  38   $conf = new FS::Conf;
  39   #yes, need it for stuff below (prolly should be cached)
  40 };
  41
  42 =head1 NAME
  43
  44 FS::cust_main::Billing - Billing mixin for cust_main
  45
  46 =head1 SYNOPSIS
  47
  48 =head1 DESCRIPTION
  49
  50 These methods are available on FS::cust_main objects.
  51
  52 =head1 METHODS
  53
  54 =over 4
  55
  56 =item bill_and_collect
  57
  58 Cancels and suspends any packages due, generates bills, applies payments and
  59 credits, and applies collection events to run cards, send bills and notices,
  60 etc.
  61
  62 Any errors prevent subsequent operations from continuing and die (but see the
  63 "fatal" flag below).
  64
  65 Options are passed as name-value pairs.  Currently available options are:
  66
  67 =over 4
  68
  69 =item time
  70
  71 Bills the customer as if it were that time.  Specified as a UNIX timestamp; see L<perlfunc/"time">).  Also see L<Time::Local> and L<Date::Parse> for conversion functions.  For example:
  72
  73  use Date::Parse;
  74  ...
  75  $cust_main->bill( 'time' => str2time('April 20th, 2001') );
  76
  77 =item invoice_time
  78
  79 Used in conjunction with the I<time> option, this option specifies the date of for the generated invoices.  Other calculations, such as whether or not to generate the invoice in the first place, are not affected.
  80
  81 =item check_freq
  82
  83 "1d" for the traditional, daily events (the default), or "1m" for the new monthly events (part_event.check_freq)
  84
  85 =item resetup
  86
  87 If set true, re-charges setup fees.
  88
  89 =item fatal
  90
  91 If set any errors prevent subsequent operations from continusing.  If set
  92 specifically to "return", returns the error (or false, if there is no error).
  93 Any other true value causes errors to die.
  94
  95 =item debug
  96
  97 Debugging level.  Default is 0 (no debugging), or can be set to 1 (passed-in options), 2 (traces progress), 3 (more information), or 4 (include full search queries)
  98
  99 =item job
 100
 101 Optional FS::queue entry to receive status updates.
 102
 103 =back
 104
 105 Options are passed to the B<bill> and B<collect> methods verbatim, so all
 106 options of those methods are also available.
 107
 108 =cut
 109
 110 sub bill_and_collect {
 111   my( $self, %options ) = @_;
 112
 113   my $log = FS::Log->new('FS::cust_main::Billing::bill_and_collect');
 114   my %logopt = (object => $self);
 115   $log->debug('start', %logopt);
 116
 117   my $error;
 118
 119   #$options{actual_time} not $options{time} because freeside-daily -d is for
 120   #pre-printing invoices
 121
 122   $options{'actual_time'} ||= time;
 123   my $job = $options{'job'};
 124
 125   my $actual_time = ( $conf->exists('next-bill-ignore-time')
 126                         ? day_end( $options{actual_time} )
 127                         : $options{actual_time}
 128                     );
 129
 130   $job->update_statustext('0,cleaning expired packages') if $job;
 131   $log->debug('canceling expired packages', %logopt);
 132   $error = $self->cancel_expired_pkgs( $actual_time );
 133   if ( $error ) {
 134     $error = "Error expiring custnum ". $self->custnum. ": $error";
 135     if    ( $options{fatal} && $options{fatal} eq 'return' ) { return $error; }
 136     else                                                     { die    $error; }
 137   }
 138
 139   $log->debug('suspending adjourned packages', %logopt);
 140   $error = $self->suspend_adjourned_pkgs( $actual_time );
 141   if ( $error ) {
 142     $error = "Error adjourning custnum ". $self->custnum. ": $error";
 143     if    ( $options{fatal} && $options{fatal} eq 'return' ) { return $error; }
 144     else                                                     { die    $error; }
 145   }
 146
 147   $log->debug('unsuspending resumed packages', %logopt);
 148   $error = $self->unsuspend_resumed_pkgs( $actual_time );
 149   if ( $error ) {
 150     $error = "Error resuming custnum ".$self->custnum. ": $error";
 151     if    ( $options{fatal} && $options{fatal} eq 'return' ) { return $error; }
 152     else                                                     { die    $error; }
 153   }
 154
 155   my $tax_district_method = $conf->config('tax_district_method');
 156   if ( $tax_district_method && $tax_district_method eq 'wa_sales' ) {
 157     # When using Washington State Sales Tax Districts,
 158     # Bail out of billing customer if sales tax district for location is missing
 159
 160     $log->debug('checking cust_location tax districts', %logopt);
 161
 162     if (
 163       my @cust_locations_missing_district =
 164         $self->cust_locations_missing_district
 165     ) {
 166       $error = sprintf
 167         'cust_location missing tax district: '.
 168         join( ', ' => (
 169           map(
 170             {
 171               sprintf
 172                 'locationnum(%s) %s %s %s %s',
 173                  $_->locationnum,
 174                  $_->address1,
 175                  $_->city,
 176                  $_->state,
 177                  $_->zip
 178             }
 179             @cust_locations_missing_district
 180           )
 181         ));
 182     }
 183   }
 184   if ( $error ) {
 185     $error = "Error calculating taxes ".$self->custnum. ": $error";
 186     if    ( $options{fatal} && $options{fatal} eq 'return' ) { return $error; }
 187     else                                                     { die    $error; }
 188   }
 189
 190   $job->update_statustext('20,billing packages') if $job;
 191   $log->debug('billing packages', %logopt);
 192   $error = $self->bill( %options );
 193   if ( $error ) {
 194     $error = "Error billing custnum ". $self->custnum. ": $error";
 195     if    ( $options{fatal} && $options{fatal} eq 'return' ) { return $error; }
 196     else                                                     { die    $error; }
 197   }
 198
 199   $job->update_statustext('50,applying payments and credits') if $job;
 200   $log->debug('applying payments and credits', %logopt);
 201   $error = $self->apply_payments_and_credits;
 202   if ( $error ) {
 203     $error = "Error applying custnum ". $self->custnum. ": $error";
 204     if    ( $options{fatal} && $options{fatal} eq 'return' ) { return $error; }
 205     else                                                     { die    $error; }
 206   }
 207
 208   # In a batch tax environment, do not run collection if any pending
 209   # invoices were created.  Collection will run after the next tax batch.
 210   state $is_batch_tax = FS::TaxEngine->new->info->{batch} ? 1 : 0;
 211   if ( $is_batch_tax && $self->pending_invoice_count ) {
 212     warn "skipped collection for custnum ".$self->custnum.
 213          " due to pending invoices\n" if $DEBUG;
 214   } elsif ( $conf->exists('cancelled_cust-noevents')
 215              && ! $self->num_ncancelled_pkgs )
 216   {
 217     warn "skipped collection for custnum ".$self->custnum.
 218          " because they have no active packages\n" if $DEBUG;
 219   } else {
 220     # run collection normally
 221     $job->update_statustext('70,running collection events') if $job;
 222     $log->debug('running collection events', %logopt);
 223     $error = $self->collect( %options );
 224     if ( $error ) {
 225       $error = "Error collecting custnum ". $self->custnum. ": $error";
 226       if    ($options{fatal} && $options{fatal} eq 'return') { return $error; }
 227       else                                                   { die    $error; }
 228     }
 229   }
 230
 231   $job->update_statustext('100,finished') if $job;
 232   $log->debug('finish', %logopt);
 233
 234   '';
 235
 236 }
 237
 238 sub cancel_expired_pkgs {
 239   my ( $self, $time, %options ) = @_;
 240
 241   my @cancel_pkgs = $self->ncancelled_pkgs( {
 242     'extra_sql' => " AND expire IS NOT NULL AND expire > 0 AND expire <= $time "
 243   } );
 244
 245   my @errors = ();
 246
 247   my @really_cancel_pkgs = ();
 248   my @cancel_reasons = ();
 249
 250   CUST_PKG: foreach my $cust_pkg ( @cancel_pkgs ) {
 251     my $cpr = $cust_pkg->last_cust_pkg_reason('expire');
 252
 253     if ( $cust_pkg->change_to_pkgnum ) {
 254
 255       my $new_pkg = FS::cust_pkg->by_key($cust_pkg->change_to_pkgnum);
 256       if ( !$new_pkg ) {
 257         push @errors, 'can\'t change pkgnum '.$cust_pkg->pkgnum.' to pkgnum '.
 258                       $cust_pkg->change_to_pkgnum.'; not expiring';
 259         next CUST_PKG;
 260       }
 261       my $error = $cust_pkg->change( 'cust_pkg'        => $new_pkg,
 262                                      'unprotect_svcs'  => 1,
 263                                    );
 264       push @errors, $error if $error && ref($error) ne 'FS::cust_pkg';
 265
 266     } else { # just cancel it
 267
 268       push @really_cancel_pkgs, $cust_pkg;
 269       push @cancel_reasons, $cpr;
 270
 271     }
 272   }
 273
 274   if (@really_cancel_pkgs) {
 275
 276     my %cancel_opt = ( 'cust_pkg' => \@really_cancel_pkgs,
 277                        'cust_pkg_reason' => \@cancel_reasons,
 278                        'time' => $time,
 279                      );
 280
 281     push @errors, $self->cancel_pkgs(%cancel_opt);
 282
 283   }
 284
 285   join(' / ', @errors);
 286
 287 }
 288
 289 sub suspend_adjourned_pkgs {
 290   my ( $self, $time, %options ) = @_;
 291
 292   my @susp_pkgs = $self->ncancelled_pkgs( {
 293     'extra_sql' =>
 294       " AND ( susp IS NULL OR susp = 0 )
 295         AND (    ( bill    IS NOT NULL AND bill    != 0 AND bill    <  $time )
 296               OR ( adjourn IS NOT NULL AND adjourn != 0 AND adjourn <= $time )
 297             )
 298       ",
 299   } );
 300
 301   #only because there's no SQL test for is_prepaid :/
 302   @susp_pkgs =
 303     grep {     (    $_->part_pkg->is_prepaid
 304                  && $_->bill
 305                  && $_->bill < $time
 306                )
 307             || (    $_->adjourn
 308                  && $_->adjourn <= $time
 309                )
 310
 311          }
 312          @susp_pkgs;
 313
 314   my @errors = ();
 315
 316   foreach my $cust_pkg ( @susp_pkgs ) {
 317     my $cpr = $cust_pkg->last_cust_pkg_reason('adjourn')
 318       if ($cust_pkg->adjourn && $cust_pkg->adjourn < $^T);
 319     my $error = $cust_pkg->suspend($cpr ? ( 'reason' => $cpr->reasonnum,
 320                                             'reason_otaker' => $cpr->otaker
 321                                           )
 322                                         : ()
 323                                   );
 324     push @errors, 'pkgnum '.$cust_pkg->pkgnum.": $error" if $error;
 325   }
 326
 327   join(' / ', @errors);
 328
 329 }
 330
 331 sub unsuspend_resumed_pkgs {
 332   my ( $self, $time, %options ) = @_;
 333
 334   my @unsusp_pkgs = $self->ncancelled_pkgs( {
 335     'extra_sql' => " AND resume IS NOT NULL AND resume > 0 AND resume <= $time "
 336   } );
 337
 338   my @errors = ();
 339
 340   foreach my $cust_pkg ( @unsusp_pkgs ) {
 341     my $error = $cust_pkg->unsuspend( 'time' => $time );
 342     push @errors, 'pkgnum '.$cust_pkg->pkgnum.": $error" if $error;
 343   }
 344
 345   join(' / ', @errors);
 346
 347 }
 348
 349 =item bill OPTIONS
 350
 351 Generates invoices (see L<FS::cust_bill>) for this customer.  Usually used in
 352 conjunction with the collect method by calling B<bill_and_collect>.
 353
 354 If there is an error, returns the error, otherwise returns false.
 355
 356 Options are passed as name-value pairs.  Currently available options are:
 357
 358 =over 4
 359
 360 =item resetup
 361
 362 If set true, re-charges setup fees.
 363
 364 =item recurring_only
 365
 366 If set true then only bill recurring charges, not setup, usage, one time
 367 charges, etc.
 368
 369 =item freq_override
 370
 371 If set, then override the normal frequency and look for a part_pkg_discount
 372 to take at that frequency.  This is appropriate only when the normal
 373 frequency for all packages is monthly, and is an error otherwise.  Use
 374 C<pkg_list> to limit the set of packages included in billing.
 375
 376 =item time
 377
 378 Bills the customer as if it were that time.  Specified as a UNIX timestamp; see L<perlfunc/"time">).  Also see L<Time::Local> and L<Date::Parse> for conversion functions.  For example:
 379
 380  use Date::Parse;
 381  ...
 382  $cust_main->bill( 'time' => str2time('April 20th, 2001') );
 383
 384 =item pkg_list
 385
 386 An array ref of specific packages (objects) to attempt billing, instead trying all of them.
 387
 388  $cust_main->bill( pkg_list => [$pkg1, $pkg2] );
 389
 390 =item not_pkgpart
 391
 392 A hashref of pkgparts to exclude from this billing run (can also be specified as a comma-separated scalar).
 393
 394 =item no_prepaid
 395
 396 Do not bill prepaid packages.  Used by freeside-daily.
 397
 398 =item invoice_time
 399
 400 Used in conjunction with the I<time> option, this option specifies the date of for the generated invoices.  Other calculations, such as whether or not to generate the invoice in the first place, are not affected.
 401
 402 =item cancel
 403
 404 This boolean value informs the us that the package is being cancelled.  This
 405 typically might mean not charging the normal recurring fee but only usage
 406 fees since the last billing. Setup charges may be charged.  Not all package
 407 plans support this feature (they tend to charge 0).
 408
 409 =item no_usage_reset
 410
 411 Prevent the resetting of usage limits during this call.
 412
 413 =item no_commit
 414
 415 Do not save the generated bill in the database.  Useful with return_bill
 416
 417 =item return_bill
 418
 419 A list reference on which the generated bill(s) will be returned.
 420
 421 =item estimate
 422
 423 Boolean value; indicates that this is an estimate rather than a "tax invoice".
 424 This will be passed through to the tax engine, as online tax services
 425 sometimes need to know it for reporting purposes. Otherwise it has no effect.
 426
 427 =item invoice_terms
 428
 429 Optional terms to be printed on this invoice.  Otherwise, customer-specific
 430 terms or the default terms are used.
 431
 432 =back
 433
 434 =cut
 435
 436 sub bill {
 437   my( $self, %options ) = @_;
 438
 439   return '' if $self->complimentary eq 'Y';
 440
 441   local($DEBUG) = $FS::cust_main::DEBUG if $FS::cust_main::DEBUG > $DEBUG;
 442   my $log = FS::Log->new('FS::cust_main::Billing::bill');
 443   my %logopt = (object => $self);
 444
 445   $log->debug('start', %logopt);
 446   warn "$me bill customer ". $self->custnum. "\n"
 447     if $DEBUG;
 448
 449   my $time = $options{'time'} || time;
 450   my $invoice_time = $options{'invoice_time'} || $time;
 451
 452   my $cmp_time = ( $conf->exists('next-bill-ignore-time')
 453                      ? day_end( $time )
 454                      : $time
 455                  );
 456
 457   $options{'not_pkgpart'} ||= {};
 458   $options{'not_pkgpart'} = { map { $_ => 1 }
 459                                   split(/\s*,\s*/, $options{'not_pkgpart'})
 460                             }
 461     unless ref($options{'not_pkgpart'});
 462
 463   local $SIG{HUP} = 'IGNORE';
 464   local $SIG{INT} = 'IGNORE';
 465   local $SIG{QUIT} = 'IGNORE';
 466   local $SIG{TERM} = 'IGNORE';
 467   local $SIG{TSTP} = 'IGNORE';
 468   local $SIG{PIPE} = 'IGNORE';
 469
 470   my $oldAutoCommit = $FS::UID::AutoCommit;
 471   local $FS::UID::AutoCommit = 0;
 472   my $dbh = dbh;
 473
 474   $log->debug('acquiring lock', %logopt);
 475   warn "$me acquiring lock on customer ". $self->custnum. "\n"
 476     if $DEBUG;
 477
 478   $self->select_for_update; #mutex
 479
 480   $log->debug('running pre-bill events', %logopt);
 481   warn "$me running pre-bill events for customer ". $self->custnum. "\n"
 482     if $DEBUG;
 483
 484   my $error = $self->do_cust_event(
 485     'debug'      => ( $options{'debug'} || 0 ),
 486     'time'       => $invoice_time,
 487     'check_freq' => $options{'check_freq'},
 488     'stage'      => 'pre-bill',
 489   )
 490     unless $options{no_commit};
 491   if ( $error ) {
 492     $dbh->rollback if $oldAutoCommit && !$options{no_commit};
 493     return $error;
 494   }
 495
 496   $log->debug('done running pre-bill events', %logopt);
 497   warn "$me done running pre-bill events for customer ". $self->custnum. "\n"
 498     if $DEBUG;
 499
 500   #keep auto-charge and non-auto-charge line items separate
 501   my @passes = ( '', 'no_auto' );
 502
 503   my %cust_bill_pkg = map { $_ => [] } @passes;
 504
 505   ###
 506   # find the packages which are due for billing, find out how much they are
 507   # & generate invoice database.
 508   ###
 509
 510   my %total_setup   = map { my $z = 0; $_ => \$z; } @passes;
 511   my %total_recur   = map { my $z = 0; $_ => \$z; } @passes;
 512
 513   my @precommit_hooks = ();
 514
 515   $options{'pkg_list'} ||= [ $self->ncancelled_pkgs ];  #param checks?
 516
 517   my %tax_engines;
 518   my $tax_is_batch = '';
 519   foreach (@passes) {
 520     $tax_engines{$_} = FS::TaxEngine->new(cust_main    => $self,
 521                                           invoice_time => $invoice_time,
 522                                           cancel       => $options{cancel},
 523                                           estimate     => $options{estimate},
 524                                          );
 525     $tax_is_batch ||= $tax_engines{$_}->info->{batch};
 526   }
 527
 528   foreach my $cust_pkg ( @{ $options{'pkg_list'} } ) {
 529
 530     next if $options{'not_pkgpart'}->{$cust_pkg->pkgpart};
 531
 532     my $part_pkg = $cust_pkg->part_pkg;
 533
 534     next if $options{'no_prepaid'} && $part_pkg->is_prepaid;
 535
 536     $log->debug('bill package '. $cust_pkg->pkgnum, %logopt);
 537     warn "  bill package ". $cust_pkg->pkgnum. "\n" if $DEBUG;
 538
 539     #? to avoid use of uninitialized value errors... ?
 540     $cust_pkg->setfield('bill', '')
 541       unless defined($cust_pkg->bill);
 542
 543     my $real_pkgpart = $cust_pkg->pkgpart;
 544     my %hash = $cust_pkg->hash;
 545
 546     # we could implement this bit as FS::part_pkg::has_hidden, but we already
 547     # suffer from performance issues
 548     $options{has_hidden} = 0;
 549     my @part_pkg = $part_pkg->self_and_bill_linked;
 550     $options{has_hidden} = 1 if ($part_pkg[1] && $part_pkg[1]->hidden);
 551
 552     # if this package was changed from another package,
 553     # and it hasn't been billed since then,
 554     # and package balances are enabled,
 555     if ( $cust_pkg->change_pkgnum
 556         and $cust_pkg->change_date >= ($cust_pkg->last_bill || 0)
 557         and $cust_pkg->change_date <  $invoice_time
 558       and $conf->exists('pkg-balances') )
 559     {
 560       # _transfer_balance will also create the appropriate credit
 561       my @transfer_items = $self->_transfer_balance($cust_pkg);
 562       # $part_pkg[0] is the "real" part_pkg
 563       my $pass = ($cust_pkg->no_auto || $part_pkg[0]->no_auto) ?
 564                   'no_auto' : '';
 565       push @{ $cust_bill_pkg{$pass} }, @transfer_items;
 566       # treating this as recur, just because most charges are recur...
 567       ${$total_recur{$pass}} += $_->recur foreach @transfer_items;
 568
 569       # currently not considering separate_bill here, as it's for
 570       # one-time charges only
 571     }
 572
 573     foreach my $part_pkg ( @part_pkg ) {
 574
 575       my $this_cust_pkg = $cust_pkg;
 576       # for add-on packages, copy the object to avoid leaking changes back to
 577       # the caller if pkg_list is in use; see RT#73607
 578       if ( $part_pkg->get('pkgpart') != $real_pkgpart ) {
 579         $this_cust_pkg = FS::cust_pkg->new({ %hash });
 580       }
 581
 582       my $pass = '';
 583       if ( $this_cust_pkg->separate_bill ) {
 584         # if no_auto is also set, that's fine. we just need to not have
 585         # invoices that are both auto and no_auto, and since the package
 586         # gets an invoice all to itself, it will only be one or the other.
 587         $pass = $this_cust_pkg->pkgnum;
 588         if (!exists $cust_bill_pkg{$pass}) { # it may not exist yet
 589           push @passes, $pass;
 590           $total_setup{$pass} = do { my $z = 0; \$z };
 591           $total_recur{$pass} = do { my $z = 0; \$z };
 592           # it also needs its own tax context
 593           $tax_engines{$pass} = FS::TaxEngine->new(
 594                                   cust_main    => $self,
 595                                   invoice_time => $invoice_time,
 596                                   cancel       => $options{cancel},
 597                                   estimate     => $options{estimate},
 598                                 );
 599           $cust_bill_pkg{$pass} = [];
 600         }
 601       } elsif ( ($this_cust_pkg->no_auto || $part_pkg->no_auto) ) {
 602         $pass = 'no_auto';
 603       }
 604
 605       my $next_bill = $this_cust_pkg->getfield('bill') || 0;
 606       my $error;
 607       # let this run once if this is the last bill upon cancellation
 608       while ( $next_bill <= $cmp_time or $options{cancel} ) {
 609         $error =
 610           $self->_make_lines( 'part_pkg'            => $part_pkg,
 611                               'cust_pkg'            => $this_cust_pkg,
 612                               'precommit_hooks'     => \@precommit_hooks,
 613                               'line_items'          => $cust_bill_pkg{$pass},
 614                               'setup'               => $total_setup{$pass},
 615                               'recur'               => $total_recur{$pass},
 616                               'tax_engine'          => $tax_engines{$pass},
 617                               'time'                => $time,
 618                               'real_pkgpart'        => $real_pkgpart,
 619                               'options'             => \%options,
 620                             );
 621
 622         # Stop if anything goes wrong
 623         last if $error;
 624
 625         # or if we're not incrementing the bill date.
 626         last if ($this_cust_pkg->getfield('bill') || 0) == $next_bill;
 627
 628         # or if we're letting it run only once
 629         last if $options{cancel};
 630
 631         $next_bill = $this_cust_pkg->getfield('bill') || 0;
 632
 633         #stop if -o was passed to freeside-daily
 634         last if $options{'one_recur'};
 635       }
 636       if ($error) {
 637         $dbh->rollback if $oldAutoCommit && !$options{no_commit};
 638         return $error;
 639       }
 640
 641     } #foreach my $part_pkg
 642
 643   } #foreach my $cust_pkg
 644
 645   foreach my $pass (@passes) { # keys %cust_bill_pkg )
 646
 647     my @cust_bill_pkg = _omit_zero_value_bundles(@{ $cust_bill_pkg{$pass} });
 648
 649     warn "$me billing pass $pass\n"
 650            #.Dumper(\@cust_bill_pkg)."\n"
 651       if $DEBUG > 2;
 652
 653     ###
 654     # process fees
 655     ###
 656
 657     my @pending_fees = FS::FeeOrigin_Mixin->by_cust($self->custnum,
 658       hashref => { 'billpkgnum' => '' }
 659     );
 660     warn "$me found pending fees:\n".Dumper(\@pending_fees)."\n"
 661       if @pending_fees and $DEBUG > 1;
 662
 663     # determine whether to generate an invoice
 664     my $generate_bill = scalar(@cust_bill_pkg) > 0;
 665
 666     foreach my $fee (@pending_fees) {
 667       $generate_bill = 1 unless $fee->nextbill;
 668     }
 669
 670     # don't create an invoice with no line items, or where the only line
 671     # items are fees that are supposed to be held until the next invoice
 672     next if !$generate_bill;
 673
 674     # calculate fees...
 675     my @fee_items;
 676     foreach my $fee_origin (@pending_fees) {
 677       my $part_fee = $fee_origin->part_fee;
 678
 679       # check whether the fee is applicable before doing anything expensive:
 680       #
 681       # if the fee def belongs to a different agent, don't charge the fee.
 682       # event conditions should prevent this, but just in case they don't,
 683       # skip the fee.
 684       if ( $part_fee->agentnum and $part_fee->agentnum != $self->agentnum ) {
 685         warn "tried to charge fee#".$part_fee->feepart .
 686              " on customer#".$self->custnum." from a different agent.\n";
 687         next;
 688       }
 689       # also skip if it's disabled
 690       next if $part_fee->disabled eq 'Y';
 691
 692       # Decide which invoice to base the fee on.
 693       my $cust_bill = $fee_origin->cust_bill;
 694       if (!$cust_bill) {
 695         # Then link it to the current invoice. This isn't the real cust_bill
 696         # object that will be inserted--in particular there are no taxes yet.
 697         # If you want to charge a fee on the total invoice amount including
 698         # taxes, you have to put the fee on the next invoice.
 699         $cust_bill = FS::cust_bill->new({
 700             'custnum'       => $self->custnum,
 701             'cust_bill_pkg' => \@cust_bill_pkg,
 702             'charged'       => ${ $total_setup{$pass} } +
 703                                ${ $total_recur{$pass} },
 704         });
 705
 706         # If the origin is for a specific package, then only apply the fee to
 707         # line items from that package.
 708         if ( my $cust_pkg = $fee_origin->cust_pkg ) {
 709           my @charge_fee_on_item;
 710           my $charge_fee_on_amount = 0;
 711           foreach (@cust_bill_pkg) {
 712             if ($_->pkgnum == $cust_pkg->pkgnum) {
 713               push @charge_fee_on_item, $_;
 714               $charge_fee_on_amount += $_->setup + $_->recur;
 715             }
 716           }
 717           $cust_bill->set('cust_bill_pkg', \@charge_fee_on_item);
 718           $cust_bill->set('charged', $charge_fee_on_amount);
 719         }
 720
 721       } # $cust_bill is now set
 722       # calculate the fee
 723       my $fee_item = $part_fee->lineitem($cust_bill) or next;
 724       # link this so that we can clear the marker on inserting the line item
 725       $fee_item->set('fee_origin', $fee_origin);
 726       push @fee_items, $fee_item;
 727
 728     }
 729
 730     # add fees to the invoice
 731     foreach my $fee_item (@fee_items) {
 732
 733       push @cust_bill_pkg, $fee_item;
 734       ${ $total_setup{$pass} } += $fee_item->setup;
 735       ${ $total_recur{$pass} } += $fee_item->recur;
 736
 737       my $part_fee = $fee_item->part_fee;
 738       my $fee_location = $self->ship_location; # I think?
 739
 740       my $error = $tax_engines{''}->add_sale($fee_item);
 741
 742       return $error if $error;
 743
 744     }
 745
 746     # XXX implementation of fees is supposed to make this go away...
 747     if ( scalar( grep { $_->recur && $_->recur > 0 } @cust_bill_pkg) ||
 748            !$conf->exists('postal_invoice-recurring_only')
 749        )
 750     {
 751
 752       my $postal_pkg = $self->charge_postal_fee();
 753       if ( $postal_pkg && !ref( $postal_pkg ) ) {
 754
 755         $dbh->rollback if $oldAutoCommit && !$options{no_commit};
 756         return "can't charge postal invoice fee for customer ".
 757           $self->custnum. ": $postal_pkg";
 758
 759       } elsif ( $postal_pkg ) {
 760
 761         my $real_pkgpart = $postal_pkg->pkgpart;
 762         # we could implement this bit as FS::part_pkg::has_hidden, but we already
 763         # suffer from performance issues
 764         $options{has_hidden} = 0;
 765         my @part_pkg = $postal_pkg->part_pkg->self_and_bill_linked;
 766         $options{has_hidden} = 1 if ($part_pkg[1] && $part_pkg[1]->hidden);
 767
 768         foreach my $part_pkg ( @part_pkg ) {
 769           my %postal_options = %options;
 770           delete $postal_options{cancel};
 771           my $error =
 772             $self->_make_lines( 'part_pkg'            => $part_pkg,
 773                                 'cust_pkg'            => $postal_pkg,
 774                                 'precommit_hooks'     => \@precommit_hooks,
 775                                 'line_items'          => \@cust_bill_pkg,
 776                                 'setup'               => $total_setup{$pass},
 777                                 'recur'               => $total_recur{$pass},
 778                                 'tax_engine'          => $tax_engines{$pass},
 779                                 'time'                => $time,
 780                                 'real_pkgpart'        => $real_pkgpart,
 781                                 'options'             => \%postal_options,
 782                               );
 783           if ($error) {
 784             $dbh->rollback if $oldAutoCommit && !$options{no_commit};
 785             return $error;
 786           }
 787         }
 788
 789         # it's silly to have a zero value postal_pkg, but....
 790         @cust_bill_pkg = _omit_zero_value_bundles(@cust_bill_pkg);
 791
 792       }
 793
 794     }
 795
 796     #add tax adjustments
 797     #XXX does this work with batch tax engines?
 798     warn "adding tax adjustments...\n" if $DEBUG > 2;
 799     foreach my $cust_tax_adjustment (
 800       qsearch('cust_tax_adjustment', { 'custnum'    => $self->custnum,
 801                                        'billpkgnum' => '',
 802                                      }
 803              )
 804     ) {
 805
 806       my $tax = sprintf('%.2f', $cust_tax_adjustment->amount );
 807
 808       my $itemdesc = $cust_tax_adjustment->taxname;
 809       $itemdesc = '' if $itemdesc eq 'Tax';
 810
 811       push @cust_bill_pkg, new FS::cust_bill_pkg {
 812         'pkgnum'      => 0,
 813         'setup'       => $tax,
 814         'recur'       => 0,
 815         'sdate'       => '',
 816         'edate'       => '',
 817         'itemdesc'    => $itemdesc,
 818         'itemcomment' => $cust_tax_adjustment->comment,
 819         'cust_tax_adjustment' => $cust_tax_adjustment,
 820         #'cust_bill_pkg_tax_location' => \@cust_bill_pkg_tax_location,
 821       };
 822
 823     }
 824
 825     my $charged = sprintf('%.2f', ${ $total_setup{$pass} } + ${ $total_recur{$pass} } );
 826
 827     my $balance = $self->balance;
 828
 829     my $previous_bill = qsearchs({ 'table'     => 'cust_bill',
 830                                    'hashref'   => { custnum=>$self->custnum },
 831                                    'extra_sql' => 'ORDER BY _date DESC LIMIT 1',
 832                                 });
 833     my $previous_balance =
 834       $previous_bill
 835         ? ( $previous_bill->billing_balance + $previous_bill->charged )
 836         : 0;
 837
 838     $log->debug('creating the new invoice', %logopt);
 839     warn "creating the new invoice\n" if $DEBUG;
 840     #create the new invoice
 841     my $cust_bill = new FS::cust_bill ( {
 842       'custnum'             => $self->custnum,
 843       '_date'               => $invoice_time,
 844       'charged'             => $charged,
 845       'billing_balance'     => $balance,
 846       'previous_balance'    => $previous_balance,
 847       'invoice_terms'       => $options{'invoice_terms'},
 848       'cust_bill_pkg'       => \@cust_bill_pkg,
 849       'pending'             => 'Y', # clear this after doing taxes
 850     } );
 851
 852     if (!$options{no_commit}) {
 853       # probably we ought to insert it as pending, and then rollback
 854       # without ever un-pending it
 855       $error = $cust_bill->insert;
 856       if ( $error ) {
 857         $dbh->rollback if $oldAutoCommit && !$options{no_commit};
 858         return "can't create invoice for customer #". $self->custnum. ": $error";
 859       }
 860
 861     }
 862
 863     # calculate and append taxes
 864     if ( ! $tax_is_batch) {
 865       local $@;
 866       my $arrayref = eval { $tax_engines{$pass}->calculate_taxes($cust_bill) };
 867
 868       if ( $@ ) {
 869         $dbh->rollback if $oldAutoCommit && !$options{no_commit};
 870         return $@;
 871       }
 872
 873       # or should this be in TaxEngine?
 874       my $total_tax = 0;
 875       foreach my $taxline ( @$arrayref ) {
 876         $total_tax += $taxline->setup;
 877         $taxline->set('invnum' => $cust_bill->invnum); # just to be sure
 878         push @cust_bill_pkg, $taxline; # for return_bill
 879
 880         if (!$options{no_commit}) {
 881           my $error = $taxline->insert;
 882           if ( $error ) {
 883             $dbh->rollback if $oldAutoCommit;
 884             return $error;
 885           }
 886         }
 887
 888       }
 889
 890       # add tax to the invoice amount and finalize it
 891       ${ $total_setup{$pass} } = sprintf('%.2f', ${ $total_setup{$pass} } + $total_tax);
 892       $charged = sprintf('%.2f', $charged + $total_tax);
 893       $cust_bill->set('charged', $charged);
 894       $cust_bill->set('pending', '');
 895
 896       if (!$options{no_commit}) {
 897         my $error = $cust_bill->replace;
 898         if ( $error ) {
 899           $dbh->rollback if $oldAutoCommit;
 900           return $error;
 901         }
 902       }
 903
 904     } # if !$tax_is_batch
 905       # if it IS batch, then we'll do all this in process_tax_batch
 906
 907     push @{$options{return_bill}}, $cust_bill if $options{return_bill};
 908
 909   } #foreach my $pass ( keys %cust_bill_pkg )
 910
 911   foreach my $hook ( @precommit_hooks ) {
 912     eval {
 913       &{$hook}; #($self) ?
 914     } unless $options{no_commit};
 915     if ( $@ ) {
 916       $dbh->rollback if $oldAutoCommit && !$options{no_commit};
 917       return "$@ running precommit hook $hook\n";
 918     }
 919   }
 920
 921   $dbh->commit or die $dbh->errstr if $oldAutoCommit && !$options{no_commit};
 922
 923   ''; #no error
 924 }
 925
 926 #discard bundled packages of 0 value
 927 # XXX we should reconsider whether we even need this
 928 sub _omit_zero_value_bundles {
 929   my @in = @_;
 930
 931   my @out = ();
 932   my @bundle = ();
 933   my $discount_show_always = $conf->exists('discount-show-always');
 934   my $show_this = 0;
 935
 936   # Sort @in the same way we do during invoice rendering, so we can identify
 937   # bundles.  See FS::Template_Mixin::_items_nontax.
 938   @in = sort { $a->pkgnum <=> $b->pkgnum        or
 939                $a->sdate  <=> $b->sdate         or
 940                ($a->pkgpart_override ? 0 : -1)  or
 941                ($b->pkgpart_override ? 0 : 1)   or
 942                $b->hidden cmp $a->hidden        or
 943                $a->pkgpart_override <=> $b->pkgpart_override
 944              } @in;
 945
 946   # this is a pack-and-deliver pattern. every time there's a cust_bill_pkg
 947   # _without_ pkgpart_override, that's the start of the new bundle. if there's
 948   # an existing bundle, and it contains a nonzero amount (or a zero amount
 949   # that's displayable anyway), push all line items in the bundle.
 950   foreach my $cust_bill_pkg ( @in ) {
 951
 952     if (scalar(@bundle) and !$cust_bill_pkg->pkgpart_override) {
 953       # ship out this bundle and reset it
 954       if ( $show_this ) {
 955         push @out, @bundle;
 956       }
 957       @bundle = ();
 958       $show_this = 0;
 959     }
 960
 961     # add this item to the current bundle
 962     push @bundle, $cust_bill_pkg;
 963
 964     # determine if it makes the bundle displayable
 965     if (   $cust_bill_pkg->setup > 0
 966         or $cust_bill_pkg->recur > 0
 967         or $cust_bill_pkg->setup_show_zero
 968         or $cust_bill_pkg->recur_show_zero
 969         or ($discount_show_always
 970           and scalar(@{ $cust_bill_pkg->get('discounts')})
 971           )
 972     ) {
 973       $show_this++;
 974     }
 975   }
 976
 977   # last bundle
 978   if ( $show_this) {
 979     push @out, @bundle;
 980   }
 981
 982   warn "  _omit_zero_value_bundles: ". scalar(@in).
 983        '->'. scalar(@out). "\n" #. Dumper(@out). "\n"
 984     if $DEBUG > 2;
 985
 986   @out;
 987 }
 988
 989 sub _make_lines {
 990   my ($self, %params) = @_;
 991
 992   local($DEBUG) = $FS::cust_main::DEBUG if $FS::cust_main::DEBUG > $DEBUG;
 993
 994   my $part_pkg = $params{part_pkg} or die "no part_pkg specified";
 995   my $cust_pkg = $params{cust_pkg} or die "no cust_pkg specified";
 996   my $cust_location = $cust_pkg->tax_location;
 997   my $precommit_hooks = $params{precommit_hooks} or die "no precommit_hooks specified";
 998   my $cust_bill_pkgs = $params{line_items} or die "no line buffer specified";
 999   my $total_setup = $params{setup} or die "no setup accumulator specified";
1000   my $total_recur = $params{recur} or die "no recur accumulator specified";
1001   my $time = $params{'time'} or die "no time specified";
1002   my (%options) = %{$params{options}};
1003
1004   my $tax_engine = $params{tax_engine};
1005
1006   if ( $part_pkg->freq ne '1' and ($options{'freq_override'} || 0) > 0 ) {
1007     # this should never happen
1008     die 'freq_override billing attempted on non-monthly package '.
1009       $cust_pkg->pkgnum;
1010   }
1011
1012   my $dbh = dbh;
1013   my $real_pkgpart = $params{real_pkgpart};
1014   my %hash = $cust_pkg->hash;
1015   my $old_cust_pkg = new FS::cust_pkg \%hash;
1016
1017   my @details = ();
1018   my $lineitems = 0;
1019
1020   $cust_pkg->pkgpart($part_pkg->pkgpart);
1021
1022   my $cmp_time = ( $conf->exists('next-bill-ignore-time')
1023                      ? day_end( $time )
1024                      : $time
1025                  );
1026
1027   ###
1028   # bill setup
1029   ###
1030
1031   my $setup = 0;
1032   my $unitsetup = 0;
1033   my @setup_discounts = ();
1034   my %setup_param = ( 'discounts'     => \@setup_discounts,
1035                       'real_pkgpart'  => $params{real_pkgpart}
1036                     );
1037   my $setup_billed_currency = '';
1038   my $setup_billed_amount = 0;
1039   # Conditions for setting setup date and charging the setup fee:
1040   # - this is not a recurring-only billing run
1041   # - and the package is not currently being canceled
1042   # - and, unless we're specifically told otherwise via 'resetup':
1043   #   - it doesn't already HAVE a setup date
1044   #   - or a start date in the future
1045   #   - and it's not suspended
1046   # - and it doesn't have an expire date in the past
1047   #
1048   # The "disable_setup_suspended" option is now obsolete; we never set the
1049   # setup date on a suspended package.
1050   if (     ! $options{recurring_only}
1051        and ! $options{cancel}
1052        and ( $options{'resetup'}
1053              || ( ! $cust_pkg->setup
1054                   && ( ! $cust_pkg->start_date
1055                        || $cust_pkg->start_date <= $cmp_time
1056                      )
1057                   && ( ! $cust_pkg->getfield('susp') )
1058                 )
1059            )
1060        and ( ! $cust_pkg->expire
1061              || $cust_pkg->expire > $cmp_time )
1062      )
1063   {
1064
1065     warn "    bill setup\n" if $DEBUG > 1;
1066
1067     unless ( $cust_pkg->waive_setup ) {
1068         $lineitems++;
1069
1070         $setup = eval { $cust_pkg->calc_setup( $time, \@details, \%setup_param ) };
1071         return "$@ running calc_setup for $cust_pkg\n"
1072           if $@;
1073
1074         # Only increment unitsetup here if there IS a setup fee.
1075         # prorate_defer_bill may cause calc_setup on a setup-stage package
1076         # to return zero, and the setup fee to be charged later. (This happens
1077         # when it's first billed on the prorate cutoff day. RT#31276.)
1078         if ( $setup ) {
1079           $unitsetup = $cust_pkg->base_setup()
1080                          || $setup; #XXX uuh
1081         }
1082
1083         if ( $setup_param{'billed_currency'} ) {
1084           $setup_billed_currency = delete $setup_param{'billed_currency'};
1085           $setup_billed_amount   = delete $setup_param{'billed_amount'};
1086         }
1087     }
1088
1089     $lineitems++
1090     if $cust_pkg->waive_setup && $part_pkg->can('prorate_setup') && $part_pkg->prorate_setup($cust_pkg, $time);
1091
1092     if ( $cust_pkg->get('setup') ) {
1093       # don't change it
1094     } elsif ( $cust_pkg->get('start_date') ) {
1095       # this allows start_date to be used to set the first bill date
1096       $cust_pkg->set('setup', $cust_pkg->get('start_date'));
1097     } else {
1098       # if unspecified, start it right now
1099       $cust_pkg->set('setup', $time);
1100     }
1101
1102     $cust_pkg->setfield('start_date', '')
1103       if $cust_pkg->start_date;
1104
1105   }
1106
1107   ###
1108   # bill recurring fee
1109   ###
1110
1111   my $recur = 0;
1112   my $unitrecur = 0;
1113   my @recur_discounts = ();
1114   my $recur_billed_currency = '';
1115   my $recur_billed_amount = 0;
1116   my $sdate;
1117
1118   my $override_quantity;
1119
1120   # Conditions for billing the recurring fee:
1121   # - the package doesn't have a future start date
1122   # - and it's not suspended
1123   #   - unless suspend_bill is enabled on the package or package def
1124   #     - but still not, if the package is on hold
1125   #   - or it's suspended for a delayed cancellation
1126   # - and its next bill date is in the past
1127   #   - or it doesn't have a next bill date yet
1128   #   - or it's a one-time charge
1129   #   - or it's a CDR plan with the "bill_every_call" option
1130   #   - or it's being canceled
1131   # - and it doesn't have an expire date in the past (this can happen with
1132   #   advance billing)
1133   #   - again, unless it's being canceled
1134   if (     ! $cust_pkg->start_date
1135        and
1136            ( ! $cust_pkg->susp
1137                || ( $cust_pkg->susp != $cust_pkg->order_date
1138                       && (    $cust_pkg->option('suspend_bill',1)
1139                            || ( $part_pkg->option('suspend_bill', 1)
1140                                  && ! $cust_pkg->option('no_suspend_bill',1)
1141                               )
1142                          )
1143                   )
1144                || $cust_pkg->is_status_delay_cancel
1145            )
1146        and
1147             ( $part_pkg->freq ne '0' && ( $cust_pkg->bill || 0 ) <= $cmp_time )
1148          || ( $part_pkg->plan eq 'voip_cdr'
1149                && $part_pkg->option('bill_every_call')
1150             )
1151          || $options{cancel}
1152
1153        and
1154           ( ! $cust_pkg->expire
1155             || $cust_pkg->expire > $cmp_time
1156             || $options{cancel}
1157           )
1158   ) {
1159
1160     # XXX should this be a package event?  probably.  events are called
1161     # at collection time at the moment, though...
1162     $part_pkg->reset_usage($cust_pkg, 'debug'=>$DEBUG)
1163       if $part_pkg->can('reset_usage') && !$options{'no_usage_reset'};
1164       #don't want to reset usage just cause we want a line item??
1165       #&& $part_pkg->pkgpart == $real_pkgpart;
1166
1167     warn "    bill recur\n" if $DEBUG > 1;
1168     $lineitems++;
1169
1170     # XXX shared with $recur_prog
1171     $sdate = ( $options{cancel} ? $cust_pkg->last_bill : $cust_pkg->bill )
1172              || $cust_pkg->setup
1173              || $time;
1174
1175     #over two params!  lets at least switch to a hashref for the rest...
1176     my $increment_next_bill = ( $part_pkg->freq ne '0'
1177                                 && ( $cust_pkg->getfield('bill') || 0 ) <= $cmp_time
1178                                 && !$options{cancel}
1179                               );
1180     my %param = ( %setup_param,
1181                   'precommit_hooks'     => $precommit_hooks,
1182                   'increment_next_bill' => $increment_next_bill,
1183                   'discounts'           => \@recur_discounts,
1184                   'real_pkgpart'        => $real_pkgpart,
1185                   'freq_override'       => $options{freq_override} || '',
1186                   'setup_fee'           => 0,
1187                 );
1188
1189     my $method = $options{cancel} ? 'calc_cancel' : 'calc_recur';
1190
1191     # There may be some part_pkg for which this is wrong.  Only those
1192     # which can_discount are supported.
1193     # (the UI should prevent adding discounts to these at the moment)
1194
1195     warn "calling $method on cust_pkg ". $cust_pkg->pkgnum.
1196          " for pkgpart ". $cust_pkg->pkgpart.
1197          " with params ". join(' / ', map "$_=>$param{$_}", keys %param). "\n"
1198       if $DEBUG > 2;
1199
1200     $recur = eval { $cust_pkg->$method( \$sdate, \@details, \%param ) };
1201     return "$@ running $method for $cust_pkg\n"
1202       if ( $@ );
1203
1204     if ($recur eq 'NOTHING') {
1205       # then calc_cancel (or calc_recur but that's not used) has declined to
1206       # generate a recurring lineitem at all. treat this as zero, but also
1207       # try not to generate a lineitem.
1208       $recur = 0;
1209       $lineitems--;
1210     }
1211
1212     #base_cancel???
1213     $unitrecur = $cust_pkg->base_recur( \$sdate ) || $recur; #XXX uuh, better
1214
1215     if ( $param{'billed_currency'} ) {
1216       $recur_billed_currency = delete $param{'billed_currency'};
1217       $recur_billed_amount   = delete $param{'billed_amount'};
1218     }
1219
1220     if ( $param{'override_quantity'} ) {
1221       $override_quantity = $param{'override_quantity'};
1222       $unitrecur = $recur / $override_quantity;
1223     }
1224
1225     if ( $increment_next_bill ) {
1226
1227       my $next_bill;
1228
1229       if ( my $main_pkg = $cust_pkg->main_pkg ) {
1230         # supplemental package
1231         # to keep in sync with the main package, simulate billing at
1232         # its frequency
1233         my $main_pkg_freq = $main_pkg->part_pkg->freq;
1234         my $supp_pkg_freq = $part_pkg->freq;
1235         if ( $supp_pkg_freq == 0 or $main_pkg_freq == 0 ) {
1236           # the UI should prevent setting up packages like this, but just
1237           # in case
1238           return "unable to calculate supplemental package period ratio";
1239         }
1240         my $ratio = $supp_pkg_freq / $main_pkg_freq;
1241         if ( $ratio == int($ratio) ) {
1242           # simple case: main package is X months, supp package is X*A months,
1243           # advance supp package to where the main package will be in A cycles.
1244           $next_bill = $sdate;
1245           for (1..$ratio) {
1246             $next_bill = $part_pkg->add_freq( $next_bill, $main_pkg_freq );
1247           }
1248         } else {
1249           # harder case: main package is X months, supp package is Y months.
1250           # advance supp package by Y months. then if they're within half a
1251           # month of each other, resync them. this may result in the period
1252           # not being exactly Y months.
1253           $next_bill = $part_pkg->add_freq( $sdate, $supp_pkg_freq );
1254           my $main_next_bill = $main_pkg->bill;
1255           if ( $main_pkg->bill <= $time ) {
1256             # then the main package has not yet been billed on this cycle;
1257             # predict what its bill date will be.
1258             $main_next_bill =
1259               $part_pkg->add_freq( $main_next_bill, $main_pkg_freq );
1260           }
1261           if ( abs($main_next_bill - $next_bill) < 86400*15 ) {
1262             $next_bill = $main_next_bill;
1263           }
1264         }
1265
1266       } else {
1267       # the normal case, not a supplemental package
1268       $next_bill = $part_pkg->add_freq($sdate, $options{freq_override} || 0);
1269       return "unparsable frequency: ".
1270         ($options{freq_override} || $part_pkg->freq)
1271         if $next_bill == -1;
1272       }
1273
1274       #pro-rating magic - if $recur_prog fiddled $sdate, want to use that
1275       # only for figuring next bill date, nothing else, so, reset $sdate again
1276       # here
1277       $sdate = $cust_pkg->bill || $cust_pkg->setup || $time;
1278       #no need, its in $hash{last_bill}# my $last_bill = $cust_pkg->last_bill;
1279       $cust_pkg->last_bill($sdate);
1280
1281       $cust_pkg->setfield('bill', $next_bill );
1282
1283     }
1284
1285     if ( $param{'setup_fee'} ) {
1286       # Add an additional setup fee at the billing stage.
1287       # Used for prorate_defer_bill.
1288       $setup += $param{'setup_fee'};
1289       $unitsetup = $cust_pkg->base_setup();
1290       $lineitems++;
1291     }
1292
1293     if ( defined $param{'discount_left_setup'} ) {
1294         foreach my $discount_setup ( values %{$param{'discount_left_setup'}} ) {
1295             $setup -= $discount_setup;
1296         }
1297     }
1298
1299   } # end of recurring fee
1300
1301   warn "\$setup is undefined" unless defined($setup);
1302   warn "\$recur is undefined" unless defined($recur);
1303   warn "\$cust_pkg->bill is undefined" unless defined($cust_pkg->bill);
1304
1305   ###
1306   # If there's line items, create em cust_bill_pkg records
1307   # If $cust_pkg has been modified, update it (if we're a real pkgpart)
1308   ###
1309
1310   if ( $lineitems ) {
1311
1312     if ( $cust_pkg->modified && $cust_pkg->pkgpart == $real_pkgpart ) {
1313       # hmm.. and if just the options are modified in some weird price plan?
1314
1315       warn "  package ". $cust_pkg->pkgnum. " modified; updating\n"
1316         if $DEBUG >1;
1317
1318       my $error = $cust_pkg->replace( $old_cust_pkg,
1319                                       'depend_jobnum'=>$options{depend_jobnum},
1320                                       'options' => { $cust_pkg->options },
1321                                     )
1322         unless $options{no_commit};
1323       return "Error modifying pkgnum ". $cust_pkg->pkgnum. ": $error"
1324         if $error; #just in case
1325     }
1326
1327     $setup = sprintf( "%.2f", $setup );
1328     $recur = sprintf( "%.2f", $recur );
1329     if ( $setup < 0 && ! $conf->exists('allow_negative_charges') ) {
1330       return "negative setup $setup for pkgnum ". $cust_pkg->pkgnum;
1331     }
1332     if ( $recur < 0 && ! $conf->exists('allow_negative_charges') ) {
1333       return "negative recur $recur for pkgnum ". $cust_pkg->pkgnum;
1334     }
1335
1336     my $discount_show_always = $conf->exists('discount-show-always')
1337                                && (    ($setup == 0 && scalar(@setup_discounts))
1338                                     || ($recur == 0 && scalar(@recur_discounts))
1339                                   );
1340
1341     if (    $setup != 0
1342          || $recur != 0
1343          || (!$part_pkg->hidden && $options{has_hidden}) #include some $0 lines
1344          || $discount_show_always
1345          || ($setup == 0 && $cust_pkg->_X_show_zero('setup'))
1346          || ($recur == 0 && $cust_pkg->_X_show_zero('recur'))
1347        )
1348     {
1349
1350       warn "    charges (setup=$setup, recur=$recur); adding line items\n"
1351         if $DEBUG > 1;
1352
1353       my @cust_pkg_detail = map { $_->detail } $cust_pkg->cust_pkg_detail('I');
1354       if ( $DEBUG > 1 ) {
1355         warn "      adding customer package invoice detail: $_\n"
1356           foreach @cust_pkg_detail;
1357       }
1358       push @details, @cust_pkg_detail;
1359
1360       my $cust_bill_pkg = new FS::cust_bill_pkg {
1361         'pkgnum'                => $cust_pkg->pkgnum,
1362         'setup'                 => $setup,
1363         'unitsetup'             => sprintf('%.2f', $unitsetup),
1364         'setup_billed_currency' => $setup_billed_currency,
1365         'setup_billed_amount'   => $setup_billed_amount,
1366         'recur'                 => $recur,
1367         'unitrecur'             => sprintf('%.2f', $unitrecur),
1368         'recur_billed_currency' => $recur_billed_currency,
1369         'recur_billed_amount'   => $recur_billed_amount,
1370         'quantity'              => $override_quantity || $cust_pkg->quantity,
1371         'details'               => \@details,
1372         'discounts'             => [ @setup_discounts, @recur_discounts ],
1373         'hidden'                => $part_pkg->hidden,
1374         'freq'                  => $part_pkg->freq,
1375       };
1376
1377       if ( $part_pkg->option('prorate_defer_bill',1)
1378            and !$hash{last_bill} ) {
1379         # both preceding and upcoming, technically
1380         $cust_bill_pkg->sdate( $cust_pkg->setup );
1381         $cust_bill_pkg->edate( $cust_pkg->bill );
1382       } elsif ( $part_pkg->recur_temporality eq 'preceding' ) {
1383         $cust_bill_pkg->sdate( $hash{last_bill} );
1384         $cust_bill_pkg->edate( $sdate - 86399   ); #60s*60m*24h-1
1385         $cust_bill_pkg->edate( $time ) if $options{cancel};
1386       } else { #if ( $part_pkg->recur_temporality eq 'upcoming' )
1387         $cust_bill_pkg->sdate( $sdate );
1388         $cust_bill_pkg->edate( $cust_pkg->bill );
1389         #$cust_bill_pkg->edate( $time ) if $options{cancel};
1390       }
1391
1392       $cust_bill_pkg->pkgpart_override($part_pkg->pkgpart)
1393         unless $part_pkg->pkgpart == $real_pkgpart;
1394
1395       $$total_setup += $setup;
1396       $$total_recur += $recur;
1397
1398       ###
1399       # handle taxes
1400       ###
1401
1402       my $error = $tax_engine->add_sale($cust_bill_pkg);
1403       return $error if $error;
1404
1405       $cust_bill_pkg->set_display(
1406         part_pkg     => $part_pkg,
1407         real_pkgpart => $real_pkgpart,
1408       );
1409
1410       push @$cust_bill_pkgs, $cust_bill_pkg;
1411
1412     } #if $setup != 0 || $recur != 0
1413
1414   } #if $line_items
1415
1416   '';
1417
1418 }
1419
1420 =item _transfer_balance TO_PKG [ FROM_PKGNUM ]
1421
1422 Takes one argument, a cust_pkg object that is being billed.  This will
1423 be called only if the package was created by a package change, and has
1424 not been billed since the package change, and package balance tracking
1425 is enabled.  The second argument can be an alternate package number to
1426 transfer the balance from; this should not be used externally.
1427
1428 Transfers the balance from the previous package (now canceled) to
1429 this package, by crediting one package and creating an invoice item for
1430 the other.  Inserts the credit and returns the invoice item (so that it
1431 can be added to an invoice that's being built).
1432
1433 If the previous package was never billed, and was also created by a package
1434 change, then this will also transfer the balance from I<its> previous
1435 package, and so on, until reaching a package that either has been billed
1436 or was not created by a package change.
1437
1438 =cut
1439
1440 my $balance_transfer_reason;
1441
1442 sub _transfer_balance {
1443   my $self = shift;
1444   my $cust_pkg = shift;
1445   my $from_pkgnum = shift || $cust_pkg->change_pkgnum;
1446   my $from_pkg = FS::cust_pkg->by_key($from_pkgnum);
1447
1448   my @transfers;
1449
1450   # if $from_pkg is not the first package in the chain, and it was never
1451   # billed, walk back
1452   if ( $from_pkg->change_pkgnum and scalar($from_pkg->cust_bill_pkg) == 0 ) {
1453     @transfers = $self->_transfer_balance($cust_pkg, $from_pkg->change_pkgnum);
1454   }
1455
1456   my $prev_balance = $self->balance_pkgnum($from_pkgnum);
1457   if ( $prev_balance != 0 ) {
1458     $balance_transfer_reason ||= FS::reason->new_or_existing(
1459       'reason' => 'Package balance transfer',
1460       'type'   => 'Internal adjustment',
1461       'class'  => 'R'
1462     );
1463
1464     my $credit = FS::cust_credit->new({
1465         'custnum'   => $self->custnum,
1466         'amount'    => abs($prev_balance),
1467         'reasonnum' => $balance_transfer_reason->reasonnum,
1468         '_date'     => $cust_pkg->change_date,
1469     });
1470
1471     my $cust_bill_pkg = FS::cust_bill_pkg->new({
1472         'setup'     => 0,
1473         'recur'     => abs($prev_balance),
1474         #'sdate'     => $from_pkg->last_bill, # not sure about this
1475         #'edate'     => $cust_pkg->change_date,
1476         'itemdesc'  => $self->mt('Previous Balance, [_1]',
1477                                  $from_pkg->part_pkg->pkg),
1478     });
1479
1480     if ( $prev_balance > 0 ) {
1481       # credit the old package, charge the new one
1482       $credit->set('pkgnum', $from_pkgnum);
1483       $cust_bill_pkg->set('pkgnum', $cust_pkg->pkgnum);
1484     } else {
1485       # the reverse
1486       $credit->set('pkgnum', $cust_pkg->pkgnum);
1487       $cust_bill_pkg->set('pkgnum', $from_pkgnum);
1488     }
1489     my $error = $credit->insert;
1490     die "error transferring package balance from #".$from_pkgnum.
1491         " to #".$cust_pkg->pkgnum.": $error\n" if $error;
1492
1493     push @transfers, $cust_bill_pkg;
1494   } # $prev_balance != 0
1495
1496   return @transfers;
1497 }
1498
1499 #### vestigial code ####
1500
1501 =item handle_taxes TAXLISTHASH CUST_BILL_PKG [ OPTIONS ]
1502
1503 This is _handle_taxes.  It's called once for each cust_bill_pkg generated
1504 from _make_lines.
1505
1506 TAXLISTHASH is a hashref shared across the entire invoice.  It looks like
1507 this:
1508 {
1509   'cust_main_county 1001' => [ [FS::cust_main_county], ... ],
1510   'cust_main_county 1002' => [ [FS::cust_main_county], ... ],
1511 }
1512
1513 'cust_main_county' can also be 'tax_rate'.  The first object in the array
1514 is always the cust_main_county or tax_rate identified by the key.
1515
1516 That "..." is a list of FS::cust_bill_pkg objects that will be fed to
1517 the 'taxline' method to calculate the amount of the tax.  This doesn't
1518 happen until calculate_taxes, though.
1519
1520 OPTIONS may include:
1521 - part_item: a part_pkg or part_fee object to be used as the package/fee
1522   definition.
1523 - location: a cust_location to be used as the billing location.
1524 - cancel: true if this package is being billed on cancellation.  This
1525   allows tax to be calculated on usage charges only.
1526
1527 If not supplied, part_item will be inferred from the pkgnum or feepart of the
1528 cust_bill_pkg, and location from the pkgnum (or, for fees, the invnum and
1529 the customer's default service location).
1530
1531 This method will also calculate exemptions for any taxes that apply to the
1532 line item (using the C<set_exemptions> method of L<FS::cust_bill_pkg>) and
1533 attach them.  This is the only place C<set_exemptions> is called in normal
1534 invoice processing.
1535
1536 =cut
1537
1538 sub _handle_taxes {
1539   my $self = shift;
1540   my $taxlisthash = shift;
1541   my $cust_bill_pkg = shift;
1542   my %options = @_;
1543
1544   # at this point I realize that we have enough information to infer all this
1545   # stuff, instead of passing around giant honking argument lists
1546   my $location = $options{location} || $cust_bill_pkg->tax_location;
1547   my $part_item = $options{part_item} || $cust_bill_pkg->part_X;
1548
1549   local($DEBUG) = $FS::cust_main::DEBUG if $FS::cust_main::DEBUG > $DEBUG;
1550
1551   return if ( $self->payby eq 'COMP' ); #dubious
1552
1553   if ( $conf->config('enable_taxproducts')
1554        && ( scalar($part_item->part_pkg_taxoverride)
1555             || $part_item->has_taxproduct
1556           )
1557      )
1558     {
1559
1560     # EXTERNAL TAX RATES (via tax_rate)
1561     my %cust_bill_pkg = ();
1562     my %taxes = ();
1563
1564     my @classes;
1565     my $usage = $cust_bill_pkg->usage || 0;
1566     push @classes, $cust_bill_pkg->usage_classes if $usage;
1567     push @classes, 'setup' if $cust_bill_pkg->setup and !$options{cancel};
1568     push @classes, 'recur' if ($cust_bill_pkg->recur - $usage)
1569         and !$options{cancel};
1570     # that's better--probably don't even need $options{cancel} now
1571     # but leave it for now, just to be safe
1572     #
1573     # About $options{cancel}: This protects against charging per-line or
1574     # per-customer or other flat-rate surcharges on a package that's being
1575     # billed on cancellation (which is an out-of-cycle bill and should only
1576     # have usage charges).  See RT#29443.
1577
1578     # customer exemption is now handled in the 'taxline' method
1579     #my $exempt = $conf->exists('cust_class-tax_exempt')
1580     #               ? ( $self->cust_class ? $self->cust_class->tax : '' )
1581     #               : $self->tax;
1582     # standardize this just to be sure
1583     #$exempt = ($exempt eq 'Y') ? 'Y' : '';
1584     #
1585     #if ( !$exempt ) {
1586
1587     unless (exists $taxes{''}) {
1588       # unsure what purpose this serves, but last time I deleted something
1589       # from here just because I didn't see the point, it actually did
1590       # something important.
1591       my $err_or_ref = $self->_gather_taxes($part_item, '', $location);
1592       return $err_or_ref unless ref($err_or_ref);
1593       $taxes{''} = $err_or_ref;
1594     }
1595
1596     # NO DISINTEGRATIONS.
1597     # my %tax_cust_bill_pkg = $cust_bill_pkg->disintegrate;
1598     #
1599     # do not call taxline() with any argument except the entire set of
1600     # cust_bill_pkgs on an invoice that are eligible for the tax.
1601
1602     # only calculate exemptions once for each tax rate, even if it's used
1603     # for multiple classes
1604     my %tax_seen = ();
1605
1606     foreach my $class (@classes) {
1607       my $err_or_ref = $self->_gather_taxes($part_item, $class, $location);
1608       return $err_or_ref unless ref($err_or_ref);
1609       my @taxes = @$err_or_ref;
1610
1611       next if !@taxes;
1612
1613       foreach my $tax ( @taxes ) {
1614
1615         my $tax_id = ref( $tax ). ' '. $tax->taxnum;
1616         # $taxlisthash: keys are tax identifiers ('FS::tax_rate 123456').
1617         # Values are arrayrefs, first the tax object (cust_main_county
1618         # or tax_rate), then the cust_bill_pkg object that the
1619         # tax applies to, then the tax class (setup, recur, usage classnum).
1620         $taxlisthash->{ $tax_id } ||= [ $tax ];
1621         push @{ $taxlisthash->{ $tax_id  } }, $cust_bill_pkg, $class;
1622
1623         # determine any exemptions that apply
1624         if (!$tax_seen{$tax_id}) {
1625           $cust_bill_pkg->set_exemptions( $tax, custnum => $self->custnum );
1626           $tax_seen{$tax_id} = 1;
1627         }
1628
1629         # tax on tax will be done later, when we actually create the tax
1630         # line items
1631
1632       }
1633     }
1634
1635   } else {
1636
1637     # INTERNAL TAX RATES (cust_main_county)
1638
1639     # We fetch taxes even if the customer is completely exempt,
1640     # because we need to record that fact.
1641
1642     my @loc_keys = qw( district city county state country );
1643     my %taxhash = map { $_ => $location->$_ } @loc_keys;
1644
1645     $taxhash{'taxclass'} = $part_item->taxclass;
1646
1647     warn "taxhash:\n". Dumper(\%taxhash) if $DEBUG > 2;
1648
1649     my @taxes = (); # entries are cust_main_county objects
1650     my %taxhash_elim = %taxhash;
1651     my @elim = qw( district city county state );
1652
1653     # WA state district city names are not stable in the WA tax tables
1654     # Allow districts to match with just a district id
1655     if ( $taxhash{district} ) {
1656       @taxes = qsearch( cust_main_county => {
1657         district => $taxhash{district},
1658         taxclass => $taxhash{taxclass},
1659       });
1660       if ( !scalar(@taxes) && $taxhash{taxclass} ) {
1661         qsearch( cust_main_county => {
1662           district => $taxhash{district},
1663           taxclass => '',
1664         });
1665       }
1666     }
1667
1668     do {
1669
1670       #first try a match with taxclass
1671       if ( !scalar(@taxes) ) {
1672         @taxes = qsearch( 'cust_main_county', \%taxhash_elim );
1673       }
1674
1675       if ( !scalar(@taxes) && $taxhash_elim{'taxclass'} ) {
1676         #then try a match without taxclass
1677         my %no_taxclass = %taxhash_elim;
1678         $no_taxclass{ 'taxclass' } = '';
1679         @taxes = qsearch( 'cust_main_county', \%no_taxclass );
1680       }
1681
1682       $taxhash_elim{ shift(@elim) } = '';
1683
1684     } while ( !scalar(@taxes) && scalar(@elim) );
1685
1686     foreach (@taxes) {
1687       my $tax_id = 'cust_main_county '.$_->taxnum;
1688       $taxlisthash->{$tax_id} ||= [ $_ ];
1689       $cust_bill_pkg->set_exemptions($_, custnum => $self->custnum);
1690       push @{ $taxlisthash->{$tax_id} }, $cust_bill_pkg;
1691     }
1692
1693   }
1694   '';
1695 }
1696
1697 =item _gather_taxes PART_ITEM CLASS CUST_LOCATION
1698
1699 Internal method used with vendor-provided tax tables.  PART_ITEM is a part_pkg
1700 or part_fee (which will define the tax eligibility of the product), CLASS is
1701 'setup', 'recur', null, or a C<usage_class> number, and CUST_LOCATION is the
1702 location where the service was provided (or billed, depending on
1703 configuration).  Returns an arrayref of L<FS::tax_rate> objects that
1704 can apply to this line item.
1705
1706 =cut
1707
1708 sub _gather_taxes {
1709   my $self = shift;
1710   my $part_item = shift;
1711   my $class = shift;
1712   my $location = shift;
1713
1714   local($DEBUG) = $FS::cust_main::DEBUG if $FS::cust_main::DEBUG > $DEBUG;
1715
1716   my $geocode = $location->geocode('cch');
1717
1718   [ $part_item->tax_rates('cch', $geocode, $class) ]
1719
1720 }
1721
1722 #### end vestigial code ####
1723
1724 =item collect [ HASHREF | OPTION => VALUE ... ]
1725
1726 (Attempt to) collect money for this customer's outstanding invoices (see
1727 L<FS::cust_bill>).  Usually used after the bill method.
1728
1729 Actions are now triggered by billing events; see L<FS::part_event> and the
1730 billing events web interface.  Old-style invoice events (see
1731 L<FS::part_bill_event>) have been deprecated.
1732
1733 If there is an error, returns the error, otherwise returns false.
1734
1735 Options are passed as name-value pairs.
1736
1737 Currently available options are:
1738
1739 =over 4
1740
1741 =item invoice_time
1742
1743 Use this time when deciding when to print invoices and late notices on those invoices.  The default is now.  It is specified as a UNIX timestamp; see L<perlfunc/"time">).  Also see L<Time::Local> and L<Date::Parse> for conversion functions.
1744
1745 =item retry
1746
1747 Retry card/echeck/LEC transactions even when not scheduled by invoice events.
1748
1749 =item check_freq
1750
1751 "1d" for the traditional, daily events (the default), or "1m" for the new monthly events (part_event.check_freq)
1752
1753 =item quiet
1754
1755 set true to surpress email card/ACH decline notices.
1756
1757 =item debug
1758
1759 Debugging level.  Default is 0 (no debugging), or can be set to 1 (passed-in options), 2 (traces progress), 3 (more information), or 4 (include full search queries)
1760
1761 =back
1762
1763 # =item payby
1764 #
1765 # allows for one time override of normal customer billing method
1766
1767 =cut
1768
1769 sub collect {
1770   my( $self, %options ) = @_;
1771
1772   local($DEBUG) = $FS::cust_main::DEBUG if $FS::cust_main::DEBUG > $DEBUG;
1773
1774   my $invoice_time = $options{'invoice_time'} || time;
1775
1776   #put below somehow?
1777   local $SIG{HUP} = 'IGNORE';
1778   local $SIG{INT} = 'IGNORE';
1779   local $SIG{QUIT} = 'IGNORE';
1780   local $SIG{TERM} = 'IGNORE';
1781   local $SIG{TSTP} = 'IGNORE';
1782   local $SIG{PIPE} = 'IGNORE';
1783
1784   my $oldAutoCommit = $FS::UID::AutoCommit;
1785   local $FS::UID::AutoCommit = 0;
1786   my $dbh = dbh;
1787
1788   $self->select_for_update; #mutex
1789
1790   if ( $DEBUG ) {
1791     my $balance = $self->balance;
1792     warn "$me collect customer ". $self->custnum. ": balance $balance\n"
1793   }
1794
1795   if ( exists($options{'retry_card'}) ) {
1796     carp 'retry_card option passed to collect is deprecated; use retry';
1797     $options{'retry'} ||= $options{'retry_card'};
1798   }
1799   if ( exists($options{'retry'}) && $options{'retry'} ) {
1800     my $error = $self->retry_realtime;
1801     if ( $error ) {
1802       $dbh->rollback if $oldAutoCommit;
1803       return $error;
1804     }
1805   }
1806
1807   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1808
1809   #never want to roll back an event just because it returned an error
1810   # unless $FS::UID::ForceObeyAutoCommit is set
1811   local $FS::UID::AutoCommit = 1
1812     unless !$oldAutoCommit
1813         && $FS::UID::ForceObeyAutoCommit;
1814
1815   $self->do_cust_event(
1816     'debug'      => ( $options{'debug'} || 0 ),
1817     'time'       => $invoice_time,
1818     'check_freq' => $options{'check_freq'},
1819     'stage'      => 'collect',
1820   );
1821
1822 }
1823
1824 =item retry_realtime
1825
1826 Schedules realtime / batch  credit card / electronic check / LEC billing
1827 events for for retry.  Useful if card information has changed or manual
1828 retry is desired.  The 'collect' method must be called to actually retry
1829 the transaction.
1830
1831 Implementation details: For either this customer, or for each of this
1832 customer's open invoices, changes the status of the first "done" (with
1833 statustext error) realtime processing event to "failed".
1834
1835 =cut
1836
1837 sub retry_realtime {
1838   my $self = shift;
1839
1840   local $SIG{HUP} = 'IGNORE';
1841   local $SIG{INT} = 'IGNORE';
1842   local $SIG{QUIT} = 'IGNORE';
1843   local $SIG{TERM} = 'IGNORE';
1844   local $SIG{TSTP} = 'IGNORE';
1845   local $SIG{PIPE} = 'IGNORE';
1846
1847   my $oldAutoCommit = $FS::UID::AutoCommit;
1848   local $FS::UID::AutoCommit = 0;
1849   my $dbh = dbh;
1850
1851   #a little false laziness w/due_cust_event (not too bad, really)
1852
1853   # I guess this is always as of now?
1854   my $join = FS::part_event_condition->join_conditions_sql('', 'time' => time);
1855   my $order = FS::part_event_condition->order_conditions_sql;
1856   my $mine =
1857   '( '
1858    . join ( ' OR ' , map {
1859     my $cust_join = FS::part_event->eventtables_cust_join->{$_} || '';
1860     my $custnum = FS::part_event->eventtables_custnum->{$_};
1861     "( part_event.eventtable = " . dbh->quote($_)
1862     . " AND tablenum IN( SELECT " . dbdef->table($_)->primary_key
1863     . " from $_ $cust_join"
1864     . " where $custnum = " . dbh->quote( $self->custnum ) . "))" ;
1865    } FS::part_event->eventtables)
1866    . ') ';
1867
1868   #here is the agent virtualization
1869   my $agent_virt = " (    part_event.agentnum IS NULL
1870                        OR part_event.agentnum = ". $self->agentnum. ' )';
1871
1872   #XXX this shouldn't be hardcoded, actions should declare it...
1873   my @realtime_events = qw(
1874     cust_bill_realtime_card
1875     cust_bill_realtime_check
1876     cust_bill_realtime_lec
1877     cust_bill_batch
1878   );
1879
1880   my $is_realtime_event =
1881     ' part_event.action IN ( '.
1882         join(',', map "'$_'", @realtime_events ).
1883     ' ) ';
1884
1885   my $batch_or_statustext =
1886     "( part_event.action = 'cust_bill_batch'
1887        OR ( statustext IS NOT NULL AND statustext != '' )
1888      )";
1889
1890
1891   my @cust_event = qsearch({
1892     'table'     => 'cust_event',
1893     'select'    => 'cust_event.*',
1894     'addl_from' => "LEFT JOIN part_event USING ( eventpart ) $join",
1895     'hashref'   => { 'status' => 'done' },
1896     'extra_sql' => " AND $batch_or_statustext ".
1897                    " AND $mine AND $is_realtime_event AND $agent_virt $order" # LIMIT 1"
1898   });
1899
1900   my %seen_invnum = ();
1901   foreach my $cust_event (@cust_event) {
1902
1903     #max one for the customer, one for each open invoice
1904     my $cust_X = $cust_event->cust_X;
1905     next if $seen_invnum{ $cust_event->part_event->eventtable eq 'cust_bill'
1906                           ? $cust_X->invnum
1907                           : 0
1908                         }++
1909          or $cust_event->part_event->eventtable eq 'cust_bill'
1910             && ! $cust_X->owed;
1911
1912     my $error = $cust_event->retry;
1913     if ( $error ) {
1914       $dbh->rollback if $oldAutoCommit;
1915       return "error scheduling event for retry: $error";
1916     }
1917
1918   }
1919
1920   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1921   '';
1922
1923 }
1924
1925 =item do_cust_event [ HASHREF | OPTION => VALUE ... ]
1926
1927 Runs billing events; see L<FS::part_event> and the billing events web
1928 interface.
1929
1930 If there is an error, returns the error, otherwise returns false.
1931
1932 Options are passed as name-value pairs.
1933
1934 Currently available options are:
1935
1936 =over 4
1937
1938 =item time
1939
1940 Use this time when deciding when to print invoices and late notices on those invoices.  The default is now.  It is specified as a UNIX timestamp; see L<perlfunc/"time">).  Also see L<Time::Local> and L<Date::Parse> for conversion functions.
1941
1942 =item check_freq
1943
1944 "1d" for the traditional, daily events (the default), or "1m" for the new monthly events (part_event.check_freq)
1945
1946 =item stage
1947
1948 "collect" (the default) or "pre-bill"
1949
1950 =item quiet
1951
1952 set true to surpress email card/ACH decline notices.
1953
1954 =item debug
1955
1956 Debugging level.  Default is 0 (no debugging), or can be set to 1 (passed-in options), 2 (traces progress), 3 (more information), or 4 (include full search queries)
1957
1958 =back
1959 =cut
1960
1961 # =item payby
1962 #
1963 # allows for one time override of normal customer billing method
1964
1965 # =item retry
1966 #
1967 # Retry card/echeck/LEC transactions even when not scheduled by invoice events.
1968
1969 sub do_cust_event {
1970   my( $self, %options ) = @_;
1971
1972   local($DEBUG) = $FS::cust_main::DEBUG if $FS::cust_main::DEBUG > $DEBUG;
1973
1974   my $time = $options{'time'} || time;
1975
1976   #put below somehow?
1977   local $SIG{HUP} = 'IGNORE';
1978   local $SIG{INT} = 'IGNORE';
1979   local $SIG{QUIT} = 'IGNORE';
1980   local $SIG{TERM} = 'IGNORE';
1981   local $SIG{TSTP} = 'IGNORE';
1982   local $SIG{PIPE} = 'IGNORE';
1983
1984   my $oldAutoCommit = $FS::UID::AutoCommit;
1985   local $FS::UID::AutoCommit = 0;
1986   my $dbh = dbh;
1987
1988   $self->select_for_update; #mutex
1989
1990   if ( $DEBUG ) {
1991     my $balance = $self->balance;
1992     warn "$me do_cust_event customer ". $self->custnum. ": balance $balance\n"
1993   }
1994
1995 #  if ( exists($options{'retry_card'}) ) {
1996 #    carp 'retry_card option passed to collect is deprecated; use retry';
1997 #    $options{'retry'} ||= $options{'retry_card'};
1998 #  }
1999 #  if ( exists($options{'retry'}) && $options{'retry'} ) {
2000 #    my $error = $self->retry_realtime;
2001 #    if ( $error ) {
2002 #      $dbh->rollback if $oldAutoCommit;
2003 #      return $error;
2004 #    }
2005 #  }
2006
2007   # false laziness w/pay_batch::import_results
2008
2009   my $due_cust_event = $self->due_cust_event(
2010     'debug'      => ( $options{'debug'} || 0 ),
2011     'time'       => $time,
2012     'check_freq' => $options{'check_freq'},
2013     'stage'      => ( $options{'stage'} || 'collect' ),
2014   );
2015   unless( ref($due_cust_event) ) {
2016     $dbh->rollback if $oldAutoCommit;
2017     return $due_cust_event;
2018   }
2019
2020   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2021
2022   #never want to roll back an event just because it or a different one
2023   # returned an error
2024   # unless $FS::UID::ForceObeyAutoCommit is set
2025   local $FS::UID::AutoCommit = 1
2026     unless !$oldAutoCommit
2027         && $FS::UID::ForceObeyAutoCommit;
2028
2029   foreach my $cust_event ( @$due_cust_event ) {
2030
2031     #XXX lock event
2032
2033     #re-eval event conditions (a previous event could have changed things)
2034     unless ( $cust_event->test_conditions ) {
2035       #don't leave stray "new/locked" records around
2036       my $error = $cust_event->delete;
2037       return $error if $error;
2038       next;
2039     }
2040
2041     {
2042       local $FS::cust_main::Billing_Realtime::realtime_bop_decline_quiet = 1
2043         if $options{'quiet'};
2044       warn "  running cust_event ". $cust_event->eventnum. "\n"
2045         if $DEBUG > 1;
2046
2047       #if ( my $error = $cust_event->do_event(%options) ) { #XXX %options?
2048       if ( my $error = $cust_event->do_event( 'time' => $time ) ) {
2049         #XXX wtf is this?  figure out a proper dealio with return value
2050         #from do_event
2051         return $error;
2052       }
2053     }
2054
2055   }
2056
2057   '';
2058
2059 }
2060
2061 =item due_cust_event [ HASHREF | OPTION => VALUE ... ]
2062
2063 Inserts database records for and returns an ordered listref of new events due
2064 for this customer, as FS::cust_event objects (see L<FS::cust_event>).  If no
2065 events are due, an empty listref is returned.  If there is an error, returns a
2066 scalar error message.
2067
2068 To actually run the events, call each event's test_condition method, and if
2069 still true, call the event's do_event method.
2070
2071 Options are passed as a hashref or as a list of name-value pairs.  Available
2072 options are:
2073
2074 =over 4
2075
2076 =item check_freq
2077
2078 Search only for events of this check frequency (how often events of this type are checked); currently "1d" (daily, the default) and "1m" (monthly) are recognized.
2079
2080 =item stage
2081
2082 "collect" (the default) or "pre-bill"
2083
2084 =item time
2085
2086 "Current time" for the events.
2087
2088 =item debug
2089
2090 Debugging level.  Default is 0 (no debugging), or can be set to 1 (passed-in options), 2 (traces progress), 3 (more information), or 4 (include full search queries)
2091
2092 =item eventtable
2093
2094 Only return events for the specified eventtable (by default, events of all eventtables are returned)
2095
2096 =item objects
2097
2098 Explicitly pass the objects to be tested (typically used with eventtable).
2099
2100 =item testonly
2101
2102 Set to true to return the objects, but not actually insert them into the
2103 database.
2104
2105 =back
2106
2107 =cut
2108
2109 sub due_cust_event {
2110   my $self = shift;
2111   my %opt = ref($_[0]) ? %{ $_[0] } : @_;
2112
2113   #???
2114   #my $DEBUG = $opt{'debug'}
2115   $opt{'debug'} ||= 0; # silence some warnings
2116   local($DEBUG) = $opt{'debug'}
2117     if $opt{'debug'} > $DEBUG;
2118   $DEBUG = $FS::cust_main::DEBUG if $FS::cust_main::DEBUG > $DEBUG;
2119
2120   warn "$me due_cust_event called with options ".
2121        join(', ', map { "$_: $opt{$_}" } keys %opt). "\n"
2122     if $DEBUG;
2123
2124   $opt{'time'} ||= time;
2125
2126   local $SIG{HUP} = 'IGNORE';
2127   local $SIG{INT} = 'IGNORE';
2128   local $SIG{QUIT} = 'IGNORE';
2129   local $SIG{TERM} = 'IGNORE';
2130   local $SIG{TSTP} = 'IGNORE';
2131   local $SIG{PIPE} = 'IGNORE';
2132
2133   my $oldAutoCommit = $FS::UID::AutoCommit;
2134   local $FS::UID::AutoCommit = 0;
2135   my $dbh = dbh;
2136
2137   $self->select_for_update #mutex
2138     unless $opt{testonly};
2139
2140   ###
2141   # find possible events (initial search)
2142   ###
2143
2144   my @cust_event = ();
2145
2146   my @eventtable = $opt{'eventtable'}
2147                      ? ( $opt{'eventtable'} )
2148                      : FS::part_event->eventtables_runorder;
2149
2150   my $check_freq = $opt{'check_freq'} || '1d';
2151
2152   foreach my $eventtable ( @eventtable ) {
2153
2154     my @objects;
2155     if ( $opt{'objects'} ) {
2156
2157       @objects = @{ $opt{'objects'} };
2158
2159     } elsif ( $eventtable eq 'cust_main' ) {
2160
2161       @objects = ( $self );
2162
2163     } else {
2164
2165       my $cm_join = " LEFT JOIN cust_main USING ( custnum )";
2166       # linkage not needed here because FS::cust_main->$eventtable will
2167       # already supply it
2168
2169       #some false laziness w/Cron::bill bill_where
2170
2171       my $join  = FS::part_event_condition->join_conditions_sql( $eventtable,
2172         'time' => $opt{'time'});
2173       my $where = FS::part_event_condition->where_conditions_sql($eventtable,
2174         'time'=>$opt{'time'},
2175       );
2176       $where = $where ? "AND $where" : '';
2177
2178       my $are_part_event =
2179       "EXISTS ( SELECT 1 FROM part_event $join
2180         WHERE check_freq = '$check_freq'
2181         AND eventtable = '$eventtable'
2182         AND ( disabled = '' OR disabled IS NULL )
2183         $where
2184         )
2185       ";
2186       #eofalse
2187
2188       @objects = $self->$eventtable(
2189         'addl_from' => $cm_join,
2190         'extra_sql' => " AND $are_part_event",
2191       );
2192     } # if ( !$opt{objects} and $eventtable ne 'cust_main' )
2193
2194     my @e_cust_event = ();
2195
2196     my $linkage = FS::part_event->eventtables_cust_join->{$eventtable} || '';
2197
2198     my $cross = "CROSS JOIN $eventtable $linkage";
2199     $cross .= ' LEFT JOIN cust_main USING ( custnum )'
2200       unless $eventtable eq 'cust_main';
2201
2202     foreach my $object ( @objects ) {
2203
2204       #this first search uses the condition_sql magic for optimization.
2205       #the more possible events we can eliminate in this step the better
2206
2207       my $cross_where = '';
2208       my $pkey = $object->primary_key;
2209       $cross_where = "$eventtable.$pkey = ". $object->$pkey();
2210
2211       my $join = FS::part_event_condition->join_conditions_sql( $eventtable,
2212         'time' => $opt{'time'});
2213       my $extra_sql =
2214         FS::part_event_condition->where_conditions_sql( $eventtable,
2215                                                         'time'=>$opt{'time'}
2216                                                       );
2217       my $order = FS::part_event_condition->order_conditions_sql( $eventtable );
2218
2219       $extra_sql = "AND $extra_sql" if $extra_sql;
2220
2221       #here is the agent virtualization
2222       $extra_sql .= " AND (    part_event.agentnum IS NULL
2223                             OR part_event.agentnum = ". $self->agentnum. ' )';
2224
2225       $extra_sql .= " $order";
2226
2227       warn "searching for events for $eventtable ". $object->$pkey. "\n"
2228         if $opt{'debug'} > 2;
2229       my @part_event = qsearch( {
2230         'debug'     => ( $opt{'debug'} > 3 ? 1 : 0 ),
2231         'select'    => 'part_event.*',
2232         'table'     => 'part_event',
2233         'addl_from' => "$cross $join",
2234         'hashref'   => { 'check_freq' => $check_freq,
2235                          'eventtable' => $eventtable,
2236                          'disabled'   => '',
2237                        },
2238         'extra_sql' => "AND $cross_where $extra_sql",
2239       } );
2240
2241       if ( $DEBUG > 2 ) {
2242         my $pkey = $object->primary_key;
2243         warn "      ". scalar(@part_event).
2244              " possible events found for $eventtable ". $object->$pkey(). "\n";
2245       }
2246
2247       push @e_cust_event, map {
2248         $_->new_cust_event($object, 'time' => $opt{'time'})
2249       } @part_event;
2250
2251     }
2252
2253     warn "    ". scalar(@e_cust_event).
2254          " subtotal possible cust events found for $eventtable\n"
2255       if $DEBUG > 1;
2256
2257     push @cust_event, @e_cust_event;
2258
2259   }
2260
2261   warn "  ". scalar(@cust_event).
2262        " total possible cust events found in initial search\n"
2263     if $DEBUG; # > 1;
2264
2265
2266   ##
2267   # test stage
2268   ##
2269
2270   $opt{stage} ||= 'collect';
2271   @cust_event =
2272     grep { my $stage = $_->part_event->event_stage;
2273            $opt{stage} eq $stage or ( ! $stage && $opt{stage} eq 'collect' )
2274          }
2275          @cust_event;
2276
2277   ##
2278   # test conditions
2279   ##
2280
2281   my %unsat = ();
2282
2283   @cust_event = grep $_->test_conditions( 'stats_hashref' => \%unsat ),
2284                      @cust_event;
2285
2286   warn "  ". scalar(@cust_event). " cust events left satisfying conditions\n"
2287     if $DEBUG; # > 1;
2288
2289   warn "    invalid conditions not eliminated with condition_sql:\n".
2290        join('', map "      $_: ".$unsat{$_}."\n", keys %unsat )
2291     if keys %unsat && $DEBUG; # > 1;
2292
2293   ##
2294   # insert
2295   ##
2296
2297   unless( $opt{testonly} ) {
2298     foreach my $cust_event ( @cust_event ) {
2299
2300       my $error = $cust_event->insert();
2301       if ( $error ) {
2302         $dbh->rollback if $oldAutoCommit;
2303         return $error;
2304       }
2305
2306     }
2307   }
2308
2309   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2310
2311   ##
2312   # return
2313   ##
2314
2315   warn "  returning events: ". Dumper(@cust_event). "\n"
2316     if $DEBUG > 2;
2317
2318   \@cust_event;
2319
2320 }
2321
2322 =item apply_payments_and_credits [ OPTION => VALUE ... ]
2323
2324 Applies unapplied payments and credits.
2325 Payments with the no_auto_apply flag set will not be applied.
2326
2327 In most cases, this new method should be used in place of sequential
2328 apply_payments and apply_credits methods.
2329
2330 A hash of optional arguments may be passed.  Currently "manual" is supported.
2331 If true, a payment receipt is sent instead of a statement when
2332 'payment_receipt_email' configuration option is set.
2333
2334 If there is an error, returns the error, otherwise returns false.
2335
2336 =cut
2337
2338 sub apply_payments_and_credits {
2339   my( $self, %options ) = @_;
2340
2341   local $SIG{HUP} = 'IGNORE';
2342   local $SIG{INT} = 'IGNORE';
2343   local $SIG{QUIT} = 'IGNORE';
2344   local $SIG{TERM} = 'IGNORE';
2345   local $SIG{TSTP} = 'IGNORE';
2346   local $SIG{PIPE} = 'IGNORE';
2347
2348   my $oldAutoCommit = $FS::UID::AutoCommit;
2349   local $FS::UID::AutoCommit = 0;
2350   my $dbh = dbh;
2351
2352   my $savepoint_label = 'Billing__apply_payments_and_credits';
2353   savepoint_create( $savepoint_label );
2354
2355   $self->select_for_update; #mutex
2356
2357   foreach my $cust_bill ( $self->open_cust_bill ) {
2358     my $error = $cust_bill->apply_payments_and_credits(%options);
2359     if ( $error ) {
2360       savepoint_rollback_and_release( $savepoint_label );
2361       $dbh->rollback if $oldAutoCommit;
2362       return "Error applying: $error";
2363     }
2364   }
2365
2366   savepoint_release( $savepoint_label );
2367   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2368   ''; #no error
2369
2370 }
2371
2372 =item apply_credits OPTION => VALUE ...
2373
2374 Applies (see L<FS::cust_credit_bill>) unapplied credits (see L<FS::cust_credit>)
2375 to outstanding invoice balances in chronological order (or reverse
2376 chronological order if the I<order> option is set to B<newest>) and returns the
2377 value of any remaining unapplied credits available for refund (see
2378 L<FS::cust_refund>).
2379
2380 Dies if there is an error.
2381
2382 =cut
2383
2384 sub apply_credits {
2385   my $self = shift;
2386   my %opt = @_;
2387
2388   local $SIG{HUP} = 'IGNORE';
2389   local $SIG{INT} = 'IGNORE';
2390   local $SIG{QUIT} = 'IGNORE';
2391   local $SIG{TERM} = 'IGNORE';
2392   local $SIG{TSTP} = 'IGNORE';
2393   local $SIG{PIPE} = 'IGNORE';
2394
2395   my $oldAutoCommit = $FS::UID::AutoCommit;
2396   local $FS::UID::AutoCommit = 0;
2397   my $dbh = dbh;
2398
2399   $self->select_for_update; #mutex
2400
2401   unless ( $self->total_unapplied_credits ) {
2402     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2403     return 0;
2404   }
2405
2406   my @credits = sort { $b->_date <=> $a->_date} (grep { $_->credited > 0 }
2407       qsearch('cust_credit', { 'custnum' => $self->custnum } ) );
2408
2409   my @invoices = $self->open_cust_bill;
2410   @invoices = sort { $b->_date <=> $a->_date } @invoices
2411     if defined($opt{'order'}) && $opt{'order'} eq 'newest';
2412
2413   if ( $conf->exists('pkg-balances') ) {
2414     # limit @credits to those w/ a pkgnum grepped from $self
2415     my %pkgnums = ();
2416     foreach my $i (@invoices) {
2417       foreach my $li ( $i->cust_bill_pkg ) {
2418         $pkgnums{$li->pkgnum} = 1;
2419       }
2420     }
2421     @credits = grep { ! $_->pkgnum || $pkgnums{$_->pkgnum} } @credits;
2422   }
2423
2424   my $credit;
2425
2426   foreach my $cust_bill ( @invoices ) {
2427
2428     if ( !defined($credit) || $credit->credited == 0) {
2429       $credit = pop @credits or last;
2430     }
2431
2432     my $owed;
2433     if ( $conf->exists('pkg-balances') && $credit->pkgnum ) {
2434       $owed = $cust_bill->owed_pkgnum($credit->pkgnum);
2435     } else {
2436       $owed = $cust_bill->owed;
2437     }
2438     unless ( $owed > 0 ) {
2439       push @credits, $credit;
2440       next;
2441     }
2442
2443     my $amount = min( $credit->credited, $owed );
2444
2445     my $cust_credit_bill = new FS::cust_credit_bill ( {
2446       'crednum' => $credit->crednum,
2447       'invnum'  => $cust_bill->invnum,
2448       'amount'  => $amount,
2449     } );
2450     $cust_credit_bill->pkgnum( $credit->pkgnum )
2451       if $conf->exists('pkg-balances') && $credit->pkgnum;
2452     my $error = $cust_credit_bill->insert;
2453     if ( $error ) {
2454       $dbh->rollback or die $dbh->errstr if $oldAutoCommit;
2455       die $error;
2456     }
2457
2458     redo if ($cust_bill->owed > 0) && ! $conf->exists('pkg-balances');
2459
2460   }
2461
2462   my $total_unapplied_credits = $self->total_unapplied_credits;
2463
2464   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2465
2466   return $total_unapplied_credits;
2467 }
2468
2469 =item apply_payments  [ OPTION => VALUE ... ]
2470
2471 Applies (see L<FS::cust_bill_pay>) unapplied payments (see L<FS::cust_pay>)
2472 to outstanding invoice balances in chronological order.
2473 Payments with the no_auto_apply flag set will not be applied.
2474
2475  #and returns the value of any remaining unapplied payments.
2476
2477 A hash of optional arguments may be passed.  Currently "manual" is supported.
2478 If true, a payment receipt is sent instead of a statement when
2479 'payment_receipt_email' configuration option is set.
2480
2481 Dies if there is an error.
2482
2483 =cut
2484
2485 sub apply_payments {
2486   my( $self, %options ) = @_;
2487
2488   local $SIG{HUP} = 'IGNORE';
2489   local $SIG{INT} = 'IGNORE';
2490   local $SIG{QUIT} = 'IGNORE';
2491   local $SIG{TERM} = 'IGNORE';
2492   local $SIG{TSTP} = 'IGNORE';
2493   local $SIG{PIPE} = 'IGNORE';
2494
2495   my $oldAutoCommit = $FS::UID::AutoCommit;
2496   local $FS::UID::AutoCommit = 0;
2497   my $dbh = dbh;
2498
2499   $self->select_for_update; #mutex
2500
2501   #return 0 unless
2502
2503   my @payments = grep { !$_->no_auto_apply } $self->unapplied_cust_pay;
2504
2505   my @invoices = $self->open_cust_bill;
2506
2507   if ( $conf->exists('pkg-balances') ) {
2508     # limit @payments to those w/ a pkgnum grepped from $self
2509     my %pkgnums = ();
2510     foreach my $i (@invoices) {
2511       foreach my $li ( $i->cust_bill_pkg ) {
2512         $pkgnums{$li->pkgnum} = 1;
2513       }
2514     }
2515     @payments = grep { ! $_->pkgnum || $pkgnums{$_->pkgnum} } @payments;
2516   }
2517
2518   my $payment;
2519
2520   foreach my $cust_bill ( @invoices ) {
2521
2522     if ( !defined($payment) || $payment->unapplied == 0 ) {
2523       $payment = pop @payments or last;
2524     }
2525
2526     my $owed;
2527     if ( $conf->exists('pkg-balances') && $payment->pkgnum ) {
2528       $owed = $cust_bill->owed_pkgnum($payment->pkgnum);
2529     } else {
2530       $owed = $cust_bill->owed;
2531     }
2532     unless ( $owed > 0 ) {
2533       push @payments, $payment;
2534       next;
2535     }
2536
2537     my $amount = min( $payment->unapplied, $owed );
2538
2539     my $cbp = {
2540       'paynum' => $payment->paynum,
2541       'invnum' => $cust_bill->invnum,
2542       'amount' => $amount,
2543     };
2544     $cbp->{_date} = $payment->_date
2545         if $options{'manual'} && $options{'backdate_application'};
2546     my $cust_bill_pay = new FS::cust_bill_pay($cbp);
2547     $cust_bill_pay->pkgnum( $payment->pkgnum )
2548       if $conf->exists('pkg-balances') && $payment->pkgnum;
2549     my $error = $cust_bill_pay->insert(%options);
2550     if ( $error ) {
2551       $dbh->rollback or die $dbh->errstr if $oldAutoCommit;
2552       die $error;
2553     }
2554
2555     redo if ( $cust_bill->owed > 0) && ! $conf->exists('pkg-balances');
2556
2557   }
2558
2559   my $total_unapplied_payments = $self->total_unapplied_payments;
2560
2561   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2562
2563   return $total_unapplied_payments;
2564 }
2565
2566 =back
2567
2568 =head1 FLOW
2569
2570   bill_and_collect
2571
2572     cancel_expired_pkgs
2573     suspend_adjourned_pkgs
2574     unsuspend_resumed_pkgs
2575
2576     bill
2577       (do_cust_event pre-bill)
2578       _make_lines
2579       _omit_zero_value_bundles
2580       calculate_taxes
2581
2582     apply_payments_and_credits
2583     collect
2584       do_cust_event
2585         due_cust_event
2586
2587 =head1 BUGS
2588
2589 =head1 SEE ALSO
2590
2591 L<FS::cust_main>, L<FS::cust_main::Billing_Realtime>
2592
2593 =cut
2594
2595 1;