FS/FS/part_pkg.pm

   1 package FS::part_pkg;
   2
   3 use strict;
   4 use vars qw( @ISA %freq %plans $DEBUG );
   5 use Carp qw(carp cluck);
   6 use Tie::IxHash;
   7 use FS::Conf;
   8 use FS::Record qw( qsearch qsearchs dbh dbdef );
   9 use FS::pkg_svc;
  10 use FS::agent_type;
  11 use FS::type_pkgs;
  12 use FS::part_pkg_option;
  13
  14 @ISA = qw( FS::Record );
  15
  16 $DEBUG = 0;
  17
  18 =head1 NAME
  19
  20 FS::part_pkg - Object methods for part_pkg objects
  21
  22 =head1 SYNOPSIS
  23
  24   use FS::part_pkg;
  25
  26   $record = new FS::part_pkg \%hash
  27   $record = new FS::part_pkg { 'column' => 'value' };
  28
  29   $custom_record = $template_record->clone;
  30
  31   $error = $record->insert;
  32
  33   $error = $new_record->replace($old_record);
  34
  35   $error = $record->delete;
  36
  37   $error = $record->check;
  38
  39   @pkg_svc = $record->pkg_svc;
  40
  41   $svcnum = $record->svcpart;
  42   $svcnum = $record->svcpart( 'svc_acct' );
  43
  44 =head1 DESCRIPTION
  45
  46 An FS::part_pkg object represents a package definition.  FS::part_pkg
  47 inherits from FS::Record.  The following fields are currently supported:
  48
  49 =over 4
  50
  51 =item pkgpart - primary key (assigned automatically for new package definitions)
  52
  53 =item pkg - Text name of this package definition (customer-viewable)
  54
  55 =item comment - Text name of this package definition (non-customer-viewable)
  56
  57 =item promo_code - Promotional code
  58
  59 =item setup - Setup fee expression (deprecated)
  60
  61 =item freq - Frequency of recurring fee
  62
  63 =item recur - Recurring fee expression (deprecated)
  64
  65 =item setuptax - Setup fee tax exempt flag, empty or `Y'
  66
  67 =item recurtax - Recurring fee tax exempt flag, empty or `Y'
  68
  69 =item taxclass - Tax class
  70
  71 =item plan - Price plan
  72
  73 =item plandata - Price plan data (deprecated - see L<FS::part_pkg_option> instead)
  74
  75 =item disabled - Disabled flag, empty or `Y'
  76
  77 =back
  78
  79 =head1 METHODS
  80
  81 =over 4
  82
  83 =item new HASHREF
  84
  85 Creates a new package definition.  To add the package definition to
  86 the database, see L<"insert">.
  87
  88 =cut
  89
  90 sub table { 'part_pkg'; }
  91
  92 =item clone
  93
  94 An alternate constructor.  Creates a new package definition by duplicating
  95 an existing definition.  A new pkgpart is assigned and `(CUSTOM) ' is prepended
  96 to the comment field.  To add the package definition to the database, see
  97 L<"insert">.
  98
  99 =cut
 100
 101 sub clone {
 102   my $self = shift;
 103   my $class = ref($self);
 104   my %hash = $self->hash;
 105   $hash{'pkgpart'} = '';
 106   $hash{'comment'} = "(CUSTOM) ". $hash{'comment'}
 107     unless $hash{'comment'} =~ /^\(CUSTOM\) /;
 108   #new FS::part_pkg ( \%hash ); # ?
 109   new $class ( \%hash ); # ?
 110 }
 111
 112 =item insert
 113
 114 Adds this package definition to the database.  If there is an error,
 115 returns the error, otherwise returns false.
 116
 117 =cut
 118
 119 sub insert {
 120   my $self = shift;
 121   warn "FS::part_pkg::insert called on $self" if $DEBUG;
 122
 123   local $SIG{HUP} = 'IGNORE';
 124   local $SIG{INT} = 'IGNORE';
 125   local $SIG{QUIT} = 'IGNORE';
 126   local $SIG{TERM} = 'IGNORE';
 127   local $SIG{TSTP} = 'IGNORE';
 128   local $SIG{PIPE} = 'IGNORE';
 129
 130   my $oldAutoCommit = $FS::UID::AutoCommit;
 131   local $FS::UID::AutoCommit = 0;
 132   my $dbh = dbh;
 133
 134   warn "  saving legacy plandata" if $DEBUG;
 135   my $plandata = $self->get('plandata');
 136   $self->set('plandata', '');
 137
 138   warn "  inserting part_pkg record" if $DEBUG;
 139   my $error = $self->SUPER::insert;
 140   if ( $error ) {
 141     $dbh->rollback if $oldAutoCommit;
 142     return $error;
 143   }
 144
 145   if ( $plandata ) {
 146   warn "  inserting part_pkg_option records for plandata" if $DEBUG;
 147     foreach my $part_pkg_option (
 148       map { /^(\w+)=(.*)$/ or do { $dbh->rollback if $oldAutoCommit;
 149                                    return "illegal plandata: $plandata";
 150                                  };
 151             new FS::part_pkg_option {
 152               'pkgpart'     => $self->pkgpart,
 153               'optionname'  => $1,
 154               'optionvalue' => $2,
 155             };
 156           }
 157       split("\n", $plandata)
 158     ) {
 159       my $error = $part_pkg_option->insert;
 160       if ( $error ) {
 161         $dbh->rollback if $oldAutoCommit;
 162         return $error;
 163       }
 164     }
 165   }
 166
 167   my $conf = new FS::Conf;
 168   if ( $conf->exists('agent_defaultpkg') ) {
 169     warn "  agent_defaultpkg set; allowing all agents to purchase package"
 170       if $DEBUG;
 171     foreach my $agent_type ( qsearch('agent_type', {} ) ) {
 172       my $type_pkgs = new FS::type_pkgs({
 173         'typenum' => $agent_type->typenum,
 174         'pkgpart' => $self->pkgpart,
 175       });
 176       my $error = $type_pkgs->insert;
 177       if ( $error ) {
 178         $dbh->rollback if $oldAutoCommit;
 179         return $error;
 180       }
 181     }
 182   }
 183
 184   warn "  commiting transaction" if $DEBUG;
 185   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 186
 187   '';
 188 }
 189
 190 =item delete
 191
 192 Currently unimplemented.
 193
 194 =cut
 195
 196 sub delete {
 197   return "Can't (yet?) delete package definitions.";
 198 # check & make sure the pkgpart isn't in cust_pkg or type_pkgs?
 199 }
 200
 201 =item replace OLD_RECORD
 202
 203 Replaces OLD_RECORD with this one in the database.  If there is an error,
 204 returns the error, otherwise returns false.
 205
 206 =cut
 207
 208 sub replace {
 209   my( $new, $old ) = ( shift, shift );
 210
 211   local $SIG{HUP} = 'IGNORE';
 212   local $SIG{INT} = 'IGNORE';
 213   local $SIG{QUIT} = 'IGNORE';
 214   local $SIG{TERM} = 'IGNORE';
 215   local $SIG{TSTP} = 'IGNORE';
 216   local $SIG{PIPE} = 'IGNORE';
 217
 218   my $oldAutoCommit = $FS::UID::AutoCommit;
 219   local $FS::UID::AutoCommit = 0;
 220   my $dbh = dbh;
 221
 222   my $plandata = $new->get('plandata');
 223   $new->set('plandata', '');
 224
 225   foreach my $part_pkg_option ( $old->part_pkg_option ) {
 226     my $error = $part_pkg_option->delete;
 227     if ( $error ) {
 228       $dbh->rollback if $oldAutoCommit;
 229       return $error;
 230     }
 231   }
 232
 233   my $error = $new->SUPER::replace($old);
 234   if ( $error ) {
 235     $dbh->rollback if $oldAutoCommit;
 236     return $error;
 237   }
 238
 239   foreach my $part_pkg_option (
 240     map { /^(\w+)=(.*)$/ or do { $dbh->rollback if $oldAutoCommit;
 241                                  return "illegal plandata: $plandata";
 242                                };
 243           new FS::part_pkg_option {
 244             'pkgpart'     => $new->pkgpart,
 245             'optionname'  => $1,
 246             'optionvalue' => $2,
 247           };
 248         }
 249     split("\n", $plandata)
 250   ) {
 251     my $error = $part_pkg_option->insert;
 252     if ( $error ) {
 253       $dbh->rollback if $oldAutoCommit;
 254       return $error;
 255     }
 256   }
 257
 258   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 259   '';
 260 }
 261
 262 =item check
 263
 264 Checks all fields to make sure this is a valid package definition.  If
 265 there is an error, returns the error, otherwise returns false.  Called by the
 266 insert and replace methods.
 267
 268 =cut
 269
 270 sub check {
 271   my $self = shift;
 272   warn "FS::part_pkg::check called on $self" if $DEBUG;
 273
 274   for (qw(setup recur plandata)) {
 275     #$self->set($_=>0) if $self->get($_) =~ /^\s*$/; }
 276     return "Use of $_ field is deprecated; set a plan and options"
 277       if length($self->get($_));
 278     $self->set($_, '');
 279   }
 280
 281   if ( $self->dbdef_table->column('freq')->type =~ /(int)/i ) {
 282     my $error = $self->ut_number('freq');
 283     return $error if $error;
 284   } else {
 285     $self->freq =~ /^(\d+[dw]?)$/
 286       or return "Illegal or empty freq: ". $self->freq;
 287     $self->freq($1);
 288   }
 289
 290   my $error = $self->ut_numbern('pkgpart')
 291     || $self->ut_text('pkg')
 292     || $self->ut_text('comment')
 293     || $self->ut_textn('promo_code')
 294     || $self->ut_alphan('plan')
 295     || $self->ut_enum('setuptax', [ '', 'Y' ] )
 296     || $self->ut_enum('recurtax', [ '', 'Y' ] )
 297     || $self->ut_textn('taxclass')
 298     || $self->ut_enum('disabled', [ '', 'Y' ] )
 299     || $self->SUPER::check
 300   ;
 301   return $error if $error;
 302
 303   return 'Unknown plan '. $self->plan
 304     unless exists($plans{$self->plan});
 305
 306   '';
 307 }
 308
 309 =item pkg_svc
 310
 311 Returns all FS::pkg_svc objects (see L<FS::pkg_svc>) for this package
 312 definition (with non-zero quantity).
 313
 314 =cut
 315
 316 sub pkg_svc {
 317   my $self = shift;
 318   #sort { $b->primary cmp $a->primary }
 319     grep { $_->quantity }
 320       qsearch( 'pkg_svc', { 'pkgpart' => $self->pkgpart } );
 321 }
 322
 323 =item svcpart [ SVCDB ]
 324
 325 Returns the svcpart of the primary service definition (see L<FS::part_svc>)
 326 associated with this package definition (see L<FS::pkg_svc>).  Returns
 327 false if there not a primary service definition or exactly one service
 328 definition with quantity 1, or if SVCDB is specified and does not match the
 329 svcdb of the service definition,
 330
 331 =cut
 332
 333 sub svcpart {
 334   my $self = shift;
 335   my $svcdb = scalar(@_) ? shift : '';
 336   my @svcdb_pkg_svc =
 337     grep { ( $svcdb eq $_->part_svc->svcdb || !$svcdb ) } $self->pkg_svc;
 338   my @pkg_svc = ();
 339   @pkg_svc = grep { $_->primary_svc =~ /^Y/i } @svcdb_pkg_svc
 340     if dbdef->table('pkg_svc')->column('primary_svc');
 341   @pkg_svc = grep {$_->quantity == 1 } @svcdb_pkg_svc
 342     unless @pkg_svc;
 343   return '' if scalar(@pkg_svc) != 1;
 344   $pkg_svc[0]->svcpart;
 345 }
 346
 347 =item payby
 348
 349 Returns a list of the acceptable payment types for this package.  Eventually
 350 this should come out of a database table and be editable, but currently has the
 351 following logic instead;
 352
 353 If the package has B<0> setup and B<0> recur, the single item B<BILL> is
 354 returned, otherwise, the single item B<CARD> is returned.
 355
 356 (CHEK?  LEC?  Probably shouldn't accept those by default, prone to abuse)
 357
 358 =cut
 359
 360 sub payby {
 361   my $self = shift;
 362   #if ( $self->setup == 0 && $self->recur == 0 ) {
 363   if (    $self->setup =~ /^\s*0+(\.0*)?\s*$/
 364        && $self->recur =~ /^\s*0+(\.0*)?\s*$/ ) {
 365     ( 'BILL' );
 366   } else {
 367     ( 'CARD' );
 368   }
 369 }
 370
 371 =item freq_pretty
 372
 373 Returns an english representation of the I<freq> field, such as "monthly",
 374 "weekly", "semi-annually", etc.
 375
 376 =cut
 377
 378 tie %freq, 'Tie::IxHash',
 379   '0'  => '(no recurring fee)',
 380   '1d' => 'daily',
 381   '1w' => 'weekly',
 382   '2w' => 'biweekly (every 2 weeks)',
 383   '1'  => 'monthly',
 384   '2'  => 'bimonthly (every 2 months)',
 385   '3'  => 'quarterly (every 3 months)',
 386   '6'  => 'semiannually (every 6 months)',
 387   '12' => 'annually',
 388   '24' => 'biannually (every 2 years)',
 389 ;
 390
 391 sub freq_pretty {
 392   my $self = shift;
 393   my $freq = $self->freq;
 394   if ( exists($freq{$freq}) ) {
 395     $freq{$freq};
 396   } else {
 397     my $interval = 'month';
 398     if ( $freq =~ /^(\d+)([dw])$/ ) {
 399       my %interval = ( 'd'=>'day', 'w'=>'week' );
 400       $interval = $interval{$2};
 401     }
 402     if ( $1 == 1 ) {
 403       "every $interval";
 404     } else {
 405       "every $freq ${interval}s";
 406     }
 407   }
 408 }
 409
 410 =item plandata
 411
 412 For backwards compatibility, returns the plandata field as well as all options
 413 from FS::part_pkg_option.
 414
 415 =cut
 416
 417 sub plandata {
 418   my $self = shift;
 419   carp "plandata is deprecated";
 420   if ( @_ ) {
 421     $self->SUPER::plandata(@_);
 422   } else {
 423     my $plandata = $self->get('plandata');
 424     my %options = $self->options;
 425     $plandata .= join('', map { "$_=$options{$_}\n" } keys %options );
 426     $plandata;
 427   }
 428 }
 429
 430 =item part_pkg_option
 431
 432 Returns all options as FS::part_pkg_option objects (see
 433 L<FS::part_pkg_option>).
 434
 435 =cut
 436
 437 sub part_pkg_option {
 438   my $self = shift;
 439   qsearch('part_pkg_option', { 'pkgpart' => $self->pkgpart } );
 440 }
 441
 442 =item options
 443
 444 Returns a list of option names and values suitable for assigning to a hash.
 445
 446 =cut
 447
 448 sub options {
 449   my $self = shift;
 450   map { $_->optionname => $_->optionvalue } $self->part_pkg_option;
 451 }
 452
 453 =item option OPTIONNAME
 454
 455 Returns the option value for the given name, or the empty string.
 456
 457 =cut
 458
 459 sub option {
 460   my( $self, $opt ) = @_;
 461   my $part_pkg_option =
 462     qsearchs('part_pkg_option', {
 463       pkgpart    => $self->pkgpart,
 464       optionname => $opt,
 465   } );
 466   return $part_pkg_option->optionvalue if $part_pkg_option;
 467   my %plandata = map { /^(\w+)=(.*)$/; ( $1 => $2 ); }
 468                      split("\n", $self->get('plandata') );
 469   return $plandata{$opt} if exists $plandata{$opt};
 470   cluck "Package definition option $opt not found in options or plandata!\n";
 471   '';
 472 }
 473
 474 =item _rebless
 475
 476 Reblesses the object into the FS::part_pkg::PLAN class (if available), where
 477 PLAN is the object's I<plan> field.  There should be better docs
 478 on how to create new price plans, but until then, see L</NEW PLAN CLASSES>.
 479
 480 =cut
 481
 482 sub _rebless {
 483   my $self = shift;
 484   my $plan = $self->plan;
 485   my $class = ref($self). "::$plan";
 486   eval "use $class;";
 487   #die $@ if $@;
 488   bless($self, $class) unless $@;
 489   $self;
 490 }
 491
 492 #fallbacks that eval the setup and recur fields, for backwards compat
 493
 494 sub calc_setup {
 495   my $self = shift;
 496   warn 'no price plan class for '. $self->plan. ", eval-ing setup\n";
 497   $self->_calc_eval('setup', @_);
 498 }
 499
 500 sub calc_recur {
 501   my $self = shift;
 502   warn 'no price plan class for '. $self->plan. ", eval-ing recur\n";
 503   $self->_calc_eval('recur', @_);
 504 }
 505
 506 use vars qw( $sdate @details );
 507 sub _calc_eval {
 508   #my( $self, $field, $cust_pkg ) = @_;
 509   my( $self, $field, $cust_pkg, $sdateref, $detailsref ) = @_;
 510   *sdate = $sdateref;
 511   *details = $detailsref;
 512   $self->$field() =~ /^(.*)$/
 513     or die "Illegal $field (pkgpart ". $self->pkgpart. '): '.
 514             $self->$field(). "\n";
 515   my $prog = $1;
 516   return 0 if $prog =~ /^\s*$/;
 517   my $value = eval $prog;
 518   die $@ if $@;
 519   $value;
 520 }
 521
 522 =back
 523
 524 =head1 SUBROUTINES
 525
 526 =over 4
 527
 528 =item plan_info
 529
 530 =cut
 531
 532 my %info;
 533 foreach my $INC ( @INC ) {
 534   foreach my $file ( glob("$INC/FS/part_pkg/*.pm") ) {
 535     warn "attempting to load plan info from $file\n" if $DEBUG;
 536     $file =~ /\/(\w+)\.pm$/ or do {
 537       warn "unrecognized file in $INC/FS/part_pkg/: $file\n";
 538       next;
 539     };
 540     my $mod = $1;
 541     my $info = eval "use FS::part_pkg::$mod; ".
 542                     "\\%FS::part_pkg::$mod\::info;";
 543     if ( $@ ) {
 544       die "error using FS::part_pkg::$mod (skipping): $@\n" if $@;
 545       next;
 546     }
 547     unless ( keys %$info ) {
 548       warn "no %info hash found in FS::part_pkg::$mod, skipping\n"
 549         unless $mod =~ /^(passwdfile|null)$/; #hack but what the heck
 550       next;
 551     }
 552     warn "got plan info from FS::part_pkg::$mod: $info\n" if $DEBUG;
 553     if ( exists($info->{'disabled'}) && $info->{'disabled'} ) {
 554       warn "skipping disabled plan FS::part_pkg::$mod" if $DEBUG;
 555       next;
 556     }
 557     $info{$mod} = $info;
 558   }
 559 }
 560
 561 tie %plans, 'Tie::IxHash',
 562   map { $_ => $info{$_} }
 563   sort { $info{$a}->{'weight'} <=> $info{$b}->{'weight'} }
 564   keys %info;
 565
 566 sub plan_info {
 567   \%plans;
 568 }
 569
 570 =back
 571
 572 =head1 NEW PLAN CLASSES
 573
 574 A module should be added in FS/FS/part_pkg/ (an example may be found in
 575 eg/plan_template.pm)
 576
 577 =head1 BUGS
 578
 579 The delete method is unimplemented.
 580
 581 setup and recur semantics are not yet defined (and are implemented in
 582 FS::cust_bill.  hmm.).
 583
 584 =head1 SEE ALSO
 585
 586 L<FS::Record>, L<FS::cust_pkg>, L<FS::type_pkgs>, L<FS::pkg_svc>, L<Safe>.
 587 schema.html from the base documentation.
 588
 589 =cut
 590
 591 1;
 592