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