X-Git-Url: http://git.freeside.biz/gitweb/?p=freeside.git;a=blobdiff_plain;f=FS%2FFS%2Fcust_pkg.pm;h=cd808d4fa15a8a8c819fb6e36fe12dfa1472c389;hp=d554d8be79ba7aeb4822f104dcc6d487d5e0b5ac;hb=c2829eb15ff44d34ce82ae02c88810a321614ce9;hpb=cbbc7e215fb2f235c05abdb8c9434bdb2385ce3f

diff --git a/FS/FS/cust_pkg.pm b/FS/FS/cust_pkg.pm
index d554d8be7..cd808d4fa 100644
--- a/FS/FS/cust_pkg.pm
+++ b/FS/FS/cust_pkg.pm
@@ -11,6 +11,8 @@ use FS::cust_main;
 use FS::type_pkgs;
 use FS::pkg_svc;
 use FS::cust_bill_pkg;
+use FS::h_cust_svc;
+use FS::reg_code;
 
 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
 # setup }
@@ -140,35 +142,88 @@ Create a new billing item.  To add the item to the database, see L<"insert">.
 
 sub table { 'cust_pkg'; }
 
-=item insert
+=item insert [ OPTION => VALUE ... ]
 
 Adds this billing item to the database ("Orders" the item).  If there is an
 error, returns the error, otherwise returns false.
 
+If the additional field I<promo_code> is defined instead of I<pkgpart>, it
+will be used to look up the package definition and agent restrictions will be
+ignored.
+
+The following options are available: I<change>
+
+I<change>, if set true, supresses any referral credit to a referring customer.
+
 =cut
 
 sub insert {
-  my $self = shift;
+  my( $self, %options ) = @_;
+
+  local $SIG{HUP} = 'IGNORE';
+  local $SIG{INT} = 'IGNORE';
+  local $SIG{QUIT} = 'IGNORE';
+  local $SIG{TERM} = 'IGNORE';
+  local $SIG{TSTP} = 'IGNORE';
+  local $SIG{PIPE} = 'IGNORE';
 
-  # custnum might not have have been defined in sub check (for one-shot new
-  # customers), so check it here instead
-  # (is this still necessary with transactions?)
+  my $oldAutoCommit = $FS::UID::AutoCommit;
+  local $FS::UID::AutoCommit = 0;
+  my $dbh = dbh;
 
-  my $error = $self->ut_number('custnum');
-  return $error if $error;
+  my $error = $self->SUPER::insert;
+  if ( $error ) {
+    $dbh->rollback if $oldAutoCommit;
+    return $error;
+  }
+
+  #if ( $self->reg_code ) {
+  #  my $reg_code = qsearchs('reg_code', { 'code' => $self->reg_code } );
+  #  $error = $reg_code->delete;
+  #  if ( $error ) {
+  #    $dbh->rollback if $oldAutoCommit;
+  #    return $error;
+  #  }
+  #}
 
+  my $conf = new FS::Conf;
   my $cust_main = $self->cust_main;
-  return "Unknown custnum: ". $self->custnum unless $cust_main;
-
-  unless ( $disable_agentcheck ) {
-    my $agent = qsearchs( 'agent', { 'agentnum' => $cust_main->agentnum } );
-    my $pkgpart_href = $agent->pkgpart_hashref;
-    return "agent ". $agent->agentnum.
-           " can't purchase pkgpart ". $self->pkgpart
-      unless $pkgpart_href->{ $self->pkgpart };
+  my $part_pkg = $self->part_pkg;
+  if ( $conf->exists('referral_credit')
+       && $cust_main->referral_custnum
+       && ! $options{'change'}
+       && $part_pkg->freq !~ /^0\D?$/
+     )
+  {
+    my $referring_cust_main = $cust_main->referring_cust_main;
+    if ( $referring_cust_main->status ne 'cancelled' ) {
+      my $error;
+      if ( $part_pkg->freq !~ /^\d+$/ ) {
+        warn 'WARNING: Not crediting customer '. $cust_main->referral_custnum.
+             ' for package '. $self->pkgnum.
+             ' ( customer '. $self->custnum. ')'.
+             ' - One-time referral credits not (yet) available for '.
+             ' packages with '. $part_pkg->freq_pretty. ' frequency';
+      } else {
+
+        my $amount = sprintf( "%.2f", $part_pkg->base_recur / $part_pkg->freq );
+        my $error =
+          $referring_cust_main->credit( $amount,
+                                        'Referral credit for '. $cust_main->name
+                                      );
+        if ( $error ) {
+          $dbh->rollback if $oldAutoCommit;
+          return "Error crediting customer ". $cust_main->referral_custnum.
+               " for referral: $error";
+        }
+
+      }
+
+    }
   }
 
-  $self->SUPER::insert;
+  $dbh->commit or die $dbh->errstr if $oldAutoCommit;
+  '';
 
 }
 
@@ -217,6 +272,8 @@ sub replace {
 
   #some logic for bill, susp, cancel?
 
+  local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
+
   $new->SUPER::replace($old);
 }
 
@@ -233,8 +290,8 @@ sub check {
 
   my $error = 
     $self->ut_numbern('pkgnum')
-    || $self->ut_numbern('custnum')
-    || $self->ut_number('pkgpart')
+    || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
+    || $self->ut_numbern('pkgpart')
     || $self->ut_numbern('setup')
     || $self->ut_numbern('bill')
     || $self->ut_numbern('susp')
@@ -242,12 +299,40 @@ sub check {
   ;
   return $error if $error;
 
-  if ( $self->custnum ) { 
-    return "Unknown customer ". $self->custnum unless $self->cust_main;
-  }
+  if ( $self->reg_code ) {
+
+    unless ( grep { $self->pkgpart == $_->pkgpart }
+             map  { $_->reg_code_pkg }
+             qsearchs( 'reg_code', { 'code'     => $self->reg_code,
+                                     'agentnum' => $self->cust_main->agentnum })
+           ) {
+      return "Unknown registraiton code";
+    }
 
-  return "Unknown pkgpart: ". $self->pkgpart
-    unless qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
+  } elsif ( $self->promo_code ) {
+
+    my $promo_part_pkg =
+      qsearchs('part_pkg', {
+        'pkgpart'    => $self->pkgpart,
+        'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
+      } );
+    return 'Unknown promotional code' unless $promo_part_pkg;
+
+  } else { 
+
+    unless ( $disable_agentcheck ) {
+      my $agent =
+        qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
+      my $pkgpart_href = $agent->pkgpart_hashref;
+      return "agent ". $agent->agentnum.
+             " can't purchase pkgpart ". $self->pkgpart
+        unless $pkgpart_href->{ $self->pkgpart };
+    }
+
+    $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
+    return $error if $error;
+
+  }
 
   $self->otaker(getotaker) unless $self->otaker;
   $self->otaker =~ /^([\w\.\-]{0,16})$/ or return "Illegal otaker";
@@ -310,6 +395,20 @@ sub cancel {
     }
   }
 
+  # Add a credit for remaining service
+  my $remaining_value = $self->calc_remain();
+  if ( $remaining_value > 0 ) {
+    my $error = $self->cust_main->credit(
+      $remaining_value,
+      'Credit for unused time on'. $self->part_pkg->pkg,
+    );
+    if ($error) {
+      $dbh->rollback if $oldAutoCommit;
+      return "Error crediting customer \$$remaining_value for unused time on".
+             $self->part_pkg->pkg. ": $error";
+    }                                                                          
+  }                                                                            
+
   unless ( $self->getfield('cancel') ) {
     my %hash = $self->hash;
     $hash{'cancel'} = time;
@@ -452,7 +551,10 @@ sub unsuspend {
 
   unless ( ! $self->getfield('susp') ) {
     my %hash = $self->hash;
+    my $inactive = time - $hash{'susp'};
     $hash{'susp'} = '';
+    $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive
+      if $inactive > 0 && ( $hash{'bill'} || $hash{'setup'} );
     my $new = new FS::cust_pkg ( \%hash );
     $error = $new->replace($self);
     if ( $error ) {
@@ -499,20 +601,151 @@ sub part_pkg {
     : qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
 }
 
-=item cust_svc
+=item calc_setup
+
+Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
+item.
+
+=cut
+
+sub calc_setup {
+  my $self = shift;
+  $self->part_pkg->calc_setup($self, @_);
+}
+
+=item calc_recur
+
+Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
+item.
+
+=cut
+
+sub calc_recur {
+  my $self = shift;
+  $self->part_pkg->calc_recur($self, @_);
+}
+
+=item calc_remain
+
+Calls the I<calc_remain> of the FS::part_pkg object associated with this
+billing item.
+
+=cut
+
+sub calc_remain {
+  my $self = shift;
+  $self->part_pkg->calc_remain($self, @_);
+}
+
+=item calc_cancel
+
+Calls the I<calc_cancel> of the FS::part_pkg object associated with this
+billing item.
+
+=cut
+
+sub calc_cancel {
+  my $self = shift;
+  $self->part_pkg->calc_cancel($self, @_);
+}
+
+=item cust_svc [ SVCPART ]
 
 Returns the services for this package, as FS::cust_svc objects (see
-L<FS::cust_svc>)
+L<FS::cust_svc>).  If a svcpart is specified, return only the matching
+services.
 
 =cut
 
 sub cust_svc {
   my $self = shift;
-  if ( $self->{'_svcnum'} ) {
-    values %{ $self->{'_svcnum'}->cache };
-  } else {
-    qsearch ( 'cust_svc', { 'pkgnum' => $self->pkgnum } );
+
+  if ( @_ ) {
+    return qsearch( 'cust_svc', { 'pkgnum'  => $self->pkgnum,
+                                  'svcpart' => shift,          } );
   }
+
+  #if ( $self->{'_svcnum'} ) {
+  #  values %{ $self->{'_svcnum'}->cache };
+  #} else {
+    $self->_sort_cust_svc(
+      [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
+    );
+  #}
+
+}
+
+=item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ] 
+
+Returns historical services for this package created before END TIMESTAMP and
+(optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
+(see L<FS::h_cust_svc>).
+
+=cut
+
+sub h_cust_svc {
+  my $self = shift;
+
+  $self->_sort_cust_svc(
+    [ qsearch( 'h_cust_svc',
+               { 'pkgnum' => $self->pkgnum, },
+               FS::h_cust_svc->sql_h_search(@_),
+             )
+    ]
+  );
+}
+
+sub _sort_cust_svc {
+  my( $self, $arrayref ) = @_;
+
+  map  { $_->[0] }
+  sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] } 
+  map {
+        my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
+                                             'svcpart' => $_->svcpart     } );
+        [ $_,
+          $pkg_svc ? $pkg_svc->primary_svc : '',
+          $pkg_svc ? $pkg_svc->quantity : 0,
+        ];
+      }
+  @$arrayref;
+
+}
+
+=item num_cust_svc [ SVCPART ]
+
+Returns the number of provisioned services for this package.  If a svcpart is
+specified, counts only the matching services.
+
+=cut
+
+sub num_cust_svc {
+  my $self = shift;
+  my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
+  $sql .= ' AND svcpart = ?' if @_;
+  my $sth = dbh->prepare($sql) or die dbh->errstr;
+  $sth->execute($self->pkgnum, @_) or die $sth->errstr;
+  $sth->fetchrow_arrayref->[0];
+}
+
+=item available_part_svc 
+
+Returns a list FS::part_svc objects representing services included in this
+package but not yet provisioned.  Each FS::part_svc object also has an extra
+field, I<num_avail>, which specifies the number of available services.
+
+=cut
+
+sub available_part_svc {
+  my $self = shift;
+  grep { $_->num_avail > 0 }
+    map {
+          my $part_svc = $_->part_svc;
+          $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
+            $_->quantity - $self->num_cust_svc($_->svcpart);
+          $part_svc;
+        }
+      $self->part_pkg->pkg_svc;
 }
 
 =item labels
@@ -527,6 +760,52 @@ sub labels {
   map { [ $_->label ] } $self->cust_svc;
 }
 
+=item h_labels END_TIMESTAMP [ START_TIMESTAMP ] 
+
+Like the labels method, but returns historical information on services that
+were active as of END_TIMESTAMP and (optionally) not cancelled before
+START_TIMESTAMP.
+
+Returns a list of lists, calling the label method for all (historical) services
+(see L<FS::h_cust_svc>) of this billing item.
+
+=cut
+
+sub h_labels {
+  my $self = shift;
+  map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
+}
+
+=item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
+
+Like h_labels, except returns a simple flat list, and shortens long 
+(currently >5) lists of identical services to one line that lists the service
+label and the number of individual services rather than individual items.
+
+=cut
+
+sub h_labels_short {
+  my $self = shift;
+
+  my %labels;
+  #tie %labels, 'Tie::IxHash';
+  push @{ $labels{$_->[0]} }, $_->[1]
+    foreach $self->h_labels(@_);
+  my @labels;
+  foreach my $label ( keys %labels ) {
+    my @values = @{ $labels{$label} };
+    my $num = scalar(@values);
+    if ( $num > 5 ) {
+      push @labels, "$label ($num)";
+    } else {
+      push @labels, map { "$label: $_" } @values;
+    }
+  }
+
+ @labels;
+
+}
+
 =item cust_main
 
 Returns the parent customer object (see L<FS::cust_main>).
@@ -654,7 +933,6 @@ sub transfer {
   my $remaining = 0;
   my $dest;
   my %target;
-  my $pkg_svc;
 
   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
     $dest = $dest_pkgnum;
@@ -665,13 +943,11 @@ sub transfer {
 
   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
 
-  foreach $pkg_svc (qsearch('pkg_svc', { pkgpart => $dest->pkgpart })) {
+  foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
   }
 
-  my $cust_svc;
-
-  foreach $cust_svc ($dest->cust_svc) {
+  foreach my $cust_svc ($dest->cust_svc) {
     $target{$cust_svc->svcpart}--;
   }
 
@@ -682,9 +958,20 @@ sub transfer {
       next if exists $svcpart2svcparts{$svcpart};
       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
       $svcpart2svcparts{$svcpart} = [
+        map  { $_->[0] }
+        sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] } 
+        map {
+              my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
+                                                   'svcpart' => $_          } );
+              [ $_,
+                $pkg_svc ? $pkg_svc->primary_svc : '',
+                $pkg_svc ? $pkg_svc->quantity : 0,
+              ];
+            }
+
         grep { $_ != $svcpart }
-          map { $_->svcpart }
-            qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
+        map  { $_->svcpart }
+        qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
       ];
       warn "alternates for svcpart $svcpart: ".
            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
@@ -692,7 +979,7 @@ sub transfer {
     }
   }
 
-  foreach $cust_svc ($self->cust_svc) {
+  foreach my $cust_svc ($self->cust_svc) {
     if($target{$cust_svc->svcpart} > 0) {
       $target{$cust_svc->svcpart}--;
       my $new = new FS::cust_svc {
@@ -716,7 +1003,7 @@ sub transfer {
                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
       if ( @alternate ) {
         warn "alternate(s) found\n" if $DEBUG;
-        my $change_svcpart = $alternate[0]; #arbitrary.
+        my $change_svcpart = $alternate[0];
         $target{$change_svcpart}--;
         my $new = new FS::cust_svc {
           svcnum  => $cust_svc->svcnum,
@@ -819,12 +1106,13 @@ sub order {
   my $cust_main = qsearchs('cust_main', { custnum => $custnum });
   return "Customer not found: $custnum" unless $cust_main;
 
+  my $change = scalar(@$remove_pkgnum) != 0;
+
   # Create the new packages.
-  my $cust_pkg;
-  foreach (@$pkgparts) {
-    $cust_pkg = new FS::cust_pkg { custnum => $custnum,
-                                   pkgpart => $_ };
-    $error = $cust_pkg->insert;
+  foreach my $pkgpart (@$pkgparts) {
+    my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
+                                      pkgpart => $pkgpart };
+    $error = $cust_pkg->insert( 'change' => $change );
     if ($error) {
       $dbh->rollback if $oldAutoCommit;
       return $error;