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