work around bug in pre-perl5.10 which is at best noisy and at worst missorting

[freeside.git] / FS / FS / cust_pkg.pm

diff --git a/FS/FS/cust_pkg.pm b/FS/FS/cust_pkg.pm
index 198e31b..d32ad1b 100644 (file)
--- a/FS/FS/cust_pkg.pm
+++ b/FS/FS/cust_pkg.pm
@@ -216,7 +216,7 @@ sub insert {
              ' packages with '. $part_pkg->freq_pretty. ' frequency';
       } else {
 
-        my $amount = sprintf( "%.2f", $part_pkg->base_recur / $part_pkg->freq );
+        my $amount = sprintf( "%.2f", $part_pkg->base_recur($self) / $part_pkg->freq );
         my $error =
           $referring_cust_main->
             credit( $amount,
@@ -1173,8 +1173,12 @@ sub h_cust_svc {
 sub _sort_cust_svc {
   my( $self, $arrayref ) = @_;
 
+  my $sort =
+    sub ($$) { my ($a, $b) = @_; $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2]
+};
+
   map  { $_->[0] }
-  sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] } 
+  sort $sort
   map {
         my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
                                              'svcpart' => $_->svcpart     } );
@@ -1800,7 +1804,7 @@ active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
 
 =item pkgpart
 
-list specified how?
+pkgpart or arrayref or hashref of pkgparts
 
 =item setup
 
@@ -1926,9 +1930,24 @@ sub search_sql {
   # parse part_pkg
   ###
 
-  my $pkgpart = join (' OR pkgpart=',
-                      grep {$_} map { /^(\d+)$/; } ($params->{'pkgpart'}));
-  push @where,  '(pkgpart=' . $pkgpart . ')' if $pkgpart;
+  if ( ref($params->{'pkgpart'}) ) {
+
+    my @pkgpart = ();
+    if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
+      @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
+    } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
+      @pkgpart = @{ $params->{'pkgpart'} };
+    } else {
+      die 'unhandled pkgpart ref '. $params->{'pkgpart'};
+    }
+
+    @pkgpart = grep /^(\d+)$/, @pkgpart;
+
+    push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
+
+  } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
+    push @where, "pkgpart = $1";
+  } 
 
   ###
   # parse dates
@@ -2153,6 +2172,24 @@ sub order {
       $dbh->rollback if $oldAutoCommit;
       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
     }
+
+    #reset usage if changing pkgpart
+    foreach my $new_pkg (@$return_cust_pkg) {
+      if ($old_pkg->pkgpart != $new_pkg->pkgpart) {
+        my $part_pkg = $new_pkg->part_pkg;
+        $error = $part_pkg->reset_usage($new_pkg, $part_pkg->is_prepaid
+                                                    ? ()
+                                                    : ( 'null' => 1 )
+                                       )
+          if $part_pkg->can('reset_usage');
+
+        if ($error) {
+          $dbh->rollback if $oldAutoCommit;
+          return "Error setting usage values: $error";
+        }
+      }
+    }
+
     $error = $old_pkg->cancel( quiet=>1 );
     if ($error) {
       $dbh->rollback;
@@ -2298,11 +2335,11 @@ All svc_accts which are part of this package have their values reset.
 =cut
 
 sub set_usage {
-  my ($self, $valueref) = @_;
+  my ($self, $valueref, %opt) = @_;
 
   foreach my $cust_svc ($self->cust_svc){
     my $svc_x = $cust_svc->svc_x;
-    $svc_x->set_usage($valueref)
+    $svc_x->set_usage($valueref, %opt)
       if $svc_x->can("set_usage");
   }
 }