FS/FS/cust_bill_ApplicationCommon.pm

   1 package FS::cust_bill_ApplicationCommon;
   2
   3 use strict;
   4 use vars qw( @ISA $DEBUG $me $skip_apply_to_lineitems_hack );
   5 use List::Util qw(min);
   6 use FS::Schema qw( dbdef );
   7 use FS::Record qw( qsearch qsearchs dbh );
   8 use FS::cust_pkg;
   9 use FS::cust_svc;
  10 use FS::cust_bill_pkg;
  11 use FS::part_svc;
  12 use FS::part_export;
  13
  14 @ISA = qw( FS::Record );
  15
  16 $DEBUG = 0;
  17 $me = '[FS::cust_bill_ApplicationCommon]';
  18
  19 $skip_apply_to_lineitems_hack = 0;
  20
  21 =head1 NAME
  22
  23 FS::cust_bill_ApplicationCommon - Base class for bill application classes
  24
  25 =head1 SYNOPSIS
  26
  27 use FS::cust_bill_ApplicationCommon;
  28
  29 @ISA = qw( FS::cust_bill_ApplicationCommon );
  30
  31 sub _app_source_name  { 'payment'; }
  32 sub _app_source_table { 'cust_pay'; }
  33 sub _app_lineitem_breakdown_table { 'cust_bill_pay_pkg'; }
  34
  35 =head1 DESCRIPTION
  36
  37 FS::cust_bill_ApplicationCommon is intended as a base class for classes which
  38 represent application of things to invoices, currently payments
  39 (see L<FS::cust_bill_pay>) or credits (see L<FS::cust_credit_bill>).
  40
  41 =head1 METHODS
  42
  43 =over 4
  44
  45 =item insert
  46
  47 =cut
  48
  49 sub insert {
  50   my $self = shift;
  51
  52   local $SIG{HUP} = 'IGNORE';
  53   local $SIG{INT} = 'IGNORE';
  54   local $SIG{QUIT} = 'IGNORE';
  55   local $SIG{TERM} = 'IGNORE';
  56   local $SIG{TSTP} = 'IGNORE';
  57   local $SIG{PIPE} = 'IGNORE';
  58
  59   my $oldAutoCommit = $FS::UID::AutoCommit;
  60   local $FS::UID::AutoCommit = 0;
  61   my $dbh = dbh;
  62
  63   my $error =    $self->SUPER::insert(@_)
  64               || $self->apply_to_lineitems(@_);
  65   if ( $error ) {
  66     $dbh->rollback if $oldAutoCommit;
  67     return $error;
  68   }
  69
  70   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
  71
  72   '';
  73
  74 }
  75
  76 =item delete
  77
  78 =cut
  79
  80 sub delete {
  81   my $self = shift;
  82
  83   local $SIG{HUP} = 'IGNORE';
  84   local $SIG{INT} = 'IGNORE';
  85   local $SIG{QUIT} = 'IGNORE';
  86   local $SIG{TERM} = 'IGNORE';
  87   local $SIG{TSTP} = 'IGNORE';
  88   local $SIG{PIPE} = 'IGNORE';
  89
  90   my $oldAutoCommit = $FS::UID::AutoCommit;
  91   local $FS::UID::AutoCommit = 0;
  92   my $dbh = dbh;
  93
  94   foreach my $app ( $self->lineitem_applications ) {
  95     my $error = $app->delete;
  96     if ( $error ) {
  97       $dbh->rollback if $oldAutoCommit;
  98       return $error;
  99     }
 100   }
 101
 102   my $error = $self->SUPER::delete(@_);
 103   if ( $error ) {
 104     $dbh->rollback if $oldAutoCommit;
 105     return $error;
 106   }
 107
 108   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 109
 110   '';
 111
 112 }
 113
 114 =item apply_to_lineitems
 115
 116 Auto-applies this invoice application to specific line items, if possible.
 117
 118 =cut
 119
 120 sub calculate_applications {
 121   my( $self, %options ) = @_;
 122
 123   return '' if $skip_apply_to_lineitems_hack;
 124
 125   my @apply = ();
 126
 127   my $conf = new FS::Conf;
 128
 129   my @open = $self->cust_bill->open_cust_bill_pkg; #FOR UPDATE...?
 130
 131   if ( exists($options{subitems}) ) {
 132     my $i = 0;
 133     my %open = ();
 134     $open{$_->billpkgnum} = $i++ foreach @open;
 135
 136     foreach my $listref ( @{$options{subitems}} ) {
 137       my ($billpkgnum, $itemamount, $taxlocationnum) = @$listref;
 138       return "Can't apply a ". $self->_app_source_name. ' of $'. $listref->[1].
 139              " to line item $billpkgnum which is not open"
 140         unless exists($open{$billpkgnum});
 141       my $itemindex = $open{$billpkgnum};
 142       my %taxhash = ();
 143       if ($taxlocationnum) {
 144         %taxhash = map { ($_->primary_key => $_->get($_->primary_key)) }
 145                    grep { $_->get($_->primary_key) == $taxlocationnum }
 146                    $open[$itemindex]->cust_bill_pkg_tax_Xlocation;
 147
 148         return "No tax line item with a key value of $taxlocationnum exists"
 149           unless scalar(%taxhash);
 150       }
 151       push @apply, [ $open[$itemindex], $itemamount, { %taxhash } ];
 152     }
 153     return \@apply;
 154   }
 155
 156   @open = grep { $_->pkgnum == $self->pkgnum } @open
 157     if $conf->exists('pkg-balances') && $self->pkgnum;
 158   warn "$me ". scalar(@open). " open line items for invoice ".
 159        $self->cust_bill->invnum. ": ". join(', ', @open). "\n"
 160     if $DEBUG;
 161   my $total = 0;
 162   foreach (@open) {
 163     $total += $_->owed_setup if $_->setup;
 164     $total += $_->owed_recur if $_->recur;
 165   }
 166   $total = sprintf('%.2f', $total);
 167
 168   if ( $self->amount > $total ) {
 169     return "Can't apply a ". $self->_app_source_name. ' of $'. $self->amount.
 170            " greater than the remaining owed on line items (\$$total)";
 171   }
 172
 173   #easy cases:
 174   # - one lineitem (a simple special case of:)
 175   # - amount is for whole invoice (well, all of remaining lineitem links)
 176   if ( $self->amount == $total ) {
 177
 178     warn "$me application amount covers remaining balance of invoice in full;".
 179          "applying to those lineitems\n"
 180       if $DEBUG;
 181
 182     #@apply = map { [ $_, $_->amount ]; } @open;
 183     #@apply = map { [ $_, $_->owed_setup + 0 || $_->owed_recur + 0 ]; } @open;
 184     @apply = map { [ $_, $_->setup ? $_->owed_setup : $_->owed_recur ]; } @open;
 185
 186   } else {
 187
 188     #slightly magic case:
 189     # - amount exactly and uniquely matches a single open lineitem
 190     #   (you must be trying to pay or credit that item, then)
 191
 192     my @same = grep {    ( $_->setup && $_->owed_setup == $self->amount )
 193                       || ( $_->recur && $_->owed_recur == $self->amount )
 194                     }
 195                     @open;
 196     if ( scalar(@same) == 1 ) {
 197       warn "$me application amount exactly and uniquely matches one lineitem;".
 198            " applying to that lineitem\n"
 199         if $DEBUG;
 200       @apply = map { [ $_, $self->amount ]; } @same
 201     }
 202
 203   }
 204
 205   unless ( @apply ) {
 206
 207     warn "$me applying amount based on package weights\n"
 208       if $DEBUG;
 209
 210     #and the rest:
 211     # - apply based on weights...
 212
 213     my $weight_col = $self->_app_part_pkg_weight_column;
 214     my @openweight = map {
 215                            my $open = $_;
 216                            my $cust_pkg = $open->cust_pkg;
 217                            my $weight =
 218                              $cust_pkg
 219                                ? ( $cust_pkg->part_pkg->$weight_col() || 0 )
 220                                : -1; #default or per-tax weight?
 221                            [ $open, $weight ]
 222                          }
 223                          @open;
 224
 225     my %saw = ();
 226     my @weights = sort { $b <=> $a }     # highest weight first
 227                   grep { ! $saw{$_}++ }  # want a list of unique weights
 228                   map  { $_->[1] }
 229                        @openweight;
 230
 231     my $remaining_amount = $self->amount;
 232     foreach my $weight ( @weights ) {
 233
 234       #i hate it when my schwartz gets tangled
 235       my @items = map { $_->[0] } grep { $weight == $_->[1] } @openweight;
 236
 237       my $itemtotal = 0;
 238       foreach my $item (@items) {
 239         $itemtotal += $item->owed_setup if $item->setup;
 240         $itemtotal += $item->owed_recur if $item->recur;
 241       }
 242       my $applytotal = min( $itemtotal, $remaining_amount );
 243       $remaining_amount -= $applytotal;
 244
 245       warn "$me applying $applytotal ($remaining_amount remaining)".
 246            " to ". scalar(@items). " lineitems with weight $weight\n"
 247         if $DEBUG;
 248
 249       #if some items are less than applytotal/num_items, then apply then in full
 250       my $lessflag;
 251       do {
 252         $lessflag = 0;
 253
 254         #no, not sprintf("%.2f",
 255         # we want this rounded DOWN for purposes of checking for line items
 256         # less than it, we don't want .66666 becoming .67 and causing this
 257         # to trigger when it shouldn't
 258         my $applyeach = int( 100 * $applytotal / scalar(@items) ) / 100;
 259
 260         my @newitems = ();
 261         foreach my $item ( @items ) {
 262           my $itemamount = $item->setup ? $item->owed_setup : $item->owed_recur;
 263           if ( $itemamount < $applyeach ) {
 264             warn "$me applying full $itemamount".
 265                  " to small line item (cust_bill_pkg ". $item->billpkgnum. ")\n"
 266               if $DEBUG;
 267             push @apply, [ $item, $itemamount ];
 268             $applytotal -= $itemamount;
 269             $lessflag=1;
 270           } else {
 271             push @newitems, $item;
 272           }
 273         }
 274         @items = @newitems;
 275
 276       } while ( $lessflag );
 277
 278       #and now that we've fallen out of the loop, distribute the rest equally...
 279
 280       # should cust_bill_pay_pkg and cust_credit_bill_pkg amount columns
 281       # become real instead of numeric(10,2) ???  no..
 282       my $applyeach = sprintf("%.2f", $applytotal / scalar(@items) );
 283
 284       my @equi_apply = map { [ $_, $applyeach ] } @items;
 285
 286       # or should we futz with pennies instead?  yes, bah!
 287       my $diff =
 288         sprintf('%.0f', 100 * ( $applytotal - $applyeach * scalar(@items) ) );
 289       $diff = 0 if $diff eq '-0'; #yay ieee fp
 290       if ( abs($diff) > scalar(@items) ) {
 291         #we must have done something really wrong, the difference is more than
 292         #a penny an item
 293         return 'Error distributing pennies applying '. $self->_app_source_name.
 294                " - can't distribute difference of $diff pennies".
 295                ' among '. scalar(@items). ' line items';
 296       }
 297
 298       warn "$me futzing with $diff pennies difference\n"
 299         if $DEBUG && $diff;
 300
 301       my $futz = 0;
 302       while ( $diff != 0 && $futz < scalar(@equi_apply) ) {
 303         if ( $diff > 0 ) {
 304           $equi_apply[$futz++]->[1] += .01;
 305           $diff -= 1;
 306         } elsif ( $diff < 0 ) {
 307           $equi_apply[$futz++]->[1] -= .01;
 308           $diff += 1;
 309         } else {
 310           die "guru exception #5 (in fortran tongue the answer)";
 311         }
 312       }
 313
 314       if ( sprintf('%.0f', $diff ) ) {
 315         return "couldn't futz with pennies enough: still $diff left";
 316       }
 317
 318       if ( $DEBUG ) {
 319         warn "$me applying ". $_->[1].
 320              " to line item (cust_bill_pkg ". $_->[0]->billpkgnum. ")\n"
 321           foreach @equi_apply;
 322       }
 323
 324
 325       push @apply, @equi_apply;
 326
 327       #$remaining_amount -= $applytotal;
 328       last unless $remaining_amount;
 329
 330     }
 331
 332   }
 333
 334   # break down lineitem amounts for tax lines
 335   # could expand @open above, instead, for a slightly different magic effect
 336   my @result = ();
 337   foreach my $apply ( @apply ) {
 338     my @sub_lines = $apply->[0]->cust_bill_pkg_tax_Xlocation;
 339     my $amount = $apply->[1];
 340     warn "applying ". $apply->[1]. " to ". $apply->[0]->desc
 341       if $DEBUG;
 342
 343     foreach my $subline ( @sub_lines ) {
 344       my $owed = $subline->owed;
 345       push @result, [ $apply->[0],
 346                       sprintf('%.2f', min($amount, $owed) ),
 347                       { $subline->primary_key => $subline->get($subline->primary_key) },
 348                     ];
 349       $amount -= $owed;
 350       $amount = 0 if $amount < 0;
 351       last unless $amount;
 352     }
 353     if ( $amount > 0 ) {
 354       push @result, [ $apply->[0], sprintf('%.2f', $amount), {} ];
 355     }
 356   }
 357
 358   \@result;
 359
 360 }
 361
 362 sub apply_to_lineitems {
 363   #my $self = shift;
 364   my( $self, %options ) = @_;
 365
 366   return '' if $skip_apply_to_lineitems_hack;
 367
 368   my $conf = new FS::Conf;
 369
 370   local $SIG{HUP} = 'IGNORE';
 371   local $SIG{INT} = 'IGNORE';
 372   local $SIG{QUIT} = 'IGNORE';
 373   local $SIG{TERM} = 'IGNORE';
 374   local $SIG{TSTP} = 'IGNORE';
 375   local $SIG{PIPE} = 'IGNORE';
 376
 377   my $oldAutoCommit = $FS::UID::AutoCommit;
 378   local $FS::UID::AutoCommit = 0;
 379   my $dbh = dbh;
 380
 381   my $listref_or_error = $self->calculate_applications(%options);
 382   unless (ref($listref_or_error)) {
 383     $dbh->rollback if $oldAutoCommit;
 384     return $listref_or_error;
 385   }
 386
 387   my @apply = @$listref_or_error;
 388
 389   # do the applicaiton(s)
 390   my $table = $self->lineitem_breakdown_table;
 391   my $source_key = dbdef->table($self->table)->primary_key;
 392   my $applied = 0;
 393   foreach my $apply ( @apply ) {
 394     my ( $cust_bill_pkg, $amount, $taxcreditref ) = @$apply;
 395     $applied += $amount;
 396     my $application = "FS::$table"->new( {
 397       $source_key  => $self->$source_key(),
 398       'billpkgnum' => $cust_bill_pkg->billpkgnum,
 399       'amount'     => sprintf('%.2f', $amount),
 400       'setuprecur' => ( $cust_bill_pkg->setup > 0 ? 'setup' : 'recur' ),
 401       'sdate'      => $cust_bill_pkg->sdate,
 402       'edate'      => $cust_bill_pkg->edate,
 403       %$taxcreditref,
 404     });
 405     my $error = $application->insert(%options);
 406     if ( $error ) {
 407       $dbh->rollback if $oldAutoCommit;
 408       return $error;
 409     }
 410
 411     # trigger export_insert_on_payment
 412     if ( $conf->exists('trigger_export_insert_on_payment')
 413       && $cust_bill_pkg->pkgnum > 0 )
 414     {
 415       if ( my $cust_pkg = $cust_bill_pkg->cust_pkg ) {
 416
 417         foreach my $cust_svc ( $cust_pkg->cust_svc ) {
 418           my $svc_x = $cust_svc->svc_x;
 419           my @part_export = grep { $_->can('export_insert_on_payment') }
 420                                  $cust_svc->part_svc->part_export;
 421
 422           foreach my $part_export ( $cust_svc->part_svc->part_export ) {
 423             $error = $part_export->export_insert_on_payment($svc_x);
 424             if ( $error ) {
 425               $dbh->rollback if $oldAutoCommit;
 426               return $error;
 427             }
 428           }
 429         }
 430       }
 431     }
 432     # done trigger export_insert_on_payment
 433
 434   }
 435
 436   #everything should always be applied to line items in full now... sanity check
 437   $applied = sprintf('%.2f', $applied);
 438   unless ( $applied == $self->amount ) {
 439     $dbh->rollback if $oldAutoCommit;
 440     return 'Error applying '. $self->_app_source_name. ' of $'. $self->amount.
 441            ' to line items - only $'. $applied. ' was applied.';
 442   }
 443
 444   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 445   '';
 446
 447 }
 448
 449 =item lineitem_applications
 450
 451 Returns all the specific line item applications for this invoice application.
 452
 453 =cut
 454
 455 sub lineitem_applications {
 456   my $self = shift;
 457   my $primary_key = dbdef->table($self->table)->primary_key;
 458   qsearch({
 459     'table'   => $self->lineitem_breakdown_table,
 460     'hashref' => { $primary_key => $self->$primary_key() },
 461   });
 462
 463 }
 464
 465 =item cust_bill
 466
 467 Returns the invoice (see L<FS::cust_bill>)
 468
 469 =cut
 470
 471 sub cust_bill {
 472   my $self = shift;
 473   qsearchs( 'cust_bill', { 'invnum' => $self->invnum } );
 474 }
 475
 476 =item applied_to_invoice
 477
 478 Returns a string representing the invoice (see L<FS::cust_bill>), for example:
 479 "applied to Invoice #54 (3/20/2008)"
 480
 481 =cut
 482
 483 sub applied_to_invoice {
 484   my $self = shift;
 485   'applied to '. $self->cust_bill->invnum_date_pretty;
 486 }
 487
 488 =item lineitem_breakdown_table
 489
 490 =cut
 491
 492 sub lineitem_breakdown_table {
 493   my $self = shift;
 494   $self->_load_table($self->_app_lineitem_breakdown_table);
 495 }
 496
 497 sub _load_table {
 498   my( $self, $table ) = @_;
 499   eval "use FS::$table";
 500   die $@ if $@;
 501   $table;
 502 }
 503
 504 =back
 505
 506 =head1 BUGS
 507
 508 =head1 SEE ALSO
 509
 510 L<FS::cust_bill_pay> and L<FS::cust_bill_pay_pkg>,
 511 L<FS::cust_credit_bill> and L<FS::cust_credit_bill_pkg>
 512
 513 =cut
 514
 515 1;
 516