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 apply_to_lineitems {
 121   #my $self = shift;
 122   my( $self, %options ) = @_;
 123
 124   return '' if $skip_apply_to_lineitems_hack;
 125
 126   my @apply = ();
 127
 128   my $conf = new FS::Conf;
 129
 130   local $SIG{HUP} = 'IGNORE';
 131   local $SIG{INT} = 'IGNORE';
 132   local $SIG{QUIT} = 'IGNORE';
 133   local $SIG{TERM} = 'IGNORE';
 134   local $SIG{TSTP} = 'IGNORE';
 135   local $SIG{PIPE} = 'IGNORE';
 136
 137   my $oldAutoCommit = $FS::UID::AutoCommit;
 138   local $FS::UID::AutoCommit = 0;
 139   my $dbh = dbh;
 140
 141   my @open = $self->cust_bill->open_cust_bill_pkg; #FOR UPDATE...?
 142   @open = grep { $_->pkgnum == $self->pkgnum } @open
 143     if $conf->exists('pkg-balances') && $self->pkgnum;
 144   warn "$me ". scalar(@open). " open line items for invoice ".
 145        $self->cust_bill->invnum. ": ". join(', ', @open). "\n"
 146     if $DEBUG;
 147   my $total = 0;
 148   $total += $_->setup + $_->recur foreach @open;
 149   $total = sprintf('%.2f', $total);
 150
 151   if ( $self->amount > $total ) {
 152     $dbh->rollback if $oldAutoCommit;
 153     return "Can't apply a ". $self->_app_source_name. ' of $'. $self->amount.
 154            " greater than the remaining owed on line items (\$$total)";
 155   }
 156
 157   #easy cases:
 158   # - one lineitem (a simple special case of:)
 159   # - amount is for whole invoice (well, all of remaining lineitem links)
 160   if ( $self->amount == $total ) {
 161
 162     warn "$me application amount covers remaining balance of invoice in full;".
 163          "applying to those lineitems\n"
 164       if $DEBUG;
 165
 166     #@apply = map { [ $_, $_->amount ]; } @open;
 167     @apply = map { [ $_, $_->setup || $_->recur ]; } @open;
 168
 169   } else {
 170
 171     #slightly magic case:
 172     # - amount exactly and uniquely matches a single open lineitem
 173     #   (you must be trying to pay or credit that item, then)
 174
 175     my @same = grep {    $_->setup == $self->amount
 176                       || $_->recur == $self->amount
 177                     }
 178                     @open;
 179     if ( scalar(@same) == 1 ) {
 180       warn "$me application amount exactly and uniquely matches one lineitem;".
 181            " applying to that lineitem\n"
 182         if $DEBUG;
 183       @apply = map { [ $_, $self->amount ]; } @same
 184     }
 185
 186   }
 187
 188   unless ( @apply ) {
 189
 190     warn "$me applying amount based on package weights\n"
 191       if $DEBUG;
 192
 193     #and the rest:
 194     # - apply based on weights...
 195
 196     my $weight_col = $self->_app_part_pkg_weight_column;
 197     my @openweight = map {
 198                            my $open = $_;
 199                            my $cust_pkg = $open->cust_pkg;
 200                            my $weight =
 201                              $cust_pkg
 202                                ? ( $cust_pkg->part_pkg->$weight_col() || 0 )
 203                                : 0; #default or per-tax weight?
 204                            [ $open, $weight ]
 205                          }
 206                          @open;
 207
 208     my %saw = ();
 209     my @weights = sort { $b <=> $a }     # highest weight first
 210                   grep { ! $saw{$_}++ }  # want a list of unique weights
 211                   map  { $_->[1] }
 212                        @openweight;
 213
 214     my $remaining_amount = $self->amount;
 215     foreach my $weight ( @weights ) {
 216
 217       #i hate it when my schwartz gets tangled
 218       my @items = map { $_->[0] } grep { $weight == $_->[1] } @openweight;
 219
 220       my $itemtotal = 0;
 221       foreach my $item (@items) { $itemtotal += $item->setup || $item->recur; }
 222       my $applytotal = min( $itemtotal, $remaining_amount );
 223       $remaining_amount -= $applytotal;
 224
 225       warn "$me applying $applytotal ($remaining_amount remaining)".
 226            " to ". scalar(@items). " lineitems with weight $weight\n"
 227         if $DEBUG;
 228
 229       #if some items are less than applytotal/num_items, then apply then in full
 230       my $lessflag;
 231       do {
 232         $lessflag = 0;
 233
 234         #no, not sprintf("%.2f",
 235         # we want this rounded DOWN for purposes of checking for line items
 236         # less than it, we don't want .66666 becoming .67 and causing this
 237         # to trigger when it shouldn't
 238         my $applyeach = int( 100 * $applytotal / scalar(@items) ) / 100;
 239
 240         my @newitems = ();
 241         foreach my $item ( @items ) {
 242           my $itemamount = $item->setup || $item->recur;
 243           if ( $itemamount < $applyeach ) {
 244             warn "$me applying full $itemamount".
 245                  " to small line item (cust_bill_pkg ". $item->billpkgnum. ")\n"
 246               if $DEBUG;
 247             push @apply, [ $item, $itemamount ];
 248             $applytotal -= $itemamount;
 249             $lessflag=1;
 250           } else {
 251             push @newitems, $item;
 252           }
 253         }
 254         @items = @newitems;
 255
 256       } while ( $lessflag && @items );
 257
 258       if ( @items ) {
 259
 260         #and now that we've fallen out of the loop, distribute the rest equally
 261
 262         # should cust_bill_pay_pkg and cust_credit_bill_pkg amount columns
 263         # become real instead of numeric(10,2) ???  no..
 264         my $applyeach = sprintf("%.2f", $applytotal / scalar(@items) );
 265
 266         my @equi_apply = map { [ $_, $applyeach ] } @items;
 267
 268         # or should we futz with pennies instead?  yes, bah!
 269         my $diff =
 270           sprintf('%.0f', 100 * ( $applytotal - $applyeach * scalar(@items) ) );
 271         $diff = 0 if $diff eq '-0'; #yay ieee fp
 272         if ( abs($diff) > scalar(@items) ) {
 273           #we must have done something really wrong, the difference is more than
 274           #a penny an item
 275           $dbh->rollback if $oldAutoCommit;
 276           return 'Error distributing pennies applying '.$self->_app_source_name.
 277                  " - can't distribute difference of $diff pennies".
 278                  ' among '. scalar(@items). ' line items';
 279         }
 280
 281         warn "$me futzing with $diff pennies difference\n"
 282           if $DEBUG && $diff;
 283
 284         my $futz = 0;
 285         while ( $diff != 0 && $futz < scalar(@equi_apply) ) {
 286           if ( $diff > 0 ) {
 287             $equi_apply[$futz++]->[1] += .01;
 288             $diff -= 1;
 289           } elsif ( $diff < 0 ) {
 290             $equi_apply[$futz++]->[1] -= .01;
 291             $diff += 1;
 292           } else {
 293             die "guru exception #5 (in fortran tongue the answer)";
 294           }
 295         }
 296
 297         if ( sprintf('%.0f', $diff ) ) {
 298           $dbh->rollback if $oldAutoCommit;
 299           return "couldn't futz with pennies enough: still $diff left";
 300         }
 301
 302         if ( $DEBUG ) {
 303           warn "$me applying ". $_->[1].
 304                " to line item (cust_bill_pkg ". $_->[0]->billpkgnum. ")\n"
 305             foreach @equi_apply;
 306         }
 307         push @apply, @equi_apply;
 308
 309       }
 310
 311       #$remaining_amount -= $applytotal;
 312       last unless $remaining_amount;
 313
 314     }
 315
 316   }
 317
 318   # do the applicaiton(s)
 319   my $table = $self->lineitem_breakdown_table;
 320   my $source_key = dbdef->table($self->table)->primary_key;
 321   my $applied = 0;
 322   foreach my $apply ( @apply ) {
 323     my ( $cust_bill_pkg, $amount ) = @$apply;
 324     $applied += $amount;
 325     my $application = "FS::$table"->new( {
 326       $source_key  => $self->$source_key(),
 327       'billpkgnum' => $cust_bill_pkg->billpkgnum,
 328       'amount'     => sprintf('%.2f', $amount),
 329       'setuprecur' => ( $cust_bill_pkg->setup > 0 ? 'setup' : 'recur' ),
 330       'sdate'      => $cust_bill_pkg->sdate,
 331       'edate'      => $cust_bill_pkg->edate,
 332     });
 333     my $error = $application->insert(%options);
 334     if ( $error ) {
 335       $dbh->rollback if $oldAutoCommit;
 336       return $error;
 337     }
 338
 339     # trigger export_insert_on_payment
 340     if ( $conf->exists('trigger_export_insert_on_payment')
 341       && $cust_bill_pkg->pkgnum > 0 )
 342     {
 343       if ( my $cust_pkg = $cust_bill_pkg->cust_pkg ) {
 344
 345         foreach my $cust_svc ( $cust_pkg->cust_svc ) {
 346           my $svc_x = $cust_svc->svc_x;
 347           my @part_export = grep { $_->can('export_insert_on_payment') }
 348                                  $cust_svc->part_svc->part_export;
 349
 350           foreach my $part_export ( $cust_svc->part_svc->part_export ) {
 351             $error = $part_export->_export_insert_on_payment($svc_x);
 352             if ( $error ) {
 353               $dbh->rollback if $oldAutoCommit;
 354               return $error;
 355             }
 356           }
 357         }
 358       }
 359     }
 360     # done trigger export_insert_on_payment
 361
 362   }
 363
 364   #everything should always be applied to line items in full now... sanity check
 365   $applied = sprintf('%.2f', $applied);
 366   unless ( $applied == $self->amount ) {
 367     $dbh->rollback if $oldAutoCommit;
 368     return 'Error applying '. $self->_app_source_name. ' of $'. $self->amount.
 369            ' to line items - only $'. $applied. ' was applied.';
 370   }
 371
 372   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 373   '';
 374
 375 }
 376
 377 =item lineitem_applications
 378
 379 Returns all the specific line item applications for this invoice application.
 380
 381 =cut
 382
 383 sub lineitem_applications {
 384   my $self = shift;
 385   my $primary_key = dbdef->table($self->table)->primary_key;
 386   qsearch({
 387     'table'   => $self->lineitem_breakdown_table,
 388     'hashref' => { $primary_key => $self->$primary_key() },
 389   });
 390
 391 }
 392
 393 =item cust_bill
 394
 395 Returns the invoice (see L<FS::cust_bill>)
 396
 397 =cut
 398
 399 sub cust_bill {
 400   my $self = shift;
 401   qsearchs( 'cust_bill', { 'invnum' => $self->invnum } );
 402 }
 403
 404 =item applied_to_invoice
 405
 406 Returns a string representing the invoice (see L<FS::cust_bill>), for example:
 407 "applied to Invoice #54 (3/20/2008)"
 408
 409 =cut
 410
 411 sub applied_to_invoice {
 412   my $self = shift;
 413   'applied to '. $self->cust_bill->invnum_date_pretty;
 414 }
 415
 416 =item lineitem_breakdown_table
 417
 418 =cut
 419
 420 sub lineitem_breakdown_table {
 421   my $self = shift;
 422   $self->_load_table($self->_app_lineitem_breakdown_table);
 423 }
 424
 425 sub _load_table {
 426   my( $self, $table ) = @_;
 427   eval "use FS::$table";
 428   die $@ if $@;
 429   $table;
 430 }
 431
 432 =back
 433
 434 =head1 BUGS
 435
 436 =head1 SEE ALSO
 437
 438 L<FS::cust_bill_pay> and L<FS::cust_bill_pay_pkg>,
 439 L<FS::cust_credit_bill> and L<FS::cust_credit_bill_pkg>
 440
 441 =cut
 442
 443 1;
 444