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