[freeside-commits] freeside/FS/FS cust_bill_ApplicationCommon.pm, 1.4, 1.5 cust_bill_pay.pm, 1.17, 1.18 cust_bill_pkg.pm, 1.11, 1.12 cust_bill.pm, 1.158, 1.159 cust_credit_bill.pm, 1.14, 1.15 part_bill_event.pm, 1.26, 1.27 part_pkg.pm, 1.54, 1.55 Record.pm, 1.130, 1.131 cust_main.pm, 1.262, 1.263 Schema.pm, 1.42, 1.43

Ivan,,, ivan at wavetail.420.am
Sun Jan 21 13:45:31 PST 2007


Update of /home/cvs/cvsroot/freeside/FS/FS
In directory wavetail:/tmp/cvs-serv32190/FS/FS

Modified Files:
	cust_bill_ApplicationCommon.pm cust_bill_pay.pm 
	cust_bill_pkg.pm cust_bill.pm cust_credit_bill.pm 
	part_bill_event.pm part_pkg.pm Record.pm cust_main.pm 
	Schema.pm 
Log Message:
Have lineitem-specific applications happen in all cases; add weightsto control

Index: part_bill_event.pm
===================================================================
RCS file: /home/cvs/cvsroot/freeside/FS/FS/part_bill_event.pm,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -d -r1.26 -r1.27
--- part_bill_event.pm	23 Oct 2006 04:21:02 -0000	1.26
+++ part_bill_event.pm	21 Jan 2007 21:45:28 -0000	1.27
@@ -133,13 +133,16 @@
 
     my $c = $self->eventcode;
 
+    #yay, these regexen will go away with the event refactor
+
     $c =~ /^\s*\$cust_main\->(suspend|cancel|invoicing_list_addpost|bill|collect)\(\);\s*("";)?\s*$/
 
       or $c =~ /^\s*\$cust_bill\->(comp|realtime_(card|ach|lec)|batch_card|send)\((%options)*\);\s*$/
 
       or $c =~ /^\s*\$cust_bill\->send(_if_newest)?\(\'[\w\-\s]+\'\s*(,\s*(\d+|\[\s*\d+(,\s*\d+)*\s*\])\s*,\s*'[\w\@\.\-\+]*'\s*)?\);\s*$/
 
-      or $c =~ /^\s*\$cust_main\->apply_payments; \$cust_main->apply_credits; "";\s*$/
+#      or $c =~ /^\s*\$cust_main\->apply_payments; \$cust_main->apply_credits; "";\s*$/
+      or $c =~ /^\s*\$cust_main\->apply_payments_and_credits; "";\s*$/
 
       or $c =~ /^\s*\$cust_main\->charge\( \s*\d*\.?\d*\s*,\s*\'[\w \!\@\#\$\%\&\(\)\-\+\;\:\"\,\.\?\/]*\'\s*\);\s*$/
 

Index: cust_bill.pm
===================================================================
RCS file: /home/cvs/cvsroot/freeside/FS/FS/cust_bill.pm,v
retrieving revision 1.158
retrieving revision 1.159
diff -u -d -r1.158 -r1.159
--- cust_bill.pm	10 Jan 2007 05:51:14 -0000	1.158
+++ cust_bill.pm	21 Jan 2007 21:45:28 -0000	1.159
@@ -4,6 +4,7 @@
 use vars qw( @ISA $DEBUG $me $conf $money_char );
 use vars qw( $invoice_lines @buf ); #yuck
 use Fcntl qw(:flock); #for spool_csv
+use List::Util qw(min max);
 use IPC::Run3;
 use Date::Format;
 use Text::Template 1.20;
@@ -228,6 +229,20 @@
   qsearch( 'cust_bill_pkg', { 'invnum' => $self->invnum } );
 }
 
+=item cust_pkg
+
+Returns the packages (see L<FS::cust_pkg>) corresponding to the line items for
+this invoice.
+
+=cut
+
+sub cust_pkg {
+  my $self = shift;
+  my @cust_pkg = map { $_->cust_pkg } $self->cust_bill_pkg;
+  my %saw = ();
+  grep { ! $saw{$_->pkgnum}++ } @cust_pkg;
+}
+
 =item open_cust_bill_pkg
 
 Returns the open line items for this invoice.
@@ -397,6 +412,79 @@
   $balance;
 }
 
+=item apply_payments_and_credits
+
+=cut
+
+sub apply_payments_and_credits {
+  my $self = shift;
+
+  my @payments = grep { $_->unapplied > 0 } $self->cust_main->cust_pay;
+  my @credits  = grep { $_->credited > 0 } $self->cust_main->cust_credit;
+
+  while ( $self->owed > 0 and ( @payments || @credits ) ) {
+
+    my $app = '';
+    if ( @payments && @credits ) {
+
+      #decide which goes first by weight of top (unapplied) line item
+
+      my @open_lineitems = $self->open_cust_bill_pkg;
+
+      my $max_pay_weight =
+        max( map { $_->cust_pkg->part_pkg->pay_weight || 0 }
+	         @open_lineitems
+	   );
+      my $max_credit_weight =
+        max( map { $_->cust_pkg->part_pkg->credit_weight || 0 }
+	         @open_lineitems
+           );
+
+      #if both are the same... payments first?  it has to be something
+      if ( $max_pay_weight >= $max_credit_weight ) {
+        $app = 'pay';
+      } else {
+        $app = 'credit';
+      }
+    
+    } elsif ( @payments ) {
+      $app = 'pay';
+    } elsif ( @credits ) {
+      $app = 'credit';
+    } else {
+      die "guru meditation #12 and 35";
+    }
+
+    if ( $app eq 'pay' ) {
+
+      my $payment = shift @payments;
+
+      $app = new FS::cust_bill_pay {
+        'paynum'  => $payment->paynum,
+	'amount'  => sprintf('%.2f', min( $payment->unapplied, $self->owed ) ),
+      };
+
+    } elsif ( $app eq 'credit' ) {
+
+      my $credit = shift @credits;
+
+      $app = new FS::cust_credit_bill {
+        'crednum' => $credit->crednum,
+	'amount'  => sprintf('%.2f', min( $credit->credited, $self->owed ) ),
+      };
+
+    } else {
+      die "guru meditation #12 and 35";
+    }
+
+    $app->invnum( $self->invnum );
+
+    my $error = $app->insert;
+    die $error if $error;
+
+  }
+
+}
 
 =item generate_email PARAMHASH
 

Index: cust_bill_ApplicationCommon.pm
===================================================================
RCS file: /home/cvs/cvsroot/freeside/FS/FS/cust_bill_ApplicationCommon.pm,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -d -r1.4 -r1.5
--- cust_bill_ApplicationCommon.pm	5 Nov 2006 19:22:02 -0000	1.4
+++ cust_bill_ApplicationCommon.pm	21 Jan 2007 21:45:28 -0000	1.5
@@ -1,13 +1,15 @@
 package FS::cust_bill_ApplicationCommon;
 
 use strict;
-use vars qw( @ISA $DEBUG );
+use vars qw( @ISA $DEBUG $me );
+use List::Util qw(min);
 use FS::Schema qw( dbdef );
 use FS::Record qw( qsearch qsearchs dbh );
 
 @ISA = qw( FS::Record );
 
 $DEBUG = 0;
+$me = '[FS::cust_bill_ApplicationCommon]';
 
 =head1 NAME
 
@@ -123,7 +125,7 @@
   my $dbh = dbh;
 
   my @open = $self->cust_bill->open_cust_bill_pkg; #FOR UPDATE...?
-  warn scalar(@open). " open line items for invoice ".
+  warn "$me ". scalar(@open). " open line items for invoice ".
        $self->cust_bill->invnum. "\n"
     if $DEBUG;
   my $total = 0;
@@ -131,7 +133,7 @@
   $total = sprintf('%.2f', $total);
 
   if ( $self->amount > $total ) {
-    dbh->rollback if $oldAutoCommit;
+    $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,6 +143,10 @@
   # - 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;
 
@@ -154,35 +160,166 @@
                       || $_->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
+    }
 
   }
 
-  #and the rest:
-  # - leave unapplied, for now
-  # - eventually, auto-apply?  sequentially?  pro-rated against total remaining?
+  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 { [ $_, ($_->cust_pkg->part_pkg->$weight_col()||0) ] }
+                         @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->setup || $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->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 );
+
+      #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';
+      }
+
+      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";
+      }
+
+      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;
+
+    }
+
+  }
 
   # 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;
+    $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,
     });
     my $error = $application->insert;
     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;
   '';
 
 }

Index: cust_credit_bill.pm
===================================================================
RCS file: /home/cvs/cvsroot/freeside/FS/FS/cust_credit_bill.pm,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -d -r1.14 -r1.15
--- cust_credit_bill.pm	21 Aug 2006 23:01:43 -0000	1.14
+++ cust_credit_bill.pm	21 Jan 2007 21:45:28 -0000	1.15
@@ -72,6 +72,7 @@
 sub _app_source_name  { 'credit'; }
 sub _app_source_table { 'cust_credit'; }
 sub _app_lineitem_breakdown_table { 'cust_credit_bill_pkg'; }
+sub _app_part_pkg_weight_column { 'credit_weight'; }
 
 =item insert
 

Index: part_pkg.pm
===================================================================
RCS file: /home/cvs/cvsroot/freeside/FS/FS/part_pkg.pm,v
retrieving revision 1.54
retrieving revision 1.55
diff -u -d -r1.54 -r1.55
--- part_pkg.pm	29 Dec 2006 08:24:41 -0000	1.54
+++ part_pkg.pm	21 Jan 2007 21:45:28 -0000	1.55
@@ -81,6 +81,10 @@
 
 =item disabled - Disabled flag, empty or `Y'
 
+=item pay_weight - Weight (relative to credit_weight and other package definitions) that controls payment application to specific line items.
+
+=item credit_weight - Weight (relative to other package definitions) that controls credit application to specific line items.
+
 =back
 
 =head1 METHODS
@@ -307,6 +311,12 @@
 sub replace {
   my( $new, $old ) = ( shift, shift );
   my %options = @_;
+
+  # We absolutely have to have an old vs. new record to make this work.
+  if (!defined($old)) {
+    $old = qsearchs( 'part_pkg', { 'pkgpart' => $new->pkgpart } );
+  }
+
   warn "FS::part_pkg::replace called on $new to replace $old ".
        "with options %options"
     if $DEBUG;
@@ -437,6 +447,8 @@
     || $self->ut_enum('recurtax', [ '', 'Y' ] )
     || $self->ut_textn('taxclass')
     || $self->ut_enum('disabled', [ '', 'Y' ] )
+    || $self->ut_floatn('pay_weight')
+    || $self->ut_floatn('credit_weight')
     || $self->SUPER::check
   ;
   return $error if $error;

Index: cust_main.pm
===================================================================
RCS file: /home/cvs/cvsroot/freeside/FS/FS/cust_main.pm,v
retrieving revision 1.262
retrieving revision 1.263
diff -u -d -r1.262 -r1.263
--- cust_main.pm	12 Jan 2007 02:04:49 -0000	1.262
+++ cust_main.pm	21 Jan 2007 21:45:28 -0000	1.263
@@ -3088,7 +3088,7 @@
   $paybatch .= ':'. $refund->order_number
     if $refund->can('order_number') && $refund->order_number;
 
-  while ( $cust_pay && $cust_pay->unappled < $amount ) {
+  while ( $cust_pay && $cust_pay->unapplied < $amount ) {
     my @cust_bill_pay = $cust_pay->cust_bill_pay;
     last unless @cust_bill_pay;
     my $cust_bill_pay = pop @cust_bill_pay;
@@ -3158,6 +3158,24 @@
   sprintf( "%.2f", $total_bill );
 }
 
+=item apply_payments_and_credits
+
+Applies unapplied payments and credits.
+
+In most cases, this new method should be used in place of sequential
+apply_payments and apply_credits methods.
+
+=cut
+
+sub apply_payments_and_credits {
+  my $self = shift;
+
+  foreach my $cust_bill ( $self->open_cust_bill ) {
+    $cust_bill->apply_payments_and_credits;
+  }
+
+}
+
 =item apply_credits OPTION => VALUE ...
 
 Applies (see L<FS::cust_credit_bill>) unapplied credits (see L<FS::cust_credit>)
@@ -4555,8 +4573,7 @@
         return "can't bill customer for $line: $error";
       }
   
-      $cust_main->apply_payments;
-      $cust_main->apply_credits;
+      $cust_main->apply_payments_and_credits;
   
       $error = $cust_main->collect();
       if ( $error ) {

Index: Record.pm
===================================================================
RCS file: /home/cvs/cvsroot/freeside/FS/FS/Record.pm,v
retrieving revision 1.130
retrieving revision 1.131
diff -u -d -r1.130 -r1.131
--- Record.pm	29 Dec 2006 08:51:32 -0000	1.130
+++ Record.pm	21 Jan 2007 21:45:28 -0000	1.131
@@ -1308,6 +1308,23 @@
   $self->setfield($field,$1);
   '';
 }
+=item ut_floatn COLUMN
+
+Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May be
+null.  If there is an error, returns the error, otherwise returns false.
+
+=cut
+
+#false laziness w/ut_ipn
+sub ut_floatn {
+  my( $self, $field ) = @_;
+  if ( $self->getfield($field) =~ /^()$/ ) {
+    $self->setfield($field,'');
+    '';
+  } else {
+    $self->ut_float($field);
+  }
+}
 
 =item ut_snumber COLUMN
 

Index: Schema.pm
===================================================================
RCS file: /home/cvs/cvsroot/freeside/FS/FS/Schema.pm,v
retrieving revision 1.42
retrieving revision 1.43
diff -u -d -r1.42 -r1.43
--- Schema.pm	12 Jan 2007 23:27:08 -0000	1.42
+++ Schema.pm	21 Jan 2007 21:45:28 -0000	1.43
@@ -716,20 +716,22 @@
 
     'part_pkg' => {
       'columns' => [
-        'pkgpart',    'serial',    '',   '', '', '', 
-        'pkg',        'varchar',   '',   $char_d, '', '', 
-        'comment',    'varchar',   '',   $char_d, '', '', 
-        'promo_code', 'varchar', 'NULL', $char_d, '', '', 
-        'setup',      @perl_type, '', '', 
-        'freq',       'varchar',   '',   $char_d, '', '', #billing frequency
-        'recur',      @perl_type, '', '', 
-        'setuptax',  'char', 'NULL', 1, '', '', 
-        'recurtax',  'char', 'NULL', 1, '', '', 
-        'plan',       'varchar', 'NULL', $char_d, '', '', 
-        'plandata',   'text', 'NULL', '', '', '', 
-        'disabled',   'char', 'NULL', 1, '', '', 
-        'taxclass',   'varchar', 'NULL', $char_d, '', '', 
-        'classnum',   'int',     'NULL', '', '', '', 
+        'pkgpart',       'serial',    '',   '', '', '', 
+        'pkg',           'varchar',   '',   $char_d, '', '', 
+        'comment',       'varchar',   '',   $char_d, '', '', 
+        'promo_code',    'varchar', 'NULL', $char_d, '', '', 
+        'setup',         @perl_type, '', '', 
+        'freq',          'varchar',   '',   $char_d, '', '', #billing frequency
+        'recur',         @perl_type, '', '', 
+        'setuptax',      'char', 'NULL', 1, '', '', 
+        'recurtax',      'char', 'NULL', 1, '', '', 
+        'plan',          'varchar', 'NULL', $char_d, '', '', 
+        'plandata',      'text', 'NULL', '', '', '', 
+        'disabled',      'char', 'NULL', 1, '', '', 
+        'taxclass',      'varchar', 'NULL', $char_d, '', '', 
+        'classnum',      'int',     'NULL', '', '', '', 
+        'pay_weight',    'real',    'NULL', '', '', '',
+        'credit_weight', 'real',    'NULL', '', '', '',
       ],
       'primary_key' => 'pkgpart',
       'unique' => [],

Index: cust_bill_pkg.pm
===================================================================
RCS file: /home/cvs/cvsroot/freeside/FS/FS/cust_bill_pkg.pm,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -d -r1.11 -r1.12
--- cust_bill_pkg.pm	21 Aug 2006 23:01:43 -0000	1.11
+++ cust_bill_pkg.pm	21 Jan 2007 21:45:28 -0000	1.12
@@ -192,6 +192,17 @@
   qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } );
 }
 
+=item cust_bill
+
+Returns the invoice (see L<FS::cust_bill>) for this invoice line item.
+
+=cut
+
+sub cust_bill {
+  my $self = shift;
+  qsearchs( 'cust_bill', { 'invnum' => $self->invnum } );
+}
+
 =item details
 
 Returns an array of detail information for the invoice line item.

Index: cust_bill_pay.pm
===================================================================
RCS file: /home/cvs/cvsroot/freeside/FS/FS/cust_bill_pay.pm,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -d -r1.17 -r1.18
--- cust_bill_pay.pm	21 Aug 2006 23:01:43 -0000	1.17
+++ cust_bill_pay.pm	21 Jan 2007 21:45:28 -0000	1.18
@@ -70,6 +70,7 @@
 sub _app_source_name   { 'payment'; }
 sub _app_source_table { 'cust_pay'; }
 sub _app_lineitem_breakdown_table { 'cust_bill_pay_pkg'; }
+sub _app_part_pkg_weight_column { 'pay_weight'; }
 
 =item insert
 



More information about the freeside-commits mailing list