new tax rating engine

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

diff --git a/FS/FS/part_pkg.pm b/FS/FS/part_pkg.pm
index 9392f4b..1e16f29 100644 (file)
--- a/FS/FS/part_pkg.pm
+++ b/FS/FS/part_pkg.pm
@@ -1,8 +1,8 @@
 package FS::part_pkg;
 
 use strict;
 package FS::part_pkg;
 
 use strict;

-use vars qw( @ISA %freq %plans $DEBUG );
-use Carp qw(carp cluck);
+use vars qw( @ISA %plans $DEBUG );
+use Carp qw(carp cluck confess);

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


@@ -12,8 +12,14 @@ 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;

+use FS::pkg_class;
+use FS::agent;
+use FS::part_pkg_taxoverride;
+use FS::part_pkg_taxproduct;

 
 

-@ISA = qw( FS::Record );
+@ISA = qw( FS::m2m_Common FS::Record ); # FS::option_Common ); # this can use option_Common
+                                                # when all the plandata bs is
+                                                # gone

 
 $DEBUG = 0;
 
 
 $DEBUG = 0;
 


@@ -56,6 +62,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 classnum - Optional package class (see L<FS::pkg_class>)
+

 =item promo_code - Promotional code
 
 =item setup - Setup fee expression (deprecated)
 =item promo_code - Promotional code
 
 =item setup - Setup fee expression (deprecated)


@@ -76,6 +84,12 @@ inherits from FS::Record.  The following fields are currently supported:
 
 =item disabled - Disabled flag, empty or `Y'
 
 
 =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.
+
+=item agentnum - Optional agentnum (see L<FS::agent>)
+

 =back
 
 =head1 METHODS
 =back
 
 =head1 METHODS


@@ -116,8 +130,8 @@ sub clone {
 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>.
+Currently available options are: I<pkg_svc>, I<primary_svc>, I<cust_pkg>, 
+I<custnum_ref> and I<options>.

 
 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<pkg_svc> is set to a hashref with svcparts as keys and quantities as
 values, appropriate FS::pkg_svc records will be inserted.


@@ -131,12 +145,17 @@ 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.
 
 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.
 

+If I<options> is set to a hashref of options, appropriate FS::part_pkg_option
+records will be inserted.
+

 =cut
 
 sub insert {
   my $self = shift;
   my %options = @_;
 =cut
 
 sub insert {
   my $self = shift;
   my %options = @_;

-  warn "FS::part_pkg::insert called on $self with options %options" if $DEBUG;
+  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';


@@ -161,7 +180,8 @@ sub insert {
   }
 
   if ( $plandata ) {
   }
 
   if ( $plandata ) {

-  warn "  inserting part_pkg_option records for plandata" if $DEBUG;
+
+    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";


@@ -180,6 +200,27 @@ sub insert {
         return $error;
       }
     }
         return $error;
       }
     }

+
+  } elsif ( $options{'options'} ) {
+
+    warn "  inserting part_pkg_option records for options hashref" if $DEBUG;
+    foreach my $optionname ( keys %{$options{'options'}} ) {
+
+      my $part_pkg_option =
+        new FS::part_pkg_option {
+          'pkgpart'     => $self->pkgpart,
+          'optionname'  => $optionname,
+          'optionvalue' => $options{'options'}->{$optionname},
+        };
+
+      my $error = $part_pkg_option->insert;
+      if ( $error ) {
+        $dbh->rollback if $oldAutoCommit;
+        return $error;
+      }
+
+    }
+

   }
 
   my $conf = new FS::Conf;
   }
 
   my $conf = new FS::Conf;


@@ -203,7 +244,10 @@ sub insert {
   my $pkg_svc = $options{'pkg_svc'} || {};
   foreach my $part_svc ( qsearch('part_svc', {} ) ) {
     my $quantity = $pkg_svc->{$part_svc->svcpart} || 0;
   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 $primary_svc =
+      ( $options{'primary_svc'} && $options{'primary_svc'}==$part_svc->svcpart )
+        ? 'Y'
+        : '';

 
     my $pkg_svc = new FS::pkg_svc( {
       'pkgpart'     => $self->pkgpart,
 
     my $pkg_svc = new FS::pkg_svc( {
       'pkgpart'     => $self->pkgpart,


@@ -272,6 +316,12 @@ FS::pkg_svc record will be updated.
 sub replace {
   my( $new, $old ) = ( shift, shift );
   my %options = @_;
 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;
   warn "FS::part_pkg::replace called on $new to replace $old ".
        "with options %options"
     if $DEBUG;


@@ -345,6 +395,7 @@ sub replace {
     next unless $old_quantity != $quantity || $old_primary_svc ne $primary_svc;
   
     my $new_pkg_svc = new FS::pkg_svc( {
     next unless $old_quantity != $quantity || $old_primary_svc ne $primary_svc;
   
     my $new_pkg_svc = new FS::pkg_svc( {

+      'pkgsvcnum'   => ( $old_pkg_svc ? $old_pkg_svc->pkgsvcnum : '' ),

       'pkgpart'     => $new->pkgpart,
       'svcpart'     => $part_svc->svcpart,
       'quantity'    => $quantity, 
       'pkgpart'     => $new->pkgpart,
       'svcpart'     => $part_svc->svcpart,
       'quantity'    => $quantity, 


@@ -387,7 +438,7 @@ sub check {
     my $error = $self->ut_number('freq');
     return $error if $error;
   } else {
     my $error = $self->ut_number('freq');
     return $error if $error;
   } else {

-    $self->freq =~ /^(\d+[dw]?)$/
+    $self->freq =~ /^(\d+[hdw]?)$/

       or return "Illegal or empty freq: ". $self->freq;
     $self->freq($1);
   }
       or return "Illegal or empty freq: ". $self->freq;
     $self->freq($1);
   }


@@ -401,16 +452,72 @@ sub check {
     || $self->ut_enum('recurtax', [ '', 'Y' ] )
     || $self->ut_textn('taxclass')
     || $self->ut_enum('disabled', [ '', 'Y' ] )
     || $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->ut_agentnum_acl('agentnum', 'Edit global package definitions')

     || $self->SUPER::check
   ;
   return $error if $error;
 
     || $self->SUPER::check
   ;
   return $error if $error;
 

+  if ( $self->classnum !~ /^$/ ) {
+    my $error = $self->ut_foreign_key('classnum', 'pkg_class', 'classnum');
+    return $error if $error;
+  } else {
+    $self->classnum('');
+  }
+

   return 'Unknown plan '. $self->plan
     unless exists($plans{$self->plan});
 
   return 'Unknown plan '. $self->plan
     unless exists($plans{$self->plan});
 

+  my $conf = new FS::Conf;
+  return 'Taxclass is required'
+    if ! $self->taxclass && $conf->exists('require_taxclasses');
+

   '';
 }
 
   '';
 }
 

+=item pkg_class
+
+Returns the package class, as an FS::pkg_class object, or the empty string
+if there is no package class.
+
+=cut
+
+sub pkg_class {
+  my $self = shift;
+  if ( $self->classnum ) {
+    qsearchs('pkg_class', { 'classnum' => $self->classnum } );
+  } else {
+    return '';
+  }
+}
+
+=item classname 
+
+Returns the package class name, or the empty string if there is no package
+class.
+
+=cut
+
+sub classname {
+  my $self = shift;
+  my $pkg_class = $self->pkg_class;
+  $pkg_class
+    ? $pkg_class->classname
+    : '';
+}
+
+=item agent 
+
+Returns the associated agent for this event, if any, as an FS::agent object.
+
+=cut
+
+sub agent {
+  my $self = shift;
+  qsearchs('agent', { 'agentnum' => $self->agentnum } );
+}
+

 =item pkg_svc
 
 Returns all FS::pkg_svc objects (see L<FS::pkg_svc>) for this package
 =item pkg_svc
 
 Returns all FS::pkg_svc objects (see L<FS::pkg_svc>) for this package


@@ -493,6 +600,38 @@ sub is_free {
   }
 }
 
   }
 }
 

+
+sub freqs_href {
+  #method, class method or sub? #my $self = shift;
+
+  tie my %freq, 'Tie::IxHash', 
+    '0'    => '(no recurring fee)',
+    '1h'   => 'hourly',
+    '1d'   => 'daily',
+    '2d'   => 'every two days',
+    '3d'   => 'every three days',
+    '1w'   => 'weekly',
+    '2w'   => 'biweekly (every 2 weeks)',
+    '1'    => 'monthly',
+    '45d'  => 'every 45 days',
+    '2'    => 'bimonthly (every 2 months)',
+    '3'    => 'quarterly (every 3 months)',
+    '4'    => 'every 4 months',
+    '137d' => 'every 4 1/2 months (137 days)',
+    '6'    => 'semiannually (every 6 months)',
+    '12'   => 'annually',
+    '13'   => 'every 13 months (annually +1 month)',
+    '24'   => 'biannually (every 2 years)',
+    '36'   => 'triannually (every 3 years)',
+    '48'   => '(every 4 years)',
+    '60'   => '(every 5 years)',
+    '120'  => '(every 10 years)',
+  ;
+
+  \%freq;
+
+}
+

 =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",


@@ -500,28 +639,19 @@ Returns an english representation of the I<freq> field, such as "monthly",
 
 =cut
 
 
 =cut
 

-tie %freq, 'Tie::IxHash', 
-  '0'  => '(no recurring fee)',
-  '1d' => 'daily',
-  '1w' => 'weekly',
-  '2w' => 'biweekly (every 2 weeks)',
-  '1'  => 'monthly',
-  '2'  => 'bimonthly (every 2 months)',
-  '3'  => 'quarterly (every 3 months)',
-  '6'  => 'semiannually (every 6 months)',
-  '12' => 'annually',
-  '24' => 'biannually (every 2 years)',
-;
-

 sub freq_pretty {
   my $self = shift;
   my $freq = $self->freq;
 sub freq_pretty {
   my $self = shift;
   my $freq = $self->freq;

-  if ( exists($freq{$freq}) ) {
-    $freq{$freq};
+
+  #my $freqs_href = $self->freqs_href;
+  my $freqs_href = freqs_href();
+
+  if ( exists($freqs_href->{$freq}) ) {
+    $freqs_href->{$freq};

   } else {
     my $interval = 'month';
   } else {
     my $interval = 'month';

-    if ( $freq =~ /^(\d+)([dw])$/ ) {
-      my %interval = ( 'd'=>'day', 'w'=>'week' );
+    if ( $freq =~ /^(\d+)([hdw])$/ ) {
+      my %interval = ( 'h' => 'hour', 'd'=>'day', 'w'=>'week' );

       $interval = $interval{$2};
     }
     if ( $1 == 1 ) {
       $interval = $interval{$2};
     }
     if ( $1 == 1 ) {


@@ -582,7 +712,7 @@ Returns the option value for the given name, or the empty string.
 =cut
 
 sub option {
 =cut
 
 sub option {

-  my( $self, $opt ) = @_;
+  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,


@@ -592,10 +722,71 @@ sub option {
   my %plandata = map { /^(\w+)=(.*)$/; ( $1 => $2 ); }
                      split("\n", $self->get('plandata') );
   return $plandata{$opt} if exists $plandata{$opt};
   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";
+  cluck "WARNING: (pkgpart ". $self->pkgpart. ") Package def option $opt ".
+        "not found in options or plandata!\n"
+    unless $ornull;

   '';
 }
 
   '';
 }
 

+=item part_pkg_taxoverride
+
+Returns all options as FS::part_pkg_taxoverride objects (see
+L<FS::part_pkg_taxoverride>).
+
+=cut
+
+sub part_pkg_taxoverride {
+  my $self = shift;
+  qsearch('part_pkg_taxoverride', { 'pkgpart' => $self->pkgpart } );
+}
+
+=item taxproduct_description
+
+Returns the description of the associated tax product for this package
+definition (see L<FS::part_pkg_taxproduct>).
+
+=cut
+
+sub taxproduct_description {
+  my $self = shift;
+  my $part_pkg_taxproduct =
+    qsearchs( 'part_pkg_taxproduct',
+              { 'taxproductnum' => $self->taxproductnum }
+            );
+  $part_pkg_taxproduct ? $part_pkg_taxproduct->description : '';
+}
+
+=item part_pkg_taxrate DATA_PROVIDER, GEOCODE
+
+Returns the package to taxrate m2m records for this package in the location
+specified by GEOCODE (see L<FS::part_pkg_taxrate> and ).
+
+=cut
+
+sub part_pkg_taxrate {
+  my $self = shift;
+  my ($data_provider, $geocode) = @_;
+
+  my $dbh = dbh;
+  # CCH oddness in m2m
+  my $extra_sql = 'AND ('.
+    join(' OR ', map{ 'geocode = '. $dbh->quote(substr($geocode, 0, $_)) }
+                 qw(10 5 2)
+        ).
+    ')';
+  my $order_by = 'ORDER BY taxclassnum, length(geocode) desc';
+  my $select   = 'DISTINCT ON(taxclassnum) *';
+
+  qsearch( { 'table'     => 'part_pkg_taxrate',
+             'select'    => 'distinct on(taxclassnum) *',
+             'hashref'   => { 'data_provider' => $data_provider,
+                              'taxproductnum' => $self->taxproductnum,
+                            },
+             'extra_sql' => $extra_sql,
+             'order_by'  => $order_by,
+         } );
+}
+

 =item _rebless
 
 Reblesses the object into the FS::part_pkg::PLAN class (if available), where
 =item _rebless
 
 Reblesses the object into the FS::part_pkg::PLAN class (if available), where


@@ -607,9 +798,16 @@ on how to create new price plans, but until then, see L</NEW PLAN CLASSES>.
 sub _rebless {
   my $self = shift;
   my $plan = $self->plan;
 sub _rebless {
   my $self = shift;
   my $plan = $self->plan;

+  unless ( $plan ) {
+    confess "no price plan found for pkgpart ". $self->pkgpart. "\n"
+      if $DEBUG;
+    return $self;
+  }
+  return $self if ref($self) =~ /::$plan$/; #already blessed into plan subclass

   my $class = ref($self). "::$plan";
   my $class = ref($self). "::$plan";

+  warn "reblessing $self into $class" if $DEBUG;

   eval "use $class;";
   eval "use $class;";

-  #die $@ if $@;
+  die $@ if $@;

   bless($self, $class) unless $@;
   $self;
 }
   bless($self, $class) unless $@;
   $self;
 }


@@ -644,6 +842,11 @@ sub _calc_eval {
   $value;
 }
 
   $value;
 }
 

+#fallback that return 0 for old legacy packages with no plan
+
+sub calc_remain { 0; }
+sub calc_cancel { 0; }
+

 =back
 
 =head1 SUBROUTINES
 =back
 
 =head1 SUBROUTINES


@@ -656,6 +859,7 @@ sub _calc_eval {
 
 my %info;
 foreach my $INC ( @INC ) {
 
 my %info;
 foreach my $INC ( @INC ) {

+  warn "globbing $INC/FS/part_pkg/*.pm\n" if $DEBUG;

   foreach my $file ( glob("$INC/FS/part_pkg/*.pm") ) {
     warn "attempting to load plan info from $file\n" if $DEBUG;
     $file =~ /\/(\w+)\.pm$/ or do {
   foreach my $file ( glob("$INC/FS/part_pkg/*.pm") ) {
     warn "attempting to load plan info from $file\n" if $DEBUG;
     $file =~ /\/(\w+)\.pm$/ or do {


@@ -692,19 +896,55 @@ sub plan_info {
   \%plans;
 }
 
   \%plans;
 }
 

+=item format OPTION DATA
+
+Returns data formatted according to the function 'format' described
+in the plan info.  Returns DATA if no such function exists.
+
+=cut
+
+sub format {
+  my ($self, $option, $data) = (shift, shift, shift);
+  if (exists($plans{$self->plan}->{fields}->{$option}{format})) {
+    &{$plans{$self->plan}->{fields}->{$option}{format}}($data);
+  }else{
+    $data;
+  }
+}
+
+=item parse OPTION DATA
+
+Returns data parsed according to the function 'parse' described
+in the plan info.  Returns DATA if no such function exists.
+
+=cut
+
+sub parse {
+  my ($self, $option, $data) = (shift, shift, shift);
+  if (exists($plans{$self->plan}->{fields}->{$option}{parse})) {
+    &{$plans{$self->plan}->{fields}->{$option}{parse}}($data);
+  }else{
+    $data;
+  }
+}
+
+

 =back
 
 =head1 NEW PLAN CLASSES
 
 =back
 
 =head1 NEW PLAN CLASSES
 

-A module should be added in FS/FS/part_pkg/ (an example may be found in
-eg/plan_template.pm)
+A module should be added in FS/FS/part_pkg/  Eventually, an example may be
+found in eg/plan_template.pm.  Until then, it is suggested that you use the
+other modules in FS/FS/part_pkg/ as a guide.

 
 =head1 BUGS
 
 The delete method is unimplemented.
 
 setup and recur semantics are not yet defined (and are implemented in
 
 =head1 BUGS
 
 The delete method is unimplemented.
 
 setup and recur semantics are not yet defined (and are implemented in

-FS::cust_bill.  hmm.).
+FS::cust_bill.  hmm.).  now they're deprecated and need to go.
+
+plandata should go

 
 =head1 SEE ALSO
 
 
 =head1 SEE ALSO