X-Git-Url: http://git.freeside.biz/gitweb/?p=freeside.git;a=blobdiff_plain;f=FS%2FFS%2Fcust_bill_ApplicationCommon.pm;h=cadb8a796673873f7e83b5692e997c0e21a7ec8d;hp=195fa8d0f1fe56831ea3b591076c7905cffd4e2e;hb=aed8ec35ccb9cdeb7ea0cb6ff2946f9d83d582f6;hpb=05686487551e26418c9b2d6b92ea0d89bb100082 diff --git a/FS/FS/cust_bill_ApplicationCommon.pm b/FS/FS/cust_bill_ApplicationCommon.pm index 195fa8d0f..cadb8a796 100644 --- a/FS/FS/cust_bill_ApplicationCommon.pm +++ b/FS/FS/cust_bill_ApplicationCommon.pm @@ -1,16 +1,23 @@ package FS::cust_bill_ApplicationCommon; use strict; -use vars qw( @ISA $DEBUG $me ); +use vars qw( @ISA $DEBUG $me $skip_apply_to_lineitems_hack ); use List::Util qw(min); use FS::Schema qw( dbdef ); use FS::Record qw( qsearch qsearchs dbh ); +use FS::cust_pkg; +use FS::cust_svc; +use FS::cust_bill_pkg; +use FS::part_svc; +use FS::part_export; @ISA = qw( FS::Record ); $DEBUG = 0; $me = '[FS::cust_bill_ApplicationCommon]'; +$skip_apply_to_lineitems_hack = 0; + =head1 NAME FS::cust_bill_ApplicationCommon - Base class for bill application classes @@ -33,6 +40,8 @@ represent application of things to invoices, currently payments =head1 METHODS +=over 4 + =item insert =cut @@ -52,7 +61,7 @@ sub insert { my $dbh = dbh; my $error = $self->SUPER::insert(@_) - || $self->apply_to_lineitems; + || $self->apply_to_lineitems(@_); if ( $error ) { $dbh->rollback if $oldAutoCommit; return $error; @@ -108,32 +117,55 @@ Auto-applies this invoice application to specific line items, if possible. =cut -sub apply_to_lineitems { - my $self = shift; +sub calculate_applications { + my( $self, %options ) = @_; - my @apply = (); + return '' if $skip_apply_to_lineitems_hack; - local $SIG{HUP} = 'IGNORE'; - local $SIG{INT} = 'IGNORE'; - local $SIG{QUIT} = 'IGNORE'; - local $SIG{TERM} = 'IGNORE'; - local $SIG{TSTP} = 'IGNORE'; - local $SIG{PIPE} = 'IGNORE'; + my @apply = (); - my $oldAutoCommit = $FS::UID::AutoCommit; - local $FS::UID::AutoCommit = 0; - my $dbh = dbh; + my $conf = new FS::Conf; my @open = $self->cust_bill->open_cust_bill_pkg; #FOR UPDATE...? + + if ( exists($options{subitems}) ) { + my $i = 0; + my %open = (); + $open{$_->billpkgnum} = $i++ foreach @open; + + foreach my $listref ( @{$options{subitems}} ) { + my ($billpkgnum, $itemamount, $taxlocationnum) = @$listref; + return "Can't apply a ". $self->_app_source_name. ' of $'. $listref->[1]. + " to line item $billpkgnum which is not open" + unless exists($open{$billpkgnum}); + my $itemindex = $open{$billpkgnum}; + my %taxhash = (); + if ($taxlocationnum) { + %taxhash = map { ($_->primary_key => $_->get($_->primary_key)) } + grep { $_->get($_->primary_key) == $taxlocationnum } + $open[$itemindex]->cust_bill_pkg_tax_Xlocation; + + return "No tax line item with a key value of $taxlocationnum exists" + unless scalar(%taxhash); + } + push @apply, [ $open[$itemindex], $itemamount, { %taxhash } ]; + } + return \@apply; + } + + @open = grep { $_->pkgnum == $self->pkgnum } @open + if $conf->exists('pkg-balances') && $self->pkgnum; warn "$me ". scalar(@open). " open line items for invoice ". - $self->cust_bill->invnum. "\n" + $self->cust_bill->invnum. ": ". join(', ', @open). "\n" if $DEBUG; my $total = 0; - $total += $_->setup + $_->recur foreach @open; + foreach (@open) { + $total += $_->owed_setup if $_->setup; + $total += $_->owed_recur if $_->recur; + } $total = sprintf('%.2f', $total); if ( $self->amount > $total ) { - $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)"; } @@ -148,7 +180,8 @@ sub apply_to_lineitems { if $DEBUG; #@apply = map { [ $_, $_->amount ]; } @open; - @apply = map { [ $_, $_->setup || $_->recur ]; } @open; + #@apply = map { [ $_, $_->owed_setup + 0 || $_->owed_recur + 0 ]; } @open; + @apply = map { [ $_, $_->setup ? $_->owed_setup : $_->owed_recur ]; } @open; } else { @@ -156,8 +189,8 @@ sub apply_to_lineitems { # - amount exactly and uniquely matches a single open lineitem # (you must be trying to pay or credit that item, then) - my @same = grep { $_->setup == $self->amount - || $_->recur == $self->amount + my @same = grep { ( $_->setup && $_->owed_setup == $self->amount ) + || ( $_->recur && $_->owed_recur == $self->amount ) } @open; if ( scalar(@same) == 1 ) { @@ -178,13 +211,21 @@ sub apply_to_lineitems { # - apply based on weights... my $weight_col = $self->_app_part_pkg_weight_column; - my @openweight = map { [ $_, ($_->cust_pkg->part_pkg->$weight_col()||0) ] } + my @openweight = map { + my $open = $_; + my $cust_pkg = $open->cust_pkg; + my $weight = + $cust_pkg + ? ( $cust_pkg->part_pkg->$weight_col() || 0 ) + : -1; #default or per-tax weight? + [ $open, $weight ] + } @open; my %saw = (); my @weights = sort { $b <=> $a } # highest weight first grep { ! $saw{$_}++ } # want a list of unique weights - map { $_->[1] } + map { $_->[1] } @openweight; my $remaining_amount = $self->amount; @@ -194,7 +235,10 @@ sub apply_to_lineitems { my @items = map { $_->[0] } grep { $weight == $_->[1] } @openweight; my $itemtotal = 0; - foreach my $item (@items) { $itemtotal += $item->setup || $item->recur; } + foreach my $item (@items) { + $itemtotal += $item->owed_setup if $item->setup; + $itemtotal += $item->owed_recur if $item->recur; + } my $applytotal = min( $itemtotal, $remaining_amount ); $remaining_amount -= $applytotal; @@ -205,96 +249,151 @@ sub apply_to_lineitems { #if some items are less than applytotal/num_items, then apply then in full my $lessflag; do { - $lessflag = 0; + $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 + #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; + my @newitems = (); + foreach my $item ( @items ) { + my $itemamount = $item->setup ? $item->owed_setup : $item->owed_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; + 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'; - } + } else { + push @newitems, $item; + } + } + @items = @newitems; + + } while ( $lessflag && @items ); + + if ( @items ) { + + #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 + 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 ) ) { + 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; - 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"; - } + #$remaining_amount -= $applytotal; + last unless $remaining_amount; - if ( $DEBUG ) { - warn "$me applying ". $_->[1]. - " to line item (cust_bill_pkg ". $_->[0]->billpkgnum. ")\n" - foreach @equi_apply; - } + } + } - push @apply, @equi_apply; + # break down lineitem amounts for tax lines + # could expand @open above, instead, for a slightly different magic effect + my @result = (); + foreach my $apply ( @apply ) { + my @sub_lines = $apply->[0]->cust_bill_pkg_tax_Xlocation; + my $amount = $apply->[1]; + warn "applying ". $apply->[1]. " to ". $apply->[0]->desc + if $DEBUG; + + foreach my $subline ( @sub_lines ) { + my $owed = $subline->owed; + push @result, [ $apply->[0], + sprintf('%.2f', min($amount, $owed) ), + { $subline->primary_key => $subline->get($subline->primary_key) }, + ]; + $amount -= $owed; + $amount = 0 if $amount < 0; + last unless $amount; + } + if ( $amount > 0 ) { + push @result, [ $apply->[0], sprintf('%.2f', $amount), {} ]; + } + } - #$remaining_amount -= $applytotal; - last unless $remaining_amount; + \@result; - } +} + +sub apply_to_lineitems { + #my $self = shift; + my( $self, %options ) = @_; + + return '' if $skip_apply_to_lineitems_hack; + + my $conf = new FS::Conf; + + local $SIG{HUP} = 'IGNORE'; + local $SIG{INT} = 'IGNORE'; + local $SIG{QUIT} = 'IGNORE'; + local $SIG{TERM} = 'IGNORE'; + local $SIG{TSTP} = 'IGNORE'; + local $SIG{PIPE} = 'IGNORE'; + my $oldAutoCommit = $FS::UID::AutoCommit; + local $FS::UID::AutoCommit = 0; + my $dbh = dbh; + + my $listref_or_error = $self->calculate_applications(%options); + unless (ref($listref_or_error)) { + $dbh->rollback if $oldAutoCommit; + return $listref_or_error; } + my @apply = @$listref_or_error; + # 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; + my ( $cust_bill_pkg, $amount, $taxcreditref ) = @$apply; $applied += $amount; my $application = "FS::$table"->new( { $source_key => $self->$source_key(), @@ -303,14 +402,50 @@ sub apply_to_lineitems { 'setuprecur' => ( $cust_bill_pkg->setup > 0 ? 'setup' : 'recur' ), 'sdate' => $cust_bill_pkg->sdate, 'edate' => $cust_bill_pkg->edate, + %$taxcreditref, }); - my $error = $application->insert; + my $error = $application->insert(%options); if ( $error ) { $dbh->rollback if $oldAutoCommit; return $error; } + + # trigger export_insert_on_payment + if ( $conf->exists('trigger_export_insert_on_payment') + && $cust_bill_pkg->pkgnum > 0 ) + { + if ( my $cust_pkg = $cust_bill_pkg->cust_pkg ) { + + foreach my $cust_svc ( $cust_pkg->cust_svc ) { + my $svc_x = $cust_svc->svc_x; + my @part_export = grep { $_->can('_export_insert_on_payment') } + $cust_svc->part_svc->part_export; + + foreach my $part_export ( @part_export ) { + $error = $part_export->_export_insert_on_payment($svc_x); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + } + } + } + } + # done trigger export_insert_on_payment + } + # unset promised payment date if there is one + my $cust_bill = $self->cust_bill; + if ( $cust_bill->promised_date and $cust_bill->owed <= 0 ) { + $cust_bill->set('promised_date', ''); + my $error = $cust_bill->replace; + if ( $error ) { + $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 ) { @@ -351,6 +486,18 @@ sub cust_bill { qsearchs( 'cust_bill', { 'invnum' => $self->invnum } ); } +=item applied_to_invoice + +Returns a string representing the invoice (see L), for example: +"applied to Invoice #54 (3/20/2008)" + +=cut + +sub applied_to_invoice { + my $self = shift; + 'applied to '. $self->cust_bill->invnum_date_pretty; +} + =item lineitem_breakdown_table =cut