1 package FS::cust_bill_ApplicationCommon;
4 use vars qw( @ISA $DEBUG $me $skip_apply_to_lineitems_hack $date_format );
5 use List::Util qw(min);
7 use FS::Schema qw( dbdef );
9 use FS::Record qw( qsearch qsearchs dbh );
12 use FS::cust_bill_pkg;
16 @ISA = qw( FS::Record );
19 $me = '[FS::cust_bill_ApplicationCommon]';
21 $skip_apply_to_lineitems_hack = 0;
23 FS::UID->install_callback( sub {
24 my $conf = new FS::Conf;
25 $date_format = $conf->config('date_format') || '%x'; #/YY
30 FS::cust_bill_ApplicationCommon - Base class for bill application classes
34 use FS::cust_bill_ApplicationCommon;
36 @ISA = qw( FS::cust_bill_ApplicationCommon );
38 sub _app_source_name { 'payment'; }
39 sub _app_source_table { 'cust_pay'; }
40 sub _app_lineitem_breakdown_table { 'cust_bill_pay_pkg'; }
44 FS::cust_bill_ApplicationCommon is intended as a base class for classes which
45 represent application of things to invoices, currently payments
46 (see L<FS::cust_bill_pay>) or credits (see L<FS::cust_credit_bill>).
59 local $SIG{HUP} = 'IGNORE';
60 local $SIG{INT} = 'IGNORE';
61 local $SIG{QUIT} = 'IGNORE';
62 local $SIG{TERM} = 'IGNORE';
63 local $SIG{TSTP} = 'IGNORE';
64 local $SIG{PIPE} = 'IGNORE';
66 my $oldAutoCommit = $FS::UID::AutoCommit;
67 local $FS::UID::AutoCommit = 0;
70 my $error = $self->SUPER::insert(@_)
71 || $self->apply_to_lineitems(@_);
73 $dbh->rollback if $oldAutoCommit;
77 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
90 local $SIG{HUP} = 'IGNORE';
91 local $SIG{INT} = 'IGNORE';
92 local $SIG{QUIT} = 'IGNORE';
93 local $SIG{TERM} = 'IGNORE';
94 local $SIG{TSTP} = 'IGNORE';
95 local $SIG{PIPE} = 'IGNORE';
97 my $oldAutoCommit = $FS::UID::AutoCommit;
98 local $FS::UID::AutoCommit = 0;
101 foreach my $app ( $self->lineitem_applications ) {
102 my $error = $app->delete;
104 $dbh->rollback if $oldAutoCommit;
109 my $error = $self->SUPER::delete(@_);
111 $dbh->rollback if $oldAutoCommit;
115 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
121 =item apply_to_lineitems
123 Auto-applies this invoice application to specific line items, if possible.
127 sub calculate_applications {
128 my( $self, %options ) = @_;
130 return '' if $skip_apply_to_lineitems_hack;
134 my $conf = new FS::Conf;
136 my @open = $self->cust_bill->open_cust_bill_pkg; #FOR UPDATE...?
138 if ( exists($options{subitems}) ) {
141 $open{$_->billpkgnum} = $i++ foreach @open;
143 foreach my $listref ( @{$options{subitems}} ) {
144 my ($billpkgnum, $itemamount, $taxlocationnum) = @$listref;
145 return "Can't apply a ". $self->_app_source_name. ' of $'. $listref->[1].
146 " to line item $billpkgnum which is not open"
147 unless exists($open{$billpkgnum});
148 my $itemindex = $open{$billpkgnum};
150 if ($taxlocationnum) {
151 %taxhash = map { ($_->primary_key => $_->get($_->primary_key)) }
152 grep { $_->get($_->primary_key) == $taxlocationnum }
153 $open[$itemindex]->cust_bill_pkg_tax_Xlocation;
155 return "No tax line item with a key value of $taxlocationnum exists"
156 unless scalar(%taxhash);
158 push @apply, [ $open[$itemindex], $itemamount, { %taxhash } ];
163 @open = grep { $_->pkgnum == $self->pkgnum } @open
164 if $conf->exists('pkg-balances') && $self->pkgnum;
165 warn "$me ". scalar(@open). " open line items for invoice ".
166 $self->cust_bill->invnum. ": ". join(', ', @open). "\n"
170 $total += $_->owed_setup if $_->setup;
171 $total += $_->owed_recur if $_->recur;
173 $total = sprintf('%.2f', $total);
175 if ( $self->amount > $total ) {
176 return "Can't apply a ". $self->_app_source_name. ' of $'. $self->amount.
177 " greater than the remaining owed on line items (\$$total)";
181 # - one lineitem (a simple special case of:)
182 # - amount is for whole invoice (well, all of remaining lineitem links)
183 if ( $self->amount == $total ) {
185 warn "$me application amount covers remaining balance of invoice in full;".
186 "applying to those lineitems\n"
189 #@apply = map { [ $_, $_->amount ]; } @open;
190 #@apply = map { [ $_, $_->owed_setup + 0 || $_->owed_recur + 0 ]; } @open;
191 @apply = map { [ $_, $_->setup ? $_->owed_setup : $_->owed_recur ]; } @open;
195 #slightly magic case:
196 # - amount exactly and uniquely matches a single open lineitem
197 # (you must be trying to pay or credit that item, then)
199 my @same = grep { ( $_->setup && $_->owed_setup == $self->amount )
200 || ( $_->recur && $_->owed_recur == $self->amount )
203 if ( scalar(@same) == 1 ) {
204 warn "$me application amount exactly and uniquely matches one lineitem;".
205 " applying to that lineitem\n"
207 @apply = map { [ $_, $self->amount ]; } @same
214 warn "$me applying amount based on package weights\n"
218 # - apply based on weights...
220 my $weight_col = $self->_app_part_pkg_weight_column;
221 my @openweight = map {
223 my $cust_pkg = $open->cust_pkg;
226 ? ( $cust_pkg->part_pkg->$weight_col() || 0 )
227 : -1; #default or per-tax weight?
233 my @weights = sort { $b <=> $a } # highest weight first
234 grep { ! $saw{$_}++ } # want a list of unique weights
238 my $remaining_amount = $self->amount;
239 foreach my $weight ( @weights ) {
241 #i hate it when my schwartz gets tangled
242 my @items = map { $_->[0] } grep { $weight == $_->[1] } @openweight;
245 foreach my $item (@items) {
246 $itemtotal += $item->owed_setup if $item->setup;
247 $itemtotal += $item->owed_recur if $item->recur;
249 my $applytotal = min( $itemtotal, $remaining_amount );
250 $remaining_amount -= $applytotal;
252 warn "$me applying $applytotal ($remaining_amount remaining)".
253 " to ". scalar(@items). " lineitems with weight $weight\n"
256 #if some items are less than applytotal/num_items, then apply then in full
261 #no, not sprintf("%.2f",
262 # we want this rounded DOWN for purposes of checking for line items
263 # less than it, we don't want .66666 becoming .67 and causing this
264 # to trigger when it shouldn't
265 my $applyeach = int( 100 * $applytotal / scalar(@items) ) / 100;
268 foreach my $item ( @items ) {
269 my $itemamount = $item->setup ? $item->owed_setup : $item->owed_recur;
270 if ( $itemamount < $applyeach ) {
271 warn "$me applying full $itemamount".
272 " to small line item (cust_bill_pkg ". $item->billpkgnum. ")\n"
274 push @apply, [ $item, $itemamount ];
275 $applytotal -= $itemamount;
278 push @newitems, $item;
283 } while ( $lessflag && @items );
287 #and now that we've fallen out of the loop, distribute the rest equally
289 # should cust_bill_pay_pkg and cust_credit_bill_pkg amount columns
290 # become real instead of numeric(10,2) ??? no..
291 my $applyeach = sprintf("%.2f", $applytotal / scalar(@items) );
293 my @equi_apply = map { [ $_, $applyeach ] } @items;
295 # or should we futz with pennies instead? yes, bah!
297 sprintf('%.0f', 100 * ( $applytotal - $applyeach * scalar(@items) ) );
298 $diff = 0 if $diff eq '-0'; #yay ieee fp
299 if ( abs($diff) > scalar(@items) ) {
300 #we must have done something really wrong, the difference is more than
302 return 'Error distributing pennies applying '.$self->_app_source_name.
303 " - can't distribute difference of $diff pennies".
304 ' among '. scalar(@items). ' line items';
307 warn "$me futzing with $diff pennies difference\n"
311 while ( $diff != 0 && $futz < scalar(@equi_apply) ) {
313 $equi_apply[$futz++]->[1] += .01;
315 } elsif ( $diff < 0 ) {
316 $equi_apply[$futz++]->[1] -= .01;
319 die "guru exception #5 (in fortran tongue the answer)";
323 if ( sprintf('%.0f', $diff ) ) {
324 return "couldn't futz with pennies enough: still $diff left";
328 warn "$me applying ". $_->[1].
329 " to line item (cust_bill_pkg ". $_->[0]->billpkgnum. ")\n"
332 push @apply, @equi_apply;
336 #$remaining_amount -= $applytotal;
337 last unless $remaining_amount;
343 # break down lineitem amounts for tax lines
344 # could expand @open above, instead, for a slightly different magic effect
346 foreach my $apply ( @apply ) {
347 # $apply = [ FS::cust_bill_pkg_tax_location record, amount ]
348 my @sub_lines = $apply->[0]->cust_bill_pkg_tax_Xlocation;
349 my $amount = $apply->[1];
350 warn "applying ". $apply->[1]. " to ". $apply->[0]->desc
353 foreach my $subline ( @sub_lines ) {
354 my $owed = $subline->owed;
355 push @result, [ $apply->[0],
356 sprintf('%.2f', min($amount, $owed) ),
357 # $subline->primary_key is "billpkgtaxlocationnum"
358 # or "billpkgtaxratelocationnum"
359 # This is the ONLY place either of those fields will
361 { $subline->primary_key => $subline->get($subline->primary_key) },
364 $amount = 0 if $amount < 0;
368 push @result, [ $apply->[0], sprintf('%.2f', $amount), {} ];
376 sub apply_to_lineitems {
378 my( $self, %options ) = @_;
380 return '' if $skip_apply_to_lineitems_hack;
382 my $conf = new FS::Conf;
384 local $SIG{HUP} = 'IGNORE';
385 local $SIG{INT} = 'IGNORE';
386 local $SIG{QUIT} = 'IGNORE';
387 local $SIG{TERM} = 'IGNORE';
388 local $SIG{TSTP} = 'IGNORE';
389 local $SIG{PIPE} = 'IGNORE';
391 my $oldAutoCommit = $FS::UID::AutoCommit;
392 local $FS::UID::AutoCommit = 0;
395 my $listref_or_error = $self->calculate_applications(%options);
396 unless (ref($listref_or_error)) {
397 $dbh->rollback if $oldAutoCommit;
398 return $listref_or_error;
401 my @apply = @$listref_or_error;
403 # do the applicaiton(s)
404 my $table = $self->lineitem_breakdown_table;
405 my $source_key = dbdef->table($self->table)->primary_key;
407 foreach my $apply ( @apply ) {
408 my ( $cust_bill_pkg, $amount, $taxcreditref ) = @$apply;
410 my $application = "FS::$table"->new( {
411 $source_key => $self->$source_key(),
412 'billpkgnum' => $cust_bill_pkg->billpkgnum,
413 'amount' => sprintf('%.2f', $amount),
414 'setuprecur' => ( $cust_bill_pkg->setup > 0 ? 'setup' : 'recur' ),
415 'sdate' => $cust_bill_pkg->sdate,
416 'edate' => $cust_bill_pkg->edate,
419 my $error = $application->insert(%options);
421 $dbh->rollback if $oldAutoCommit;
425 # trigger export_insert_on_payment
426 if ( $conf->exists('trigger_export_insert_on_payment')
427 && $cust_bill_pkg->pkgnum > 0 )
429 if ( my $cust_pkg = $cust_bill_pkg->cust_pkg ) {
431 foreach my $cust_svc ( $cust_pkg->cust_svc ) {
432 my $svc_x = $cust_svc->svc_x;
433 my @part_export = grep { $_->can('_export_insert_on_payment') }
434 $cust_svc->part_svc->part_export;
436 foreach my $part_export ( @part_export ) {
437 $error = $part_export->_export_insert_on_payment($svc_x);
439 $dbh->rollback if $oldAutoCommit;
446 # done trigger export_insert_on_payment
450 # unset promised payment date if there is one
451 my $cust_bill = $self->cust_bill;
452 if ( $cust_bill->promised_date and $cust_bill->owed <= 0 ) {
453 $cust_bill->set('promised_date', '');
454 my $error = $cust_bill->replace;
456 $dbh->rollback if $oldAutoCommit;
461 #everything should always be applied to line items in full now... sanity check
462 $applied = sprintf('%.2f', $applied);
463 unless ( $applied == $self->amount ) {
464 $dbh->rollback if $oldAutoCommit;
465 return 'Error applying '. $self->_app_source_name. ' of $'. $self->amount.
466 ' to line items - only $'. $applied. ' was applied.';
469 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
474 =item lineitem_applications
476 Returns all the specific line item applications for this invoice application.
480 sub lineitem_applications {
482 my $primary_key = dbdef->table($self->table)->primary_key;
484 'table' => $self->lineitem_breakdown_table,
485 'hashref' => { $primary_key => $self->$primary_key() },
492 Returns the invoice (see L<FS::cust_bill>)
498 qsearchs( 'cust_bill', { 'invnum' => $self->invnum } );
501 =item applied_to_invoice
503 Returns a string representing the invoice (see L<FS::cust_bill>), for example:
504 "applied to Invoice #54 (3/20/2008)"
508 sub applied_to_invoice {
510 my $string = 'applied to '. $self->cust_bill->invnum_date_pretty;
512 #show application date if over 24 hours after (or before) payment/credit date
513 $string .= ' on '. $self->_date_pretty
514 if abs( $self->_date - $self->_app_source_object->_date ) > 86400;
519 =item _app_source_object
523 sub _app_source_object {
525 my $source_table = $self->_app_source_table;
526 $self->$source_table();
531 Returns a string with the application date, for example: "3/20/2008"
537 time2str($date_format, $self->_date);
540 =item lineitem_breakdown_table
544 sub lineitem_breakdown_table {
546 $self->_load_table($self->_app_lineitem_breakdown_table);
550 my( $self, $table ) = @_;
551 eval "use FS::$table";
562 L<FS::cust_bill_pay> and L<FS::cust_bill_pay_pkg>,
563 L<FS::cust_credit_bill> and L<FS::cust_credit_bill_pkg>