1 package FS::cust_bill_ApplicationCommon;
4 use vars qw( @ISA $DEBUG $me $skip_apply_to_lineitems_hack );
5 use List::Util qw(min);
6 use FS::Schema qw( dbdef );
7 use FS::Record qw( qsearch qsearchs dbh );
9 @ISA = qw( FS::Record );
12 $me = '[FS::cust_bill_ApplicationCommon]';
14 $skip_apply_to_lineitems_hack = 0;
18 FS::cust_bill_ApplicationCommon - Base class for bill application classes
22 use FS::cust_bill_ApplicationCommon;
24 @ISA = qw( FS::cust_bill_ApplicationCommon );
26 sub _app_source_name { 'payment'; }
27 sub _app_source_table { 'cust_pay'; }
28 sub _app_lineitem_breakdown_table { 'cust_bill_pay_pkg'; }
32 FS::cust_bill_ApplicationCommon is intended as a base class for classes which
33 represent application of things to invoices, currently payments
34 (see L<FS::cust_bill_pay>) or credits (see L<FS::cust_credit_bill>).
47 local $SIG{HUP} = 'IGNORE';
48 local $SIG{INT} = 'IGNORE';
49 local $SIG{QUIT} = 'IGNORE';
50 local $SIG{TERM} = 'IGNORE';
51 local $SIG{TSTP} = 'IGNORE';
52 local $SIG{PIPE} = 'IGNORE';
54 my $oldAutoCommit = $FS::UID::AutoCommit;
55 local $FS::UID::AutoCommit = 0;
58 my $error = $self->SUPER::insert(@_)
59 || $self->apply_to_lineitems(@_);
61 $dbh->rollback if $oldAutoCommit;
65 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
78 local $SIG{HUP} = 'IGNORE';
79 local $SIG{INT} = 'IGNORE';
80 local $SIG{QUIT} = 'IGNORE';
81 local $SIG{TERM} = 'IGNORE';
82 local $SIG{TSTP} = 'IGNORE';
83 local $SIG{PIPE} = 'IGNORE';
85 my $oldAutoCommit = $FS::UID::AutoCommit;
86 local $FS::UID::AutoCommit = 0;
89 foreach my $app ( $self->lineitem_applications ) {
90 my $error = $app->delete;
92 $dbh->rollback if $oldAutoCommit;
97 my $error = $self->SUPER::delete(@_);
99 $dbh->rollback if $oldAutoCommit;
103 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
109 =item apply_to_lineitems
111 Auto-applies this invoice application to specific line items, if possible.
115 sub calculate_applications {
116 my( $self, %options ) = @_;
118 return '' if $skip_apply_to_lineitems_hack;
122 my $conf = new FS::Conf;
124 my @open = $self->cust_bill->open_cust_bill_pkg; #FOR UPDATE...?
126 if ( exists($options{subitems}) ) {
129 $open{$_->billpkgnum} = $i++ foreach @open;
131 foreach my $listref ( @{$options{subitems}} ) {
132 my ($billpkgnum, $itemamount, $taxlocationnum) = @$listref;
133 return "Can't apply a ". $self->_app_source_name. ' of $'. $listref->[1].
134 " to line item $billpkgnum which is not open"
135 unless exists($open{$billpkgnum});
136 my $itemindex = $open{$billpkgnum};
138 if ($taxlocationnum) {
139 %taxhash = map { ($_->primary_key => $_->get($_->primary_key)) }
140 grep { $_->get($_->primary_key) == $taxlocationnum }
141 $open[$itemindex]->cust_bill_pkg_tax_Xlocation;
143 return "No tax line item with a key value of $taxlocationnum exists"
144 unless scalar(%taxhash);
146 push @apply, [ $open[$itemindex], $itemamount, { %taxhash } ];
151 @open = grep { $_->pkgnum == $self->pkgnum } @open
152 if $conf->exists('pkg-balances') && $self->pkgnum;
153 warn "$me ". scalar(@open). " open line items for invoice ".
154 $self->cust_bill->invnum. ": ". join(', ', @open). "\n"
158 $total += $_->owed_setup if $_->setup;
159 $total += $_->owed_recur if $_->recur;
161 $total = sprintf('%.2f', $total);
163 if ( $self->amount > $total ) {
164 return "Can't apply a ". $self->_app_source_name. ' of $'. $self->amount.
165 " greater than the remaining owed on line items (\$$total)";
169 # - one lineitem (a simple special case of:)
170 # - amount is for whole invoice (well, all of remaining lineitem links)
171 if ( $self->amount == $total ) {
173 warn "$me application amount covers remaining balance of invoice in full;".
174 "applying to those lineitems\n"
177 #@apply = map { [ $_, $_->amount ]; } @open;
178 @apply = map { [ $_, $_->owed_setup + 0 || $_->owed_recur + 0 ]; } @open;
182 #slightly magic case:
183 # - amount exactly and uniquely matches a single open lineitem
184 # (you must be trying to pay or credit that item, then)
186 my @same = grep { $_->owed_setup == $self->amount
187 || $_->owed_recur == $self->amount
190 if ( scalar(@same) == 1 ) {
191 warn "$me application amount exactly and uniquely matches one lineitem;".
192 " applying to that lineitem\n"
194 @apply = map { [ $_, $self->amount ]; } @same
201 warn "$me applying amount based on package weights\n"
205 # - apply based on weights...
207 my $weight_col = $self->_app_part_pkg_weight_column;
208 my @openweight = map {
210 my $cust_pkg = $open->cust_pkg;
213 ? ( $cust_pkg->part_pkg->$weight_col() || 0 )
214 : -1; #default or per-tax weight?
220 my @weights = sort { $b <=> $a } # highest weight first
221 grep { ! $saw{$_}++ } # want a list of unique weights
225 my $remaining_amount = $self->amount;
226 foreach my $weight ( @weights ) {
228 #i hate it when my schwartz gets tangled
229 my @items = map { $_->[0] } grep { $weight == $_->[1] } @openweight;
232 foreach my $item (@items) { $itemtotal += $item->owed_setup + 0 || $item->owed_recur + 0; }
233 my $applytotal = min( $itemtotal, $remaining_amount );
234 $remaining_amount -= $applytotal;
236 warn "$me applying $applytotal ($remaining_amount remaining)".
237 " to ". scalar(@items). " lineitems with weight $weight\n"
240 #if some items are less than applytotal/num_items, then apply then in full
245 #no, not sprintf("%.2f",
246 # we want this rounded DOWN for purposes of checking for line items
247 # less than it, we don't want .66666 becoming .67 and causing this
248 # to trigger when it shouldn't
249 my $applyeach = int( 100 * $applytotal / scalar(@items) ) / 100;
252 foreach my $item ( @items ) {
253 my $itemamount = $item->owed_setup + 0 || $item->owed_recur + 0;
254 if ( $itemamount < $applyeach ) {
255 warn "$me applying full $itemamount".
256 " to small line item (cust_bill_pkg ". $item->billpkgnum. ")\n"
258 push @apply, [ $item, $itemamount ];
259 $applytotal -= $itemamount;
262 push @newitems, $item;
267 } while ( $lessflag );
269 #and now that we've fallen out of the loop, distribute the rest equally...
271 # should cust_bill_pay_pkg and cust_credit_bill_pkg amount columns
272 # become real instead of numeric(10,2) ??? no..
273 my $applyeach = sprintf("%.2f", $applytotal / scalar(@items) );
275 my @equi_apply = map { [ $_, $applyeach ] } @items;
277 # or should we futz with pennies instead? yes, bah!
279 sprintf('%.0f', 100 * ( $applytotal - $applyeach * scalar(@items) ) );
280 $diff = 0 if $diff eq '-0'; #yay ieee fp
281 if ( abs($diff) > scalar(@items) ) {
282 #we must have done something really wrong, the difference is more than
284 return 'Error distributing pennies applying '. $self->_app_source_name.
285 " - can't distribute difference of $diff pennies".
286 ' among '. scalar(@items). ' line items';
289 warn "$me futzing with $diff pennies difference\n"
293 while ( $diff != 0 && $futz < scalar(@equi_apply) ) {
295 $equi_apply[$futz++]->[1] += .01;
297 } elsif ( $diff < 0 ) {
298 $equi_apply[$futz++]->[1] -= .01;
301 die "guru exception #5 (in fortran tongue the answer)";
305 if ( sprintf('%.0f', $diff ) ) {
306 return "couldn't futz with pennies enough: still $diff left";
310 warn "$me applying ". $_->[1].
311 " to line item (cust_bill_pkg ". $_->[0]->billpkgnum. ")\n"
316 push @apply, @equi_apply;
318 #$remaining_amount -= $applytotal;
319 last unless $remaining_amount;
325 # break down lineitem amounts for tax lines
326 # could expand @open above, instead, for a slightly different magic effect
328 foreach my $apply ( @apply ) {
329 my @sub_lines = $apply->[0]->cust_bill_pkg_tax_Xlocation;
330 my $amount = $apply->[1];
331 warn "applying ". $apply->[1]. " to ". $apply->[0]->desc
334 foreach my $subline ( @sub_lines ) {
335 my $owed = $subline->owed;
336 push @result, [ $apply->[0],
337 sprintf('%.2f', min($amount, $owed) ),
338 { $subline->primary_key => $subline->get($subline->primary_key) },
341 $amount = 0 if $amount < 0;
345 push @result, [ $apply->[0], sprintf('%.2f', $amount), {} ];
353 sub apply_to_lineitems {
355 my( $self, %options ) = @_;
357 return '' if $skip_apply_to_lineitems_hack;
361 my $conf = new FS::Conf;
363 local $SIG{HUP} = 'IGNORE';
364 local $SIG{INT} = 'IGNORE';
365 local $SIG{QUIT} = 'IGNORE';
366 local $SIG{TERM} = 'IGNORE';
367 local $SIG{TSTP} = 'IGNORE';
368 local $SIG{PIPE} = 'IGNORE';
370 my $oldAutoCommit = $FS::UID::AutoCommit;
371 local $FS::UID::AutoCommit = 0;
374 my $listref_or_error = $self->calculate_applications(%options);
375 unless (ref($listref_or_error)) {
376 $dbh->rollback if $oldAutoCommit;
377 return $listref_or_error;
380 my @apply = @$listref_or_error;
382 # do the applicaiton(s)
383 my $table = $self->lineitem_breakdown_table;
384 my $source_key = dbdef->table($self->table)->primary_key;
386 foreach my $apply ( @apply ) {
387 my ( $cust_bill_pkg, $amount, $taxcreditref ) = @$apply;
389 my $application = "FS::$table"->new( {
390 $source_key => $self->$source_key(),
391 'billpkgnum' => $cust_bill_pkg->billpkgnum,
392 'amount' => sprintf('%.2f', $amount),
393 'setuprecur' => ( $cust_bill_pkg->setup > 0 ? 'setup' : 'recur' ),
394 'sdate' => $cust_bill_pkg->sdate,
395 'edate' => $cust_bill_pkg->edate,
398 my $error = $application->insert(%options);
400 $dbh->rollback if $oldAutoCommit;
405 #everything should always be applied to line items in full now... sanity check
406 $applied = sprintf('%.2f', $applied);
407 unless ( $applied == $self->amount ) {
408 $dbh->rollback if $oldAutoCommit;
409 return 'Error applying '. $self->_app_source_name. ' of $'. $self->amount.
410 ' to line items - only $'. $applied. ' was applied.';
413 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
418 =item lineitem_applications
420 Returns all the specific line item applications for this invoice application.
424 sub lineitem_applications {
426 my $primary_key = dbdef->table($self->table)->primary_key;
428 'table' => $self->lineitem_breakdown_table,
429 'hashref' => { $primary_key => $self->$primary_key() },
436 Returns the invoice (see L<FS::cust_bill>)
442 qsearchs( 'cust_bill', { 'invnum' => $self->invnum } );
445 =item applied_to_invoice
447 Returns a string representing the invoice (see L<FS::cust_bill>), for example:
448 "applied to Invoice #54 (3/20/2008)"
452 sub applied_to_invoice {
454 'applied to '. $self->cust_bill->invnum_date_pretty;
457 =item lineitem_breakdown_table
461 sub lineitem_breakdown_table {
463 $self->_load_table($self->_app_lineitem_breakdown_table);
467 my( $self, $table ) = @_;
468 eval "use FS::$table";
479 L<FS::cust_bill_pay> and L<FS::cust_bill_pay_pkg>,
480 L<FS::cust_credit_bill> and L<FS::cust_credit_bill_pkg>