registration codes

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

diff --git a/FS/FS/part_pkg.pm b/FS/FS/part_pkg.pm
index 67c7c96..f210a67 100644 (file)
--- a/FS/FS/part_pkg.pm
+++ b/FS/FS/part_pkg.pm
@@ -2,11 +2,13 @@ package FS::part_pkg;
 
 use strict;
 use vars qw( @ISA %freq %plans $DEBUG );
 
 use strict;
 use vars qw( @ISA %freq %plans $DEBUG );

-use Carp;
+use Carp qw(carp cluck);

 use Tie::IxHash;
 use FS::Conf;
 use FS::Record qw( qsearch qsearchs dbh dbdef );
 use FS::pkg_svc;
 use Tie::IxHash;
 use FS::Conf;
 use FS::Record qw( qsearch qsearchs dbh dbdef );
 use FS::pkg_svc;

+use FS::part_svc;
+use FS::cust_pkg;

 use FS::agent_type;
 use FS::type_pkgs;
 use FS::part_pkg_option;
 use FS::agent_type;
 use FS::type_pkgs;
 use FS::part_pkg_option;


@@ -54,6 +56,8 @@ inherits from FS::Record.  The following fields are currently supported:
 
 =item comment - Text name of this package definition (non-customer-viewable)
 
 
 =item comment - Text name of this package definition (non-customer-viewable)
 

+=item promo_code - Promotional code
+

 =item setup - Setup fee expression (deprecated)
 
 =item freq - Frequency of recurring fee
 =item setup - Setup fee expression (deprecated)
 
 =item freq - Frequency of recurring fee


@@ -107,16 +111,34 @@ sub clone {
   new $class ( \%hash ); # ?
 }
 
   new $class ( \%hash ); # ?
 }
 

-=item insert
+=item insert [ , OPTION => VALUE ... ]

 
 Adds this package definition to the database.  If there is an error,
 returns the error, otherwise returns false.
 
 
 Adds this package definition to the database.  If there is an error,
 returns the error, otherwise returns false.
 

+Currently available options are: I<pkg_svc>, I<primary_svc>, I<cust_pkg> and
+I<custnum_ref>.
+
+If I<pkg_svc> is set to a hashref with svcparts as keys and quantities as
+values, appropriate FS::pkg_svc records will be inserted.
+
+If I<primary_svc> is set to the svcpart of the primary service, the appropriate
+FS::pkg_svc record will be updated.
+
+If I<cust_pkg> is set to a pkgnum of a FS::cust_pkg record (or the FS::cust_pkg
+record itself), the object will be updated to point to this package definition.
+
+In conjunction with I<cust_pkg>, if I<custnum_ref> is set to a scalar reference,
+the scalar will be updated with the custnum value from the cust_pkg record.
+

 =cut
 
 sub insert {
   my $self = shift;
 =cut
 
 sub insert {
   my $self = shift;

-  warn "FS::part_pkg::insert called on $self" if $DEBUG;
+  my %options = @_;
+  warn "FS::part_pkg::insert called on $self with options ".
+       join(', ', map "$_=>$options{$_}", keys %options)
+    if $DEBUG;

 
   local $SIG{HUP} = 'IGNORE';
   local $SIG{INT} = 'IGNORE';
 
   local $SIG{HUP} = 'IGNORE';
   local $SIG{INT} = 'IGNORE';


@@ -179,6 +201,44 @@ sub insert {
     }
   }
 
     }
   }
 

+  warn "  inserting pkg_svc records" if $DEBUG;
+  my $pkg_svc = $options{'pkg_svc'} || {};
+  foreach my $part_svc ( qsearch('part_svc', {} ) ) {
+    my $quantity = $pkg_svc->{$part_svc->svcpart} || 0;
+    my $primary_svc = $options{'primary_svc'} == $part_svc->svcpart ? 'Y' : '';
+
+    my $pkg_svc = new FS::pkg_svc( {
+      'pkgpart'     => $self->pkgpart,
+      'svcpart'     => $part_svc->svcpart,
+      'quantity'    => $quantity, 
+      'primary_svc' => $primary_svc,
+    } );
+    my $error = $pkg_svc->insert;
+    if ( $error ) {
+      $dbh->rollback if $oldAutoCommit;
+      return $error;
+    }
+  }
+
+  if ( $options{'cust_pkg'} ) {
+    warn "  updating cust_pkg record " if $DEBUG;
+    my $old_cust_pkg =
+      ref($options{'cust_pkg'})
+        ? $options{'cust_pkg'}
+        : qsearchs('cust_pkg', { pkgnum => $options{'cust_pkg'} } );
+    ${ $options{'custnum_ref'} } = $old_cust_pkg->custnum
+      if $options{'custnum_ref'};
+    my %hash = $old_cust_pkg->hash;
+    $hash{'pkgpart'} = $self->pkgpart,
+    my $new_cust_pkg = new FS::cust_pkg \%hash;
+    local($FS::cust_pkg::disable_agentcheck) = 1;
+    my $error = $new_cust_pkg->replace($old_cust_pkg);
+    if ( $error ) {
+      $dbh->rollback if $oldAutoCommit;
+      return "Error modifying cust_pkg record: $error";
+    }
+  }
+

   warn "  commiting transaction" if $DEBUG;
   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 
   warn "  commiting transaction" if $DEBUG;
   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 


@@ -196,15 +256,27 @@ sub delete {
 # check & make sure the pkgpart isn't in cust_pkg or type_pkgs?
 }
 
 # check & make sure the pkgpart isn't in cust_pkg or type_pkgs?
 }
 

-=item replace OLD_RECORD
+=item replace OLD_RECORD [ , OPTION => VALUE ... ]

 
 Replaces OLD_RECORD with this one in the database.  If there is an error,
 returns the error, otherwise returns false.
 
 
 Replaces OLD_RECORD with this one in the database.  If there is an error,
 returns the error, otherwise returns false.
 

+Currently available options are: I<pkg_svc> and I<primary_svc>
+
+If I<pkg_svc> is set to a hashref with svcparts as keys and quantities as
+values, the appropriate FS::pkg_svc records will be replace.
+
+If I<primary_svc> is set to the svcpart of the primary service, the appropriate
+FS::pkg_svc record will be updated.
+

 =cut
 
 sub replace {
   my( $new, $old ) = ( shift, shift );
 =cut
 
 sub replace {
   my( $new, $old ) = ( shift, shift );

+  my %options = @_;
+  warn "FS::part_pkg::replace called on $new to replace $old ".
+       "with options %options"
+    if $DEBUG;

 
   local $SIG{HUP} = 'IGNORE';
   local $SIG{INT} = 'IGNORE';
 
   local $SIG{HUP} = 'IGNORE';
   local $SIG{INT} = 'IGNORE';


@@ -217,9 +289,11 @@ sub replace {
   local $FS::UID::AutoCommit = 0;
   my $dbh = dbh;
 
   local $FS::UID::AutoCommit = 0;
   my $dbh = dbh;
 

+  warn "  saving legacy plandata" if $DEBUG;

   my $plandata = $new->get('plandata');
   $new->set('plandata', '');
 
   my $plandata = $new->get('plandata');
   $new->set('plandata', '');
 

+  warn "  deleting old part_pkg_option records" if $DEBUG;

   foreach my $part_pkg_option ( $old->part_pkg_option ) {
     my $error = $part_pkg_option->delete;
     if ( $error ) {
   foreach my $part_pkg_option ( $old->part_pkg_option ) {
     my $error = $part_pkg_option->delete;
     if ( $error ) {


@@ -228,12 +302,14 @@ sub replace {
     }
   }
 
     }
   }
 

+  warn "  replacing part_pkg record" if $DEBUG;

   my $error = $new->SUPER::replace($old);
   if ( $error ) {
     $dbh->rollback if $oldAutoCommit;
     return $error;
   }
 
   my $error = $new->SUPER::replace($old);
   if ( $error ) {
     $dbh->rollback if $oldAutoCommit;
     return $error;
   }
 

+  warn "  inserting part_pkg_option records for plandata" if $DEBUG;

   foreach my $part_pkg_option ( 
     map { /^(\w+)=(.*)$/ or do { $dbh->rollback if $oldAutoCommit;
                                  return "illegal plandata: $plandata";
   foreach my $part_pkg_option ( 
     map { /^(\w+)=(.*)$/ or do { $dbh->rollback if $oldAutoCommit;
                                  return "illegal plandata: $plandata";


@@ -253,6 +329,39 @@ sub replace {
     }
   }
 
     }
   }
 

+  warn "  replacing pkg_svc records" if $DEBUG;
+  my $pkg_svc = $options{'pkg_svc'} || {};
+  foreach my $part_svc ( qsearch('part_svc', {} ) ) {
+    my $quantity = $pkg_svc->{$part_svc->svcpart} || 0;
+    my $primary_svc = $options{'primary_svc'} == $part_svc->svcpart ? 'Y' : '';
+
+    my $old_pkg_svc = qsearchs('pkg_svc', {
+      'pkgpart' => $old->pkgpart,
+      'svcpart' => $part_svc->svcpart,
+    } );
+    my $old_quantity = $old_pkg_svc ? $old_pkg_svc->quantity : 0;
+    my $old_primary_svc =
+      ( $old_pkg_svc && $old_pkg_svc->dbdef_table->column('primary_svc') )
+        ? $old_pkg_svc->primary_svc
+        : '';
+    next unless $old_quantity != $quantity || $old_primary_svc ne $primary_svc;
+  
+    my $new_pkg_svc = new FS::pkg_svc( {
+      'pkgpart'     => $new->pkgpart,
+      'svcpart'     => $part_svc->svcpart,
+      'quantity'    => $quantity, 
+      'primary_svc' => $primary_svc,
+    } );
+    my $error = $old_pkg_svc
+                  ? $new_pkg_svc->replace($old_pkg_svc)
+                  : $new_pkg_svc->insert;
+    if ( $error ) {
+      $dbh->rollback if $oldAutoCommit;
+      return $error;
+    }
+  }
+
+  warn "  commiting transaction" if $DEBUG;

   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
   '';
 }
   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
   '';
 }


@@ -288,6 +397,7 @@ sub check {
   my $error = $self->ut_numbern('pkgpart')
     || $self->ut_text('pkg')
     || $self->ut_text('comment')
   my $error = $self->ut_numbern('pkgpart')
     || $self->ut_text('pkg')
     || $self->ut_text('comment')

+    || $self->ut_textn('promo_code')

     || $self->ut_alphan('plan')
     || $self->ut_enum('setuptax', [ '', 'Y' ] )
     || $self->ut_enum('recurtax', [ '', 'Y' ] )
     || $self->ut_alphan('plan')
     || $self->ut_enum('setuptax', [ '', 'Y' ] )
     || $self->ut_enum('recurtax', [ '', 'Y' ] )


@@ -345,9 +455,9 @@ sub svcpart {
 
 Returns a list of the acceptable payment types for this package.  Eventually
 this should come out of a database table and be editable, but currently has the
 
 Returns a list of the acceptable payment types for this package.  Eventually
 this should come out of a database table and be editable, but currently has the

-following logic instead;
+following logic instead:

 
 

-If the package has B<0> setup and B<0> recur, the single item B<BILL> is
+If the package is free, the single item B<BILL> is

 returned, otherwise, the single item B<CARD> is returned.
 
 (CHEK?  LEC?  Probably shouldn't accept those by default, prone to abuse)
 returned, otherwise, the single item B<CARD> is returned.
 
 (CHEK?  LEC?  Probably shouldn't accept those by default, prone to abuse)


@@ -356,15 +466,35 @@ returned, otherwise, the single item B<CARD> is returned.
 
 sub payby {
   my $self = shift;
 
 sub payby {
   my $self = shift;

-  #if ( $self->setup == 0 && $self->recur == 0 ) {
-  if (    $self->setup =~ /^\s*0+(\.0*)?\s*$/
-       && $self->recur =~ /^\s*0+(\.0*)?\s*$/ ) {
+  if ( $self->is_free ) {

     ( 'BILL' );
   } else {
     ( 'CARD' );
   }
 }
 
     ( 'BILL' );
   } else {
     ( 'CARD' );
   }
 }
 

+=item is_free
+
+Returns true if this package is free.  
+
+=cut
+
+sub is_free {
+  my $self = shift;
+  unless ( $self->plan ) {
+    $self->setup =~ /^\s*0+(\.0*)?\s*$/
+      && $self->recur =~ /^\s*0+(\.0*)?\s*$/;
+  } elsif ( $self->can('is_free_options') ) {
+    not grep { $_ !~ /^\s*0*(\.0*)?\s*$/ }
+         map { $self->option($_) } 
+             $self->is_free_options;
+  } else {
+    warn "FS::part_pkg::is_free: FS::part_pkg::". $self->plan. " subclass ".
+         "provides neither is_free_options nor is_free method; returning false";
+    0;
+  }
+}
+

 =item freq_pretty
 
 Returns an english representation of the I<freq> field, such as "monthly",
 =item freq_pretty
 
 Returns an english representation of the I<freq> field, such as "monthly",


@@ -454,13 +584,19 @@ Returns the option value for the given name, or the empty string.
 =cut
 
 sub option {
 =cut
 
 sub option {

-  my $self = shift;
+  my( $self, $opt, $ornull ) = @_;

   my $part_pkg_option =
     qsearchs('part_pkg_option', {
       pkgpart    => $self->pkgpart,
   my $part_pkg_option =
     qsearchs('part_pkg_option', {
       pkgpart    => $self->pkgpart,

-      optionname => shift,
+      optionname => $opt,

   } );
   } );

-  $part_pkg_option ? $part_pkg_option->optionvalue : '';
+  return $part_pkg_option->optionvalue if $part_pkg_option;
+  my %plandata = map { /^(\w+)=(.*)$/; ( $1 => $2 ); }
+                     split("\n", $self->get('plandata') );
+  return $plandata{$opt} if exists $plandata{$opt};
+  cluck "Package definition option $opt not found in options or plandata!\n"
+    unless $ornull;
+  '';

 }
 
 =item _rebless
 }
 
 =item _rebless