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