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