FS/FS/cust_bill_ApplicationCommon.pm

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