package FS::cust_bill_ApplicationCommon; use strict; use vars qw( @ISA $DEBUG $me $skip_apply_to_lineitems_hack $date_format ); use List::Util qw(min); use Date::Format; use FS::Schema qw( dbdef ); use FS::UID; 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; FS::UID->install_callback( sub { my $conf = new FS::Conf; $date_format = $conf->config('date_format') || '%x'; #/YY } ); =head1 NAME FS::cust_bill_ApplicationCommon - Base class for bill application classes =head1 SYNOPSIS use FS::cust_bill_ApplicationCommon; @ISA = qw( FS::cust_bill_ApplicationCommon ); sub _app_source_name { 'payment'; } sub _app_source_table { 'cust_pay'; } sub _app_lineitem_breakdown_table { 'cust_bill_pay_pkg'; } =head1 DESCRIPTION FS::cust_bill_ApplicationCommon is intended as a base class for classes which represent application of things to invoices, currently payments (see L) or credits (see L). =head1 METHODS =over 4 =item insert =cut sub insert { my $self = shift; 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 $error = $self->SUPER::insert(@_) || $self->apply_to_lineitems(@_); if ( $error ) { $dbh->rollback if $oldAutoCommit; return $error; } $dbh->commit or die $dbh->errstr if $oldAutoCommit; ''; } =item delete =cut sub delete { my $self = shift; 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; foreach my $app ( $self->lineitem_applications ) { my $error = $app->delete; if ( $error ) { $dbh->rollback if $oldAutoCommit; return $error; } } my $error = $self->SUPER::delete(@_); if ( $error ) { $dbh->rollback if $oldAutoCommit; return $error; } $dbh->commit or die $dbh->errstr if $oldAutoCommit; ''; } =item apply_to_lineitems Auto-applies this invoice application to specific line items, if possible. =cut sub calculate_applications { my( $self, %options ) = @_; return '' if $skip_apply_to_lineitems_hack; my @apply = (); 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. ": ". join(', ', @open). "\n" if $DEBUG; my $total = 0; foreach (@open) { $total += $_->owed_setup if $_->setup; $total += $_->owed_recur if $_->recur; } $total = sprintf('%.2f', $total); if ( $self->amount > $total ) { return "Can't apply a ". $self->_app_source_name. ' of $'. $self->amount. " greater than the remaining owed on line items (\$$total)"; } #easy cases: # - one lineitem (a simple special case of:) # - 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 { [ $_, $_->owed_setup + 0 || $_->owed_recur + 0 ]; } @open; @apply = map { [ $_, $_->setup ? $_->owed_setup : $_->owed_recur ]; } @open; } else { #slightly magic case: # - amount exactly and uniquely matches a single open lineitem # (you must be trying to pay or credit that item, then) my @same = grep { ( $_->setup && $_->owed_setup == $self->amount ) || ( $_->recur && $_->owed_recur == $self->amount ) } @open; 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 } } 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 { 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] } @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->owed_setup if $item->setup; $itemtotal += $item->owed_recur if $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->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; $lessflag=1; } 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; } #$remaining_amount -= $applytotal; last unless $remaining_amount; } } # break down lineitem amounts for tax lines # could expand @open above, instead, for a slightly different magic effect my @result = (); foreach my $apply ( @apply ) { # $apply = [ FS::cust_bill_pkg_tax_location record, amount ] 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 is "billpkgtaxlocationnum" # or "billpkgtaxratelocationnum" # This is the ONLY place either of those fields will # be set. { $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), {} ]; } } \@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, $taxcreditref ) = @$apply; $applied += $amount; my $application = "FS::$table"->new( { $source_key => $self->$source_key(), 'billpkgnum' => $cust_bill_pkg->billpkgnum, 'amount' => sprintf('%.2f', $amount), 'setuprecur' => ( $cust_bill_pkg->setup > 0 ? 'setup' : 'recur' ), 'sdate' => $cust_bill_pkg->sdate, 'edate' => $cust_bill_pkg->edate, %$taxcreditref, }); 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 ) { $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; ''; } =item lineitem_applications Returns all the specific line item applications for this invoice application. =cut sub lineitem_applications { my $self = shift; my $primary_key = dbdef->table($self->table)->primary_key; qsearch({ 'table' => $self->lineitem_breakdown_table, 'hashref' => { $primary_key => $self->$primary_key() }, }); } =item cust_bill Returns the invoice (see L) =cut sub cust_bill { my $self = shift; 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)" Intended for back-end context, with regard to translation and date formatting. =cut sub applied_to_invoice { my $self = shift; my $string = 'applied to '. $self->cust_bill->invnum_date_pretty; #show application date if over 24 hours after (or before) payment/credit date $string .= ' on '. $self->_date_pretty if abs( $self->_date - $self->_app_source_object->_date ) > 86400; $string; } =item _app_source_object =cut sub _app_source_object { my $self = shift; my $source_table = $self->_app_source_table; $self->$source_table(); } =item _date_pretty Returns a string with the application date, for example: "3/20/2008" =cut sub _date_pretty { my $self = shift; time2str($date_format, $self->_date); } =item lineitem_breakdown_table =cut sub lineitem_breakdown_table { my $self = shift; $self->_load_table($self->_app_lineitem_breakdown_table); } sub _load_table { my( $self, $table ) = @_; eval "use FS::$table"; die $@ if $@; $table; } =back =head1 BUGS =head1 SEE ALSO L and L, L and L =cut 1;