FS/FS/cust_main/Billing.pm

   1 package FS::cust_main::Billing;
   2
   3 use strict;
   4 use vars qw( $conf $DEBUG $me );
   5 use Carp;
   6 use FS::UID qw( dbh );
   7 use FS::Record qw( qsearch qsearchs dbdef );
   8 use FS::cust_bill;
   9 use FS::cust_bill_pkg;
  10 use FS::cust_bill_pkg_display;
  11 use FS::cust_bill_pay;
  12 use FS::cust_credit_bill;
  13 use FS::cust_pkg;
  14 use FS::cust_tax_adjustment;
  15 use FS::tax_rate;
  16 use FS::tax_rate_location;
  17 use FS::cust_bill_pkg_tax_location;
  18 use FS::cust_bill_pkg_tax_rate_location;
  19 use FS::part_event;
  20 use FS::part_event_condition;
  21
  22 # 1 is mostly method/subroutine entry and options
  23 # 2 traces progress of some operations
  24 # 3 is even more information including possibly sensitive data
  25 $DEBUG = 0;
  26 $me = '[FS::cust_main::Billing]';
  27
  28 install_callback FS::UID sub {
  29   $conf = new FS::Conf;
  30   #yes, need it for stuff below (prolly should be cached)
  31 };
  32
  33 =head1 NAME
  34
  35 FS::cust_main::Billing - Billing mixin for cust_main
  36
  37 =head1 SYNOPSIS
  38
  39 =head1 DESCRIPTIONS
  40
  41 These methods are available on FS::cust_main objects.
  42
  43 =head1 METHODS
  44
  45 =over 4
  46
  47 =item bill_and_collect
  48
  49 Cancels and suspends any packages due, generates bills, applies payments and
  50 credits, and applies collection events to run cards, send bills and notices,
  51 etc.
  52
  53 By default, warns on errors and continues with the next operation (but see the
  54 "fatal" flag below).
  55
  56 Options are passed as name-value pairs.  Currently available options are:
  57
  58 =over 4
  59
  60 =item time
  61
  62 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:
  63
  64  use Date::Parse;
  65  ...
  66  $cust_main->bill( 'time' => str2time('April 20th, 2001') );
  67
  68 =item invoice_time
  69
  70 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.
  71
  72 =item check_freq
  73
  74 "1d" for the traditional, daily events (the default), or "1m" for the new monthly events (part_event.check_freq)
  75
  76 =item resetup
  77
  78 If set true, re-charges setup fees.
  79
  80 =item fatal
  81
  82 If set any errors prevent subsequent operations from continusing.  If set
  83 specifically to "return", returns the error (or false, if there is no error).
  84 Any other true value causes errors to die.
  85
  86 =item debug
  87
  88 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)
  89
  90 =item job
  91
  92 Optional FS::queue entry to receive status updates.
  93
  94 =back
  95
  96 Options are passed to the B<bill> and B<collect> methods verbatim, so all
  97 options of those methods are also available.
  98
  99 =cut
 100
 101 sub bill_and_collect {
 102   my( $self, %options ) = @_;
 103
 104   my $error;
 105
 106   #$options{actual_time} not $options{time} because freeside-daily -d is for
 107   #pre-printing invoices
 108
 109   $options{'actual_time'} ||= time;
 110   my $job = $options{'job'};
 111
 112   $job->update_statustext('0,cleaning expired packages') if $job;
 113   $error = $self->cancel_expired_pkgs( $options{actual_time} );
 114   if ( $error ) {
 115     $error = "Error expiring custnum ". $self->custnum. ": $error";
 116     if    ( $options{fatal} && $options{fatal} eq 'return' ) { return $error; }
 117     elsif ( $options{fatal}                                ) { die    $error; }
 118     else                                                     { warn   $error; }
 119   }
 120
 121   $error = $self->suspend_adjourned_pkgs( $options{actual_time} );
 122   if ( $error ) {
 123     $error = "Error adjourning custnum ". $self->custnum. ": $error";
 124     if    ( $options{fatal} && $options{fatal} eq 'return' ) { return $error; }
 125     elsif ( $options{fatal}                                ) { die    $error; }
 126     else                                                     { warn   $error; }
 127   }
 128
 129   $job->update_statustext('20,billing packages') if $job;
 130   $error = $self->bill( %options );
 131   if ( $error ) {
 132     $error = "Error billing custnum ". $self->custnum. ": $error";
 133     if    ( $options{fatal} && $options{fatal} eq 'return' ) { return $error; }
 134     elsif ( $options{fatal}                                ) { die    $error; }
 135     else                                                     { warn   $error; }
 136   }
 137
 138   $job->update_statustext('50,applying payments and credits') if $job;
 139   $error = $self->apply_payments_and_credits;
 140   if ( $error ) {
 141     $error = "Error applying custnum ". $self->custnum. ": $error";
 142     if    ( $options{fatal} && $options{fatal} eq 'return' ) { return $error; }
 143     elsif ( $options{fatal}                                ) { die    $error; }
 144     else                                                     { warn   $error; }
 145   }
 146
 147   $job->update_statustext('70,running collection events') if $job;
 148   unless ( $conf->exists('cancelled_cust-noevents')
 149            && ! $self->num_ncancelled_pkgs
 150   ) {
 151     $error = $self->collect( %options );
 152     if ( $error ) {
 153       $error = "Error collecting custnum ". $self->custnum. ": $error";
 154       if    ($options{fatal} && $options{fatal} eq 'return') { return $error; }
 155       elsif ($options{fatal}                               ) { die    $error; }
 156       else                                                   { warn   $error; }
 157     }
 158   }
 159   $job->update_statustext('100,finished') if $job;
 160
 161   '';
 162
 163 }
 164
 165 sub cancel_expired_pkgs {
 166   my ( $self, $time, %options ) = @_;
 167
 168   my @cancel_pkgs = $self->ncancelled_pkgs( {
 169     'extra_sql' => " AND expire IS NOT NULL AND expire > 0 AND expire <= $time "
 170   } );
 171
 172   my @errors = ();
 173
 174   foreach my $cust_pkg ( @cancel_pkgs ) {
 175     my $cpr = $cust_pkg->last_cust_pkg_reason('expire');
 176     my $error = $cust_pkg->cancel($cpr ? ( 'reason'        => $cpr->reasonnum,
 177                                            'reason_otaker' => $cpr->otaker
 178                                          )
 179                                        : ()
 180                                  );
 181     push @errors, 'pkgnum '.$cust_pkg->pkgnum.": $error" if $error;
 182   }
 183
 184   scalar(@errors) ? join(' / ', @errors) : '';
 185
 186 }
 187
 188 sub suspend_adjourned_pkgs {
 189   my ( $self, $time, %options ) = @_;
 190
 191   my @susp_pkgs = $self->ncancelled_pkgs( {
 192     'extra_sql' =>
 193       " AND ( susp IS NULL OR susp = 0 )
 194         AND (    ( bill    IS NOT NULL AND bill    != 0 AND bill    <  $time )
 195               OR ( adjourn IS NOT NULL AND adjourn != 0 AND adjourn <= $time )
 196             )
 197       ",
 198   } );
 199
 200   #only because there's no SQL test for is_prepaid :/
 201   @susp_pkgs =
 202     grep {     (    $_->part_pkg->is_prepaid
 203                  && $_->bill
 204                  && $_->bill < $time
 205                )
 206             || (    $_->adjourn
 207                  && $_->adjourn <= $time
 208                )
 209
 210          }
 211          @susp_pkgs;
 212
 213   my @errors = ();
 214
 215   foreach my $cust_pkg ( @susp_pkgs ) {
 216     my $cpr = $cust_pkg->last_cust_pkg_reason('adjourn')
 217       if ($cust_pkg->adjourn && $cust_pkg->adjourn < $^T);
 218     my $error = $cust_pkg->suspend($cpr ? ( 'reason' => $cpr->reasonnum,
 219                                             'reason_otaker' => $cpr->otaker
 220                                           )
 221                                         : ()
 222                                   );
 223     push @errors, 'pkgnum '.$cust_pkg->pkgnum.": $error" if $error;
 224   }
 225
 226   scalar(@errors) ? join(' / ', @errors) : '';
 227
 228 }
 229
 230 =item bill OPTIONS
 231
 232 Generates invoices (see L<FS::cust_bill>) for this customer.  Usually used in
 233 conjunction with the collect method by calling B<bill_and_collect>.
 234
 235 If there is an error, returns the error, otherwise returns false.
 236
 237 Options are passed as name-value pairs.  Currently available options are:
 238
 239 =over 4
 240
 241 =item resetup
 242
 243 If set true, re-charges setup fees.
 244
 245 =item time
 246
 247 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:
 248
 249  use Date::Parse;
 250  ...
 251  $cust_main->bill( 'time' => str2time('April 20th, 2001') );
 252
 253 =item pkg_list
 254
 255 An array ref of specific packages (objects) to attempt billing, instead trying all of them.
 256
 257  $cust_main->bill( pkg_list => [$pkg1, $pkg2] );
 258
 259 =item not_pkgpart
 260
 261 A hashref of pkgparts to exclude from this billing run (can also be specified as a comma-separated scalar).
 262
 263 =item invoice_time
 264
 265 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.
 266
 267 =item cancel
 268
 269 This boolean value informs the us that the package is being cancelled.  This
 270 typically might mean not charging the normal recurring fee but only usage
 271 fees since the last billing. Setup charges may be charged.  Not all package
 272 plans support this feature (they tend to charge 0).
 273
 274 =item invoice_terms
 275
 276 Optional terms to be printed on this invoice.  Otherwise, customer-specific
 277 terms or the default terms are used.
 278
 279 =back
 280
 281 =cut
 282
 283 sub bill {
 284   my( $self, %options ) = @_;
 285   return '' if $self->payby eq 'COMP';
 286   warn "$me bill customer ". $self->custnum. "\n"
 287     if $DEBUG;
 288
 289   my $time = $options{'time'} || time;
 290   my $invoice_time = $options{'invoice_time'} || $time;
 291
 292   $options{'not_pkgpart'} ||= {};
 293   $options{'not_pkgpart'} = { map { $_ => 1 }
 294                                   split(/\s*,\s*/, $options{'not_pkgpart'})
 295                             }
 296     unless ref($options{'not_pkgpart'});
 297
 298   local $SIG{HUP} = 'IGNORE';
 299   local $SIG{INT} = 'IGNORE';
 300   local $SIG{QUIT} = 'IGNORE';
 301   local $SIG{TERM} = 'IGNORE';
 302   local $SIG{TSTP} = 'IGNORE';
 303   local $SIG{PIPE} = 'IGNORE';
 304
 305   my $oldAutoCommit = $FS::UID::AutoCommit;
 306   local $FS::UID::AutoCommit = 0;
 307   my $dbh = dbh;
 308
 309   warn "$me acquiring lock on customer ". $self->custnum. "\n"
 310     if $DEBUG;
 311
 312   $self->select_for_update; #mutex
 313
 314   warn "$me running pre-bill events for customer ". $self->custnum. "\n"
 315     if $DEBUG;
 316
 317   my $error = $self->do_cust_event(
 318     'debug'      => ( $options{'debug'} || 0 ),
 319     'time'       => $invoice_time,
 320     'check_freq' => $options{'check_freq'},
 321     'stage'      => 'pre-bill',
 322   );
 323   if ( $error ) {
 324     $dbh->rollback if $oldAutoCommit;
 325     return $error;
 326   }
 327
 328   warn "$me done running pre-bill events for customer ". $self->custnum. "\n"
 329     if $DEBUG;
 330
 331   #keep auto-charge and non-auto-charge line items separate
 332   my @passes = ( '', 'no_auto' );
 333
 334   my %cust_bill_pkg = map { $_ => [] } @passes;
 335
 336   ###
 337   # find the packages which are due for billing, find out how much they are
 338   # & generate invoice database.
 339   ###
 340
 341   my %total_setup   = map { my $z = 0; $_ => \$z; } @passes;
 342   my %total_recur   = map { my $z = 0; $_ => \$z; } @passes;
 343
 344   my %taxlisthash = map { $_ => {} } @passes;
 345
 346   my @precommit_hooks = ();
 347
 348   $options{'pkg_list'} ||= [ $self->ncancelled_pkgs ];  #param checks?
 349   foreach my $cust_pkg ( @{ $options{'pkg_list'} } ) {
 350
 351     next if $options{'not_pkgpart'}->{$cust_pkg->pkgpart};
 352
 353     warn "  bill package ". $cust_pkg->pkgnum. "\n" if $DEBUG > 1;
 354
 355     #? to avoid use of uninitialized value errors... ?
 356     $cust_pkg->setfield('bill', '')
 357       unless defined($cust_pkg->bill);
 358
 359     #my $part_pkg = $cust_pkg->part_pkg;
 360
 361     my $real_pkgpart = $cust_pkg->pkgpart;
 362     my %hash = $cust_pkg->hash;
 363
 364     # we could implement this bit as FS::part_pkg::has_hidden, but we already
 365     # suffer from performance issues
 366     $options{has_hidden} = 0;
 367     my @part_pkg = $cust_pkg->part_pkg->self_and_bill_linked;
 368     $options{has_hidden} = 1 if ($part_pkg[1] && $part_pkg[1]->hidden);
 369
 370     foreach my $part_pkg ( @part_pkg ) {
 371
 372       $cust_pkg->set($_, $hash{$_}) foreach qw ( setup last_bill bill );
 373
 374       my $pass = ($cust_pkg->no_auto || $part_pkg->no_auto) ? 'no_auto' : '';
 375
 376       my $error =
 377         $self->_make_lines( 'part_pkg'            => $part_pkg,
 378                             'cust_pkg'            => $cust_pkg,
 379                             'precommit_hooks'     => \@precommit_hooks,
 380                             'line_items'          => $cust_bill_pkg{$pass},
 381                             'setup'               => $total_setup{$pass},
 382                             'recur'               => $total_recur{$pass},
 383                             'tax_matrix'          => $taxlisthash{$pass},
 384                             'time'                => $time,
 385                             'real_pkgpart'        => $real_pkgpart,
 386                             'options'             => \%options,
 387                           );
 388       if ($error) {
 389         $dbh->rollback if $oldAutoCommit;
 390         return $error;
 391       }
 392
 393     } #foreach my $part_pkg
 394
 395   } #foreach my $cust_pkg
 396
 397   #if the customer isn't on an automatic payby, everything can go on a single
 398   #invoice anyway?
 399   #if ( $cust_main->payby !~ /^(CARD|CHEK)$/ ) {
 400     #merge everything into one list
 401   #}
 402
 403   foreach my $pass (@passes) { # keys %cust_bill_pkg ) {
 404
 405     my @cust_bill_pkg = _omit_zero_value_bundles(@{ $cust_bill_pkg{$pass} });
 406
 407     next unless @cust_bill_pkg; #don't create an invoice w/o line items
 408
 409     if ( scalar( grep { $_->recur && $_->recur > 0 } @cust_bill_pkg) ||
 410            !$conf->exists('postal_invoice-recurring_only')
 411        )
 412     {
 413
 414       my $postal_pkg = $self->charge_postal_fee();
 415       if ( $postal_pkg && !ref( $postal_pkg ) ) {
 416
 417         $dbh->rollback if $oldAutoCommit;
 418         return "can't charge postal invoice fee for customer ".
 419           $self->custnum. ": $postal_pkg";
 420
 421       } elsif ( $postal_pkg ) {
 422
 423         my $real_pkgpart = $postal_pkg->pkgpart;
 424         # we could implement this bit as FS::part_pkg::has_hidden, but we already
 425         # suffer from performance issues
 426         $options{has_hidden} = 0;
 427         my @part_pkg = $postal_pkg->part_pkg->self_and_bill_linked;
 428         $options{has_hidden} = 1 if ($part_pkg[1] && $part_pkg[1]->hidden);
 429
 430         foreach my $part_pkg ( @part_pkg ) {
 431           my %postal_options = %options;
 432           delete $postal_options{cancel};
 433           my $error =
 434             $self->_make_lines( 'part_pkg'            => $part_pkg,
 435                                 'cust_pkg'            => $postal_pkg,
 436                                 'precommit_hooks'     => \@precommit_hooks,
 437                                 'line_items'          => \@cust_bill_pkg,
 438                                 'setup'               => $total_setup{$pass},
 439                                 'recur'               => $total_recur{$pass},
 440                                 'tax_matrix'          => $taxlisthash{$pass},
 441                                 'time'                => $time,
 442                                 'real_pkgpart'        => $real_pkgpart,
 443                                 'options'             => \%postal_options,
 444                               );
 445           if ($error) {
 446             $dbh->rollback if $oldAutoCommit;
 447             return $error;
 448           }
 449         }
 450
 451         # it's silly to have a zero value postal_pkg, but....
 452         @cust_bill_pkg = _omit_zero_value_bundles(@cust_bill_pkg);
 453
 454       }
 455
 456     }
 457
 458     my $listref_or_error =
 459       $self->calculate_taxes( \@cust_bill_pkg, $taxlisthash{$pass}, $invoice_time);
 460
 461     unless ( ref( $listref_or_error ) ) {
 462       $dbh->rollback if $oldAutoCommit;
 463       return $listref_or_error;
 464     }
 465
 466     foreach my $taxline ( @$listref_or_error ) {
 467       ${ $total_setup{$pass} } =
 468         sprintf('%.2f', ${ $total_setup{$pass} } + $taxline->setup );
 469       push @cust_bill_pkg, $taxline;
 470     }
 471
 472     #add tax adjustments
 473     warn "adding tax adjustments...\n" if $DEBUG > 2;
 474     foreach my $cust_tax_adjustment (
 475       qsearch('cust_tax_adjustment', { 'custnum'    => $self->custnum,
 476                                        'billpkgnum' => '',
 477                                      }
 478              )
 479     ) {
 480
 481       my $tax = sprintf('%.2f', $cust_tax_adjustment->amount );
 482
 483       my $itemdesc = $cust_tax_adjustment->taxname;
 484       $itemdesc = '' if $itemdesc eq 'Tax';
 485
 486       push @cust_bill_pkg, new FS::cust_bill_pkg {
 487         'pkgnum'      => 0,
 488         'setup'       => $tax,
 489         'recur'       => 0,
 490         'sdate'       => '',
 491         'edate'       => '',
 492         'itemdesc'    => $itemdesc,
 493         'itemcomment' => $cust_tax_adjustment->comment,
 494         'cust_tax_adjustment' => $cust_tax_adjustment,
 495         #'cust_bill_pkg_tax_location' => \@cust_bill_pkg_tax_location,
 496       };
 497
 498     }
 499
 500     my $charged = sprintf('%.2f', ${ $total_setup{$pass} } + ${ $total_recur{$pass} } );
 501
 502     my @cust_bill = $self->cust_bill;
 503     my $balance = $self->balance;
 504     my $previous_balance = scalar(@cust_bill)
 505                              ? ( $cust_bill[$#cust_bill]->billing_balance || 0 )
 506                              : 0;
 507
 508     $previous_balance += $cust_bill[$#cust_bill]->charged
 509       if scalar(@cust_bill);
 510     #my $balance_adjustments =
 511     #  sprintf('%.2f', $balance - $prior_prior_balance - $prior_charged);
 512
 513     #create the new invoice
 514     my $cust_bill = new FS::cust_bill ( {
 515       'custnum'             => $self->custnum,
 516       '_date'               => ( $invoice_time ),
 517       'charged'             => $charged,
 518       'billing_balance'     => $balance,
 519       'previous_balance'    => $previous_balance,
 520       'invoice_terms'       => $options{'invoice_terms'},
 521     } );
 522     $error = $cust_bill->insert;
 523     if ( $error ) {
 524       $dbh->rollback if $oldAutoCommit;
 525       return "can't create invoice for customer #". $self->custnum. ": $error";
 526     }
 527
 528     foreach my $cust_bill_pkg ( @cust_bill_pkg ) {
 529       $cust_bill_pkg->invnum($cust_bill->invnum);
 530       my $error = $cust_bill_pkg->insert;
 531       if ( $error ) {
 532         $dbh->rollback if $oldAutoCommit;
 533         return "can't create invoice line item: $error";
 534       }
 535     }
 536
 537   } #foreach my $pass ( keys %cust_bill_pkg )
 538
 539   foreach my $hook ( @precommit_hooks ) {
 540     eval {
 541       &{$hook}; #($self) ?
 542     };
 543     if ( $@ ) {
 544       $dbh->rollback if $oldAutoCommit;
 545       return "$@ running precommit hook $hook\n";
 546     }
 547   }
 548
 549   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 550   ''; #no error
 551 }
 552
 553 #discard bundled packages of 0 value
 554 sub _omit_zero_value_bundles {
 555
 556   my @cust_bill_pkg = ();
 557   my @cust_bill_pkg_bundle = ();
 558   my $sum = 0;
 559
 560   foreach my $cust_bill_pkg ( @_ ) {
 561     if (scalar(@cust_bill_pkg_bundle) && !$cust_bill_pkg->pkgpart_override) {
 562       push @cust_bill_pkg, @cust_bill_pkg_bundle if $sum > 0;
 563       @cust_bill_pkg_bundle = ();
 564       $sum = 0;
 565     }
 566     $sum += $cust_bill_pkg->setup + $cust_bill_pkg->recur;
 567     push @cust_bill_pkg_bundle, $cust_bill_pkg;
 568   }
 569   push @cust_bill_pkg, @cust_bill_pkg_bundle if $sum > 0;
 570
 571   (@cust_bill_pkg);
 572
 573 }
 574
 575 =item calculate_taxes LINEITEMREF TAXHASHREF INVOICE_TIME
 576
 577 This is a weird one.  Perhaps it should not even be exposed.
 578
 579 Generates tax line items (see L<FS::cust_bill_pkg>) for this customer.
 580 Usually used internally by bill method B<bill>.
 581
 582 If there is an error, returns the error, otherwise returns reference to a
 583 list of line items suitable for insertion.
 584
 585 =over 4
 586
 587 =item LINEITEMREF
 588
 589 An array ref of the line items being billed.
 590
 591 =item TAXHASHREF
 592
 593 A strange beast.  The keys to this hash are internal identifiers consisting
 594 of the name of the tax object type, a space, and its unique identifier ( e.g.
 595  'cust_main_county 23' ).  The values of the hash are listrefs.  The first
 596 item in the list is the tax object.  The remaining items are either line
 597 items or floating point values (currency amounts).
 598
 599 The taxes are calculated on this entity.  Calculated exemption records are
 600 transferred to the LINEITEMREF items on the assumption that they are related.
 601
 602 Read the source.
 603
 604 =item INVOICE_TIME
 605
 606 This specifies the date appearing on the associated invoice.  Some
 607 jurisdictions (i.e. Texas) have tax exemptions which are date sensitive.
 608
 609 =back
 610
 611 =cut
 612 sub calculate_taxes {
 613   my ($self, $cust_bill_pkg, $taxlisthash, $invoice_time) = @_;
 614
 615   my @tax_line_items = ();
 616
 617   warn "having a look at the taxes we found...\n" if $DEBUG > 2;
 618
 619   # keys are tax names (as printed on invoices / itemdesc )
 620   # values are listrefs of taxlisthash keys (internal identifiers)
 621   my %taxname = ();
 622
 623   # keys are taxlisthash keys (internal identifiers)
 624   # values are (cumulative) amounts
 625   my %tax = ();
 626
 627   # keys are taxlisthash keys (internal identifiers)
 628   # values are listrefs of cust_bill_pkg_tax_location hashrefs
 629   my %tax_location = ();
 630
 631   # keys are taxlisthash keys (internal identifiers)
 632   # values are listrefs of cust_bill_pkg_tax_rate_location hashrefs
 633   my %tax_rate_location = ();
 634
 635   foreach my $tax ( keys %$taxlisthash ) {
 636     my $tax_object = shift @{ $taxlisthash->{$tax} };
 637     warn "found ". $tax_object->taxname. " as $tax\n" if $DEBUG > 2;
 638     warn " ". join('/', @{ $taxlisthash->{$tax} } ). "\n" if $DEBUG > 2;
 639     my $hashref_or_error =
 640       $tax_object->taxline( $taxlisthash->{$tax},
 641                             'custnum'      => $self->custnum,
 642                             'invoice_time' => $invoice_time
 643                           );
 644     return $hashref_or_error unless ref($hashref_or_error);
 645
 646     unshift @{ $taxlisthash->{$tax} }, $tax_object;
 647
 648     my $name   = $hashref_or_error->{'name'};
 649     my $amount = $hashref_or_error->{'amount'};
 650
 651     #warn "adding $amount as $name\n";
 652     $taxname{ $name } ||= [];
 653     push @{ $taxname{ $name } }, $tax;
 654
 655     $tax{ $tax } += $amount;
 656
 657     $tax_location{ $tax } ||= [];
 658     if ( $tax_object->get('pkgnum') || $tax_object->get('locationnum') ) {
 659       push @{ $tax_location{ $tax }  },
 660         {
 661           'taxnum'      => $tax_object->taxnum,
 662           'taxtype'     => ref($tax_object),
 663           'pkgnum'      => $tax_object->get('pkgnum'),
 664           'locationnum' => $tax_object->get('locationnum'),
 665           'amount'      => sprintf('%.2f', $amount ),
 666         };
 667     }
 668
 669     $tax_rate_location{ $tax } ||= [];
 670     if ( ref($tax_object) eq 'FS::tax_rate' ) {
 671       my $taxratelocationnum =
 672         $tax_object->tax_rate_location->taxratelocationnum;
 673       push @{ $tax_rate_location{ $tax }  },
 674         {
 675           'taxnum'             => $tax_object->taxnum,
 676           'taxtype'            => ref($tax_object),
 677           'amount'             => sprintf('%.2f', $amount ),
 678           'locationtaxid'      => $tax_object->location,
 679           'taxratelocationnum' => $taxratelocationnum,
 680         };
 681     }
 682
 683   }
 684
 685   #move the cust_tax_exempt_pkg records to the cust_bill_pkgs we will commit
 686   my %packagemap = map { $_->pkgnum => $_ } @$cust_bill_pkg;
 687   foreach my $tax ( keys %$taxlisthash ) {
 688     foreach ( @{ $taxlisthash->{$tax} }[1 ... scalar(@{ $taxlisthash->{$tax} })] ) {
 689       next unless ref($_) eq 'FS::cust_bill_pkg';
 690
 691       push @{ $packagemap{$_->pkgnum}->_cust_tax_exempt_pkg },
 692         splice( @{ $_->_cust_tax_exempt_pkg } );
 693     }
 694   }
 695
 696   #consolidate and create tax line items
 697   warn "consolidating and generating...\n" if $DEBUG > 2;
 698   foreach my $taxname ( keys %taxname ) {
 699     my $tax = 0;
 700     my %seen = ();
 701     my @cust_bill_pkg_tax_location = ();
 702     my @cust_bill_pkg_tax_rate_location = ();
 703     warn "adding $taxname\n" if $DEBUG > 1;
 704     foreach my $taxitem ( @{ $taxname{$taxname} } ) {
 705       next if $seen{$taxitem}++;
 706       warn "adding $tax{$taxitem}\n" if $DEBUG > 1;
 707       $tax += $tax{$taxitem};
 708       push @cust_bill_pkg_tax_location,
 709         map { new FS::cust_bill_pkg_tax_location $_ }
 710             @{ $tax_location{ $taxitem } };
 711       push @cust_bill_pkg_tax_rate_location,
 712         map { new FS::cust_bill_pkg_tax_rate_location $_ }
 713             @{ $tax_rate_location{ $taxitem } };
 714     }
 715     next unless $tax;
 716
 717     $tax = sprintf('%.2f', $tax );
 718
 719     my $pkg_category = qsearchs( 'pkg_category', { 'categoryname' => $taxname,
 720                                                    'disabled'     => '',
 721                                                  },
 722                                );
 723
 724     my @display = ();
 725     if ( $pkg_category and
 726          $conf->config('invoice_latexsummary') ||
 727          $conf->config('invoice_htmlsummary')
 728        )
 729     {
 730
 731       my %hash = (  'section' => $pkg_category->categoryname );
 732       push @display, new FS::cust_bill_pkg_display { type => 'S', %hash };
 733
 734     }
 735
 736     push @tax_line_items, new FS::cust_bill_pkg {
 737       'pkgnum'   => 0,
 738       'setup'    => $tax,
 739       'recur'    => 0,
 740       'sdate'    => '',
 741       'edate'    => '',
 742       'itemdesc' => $taxname,
 743       'display'  => \@display,
 744       'cust_bill_pkg_tax_location' => \@cust_bill_pkg_tax_location,
 745       'cust_bill_pkg_tax_rate_location' => \@cust_bill_pkg_tax_rate_location,
 746     };
 747
 748   }
 749
 750   \@tax_line_items;
 751 }
 752
 753 sub _make_lines {
 754   my ($self, %params) = @_;
 755
 756   my $part_pkg = $params{part_pkg} or die "no part_pkg specified";
 757   my $cust_pkg = $params{cust_pkg} or die "no cust_pkg specified";
 758   my $precommit_hooks = $params{precommit_hooks} or die "no package specified";
 759   my $cust_bill_pkgs = $params{line_items} or die "no line buffer specified";
 760   my $total_setup = $params{setup} or die "no setup accumulator specified";
 761   my $total_recur = $params{recur} or die "no recur accumulator specified";
 762   my $taxlisthash = $params{tax_matrix} or die "no tax accumulator specified";
 763   my $time = $params{'time'} or die "no time specified";
 764   my (%options) = %{$params{options}};
 765
 766   my $dbh = dbh;
 767   my $real_pkgpart = $params{real_pkgpart};
 768   my %hash = $cust_pkg->hash;
 769   my $old_cust_pkg = new FS::cust_pkg \%hash;
 770
 771   my @details = ();
 772   my @discounts = ();
 773   my $lineitems = 0;
 774
 775   $cust_pkg->pkgpart($part_pkg->pkgpart);
 776
 777   ###
 778   # bill setup
 779   ###
 780
 781   my $setup = 0;
 782   my $unitsetup = 0;
 783   if ( $options{'resetup'}
 784        || ( ! $cust_pkg->setup
 785             && ( ! $cust_pkg->start_date
 786                  || $cust_pkg->start_date <= $time
 787                )
 788             && ( ! $conf->exists('disable_setup_suspended_pkgs')
 789                  || ( $conf->exists('disable_setup_suspended_pkgs') &&
 790                       ! $cust_pkg->getfield('susp')
 791                     )
 792                )
 793           )
 794     )
 795   {
 796
 797     warn "    bill setup\n" if $DEBUG > 1;
 798     $lineitems++;
 799
 800     $setup = eval { $cust_pkg->calc_setup( $time, \@details ) };
 801     return "$@ running calc_setup for $cust_pkg\n"
 802       if $@;
 803
 804     $unitsetup = $cust_pkg->part_pkg->unit_setup || $setup; #XXX uuh
 805
 806     $cust_pkg->setfield('setup', $time)
 807       unless $cust_pkg->setup;
 808           #do need it, but it won't get written to the db
 809           #|| $cust_pkg->pkgpart != $real_pkgpart;
 810
 811     $cust_pkg->setfield('start_date', '')
 812       if $cust_pkg->start_date;
 813
 814   }
 815
 816   ###
 817   # bill recurring fee
 818   ###
 819
 820   #XXX unit stuff here too
 821   my $recur = 0;
 822   my $unitrecur = 0;
 823   my $sdate;
 824   if (     ! $cust_pkg->get('susp')
 825        and ! $cust_pkg->get('start_date')
 826        and ( $part_pkg->getfield('freq') ne '0'
 827              && ( $cust_pkg->getfield('bill') || 0 ) <= $time
 828            )
 829         || ( $part_pkg->plan eq 'voip_cdr'
 830               && $part_pkg->option('bill_every_call')
 831            )
 832         || ( $options{cancel} )
 833   ) {
 834
 835     # XXX should this be a package event?  probably.  events are called
 836     # at collection time at the moment, though...
 837     $part_pkg->reset_usage($cust_pkg, 'debug'=>$DEBUG)
 838       if $part_pkg->can('reset_usage');
 839       #don't want to reset usage just cause we want a line item??
 840       #&& $part_pkg->pkgpart == $real_pkgpart;
 841
 842     warn "    bill recur\n" if $DEBUG > 1;
 843     $lineitems++;
 844
 845     # XXX shared with $recur_prog
 846     $sdate = ( $options{cancel} ? $cust_pkg->last_bill : $cust_pkg->bill )
 847              || $cust_pkg->setup
 848              || $time;
 849
 850     #over two params!  lets at least switch to a hashref for the rest...
 851     my $increment_next_bill = ( $part_pkg->freq ne '0'
 852                                 && ( $cust_pkg->getfield('bill') || 0 ) <= $time
 853                                 && !$options{cancel}
 854                               );
 855     my %param = ( 'precommit_hooks'     => $precommit_hooks,
 856                   'increment_next_bill' => $increment_next_bill,
 857                   'discounts'           => \@discounts,
 858                   'real_pkgpart'        => $real_pkgpart,
 859                 );
 860
 861     my $method = $options{cancel} ? 'calc_cancel' : 'calc_recur';
 862     $recur = eval { $cust_pkg->$method( \$sdate, \@details, \%param ) };
 863     return "$@ running $method for $cust_pkg\n"
 864       if ( $@ );
 865
 866     if ( $increment_next_bill ) {
 867
 868       my $next_bill = $part_pkg->add_freq($sdate);
 869       return "unparsable frequency: ". $part_pkg->freq
 870         if $next_bill == -1;
 871
 872       #pro-rating magic - if $recur_prog fiddled $sdate, want to use that
 873       # only for figuring next bill date, nothing else, so, reset $sdate again
 874       # here
 875       $sdate = $cust_pkg->bill || $cust_pkg->setup || $time;
 876       #no need, its in $hash{last_bill}# my $last_bill = $cust_pkg->last_bill;
 877       $cust_pkg->last_bill($sdate);
 878
 879       $cust_pkg->setfield('bill', $next_bill );
 880
 881     }
 882
 883   }
 884
 885   warn "\$setup is undefined" unless defined($setup);
 886   warn "\$recur is undefined" unless defined($recur);
 887   warn "\$cust_pkg->bill is undefined" unless defined($cust_pkg->bill);
 888
 889   ###
 890   # If there's line items, create em cust_bill_pkg records
 891   # If $cust_pkg has been modified, update it (if we're a real pkgpart)
 892   ###
 893
 894   if ( $lineitems || $options{has_hidden} ) {
 895
 896     if ( $cust_pkg->modified && $cust_pkg->pkgpart == $real_pkgpart ) {
 897       # hmm.. and if just the options are modified in some weird price plan?
 898
 899       warn "  package ". $cust_pkg->pkgnum. " modified; updating\n"
 900         if $DEBUG >1;
 901
 902       my $error = $cust_pkg->replace( $old_cust_pkg,
 903                                       'options' => { $cust_pkg->options },
 904                                     );
 905       return "Error modifying pkgnum ". $cust_pkg->pkgnum. ": $error"
 906         if $error; #just in case
 907     }
 908
 909     $setup = sprintf( "%.2f", $setup );
 910     $recur = sprintf( "%.2f", $recur );
 911     if ( $setup < 0 && ! $conf->exists('allow_negative_charges') ) {
 912       return "negative setup $setup for pkgnum ". $cust_pkg->pkgnum;
 913     }
 914     if ( $recur < 0 && ! $conf->exists('allow_negative_charges') ) {
 915       return "negative recur $recur for pkgnum ". $cust_pkg->pkgnum;
 916     }
 917
 918     if ( $setup != 0 ||
 919          $recur != 0 ||
 920          !$part_pkg->hidden && $options{has_hidden} ) #include some $0 lines
 921     {
 922
 923       warn "    charges (setup=$setup, recur=$recur); adding line items\n"
 924         if $DEBUG > 1;
 925
 926       my @cust_pkg_detail = map { $_->detail } $cust_pkg->cust_pkg_detail('I');
 927       if ( $DEBUG > 1 ) {
 928         warn "      adding customer package invoice detail: $_\n"
 929           foreach @cust_pkg_detail;
 930       }
 931       push @details, @cust_pkg_detail;
 932
 933       my $cust_bill_pkg = new FS::cust_bill_pkg {
 934         'pkgnum'    => $cust_pkg->pkgnum,
 935         'setup'     => $setup,
 936         'unitsetup' => $unitsetup,
 937         'recur'     => $recur,
 938         'unitrecur' => $unitrecur,
 939         'quantity'  => $cust_pkg->quantity,
 940         'details'   => \@details,
 941         'discounts' => \@discounts,
 942         'hidden'    => $part_pkg->hidden,
 943       };
 944
 945       if ( $part_pkg->option('recur_temporality', 1) eq 'preceding' ) {
 946         $cust_bill_pkg->sdate( $hash{last_bill} );
 947         $cust_bill_pkg->edate( $sdate - 86399   ); #60s*60m*24h-1
 948         $cust_bill_pkg->edate( $time ) if $options{cancel};
 949       } else { #if ( $part_pkg->option('recur_temporality', 1) eq 'upcoming' ) {
 950         $cust_bill_pkg->sdate( $sdate );
 951         $cust_bill_pkg->edate( $cust_pkg->bill );
 952         #$cust_bill_pkg->edate( $time ) if $options{cancel};
 953       }
 954
 955       $cust_bill_pkg->pkgpart_override($part_pkg->pkgpart)
 956         unless $part_pkg->pkgpart == $real_pkgpart;
 957
 958       $$total_setup += $setup;
 959       $$total_recur += $recur;
 960
 961       ###
 962       # handle taxes
 963       ###
 964
 965       my $error =
 966         $self->_handle_taxes($part_pkg, $taxlisthash, $cust_bill_pkg, $cust_pkg, $options{invoice_time}, $real_pkgpart, \%options);
 967       return $error if $error;
 968
 969       push @$cust_bill_pkgs, $cust_bill_pkg;
 970
 971     } #if $setup != 0 || $recur != 0
 972
 973   } #if $line_items
 974
 975   '';
 976
 977 }
 978
 979 sub _handle_taxes {
 980   my $self = shift;
 981   my $part_pkg = shift;
 982   my $taxlisthash = shift;
 983   my $cust_bill_pkg = shift;
 984   my $cust_pkg = shift;
 985   my $invoice_time = shift;
 986   my $real_pkgpart = shift;
 987   my $options = shift;
 988
 989   my %cust_bill_pkg = ();
 990   my %taxes = ();
 991
 992   my @classes;
 993   #push @classes, $cust_bill_pkg->usage_classes if $cust_bill_pkg->type eq 'U';
 994   push @classes, $cust_bill_pkg->usage_classes if $cust_bill_pkg->usage;
 995   push @classes, 'setup' if ($cust_bill_pkg->setup && !$options->{cancel});
 996   push @classes, 'recur' if ($cust_bill_pkg->recur && !$options->{cancel});
 997
 998   if ( $self->tax !~ /Y/i && $self->payby ne 'COMP' ) {
 999
1000     if ( $conf->exists('enable_taxproducts')
1001          && ( scalar($part_pkg->part_pkg_taxoverride)
1002               || $part_pkg->has_taxproduct
1003             )
1004        )
1005     {
1006
1007       if ( $conf->exists('tax-pkg_address') && $cust_pkg->locationnum ) {
1008         return "fatal: Can't (yet) use tax-pkg_address with taxproducts";
1009       }
1010
1011       foreach my $class (@classes) {
1012         my $err_or_ref = $self->_gather_taxes( $part_pkg, $class );
1013         return $err_or_ref unless ref($err_or_ref);
1014         $taxes{$class} = $err_or_ref;
1015       }
1016
1017       unless (exists $taxes{''}) {
1018         my $err_or_ref = $self->_gather_taxes( $part_pkg, '' );
1019         return $err_or_ref unless ref($err_or_ref);
1020         $taxes{''} = $err_or_ref;
1021       }
1022
1023     } else {
1024
1025       my @loc_keys = qw( city county state country );
1026       my %taxhash;
1027       if ( $conf->exists('tax-pkg_address') && $cust_pkg->locationnum ) {
1028         my $cust_location = $cust_pkg->cust_location;
1029         %taxhash = map { $_ => $cust_location->$_()    } @loc_keys;
1030       } else {
1031         my $prefix =
1032           ( $conf->exists('tax-ship_address') && length($self->ship_last) )
1033           ? 'ship_'
1034           : '';
1035         %taxhash = map { $_ => $self->get("$prefix$_") } @loc_keys;
1036       }
1037
1038       $taxhash{'taxclass'} = $part_pkg->taxclass;
1039
1040       my @taxes = ();
1041       my %taxhash_elim = %taxhash;
1042       my @elim = qw( city county state );
1043       do {
1044
1045         #first try a match with taxclass
1046         @taxes = qsearch( 'cust_main_county', \%taxhash_elim );
1047
1048         if ( !scalar(@taxes) && $taxhash_elim{'taxclass'} ) {
1049           #then try a match without taxclass
1050           my %no_taxclass = %taxhash_elim;
1051           $no_taxclass{ 'taxclass' } = '';
1052           @taxes = qsearch( 'cust_main_county', \%no_taxclass );
1053         }
1054
1055         $taxhash_elim{ shift(@elim) } = '';
1056
1057       } while ( !scalar(@taxes) && scalar(@elim) );
1058
1059       @taxes = grep { ! $_->taxname or ! $self->tax_exemption($_->taxname) }
1060                     @taxes
1061         if $self->cust_main_exemption; #just to be safe
1062
1063       if ( $conf->exists('tax-pkg_address') && $cust_pkg->locationnum ) {
1064         foreach (@taxes) {
1065           $_->set('pkgnum',      $cust_pkg->pkgnum );
1066           $_->set('locationnum', $cust_pkg->locationnum );
1067         }
1068       }
1069
1070       $taxes{''} = [ @taxes ];
1071       $taxes{'setup'} = [ @taxes ];
1072       $taxes{'recur'} = [ @taxes ];
1073       $taxes{$_} = [ @taxes ] foreach (@classes);
1074
1075       # # maybe eliminate this entirely, along with all the 0% records
1076       # unless ( @taxes ) {
1077       #   return
1078       #     "fatal: can't find tax rate for state/county/country/taxclass ".
1079       #     join('/', map $taxhash{$_}, qw(state county country taxclass) );
1080       # }
1081
1082     } #if $conf->exists('enable_taxproducts') ...
1083
1084   }
1085
1086   my @display = ();
1087   my $separate = $conf->exists('separate_usage');
1088   my $temp_pkg = new FS::cust_pkg { pkgpart => $real_pkgpart };
1089   my $usage_mandate = $temp_pkg->part_pkg->option('usage_mandate', 'Hush!');
1090   my $section = $temp_pkg->part_pkg->categoryname;
1091   if ( $separate || $section || $usage_mandate ) {
1092
1093     my %hash = ( 'section' => $section );
1094
1095     $section = $temp_pkg->part_pkg->option('usage_section', 'Hush!');
1096     my $summary = $temp_pkg->part_pkg->option('summarize_usage', 'Hush!');
1097     if ( $separate ) {
1098       push @display, new FS::cust_bill_pkg_display { type => 'S', %hash };
1099       push @display, new FS::cust_bill_pkg_display { type => 'R', %hash };
1100     } else {
1101       push @display, new FS::cust_bill_pkg_display
1102                        { type => '',
1103                          %hash,
1104                          ( ( $usage_mandate ) ? ( 'summary' => 'Y' ) : () ),
1105                        };
1106     }
1107
1108     if ($separate && $section && $summary) {
1109       push @display, new FS::cust_bill_pkg_display { type    => 'U',
1110                                                      summary => 'Y',
1111                                                      %hash,
1112                                                    };
1113     }
1114     if ($usage_mandate || $section && $summary) {
1115       $hash{post_total} = 'Y';
1116     }
1117
1118     if ($separate || $usage_mandate) {
1119       $hash{section} = $section if ($separate || $usage_mandate);
1120       push @display, new FS::cust_bill_pkg_display { type => 'U', %hash };
1121     }
1122
1123   }
1124   $cust_bill_pkg->set('display', \@display);
1125
1126   my %tax_cust_bill_pkg = $cust_bill_pkg->disintegrate;
1127   foreach my $key (keys %tax_cust_bill_pkg) {
1128     my @taxes = @{ $taxes{$key} || [] };
1129     my $tax_cust_bill_pkg = $tax_cust_bill_pkg{$key};
1130
1131     my %localtaxlisthash = ();
1132     foreach my $tax ( @taxes ) {
1133
1134       my $taxname = ref( $tax ). ' '. $tax->taxnum;
1135 #      $taxname .= ' pkgnum'. $cust_pkg->pkgnum.
1136 #                  ' locationnum'. $cust_pkg->locationnum
1137 #        if $conf->exists('tax-pkg_address') && $cust_pkg->locationnum;
1138
1139       $taxlisthash->{ $taxname } ||= [ $tax ];
1140       push @{ $taxlisthash->{ $taxname  } }, $tax_cust_bill_pkg;
1141
1142       $localtaxlisthash{ $taxname } ||= [ $tax ];
1143       push @{ $localtaxlisthash{ $taxname  } }, $tax_cust_bill_pkg;
1144
1145     }
1146
1147     warn "finding taxed taxes...\n" if $DEBUG > 2;
1148     foreach my $tax ( keys %localtaxlisthash ) {
1149       my $tax_object = shift @{ $localtaxlisthash{$tax} };
1150       warn "found possible taxed tax ". $tax_object->taxname. " we call $tax\n"
1151         if $DEBUG > 2;
1152       next unless $tax_object->can('tax_on_tax');
1153
1154       foreach my $tot ( $tax_object->tax_on_tax( $self ) ) {
1155         my $totname = ref( $tot ). ' '. $tot->taxnum;
1156
1157         warn "checking $totname which we call ". $tot->taxname. " as applicable\n"
1158           if $DEBUG > 2;
1159         next unless exists( $localtaxlisthash{ $totname } ); # only increase
1160                                                              # existing taxes
1161         warn "adding $totname to taxed taxes\n" if $DEBUG > 2;
1162         my $hashref_or_error =
1163           $tax_object->taxline( $localtaxlisthash{$tax},
1164                                 'custnum'      => $self->custnum,
1165                                 'invoice_time' => $invoice_time,
1166                               );
1167         return $hashref_or_error
1168           unless ref($hashref_or_error);
1169
1170         $taxlisthash->{ $totname } ||= [ $tot ];
1171         push @{ $taxlisthash->{ $totname  } }, $hashref_or_error->{amount};
1172
1173       }
1174     }
1175
1176   }
1177
1178   '';
1179 }
1180
1181 sub _gather_taxes {
1182   my $self = shift;
1183   my $part_pkg = shift;
1184   my $class = shift;
1185
1186   my @taxes = ();
1187   my $geocode = $self->geocode('cch');
1188
1189   my @taxclassnums = map { $_->taxclassnum }
1190                      $part_pkg->part_pkg_taxoverride($class);
1191
1192   unless (@taxclassnums) {
1193     @taxclassnums = map { $_->taxclassnum }
1194                     grep { $_->taxable eq 'Y' }
1195                     $part_pkg->part_pkg_taxrate('cch', $geocode, $class);
1196   }
1197   warn "Found taxclassnum values of ". join(',', @taxclassnums)
1198     if $DEBUG;
1199
1200   my $extra_sql =
1201     "AND (".
1202     join(' OR ', map { "taxclassnum = $_" } @taxclassnums ). ")";
1203
1204   @taxes = qsearch({ 'table' => 'tax_rate',
1205                      'hashref' => { 'geocode' => $geocode, },
1206                      'extra_sql' => $extra_sql,
1207                   })
1208     if scalar(@taxclassnums);
1209
1210   warn "Found taxes ".
1211        join(',', map{ ref($_). " ". $_->get($_->primary_key) } @taxes). "\n"
1212    if $DEBUG;
1213
1214   [ @taxes ];
1215
1216 }
1217
1218 =item collect [ HASHREF | OPTION => VALUE ... ]
1219
1220 (Attempt to) collect money for this customer's outstanding invoices (see
1221 L<FS::cust_bill>).  Usually used after the bill method.
1222
1223 Actions are now triggered by billing events; see L<FS::part_event> and the
1224 billing events web interface.  Old-style invoice events (see
1225 L<FS::part_bill_event>) have been deprecated.
1226
1227 If there is an error, returns the error, otherwise returns false.
1228
1229 Options are passed as name-value pairs.
1230
1231 Currently available options are:
1232
1233 =over 4
1234
1235 =item invoice_time
1236
1237 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.
1238
1239 =item retry
1240
1241 Retry card/echeck/LEC transactions even when not scheduled by invoice events.
1242
1243 =item check_freq
1244
1245 "1d" for the traditional, daily events (the default), or "1m" for the new monthly events (part_event.check_freq)
1246
1247 =item quiet
1248
1249 set true to surpress email card/ACH decline notices.
1250
1251 =item debug
1252
1253 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)
1254
1255 =back
1256
1257 # =item payby
1258 #
1259 # allows for one time override of normal customer billing method
1260
1261 =cut
1262
1263 sub collect {
1264   my( $self, %options ) = @_;
1265   my $invoice_time = $options{'invoice_time'} || time;
1266
1267   #put below somehow?
1268   local $SIG{HUP} = 'IGNORE';
1269   local $SIG{INT} = 'IGNORE';
1270   local $SIG{QUIT} = 'IGNORE';
1271   local $SIG{TERM} = 'IGNORE';
1272   local $SIG{TSTP} = 'IGNORE';
1273   local $SIG{PIPE} = 'IGNORE';
1274
1275   my $oldAutoCommit = $FS::UID::AutoCommit;
1276   local $FS::UID::AutoCommit = 0;
1277   my $dbh = dbh;
1278
1279   $self->select_for_update; #mutex
1280
1281   if ( $DEBUG ) {
1282     my $balance = $self->balance;
1283     warn "$me collect customer ". $self->custnum. ": balance $balance\n"
1284   }
1285
1286   if ( exists($options{'retry_card'}) ) {
1287     carp 'retry_card option passed to collect is deprecated; use retry';
1288     $options{'retry'} ||= $options{'retry_card'};
1289   }
1290   if ( exists($options{'retry'}) && $options{'retry'} ) {
1291     my $error = $self->retry_realtime;
1292     if ( $error ) {
1293       $dbh->rollback if $oldAutoCommit;
1294       return $error;
1295     }
1296   }
1297
1298   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1299
1300   #never want to roll back an event just because it returned an error
1301   local $FS::UID::AutoCommit = 1; #$oldAutoCommit;
1302
1303   $self->do_cust_event(
1304     'debug'      => ( $options{'debug'} || 0 ),
1305     'time'       => $invoice_time,
1306     'check_freq' => $options{'check_freq'},
1307     'stage'      => 'collect',
1308   );
1309
1310 }
1311
1312 =item retry_realtime
1313
1314 Schedules realtime / batch  credit card / electronic check / LEC billing
1315 events for for retry.  Useful if card information has changed or manual
1316 retry is desired.  The 'collect' method must be called to actually retry
1317 the transaction.
1318
1319 Implementation details: For either this customer, or for each of this
1320 customer's open invoices, changes the status of the first "done" (with
1321 statustext error) realtime processing event to "failed".
1322
1323 =cut
1324
1325 sub retry_realtime {
1326   my $self = shift;
1327
1328   local $SIG{HUP} = 'IGNORE';
1329   local $SIG{INT} = 'IGNORE';
1330   local $SIG{QUIT} = 'IGNORE';
1331   local $SIG{TERM} = 'IGNORE';
1332   local $SIG{TSTP} = 'IGNORE';
1333   local $SIG{PIPE} = 'IGNORE';
1334
1335   my $oldAutoCommit = $FS::UID::AutoCommit;
1336   local $FS::UID::AutoCommit = 0;
1337   my $dbh = dbh;
1338
1339   #a little false laziness w/due_cust_event (not too bad, really)
1340
1341   my $join = FS::part_event_condition->join_conditions_sql;
1342   my $order = FS::part_event_condition->order_conditions_sql;
1343   my $mine =
1344   '( '
1345    . join ( ' OR ' , map {
1346     "( part_event.eventtable = " . dbh->quote($_)
1347     . " AND tablenum IN( SELECT " . dbdef->table($_)->primary_key . " from $_ where custnum = " . dbh->quote( $self->custnum ) . "))" ;
1348    } FS::part_event->eventtables)
1349    . ') ';
1350
1351   #here is the agent virtualization
1352   my $agent_virt = " (    part_event.agentnum IS NULL
1353                        OR part_event.agentnum = ". $self->agentnum. ' )';
1354
1355   #XXX this shouldn't be hardcoded, actions should declare it...
1356   my @realtime_events = qw(
1357     cust_bill_realtime_card
1358     cust_bill_realtime_check
1359     cust_bill_realtime_lec
1360     cust_bill_batch
1361   );
1362
1363   my $is_realtime_event = ' ( '. join(' OR ', map "part_event.action = '$_'",
1364                                                   @realtime_events
1365                                      ).
1366                           ' ) ';
1367
1368   my @cust_event = qsearchs({
1369     'table'     => 'cust_event',
1370     'select'    => 'cust_event.*',
1371     'addl_from' => "LEFT JOIN part_event USING ( eventpart ) $join",
1372     'hashref'   => { 'status' => 'done' },
1373     'extra_sql' => " AND statustext IS NOT NULL AND statustext != '' ".
1374                    " AND $mine AND $is_realtime_event AND $agent_virt $order" # LIMIT 1"
1375   });
1376
1377   my %seen_invnum = ();
1378   foreach my $cust_event (@cust_event) {
1379
1380     #max one for the customer, one for each open invoice
1381     my $cust_X = $cust_event->cust_X;
1382     next if $seen_invnum{ $cust_event->part_event->eventtable eq 'cust_bill'
1383                           ? $cust_X->invnum
1384                           : 0
1385                         }++
1386          or $cust_event->part_event->eventtable eq 'cust_bill'
1387             && ! $cust_X->owed;
1388
1389     my $error = $cust_event->retry;
1390     if ( $error ) {
1391       $dbh->rollback if $oldAutoCommit;
1392       return "error scheduling event for retry: $error";
1393     }
1394
1395   }
1396
1397   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1398   '';
1399
1400 }
1401
1402 =item do_cust_event [ HASHREF | OPTION => VALUE ... ]
1403
1404 Runs billing events; see L<FS::part_event> and the billing events web
1405 interface.
1406
1407 If there is an error, returns the error, otherwise returns false.
1408
1409 Options are passed as name-value pairs.
1410
1411 Currently available options are:
1412
1413 =over 4
1414
1415 =item time
1416
1417 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.
1418
1419 =item check_freq
1420
1421 "1d" for the traditional, daily events (the default), or "1m" for the new monthly events (part_event.check_freq)
1422
1423 =item stage
1424
1425 "collect" (the default) or "pre-bill"
1426
1427 =item quiet
1428
1429 set true to surpress email card/ACH decline notices.
1430
1431 =item debug
1432
1433 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)
1434
1435 =cut
1436
1437 # =item payby
1438 #
1439 # allows for one time override of normal customer billing method
1440
1441 # =item retry
1442 #
1443 # Retry card/echeck/LEC transactions even when not scheduled by invoice events.
1444
1445 sub do_cust_event {
1446   my( $self, %options ) = @_;
1447   my $time = $options{'time'} || time;
1448
1449   #put below somehow?
1450   local $SIG{HUP} = 'IGNORE';
1451   local $SIG{INT} = 'IGNORE';
1452   local $SIG{QUIT} = 'IGNORE';
1453   local $SIG{TERM} = 'IGNORE';
1454   local $SIG{TSTP} = 'IGNORE';
1455   local $SIG{PIPE} = 'IGNORE';
1456
1457   my $oldAutoCommit = $FS::UID::AutoCommit;
1458   local $FS::UID::AutoCommit = 0;
1459   my $dbh = dbh;
1460
1461   $self->select_for_update; #mutex
1462
1463   if ( $DEBUG ) {
1464     my $balance = $self->balance;
1465     warn "$me do_cust_event customer ". $self->custnum. ": balance $balance\n"
1466   }
1467
1468 #  if ( exists($options{'retry_card'}) ) {
1469 #    carp 'retry_card option passed to collect is deprecated; use retry';
1470 #    $options{'retry'} ||= $options{'retry_card'};
1471 #  }
1472 #  if ( exists($options{'retry'}) && $options{'retry'} ) {
1473 #    my $error = $self->retry_realtime;
1474 #    if ( $error ) {
1475 #      $dbh->rollback if $oldAutoCommit;
1476 #      return $error;
1477 #    }
1478 #  }
1479
1480   # false laziness w/pay_batch::import_results
1481
1482   my $due_cust_event = $self->due_cust_event(
1483     'debug'      => ( $options{'debug'} || 0 ),
1484     'time'       => $time,
1485     'check_freq' => $options{'check_freq'},
1486     'stage'      => ( $options{'stage'} || 'collect' ),
1487   );
1488   unless( ref($due_cust_event) ) {
1489     $dbh->rollback if $oldAutoCommit;
1490     return $due_cust_event;
1491   }
1492
1493   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1494   #never want to roll back an event just because it or a different one
1495   # returned an error
1496   local $FS::UID::AutoCommit = 1; #$oldAutoCommit;
1497
1498   foreach my $cust_event ( @$due_cust_event ) {
1499
1500     #XXX lock event
1501
1502     #re-eval event conditions (a previous event could have changed things)
1503     unless ( $cust_event->test_conditions( 'time' => $time ) ) {
1504       #don't leave stray "new/locked" records around
1505       my $error = $cust_event->delete;
1506       return $error if $error;
1507       next;
1508     }
1509
1510     {
1511       local $FS::cust_main::Billing_Realtime::realtime_bop_decline_quiet = 1
1512         if $options{'quiet'};
1513       warn "  running cust_event ". $cust_event->eventnum. "\n"
1514         if $DEBUG > 1;
1515
1516       #if ( my $error = $cust_event->do_event(%options) ) { #XXX %options?
1517       if ( my $error = $cust_event->do_event() ) {
1518         #XXX wtf is this?  figure out a proper dealio with return value
1519         #from do_event
1520         return $error;
1521       }
1522     }
1523
1524   }
1525
1526   '';
1527
1528 }
1529
1530 =item due_cust_event [ HASHREF | OPTION => VALUE ... ]
1531
1532 Inserts database records for and returns an ordered listref of new events due
1533 for this customer, as FS::cust_event objects (see L<FS::cust_event>).  If no
1534 events are due, an empty listref is returned.  If there is an error, returns a
1535 scalar error message.
1536
1537 To actually run the events, call each event's test_condition method, and if
1538 still true, call the event's do_event method.
1539
1540 Options are passed as a hashref or as a list of name-value pairs.  Available
1541 options are:
1542
1543 =over 4
1544
1545 =item check_freq
1546
1547 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.
1548
1549 =item stage
1550
1551 "collect" (the default) or "pre-bill"
1552
1553 =item time
1554
1555 "Current time" for the events.
1556
1557 =item debug
1558
1559 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)
1560
1561 =item eventtable
1562
1563 Only return events for the specified eventtable (by default, events of all eventtables are returned)
1564
1565 =item objects
1566
1567 Explicitly pass the objects to be tested (typically used with eventtable).
1568
1569 =item testonly
1570
1571 Set to true to return the objects, but not actually insert them into the
1572 database.
1573
1574 =back
1575
1576 =cut
1577
1578 sub due_cust_event {
1579   my $self = shift;
1580   my %opt = ref($_[0]) ? %{ $_[0] } : @_;
1581
1582   #???
1583   #my $DEBUG = $opt{'debug'}
1584   local($DEBUG) = $opt{'debug'}
1585     if defined($opt{'debug'}) && $opt{'debug'} > $DEBUG;
1586
1587   warn "$me due_cust_event called with options ".
1588        join(', ', map { "$_: $opt{$_}" } keys %opt). "\n"
1589     if $DEBUG;
1590
1591   $opt{'time'} ||= time;
1592
1593   local $SIG{HUP} = 'IGNORE';
1594   local $SIG{INT} = 'IGNORE';
1595   local $SIG{QUIT} = 'IGNORE';
1596   local $SIG{TERM} = 'IGNORE';
1597   local $SIG{TSTP} = 'IGNORE';
1598   local $SIG{PIPE} = 'IGNORE';
1599
1600   my $oldAutoCommit = $FS::UID::AutoCommit;
1601   local $FS::UID::AutoCommit = 0;
1602   my $dbh = dbh;
1603
1604   $self->select_for_update #mutex
1605     unless $opt{testonly};
1606
1607   ###
1608   # find possible events (initial search)
1609   ###
1610
1611   my @cust_event = ();
1612
1613   my @eventtable = $opt{'eventtable'}
1614                      ? ( $opt{'eventtable'} )
1615                      : FS::part_event->eventtables_runorder;
1616
1617   my $check_freq = $opt{'check_freq'} || '1d';
1618
1619   foreach my $eventtable ( @eventtable ) {
1620
1621     my @objects;
1622     if ( $opt{'objects'} ) {
1623
1624       @objects = @{ $opt{'objects'} };
1625
1626     } else {
1627
1628       #my @objects = $self->$eventtable(); # sub cust_main { @{ [ $self ] }; }
1629       if ( $eventtable eq 'cust_main' ) {
1630         @objects = ( $self );
1631       } else {
1632
1633         my $cm_join =
1634           "LEFT JOIN cust_main USING ( custnum )";
1635
1636         #some false laziness w/Cron::bill bill_where
1637
1638         my $join  = FS::part_event_condition->join_conditions_sql( $eventtable);
1639         my $where = FS::part_event_condition->where_conditions_sql($eventtable,
1640                                                            'time'=>$opt{'time'},
1641                                                                   );
1642         $where = $where ? "AND $where" : '';
1643
1644         my $are_part_event =
1645           "EXISTS ( SELECT 1 FROM part_event $join
1646                       WHERE check_freq = '$check_freq'
1647                         AND eventtable = '$eventtable'
1648                         AND ( disabled = '' OR disabled IS NULL )
1649                         $where
1650                   )
1651           ";
1652         #eofalse
1653
1654         @objects = $self->$eventtable(
1655                      'addl_from' => $cm_join,
1656                      'extra_sql' => " AND $are_part_event",
1657                    );
1658       }
1659
1660     }
1661
1662     my @e_cust_event = ();
1663
1664     my $cross = "CROSS JOIN $eventtable";
1665     $cross .= ' LEFT JOIN cust_main USING ( custnum )'
1666       unless $eventtable eq 'cust_main';
1667
1668     foreach my $object ( @objects ) {
1669
1670       #this first search uses the condition_sql magic for optimization.
1671       #the more possible events we can eliminate in this step the better
1672
1673       my $cross_where = '';
1674       my $pkey = $object->primary_key;
1675       $cross_where = "$eventtable.$pkey = ". $object->$pkey();
1676
1677       my $join = FS::part_event_condition->join_conditions_sql( $eventtable );
1678       my $extra_sql =
1679         FS::part_event_condition->where_conditions_sql( $eventtable,
1680                                                         'time'=>$opt{'time'}
1681                                                       );
1682       my $order = FS::part_event_condition->order_conditions_sql( $eventtable );
1683
1684       $extra_sql = "AND $extra_sql" if $extra_sql;
1685
1686       #here is the agent virtualization
1687       $extra_sql .= " AND (    part_event.agentnum IS NULL
1688                             OR part_event.agentnum = ". $self->agentnum. ' )';
1689
1690       $extra_sql .= " $order";
1691
1692       warn "searching for events for $eventtable ". $object->$pkey. "\n"
1693         if $opt{'debug'} > 2;
1694       my @part_event = qsearch( {
1695         'debug'     => ( $opt{'debug'} > 3 ? 1 : 0 ),
1696         'select'    => 'part_event.*',
1697         'table'     => 'part_event',
1698         'addl_from' => "$cross $join",
1699         'hashref'   => { 'check_freq' => $check_freq,
1700                          'eventtable' => $eventtable,
1701                          'disabled'   => '',
1702                        },
1703         'extra_sql' => "AND $cross_where $extra_sql",
1704       } );
1705
1706       if ( $DEBUG > 2 ) {
1707         my $pkey = $object->primary_key;
1708         warn "      ". scalar(@part_event).
1709              " possible events found for $eventtable ". $object->$pkey(). "\n";
1710       }
1711
1712       push @e_cust_event, map { $_->new_cust_event($object) } @part_event;
1713
1714     }
1715
1716     warn "    ". scalar(@e_cust_event).
1717          " subtotal possible cust events found for $eventtable\n"
1718       if $DEBUG > 1;
1719
1720     push @cust_event, @e_cust_event;
1721
1722   }
1723
1724   warn "  ". scalar(@cust_event).
1725        " total possible cust events found in initial search\n"
1726     if $DEBUG; # > 1;
1727
1728
1729   ##
1730   # test stage
1731   ##
1732
1733   $opt{stage} ||= 'collect';
1734   @cust_event =
1735     grep { my $stage = $_->part_event->event_stage;
1736            $opt{stage} eq $stage or ( ! $stage && $opt{stage} eq 'collect' )
1737          }
1738          @cust_event;
1739
1740   ##
1741   # test conditions
1742   ##
1743
1744   my %unsat = ();
1745
1746   @cust_event = grep $_->test_conditions( 'time'          => $opt{'time'},
1747                                           'stats_hashref' => \%unsat ),
1748                      @cust_event;
1749
1750   warn "  ". scalar(@cust_event). " cust events left satisfying conditions\n"
1751     if $DEBUG; # > 1;
1752
1753   warn "    invalid conditions not eliminated with condition_sql:\n".
1754        join('', map "      $_: ".$unsat{$_}."\n", keys %unsat )
1755     if keys %unsat && $DEBUG; # > 1;
1756
1757   ##
1758   # insert
1759   ##
1760
1761   unless( $opt{testonly} ) {
1762     foreach my $cust_event ( @cust_event ) {
1763
1764       my $error = $cust_event->insert();
1765       if ( $error ) {
1766         $dbh->rollback if $oldAutoCommit;
1767         return $error;
1768       }
1769
1770     }
1771   }
1772
1773   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1774
1775   ##
1776   # return
1777   ##
1778
1779   warn "  returning events: ". Dumper(@cust_event). "\n"
1780     if $DEBUG > 2;
1781
1782   \@cust_event;
1783
1784 }
1785
1786 =item apply_payments_and_credits [ OPTION => VALUE ... ]
1787
1788 Applies unapplied payments and credits.
1789
1790 In most cases, this new method should be used in place of sequential
1791 apply_payments and apply_credits methods.
1792
1793 A hash of optional arguments may be passed.  Currently "manual" is supported.
1794 If true, a payment receipt is sent instead of a statement when
1795 'payment_receipt_email' configuration option is set.
1796
1797 If there is an error, returns the error, otherwise returns false.
1798
1799 =cut
1800
1801 sub apply_payments_and_credits {
1802   my( $self, %options ) = @_;
1803
1804   local $SIG{HUP} = 'IGNORE';
1805   local $SIG{INT} = 'IGNORE';
1806   local $SIG{QUIT} = 'IGNORE';
1807   local $SIG{TERM} = 'IGNORE';
1808   local $SIG{TSTP} = 'IGNORE';
1809   local $SIG{PIPE} = 'IGNORE';
1810
1811   my $oldAutoCommit = $FS::UID::AutoCommit;
1812   local $FS::UID::AutoCommit = 0;
1813   my $dbh = dbh;
1814
1815   $self->select_for_update; #mutex
1816
1817   foreach my $cust_bill ( $self->open_cust_bill ) {
1818     my $error = $cust_bill->apply_payments_and_credits(%options);
1819     if ( $error ) {
1820       $dbh->rollback if $oldAutoCommit;
1821       return "Error applying: $error";
1822     }
1823   }
1824
1825   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1826   ''; #no error
1827
1828 }
1829
1830 =item apply_credits OPTION => VALUE ...
1831
1832 Applies (see L<FS::cust_credit_bill>) unapplied credits (see L<FS::cust_credit>)
1833 to outstanding invoice balances in chronological order (or reverse
1834 chronological order if the I<order> option is set to B<newest>) and returns the
1835 value of any remaining unapplied credits available for refund (see
1836 L<FS::cust_refund>).
1837
1838 Dies if there is an error.
1839
1840 =cut
1841
1842 sub apply_credits {
1843   my $self = shift;
1844   my %opt = @_;
1845
1846   local $SIG{HUP} = 'IGNORE';
1847   local $SIG{INT} = 'IGNORE';
1848   local $SIG{QUIT} = 'IGNORE';
1849   local $SIG{TERM} = 'IGNORE';
1850   local $SIG{TSTP} = 'IGNORE';
1851   local $SIG{PIPE} = 'IGNORE';
1852
1853   my $oldAutoCommit = $FS::UID::AutoCommit;
1854   local $FS::UID::AutoCommit = 0;
1855   my $dbh = dbh;
1856
1857   $self->select_for_update; #mutex
1858
1859   unless ( $self->total_unapplied_credits ) {
1860     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1861     return 0;
1862   }
1863
1864   my @credits = sort { $b->_date <=> $a->_date} (grep { $_->credited > 0 }
1865       qsearch('cust_credit', { 'custnum' => $self->custnum } ) );
1866
1867   my @invoices = $self->open_cust_bill;
1868   @invoices = sort { $b->_date <=> $a->_date } @invoices
1869     if defined($opt{'order'}) && $opt{'order'} eq 'newest';
1870
1871   if ( $conf->exists('pkg-balances') ) {
1872     # limit @credits to those w/ a pkgnum grepped from $self
1873     my %pkgnums = ();
1874     foreach my $i (@invoices) {
1875       foreach my $li ( $i->cust_bill_pkg ) {
1876         $pkgnums{$li->pkgnum} = 1;
1877       }
1878     }
1879     @credits = grep { ! $_->pkgnum || $pkgnums{$_->pkgnum} } @credits;
1880   }
1881
1882   my $credit;
1883
1884   foreach my $cust_bill ( @invoices ) {
1885
1886     if ( !defined($credit) || $credit->credited == 0) {
1887       $credit = pop @credits or last;
1888     }
1889
1890     my $owed;
1891     if ( $conf->exists('pkg-balances') && $credit->pkgnum ) {
1892       $owed = $cust_bill->owed_pkgnum($credit->pkgnum);
1893     } else {
1894       $owed = $cust_bill->owed;
1895     }
1896     unless ( $owed > 0 ) {
1897       push @credits, $credit;
1898       next;
1899     }
1900
1901     my $amount = min( $credit->credited, $owed );
1902
1903     my $cust_credit_bill = new FS::cust_credit_bill ( {
1904       'crednum' => $credit->crednum,
1905       'invnum'  => $cust_bill->invnum,
1906       'amount'  => $amount,
1907     } );
1908     $cust_credit_bill->pkgnum( $credit->pkgnum )
1909       if $conf->exists('pkg-balances') && $credit->pkgnum;
1910     my $error = $cust_credit_bill->insert;
1911     if ( $error ) {
1912       $dbh->rollback or die $dbh->errstr if $oldAutoCommit;
1913       die $error;
1914     }
1915
1916     redo if ($cust_bill->owed > 0) && ! $conf->exists('pkg-balances');
1917
1918   }
1919
1920   my $total_unapplied_credits = $self->total_unapplied_credits;
1921
1922   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1923
1924   return $total_unapplied_credits;
1925 }
1926
1927 =item apply_payments  [ OPTION => VALUE ... ]
1928
1929 Applies (see L<FS::cust_bill_pay>) unapplied payments (see L<FS::cust_pay>)
1930 to outstanding invoice balances in chronological order.
1931
1932  #and returns the value of any remaining unapplied payments.
1933
1934 A hash of optional arguments may be passed.  Currently "manual" is supported.
1935 If true, a payment receipt is sent instead of a statement when
1936 'payment_receipt_email' configuration option is set.
1937
1938 Dies if there is an error.
1939
1940 =cut
1941
1942 sub apply_payments {
1943   my( $self, %options ) = @_;
1944
1945   local $SIG{HUP} = 'IGNORE';
1946   local $SIG{INT} = 'IGNORE';
1947   local $SIG{QUIT} = 'IGNORE';
1948   local $SIG{TERM} = 'IGNORE';
1949   local $SIG{TSTP} = 'IGNORE';
1950   local $SIG{PIPE} = 'IGNORE';
1951
1952   my $oldAutoCommit = $FS::UID::AutoCommit;
1953   local $FS::UID::AutoCommit = 0;
1954   my $dbh = dbh;
1955
1956   $self->select_for_update; #mutex
1957
1958   #return 0 unless
1959
1960   my @payments = sort { $b->_date <=> $a->_date }
1961                  grep { $_->unapplied > 0 }
1962                  $self->cust_pay;
1963
1964   my @invoices = sort { $a->_date <=> $b->_date}
1965                  grep { $_->owed > 0 }
1966                  $self->cust_bill;
1967
1968   if ( $conf->exists('pkg-balances') ) {
1969     # limit @payments to those w/ a pkgnum grepped from $self
1970     my %pkgnums = ();
1971     foreach my $i (@invoices) {
1972       foreach my $li ( $i->cust_bill_pkg ) {
1973         $pkgnums{$li->pkgnum} = 1;
1974       }
1975     }
1976     @payments = grep { ! $_->pkgnum || $pkgnums{$_->pkgnum} } @payments;
1977   }
1978
1979   my $payment;
1980
1981   foreach my $cust_bill ( @invoices ) {
1982
1983     if ( !defined($payment) || $payment->unapplied == 0 ) {
1984       $payment = pop @payments or last;
1985     }
1986
1987     my $owed;
1988     if ( $conf->exists('pkg-balances') && $payment->pkgnum ) {
1989       $owed = $cust_bill->owed_pkgnum($payment->pkgnum);
1990     } else {
1991       $owed = $cust_bill->owed;
1992     }
1993     unless ( $owed > 0 ) {
1994       push @payments, $payment;
1995       next;
1996     }
1997
1998     my $amount = min( $payment->unapplied, $owed );
1999
2000     my $cust_bill_pay = new FS::cust_bill_pay ( {
2001       'paynum' => $payment->paynum,
2002       'invnum' => $cust_bill->invnum,
2003       'amount' => $amount,
2004     } );
2005     $cust_bill_pay->pkgnum( $payment->pkgnum )
2006       if $conf->exists('pkg-balances') && $payment->pkgnum;
2007     my $error = $cust_bill_pay->insert(%options);
2008     if ( $error ) {
2009       $dbh->rollback or die $dbh->errstr if $oldAutoCommit;
2010       die $error;
2011     }
2012
2013     redo if ( $cust_bill->owed > 0) && ! $conf->exists('pkg-balances');
2014
2015   }
2016
2017   my $total_unapplied_payments = $self->total_unapplied_payments;
2018
2019   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2020
2021   return $total_unapplied_payments;
2022 }
2023
2024 1;