X-Git-Url: http://git.freeside.biz/gitweb/?a=blobdiff_plain;f=FS%2FFS%2Fcust_bill_ApplicationCommon.pm;h=195fa8d0f1fe56831ea3b591076c7905cffd4e2e;hb=6af586392aef95c6fe35326ced1a9073b068a78c;hp=fa5f53b87b8c18f3156c5582e2b2594a0bbf0039;hpb=abb4b384799691f8eb1f77512823d66487366208;p=freeside.git diff --git a/FS/FS/cust_bill_ApplicationCommon.pm b/FS/FS/cust_bill_ApplicationCommon.pm index fa5f53b87..195fa8d0f 100644 --- a/FS/FS/cust_bill_ApplicationCommon.pm +++ b/FS/FS/cust_bill_ApplicationCommon.pm @@ -1,13 +1,15 @@ package FS::cust_bill_ApplicationCommon; use strict; -use vars qw( @ISA $DEBUG ); +use vars qw( @ISA $DEBUG $me ); +use List::Util qw(min); use FS::Schema qw( dbdef ); use FS::Record qw( qsearch qsearchs dbh ); @ISA = qw( FS::Record ); -$DEBUG = 1; +$DEBUG = 0; +$me = '[FS::cust_bill_ApplicationCommon]'; =head1 NAME @@ -123,7 +125,7 @@ sub apply_to_lineitems { my $dbh = dbh; my @open = $self->cust_bill->open_cust_bill_pkg; #FOR UPDATE...? - warn scalar(@open). " open line items for invoice ". + warn "$me ". scalar(@open). " open line items for invoice ". $self->cust_bill->invnum. "\n" if $DEBUG; my $total = 0; @@ -131,7 +133,7 @@ sub apply_to_lineitems { $total = sprintf('%.2f', $total); if ( $self->amount > $total ) { - dbh->rollback if $oldAutoCommit; + $dbh->rollback if $oldAutoCommit; return "Can't apply a ". $self->_app_source_name. ' of $'. $self->amount. " greater than the remaining owed on line items (\$$total)"; } @@ -141,6 +143,10 @@ sub apply_to_lineitems { # - amount is for whole invoice (well, all of remaining lineitem links) if ( $self->amount == $total ) { + warn "$me application amount covers remaining balance of invoice in full;". + "applying to those lineitems\n" + if $DEBUG; + #@apply = map { [ $_, $_->amount ]; } @open; @apply = map { [ $_, $_->setup || $_->recur ]; } @open; @@ -154,33 +160,166 @@ sub apply_to_lineitems { || $_->recur == $self->amount } @open; - @apply = map { [ $_, $self->amount ]; } @same - if scalar(@same) == 1; + if ( scalar(@same) == 1 ) { + warn "$me application amount exactly and uniquely matches one lineitem;". + " applying to that lineitem\n" + if $DEBUG; + @apply = map { [ $_, $self->amount ]; } @same + } } - #and the rest: - # - leave unapplied, for now - # - eventually, auto-apply? sequentially? pro-rated against total remaining? + unless ( @apply ) { + + warn "$me applying amount based on package weights\n" + if $DEBUG; + + #and the rest: + # - apply based on weights... + + my $weight_col = $self->_app_part_pkg_weight_column; + my @openweight = map { [ $_, ($_->cust_pkg->part_pkg->$weight_col()||0) ] } + @open; + + my %saw = (); + my @weights = sort { $b <=> $a } # highest weight first + grep { ! $saw{$_}++ } # want a list of unique weights + map { $_->[1] } + @openweight; + + my $remaining_amount = $self->amount; + foreach my $weight ( @weights ) { + + #i hate it when my schwartz gets tangled + my @items = map { $_->[0] } grep { $weight == $_->[1] } @openweight; + + my $itemtotal = 0; + foreach my $item (@items) { $itemtotal += $item->setup || $item->recur; } + my $applytotal = min( $itemtotal, $remaining_amount ); + $remaining_amount -= $applytotal; + + warn "$me applying $applytotal ($remaining_amount remaining)". + " to ". scalar(@items). " lineitems with weight $weight\n" + if $DEBUG; + + #if some items are less than applytotal/num_items, then apply then in full + my $lessflag; + do { + $lessflag = 0; + + #no, not sprintf("%.2f", + # we want this rounded DOWN for purposes of checking for line items + # less than it, we don't want .66666 becoming .67 and causing this + # to trigger when it shouldn't + my $applyeach = int( 100 * $applytotal / scalar(@items) ) / 100; + + my @newitems = (); + foreach my $item ( @items ) { + my $itemamount = $item->setup || $item->recur; + if ( $itemamount < $applyeach ) { + warn "$me applying full $itemamount". + " to small line item (cust_bill_pkg ". $item->billpkgnum. ")\n" + if $DEBUG; + push @apply, [ $item, $itemamount ]; + $applytotal -= $itemamount; + $lessflag=1; + } else { + push @newitems, $item; + } + } + @items = @newitems; + + } while ( $lessflag ); + + #and now that we've fallen out of the loop, distribute the rest equally... + + # should cust_bill_pay_pkg and cust_credit_bill_pkg amount columns + # become real instead of numeric(10,2) ??? no.. + my $applyeach = sprintf("%.2f", $applytotal / scalar(@items) ); + + my @equi_apply = map { [ $_, $applyeach ] } @items; + + # or should we futz with pennies instead? yes, bah! + my $diff = + sprintf('%.0f', 100 * ( $applytotal - $applyeach * scalar(@items) ) ); + $diff = 0 if $diff eq '-0'; #yay ieee fp + if ( abs($diff) > scalar(@items) ) { + #we must have done something really wrong, the difference is more than + #a penny an item + $dbh->rollback if $oldAutoCommit; + return 'Error distributing pennies applying '. $self->_app_source_name. + " - can't distribute difference of $diff pennies". + ' among '. scalar(@items). ' line items'; + } + + warn "$me futzing with $diff pennies difference\n" + if $DEBUG && $diff; + + my $futz = 0; + while ( $diff != 0 && $futz < scalar(@equi_apply) ) { + if ( $diff > 0 ) { + $equi_apply[$futz++]->[1] += .01; + $diff -= 1; + } elsif ( $diff < 0 ) { + $equi_apply[$futz++]->[1] -= .01; + $diff += 1; + } else { + die "guru exception #5 (in fortran tongue the answer)"; + } + } + + if ( sprintf('%.0f', $diff ) ) { + $dbh->rollback if $oldAutoCommit; + return "couldn't futz with pennies enough: still $diff left"; + } + + if ( $DEBUG ) { + warn "$me applying ". $_->[1]. + " to line item (cust_bill_pkg ". $_->[0]->billpkgnum. ")\n" + foreach @equi_apply; + } + + + push @apply, @equi_apply; + + #$remaining_amount -= $applytotal; + last unless $remaining_amount; + + } + + } # do the applicaiton(s) my $table = $self->lineitem_breakdown_table; my $source_key = dbdef->table($self->table)->primary_key; + my $applied = 0; foreach my $apply ( @apply ) { my ( $cust_bill_pkg, $amount ) = @$apply; + $applied += $amount; my $application = "FS::$table"->new( { $source_key => $self->$source_key(), 'billpkgnum' => $cust_bill_pkg->billpkgnum, - 'amount' => $amount, + 'amount' => sprintf('%.2f', $amount), 'setuprecur' => ( $cust_bill_pkg->setup > 0 ? 'setup' : 'recur' ), + 'sdate' => $cust_bill_pkg->sdate, + 'edate' => $cust_bill_pkg->edate, }); my $error = $application->insert; if ( $error ) { - dbh->rollbck if $oldAutoCommit; + $dbh->rollback if $oldAutoCommit; return $error; } } + #everything should always be applied to line items in full now... sanity check + $applied = sprintf('%.2f', $applied); + unless ( $applied == $self->amount ) { + $dbh->rollback if $oldAutoCommit; + return 'Error applying '. $self->_app_source_name. ' of $'. $self->amount. + ' to line items - only $'. $applied. ' was applied.'; + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; ''; }