X-Git-Url: http://git.freeside.biz/gitweb/?p=freeside.git;a=blobdiff_plain;f=FS%2FFS%2Fcust_bill_ApplicationCommon.pm;h=cadb8a796673873f7e83b5692e997c0e21a7ec8d;hp=fa5f53b87b8c18f3156c5582e2b2594a0bbf0039;hb=aed8ec35ccb9cdeb7ea0cb6ff2946f9d83d582f6;hpb=abb4b384799691f8eb1f77512823d66487366208

diff --git a/FS/FS/cust_bill_ApplicationCommon.pm b/FS/FS/cust_bill_ApplicationCommon.pm
index fa5f53b87..cadb8a796 100644
--- a/FS/FS/cust_bill_ApplicationCommon.pm
+++ b/FS/FS/cust_bill_ApplicationCommon.pm
@@ -1,13 +1,22 @@
 package FS::cust_bill_ApplicationCommon;
 
 use strict;
-use vars qw( @ISA $DEBUG );
+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 = 1;
+$DEBUG = 0;
+$me = '[FS::cust_bill_ApplicationCommon]';
+
+$skip_apply_to_lineitems_hack = 0;
 
 =head1 NAME
 
@@ -31,6 +40,8 @@ represent application of things to invoices, currently payments
 
 =head1 METHODS
 
+=over 4
+
 =item insert
 
 =cut
@@ -50,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;
@@ -106,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...?
-  warn scalar(@open). " open line items for invoice ".
-       $self->cust_bill->invnum. "\n"
+
+  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;
-  $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)";
   }
@@ -141,8 +175,13 @@ 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;
+    #@apply = map { [ $_, $_->owed_setup + 0 || $_->owed_recur + 0 ]; } @open;
+    @apply = map { [ $_, $_->setup ? $_->owed_setup : $_->owed_recur ]; } @open;
 
   } else {
 
@@ -150,37 +189,272 @@ 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;
-    @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
+    }
+
+  }
+
+  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 ) {
+    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), {} ];
+    }
   }
 
-  #and the rest:
-  # - leave unapplied, for now
-  # - eventually, auto-apply?  sequentially?  pro-rated against total remaining?
+  \@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(),
       '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,
+      %$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->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;
   '';
 
 }
@@ -212,6 +486,18 @@ sub cust_bill {
   qsearchs( 'cust_bill', { 'invnum' => $self->invnum } );
 }
 
+=item applied_to_invoice
+
+Returns a string representing the invoice (see L<FS::cust_bill>), 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