FS/FS/part_pkg.pm

   1 package FS::part_pkg;
   2
   3 use strict;
   4 use vars qw( @ISA %plans $DEBUG $setup_hack $skip_pkg_svc_hack );
   5 use Carp qw(carp cluck confess);
   6 use Scalar::Util qw( blessed );
   7 use Time::Local qw( timelocal_nocheck );
   8 use Tie::IxHash;
   9 use FS::Conf;
  10 use FS::Record qw( qsearch qsearchs dbh dbdef );
  11 use FS::pkg_svc;
  12 use FS::part_svc;
  13 use FS::cust_pkg;
  14 use FS::agent_type;
  15 use FS::type_pkgs;
  16 use FS::part_pkg_option;
  17 use FS::pkg_class;
  18 use FS::agent;
  19 use FS::part_pkg_taxoverride;
  20 use FS::part_pkg_taxproduct;
  21 use FS::part_pkg_link;
  22
  23 @ISA = qw( FS::m2m_Common FS::option_Common );
  24 $DEBUG = 0;
  25 $setup_hack = 0;
  26 $skip_pkg_svc_hack = 0;
  27
  28 =head1 NAME
  29
  30 FS::part_pkg - Object methods for part_pkg objects
  31
  32 =head1 SYNOPSIS
  33
  34   use FS::part_pkg;
  35
  36   $record = new FS::part_pkg \%hash
  37   $record = new FS::part_pkg { 'column' => 'value' };
  38
  39   $custom_record = $template_record->clone;
  40
  41   $error = $record->insert;
  42
  43   $error = $new_record->replace($old_record);
  44
  45   $error = $record->delete;
  46
  47   $error = $record->check;
  48
  49   @pkg_svc = $record->pkg_svc;
  50
  51   $svcnum = $record->svcpart;
  52   $svcnum = $record->svcpart( 'svc_acct' );
  53
  54 =head1 DESCRIPTION
  55
  56 An FS::part_pkg object represents a package definition.  FS::part_pkg
  57 inherits from FS::Record.  The following fields are currently supported:
  58
  59 =over 4
  60
  61 =item pkgpart - primary key (assigned automatically for new package definitions)
  62
  63 =item pkg - Text name of this package definition (customer-viewable)
  64
  65 =item comment - Text name of this package definition (non-customer-viewable)
  66
  67 =item classnum - Optional package class (see L<FS::pkg_class>)
  68
  69 =item promo_code - Promotional code
  70
  71 =item setup - Setup fee expression (deprecated)
  72
  73 =item freq - Frequency of recurring fee
  74
  75 =item recur - Recurring fee expression (deprecated)
  76
  77 =item setuptax - Setup fee tax exempt flag, empty or `Y'
  78
  79 =item recurtax - Recurring fee tax exempt flag, empty or `Y'
  80
  81 =item taxclass - Tax class
  82
  83 =item plan - Price plan
  84
  85 =item plandata - Price plan data (deprecated - see L<FS::part_pkg_option> instead)
  86
  87 =item disabled - Disabled flag, empty or `Y'
  88
  89 =item custom - Custom flag, empty or `Y'
  90
  91 =item setup_cost - for cost tracking
  92
  93 =item recur_cost - for cost tracking
  94
  95 =item pay_weight - Weight (relative to credit_weight and other package definitions) that controls payment application to specific line items.
  96
  97 =item credit_weight - Weight (relative to other package definitions) that controls credit application to specific line items.
  98
  99 =item agentnum - Optional agentnum (see L<FS::agent>)
 100
 101 =back
 102
 103 =head1 METHODS
 104
 105 =over 4
 106
 107 =item new HASHREF
 108
 109 Creates a new package definition.  To add the package definition to
 110 the database, see L<"insert">.
 111
 112 =cut
 113
 114 sub table { 'part_pkg'; }
 115
 116 =item clone
 117
 118 An alternate constructor.  Creates a new package definition by duplicating
 119 an existing definition.  A new pkgpart is assigned and the custom flag is
 120 set to Y.  To add the package definition to the database, see L<"insert">.
 121
 122 =cut
 123
 124 sub clone {
 125   my $self = shift;
 126   my $class = ref($self);
 127   my %hash = $self->hash;
 128   $hash{'pkgpart'} = '';
 129   $hash{'custom'} = 'Y';
 130   #new FS::part_pkg ( \%hash ); # ?
 131   new $class ( \%hash ); # ?
 132 }
 133
 134 =item insert [ , OPTION => VALUE ... ]
 135
 136 Adds this package definition to the database.  If there is an error,
 137 returns the error, otherwise returns false.
 138
 139 Currently available options are: I<pkg_svc>, I<primary_svc>, I<cust_pkg>,
 140 I<custnum_ref> and I<options>.
 141
 142 If I<pkg_svc> is set to a hashref with svcparts as keys and quantities as
 143 values, appropriate FS::pkg_svc records will be inserted.
 144
 145 If I<primary_svc> is set to the svcpart of the primary service, the appropriate
 146 FS::pkg_svc record will be updated.
 147
 148 If I<cust_pkg> is set to a pkgnum of a FS::cust_pkg record (or the FS::cust_pkg
 149 record itself), the object will be updated to point to this package definition.
 150
 151 In conjunction with I<cust_pkg>, if I<custnum_ref> is set to a scalar reference,
 152 the scalar will be updated with the custnum value from the cust_pkg record.
 153
 154 If I<tax_overrides> is set to a hashref with usage classes as keys and comma
 155 separated tax class numbers as values, appropriate FS::part_pkg_taxoverride
 156 records will be inserted.
 157
 158 If I<options> is set to a hashref of options, appropriate FS::part_pkg_option
 159 records will be inserted.
 160
 161 =cut
 162
 163 sub insert {
 164   my $self = shift;
 165   my %options = @_;
 166   warn "FS::part_pkg::insert called on $self with options ".
 167        join(', ', map "$_=>$options{$_}", keys %options)
 168     if $DEBUG;
 169
 170   local $SIG{HUP} = 'IGNORE';
 171   local $SIG{INT} = 'IGNORE';
 172   local $SIG{QUIT} = 'IGNORE';
 173   local $SIG{TERM} = 'IGNORE';
 174   local $SIG{TSTP} = 'IGNORE';
 175   local $SIG{PIPE} = 'IGNORE';
 176
 177   my $oldAutoCommit = $FS::UID::AutoCommit;
 178   local $FS::UID::AutoCommit = 0;
 179   my $dbh = dbh;
 180
 181   warn "  inserting part_pkg record" if $DEBUG;
 182   my $error = $self->SUPER::insert( $options{options} );
 183   if ( $error ) {
 184     $dbh->rollback if $oldAutoCommit;
 185     return $error;
 186   }
 187
 188   my $conf = new FS::Conf;
 189   if ( $conf->exists('agent_defaultpkg') ) {
 190     warn "  agent_defaultpkg set; allowing all agents to purchase package"
 191       if $DEBUG;
 192     foreach my $agent_type ( qsearch('agent_type', {} ) ) {
 193       my $type_pkgs = new FS::type_pkgs({
 194         'typenum' => $agent_type->typenum,
 195         'pkgpart' => $self->pkgpart,
 196       });
 197       my $error = $type_pkgs->insert;
 198       if ( $error ) {
 199         $dbh->rollback if $oldAutoCommit;
 200         return $error;
 201       }
 202     }
 203   }
 204
 205   warn "  inserting part_pkg_taxoverride records" if $DEBUG;
 206   my %overrides = %{ $options{'tax_overrides'} || {} };
 207   foreach my $usage_class ( keys %overrides ) {
 208     my $override =
 209       ( exists($overrides{$usage_class}) && defined($overrides{$usage_class}) )
 210         ? $overrides{$usage_class}
 211         : '';
 212     my @overrides = (grep "$_", split(',', $override) );
 213     my $error = $self->process_m2m (
 214                   'link_table'   => 'part_pkg_taxoverride',
 215                   'target_table' => 'tax_class',
 216                   'hashref'      => { 'usage_class' => $usage_class },
 217                   'params'       => \@overrides,
 218                 );
 219     if ( $error ) {
 220       $dbh->rollback if $oldAutoCommit;
 221       return $error;
 222     }
 223   }
 224
 225   unless ( $skip_pkg_svc_hack ) {
 226
 227     warn "  inserting pkg_svc records" if $DEBUG;
 228     my $pkg_svc = $options{'pkg_svc'} || {};
 229     foreach my $part_svc ( qsearch('part_svc', {} ) ) {
 230       my $quantity = $pkg_svc->{$part_svc->svcpart} || 0;
 231       my $primary_svc =
 232         ( $options{'primary_svc'} && $options{'primary_svc'}==$part_svc->svcpart )
 233           ? 'Y'
 234           : '';
 235
 236       my $pkg_svc = new FS::pkg_svc( {
 237         'pkgpart'     => $self->pkgpart,
 238         'svcpart'     => $part_svc->svcpart,
 239         'quantity'    => $quantity,
 240         'primary_svc' => $primary_svc,
 241       } );
 242       my $error = $pkg_svc->insert;
 243       if ( $error ) {
 244         $dbh->rollback if $oldAutoCommit;
 245         return $error;
 246       }
 247     }
 248
 249   }
 250
 251   if ( $options{'cust_pkg'} ) {
 252     warn "  updating cust_pkg record " if $DEBUG;
 253     my $old_cust_pkg =
 254       ref($options{'cust_pkg'})
 255         ? $options{'cust_pkg'}
 256         : qsearchs('cust_pkg', { pkgnum => $options{'cust_pkg'} } );
 257     ${ $options{'custnum_ref'} } = $old_cust_pkg->custnum
 258       if $options{'custnum_ref'};
 259     my %hash = $old_cust_pkg->hash;
 260     $hash{'pkgpart'} = $self->pkgpart,
 261     my $new_cust_pkg = new FS::cust_pkg \%hash;
 262     local($FS::cust_pkg::disable_agentcheck) = 1;
 263     my $error = $new_cust_pkg->replace($old_cust_pkg);
 264     if ( $error ) {
 265       $dbh->rollback if $oldAutoCommit;
 266       return "Error modifying cust_pkg record: $error";
 267     }
 268   }
 269
 270   warn "  commiting transaction" if $DEBUG;
 271   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 272
 273   '';
 274 }
 275
 276 =item delete
 277
 278 Currently unimplemented.
 279
 280 =cut
 281
 282 sub delete {
 283   return "Can't (yet?) delete package definitions.";
 284 # check & make sure the pkgpart isn't in cust_pkg or type_pkgs?
 285 }
 286
 287 =item replace OLD_RECORD [ , OPTION => VALUE ... ]
 288
 289 Replaces OLD_RECORD with this one in the database.  If there is an error,
 290 returns the error, otherwise returns false.
 291
 292 Currently available options are: I<pkg_svc>, I<primary_svc> and I<options>
 293
 294 If I<pkg_svc> is set to a hashref with svcparts as keys and quantities as
 295 values, the appropriate FS::pkg_svc records will be replaced.
 296
 297 If I<primary_svc> is set to the svcpart of the primary service, the appropriate
 298 FS::pkg_svc record will be updated.
 299
 300 If I<options> is set to a hashref, the appropriate FS::part_pkg_option records
 301 will be replaced.
 302
 303 =cut
 304
 305 sub replace {
 306   my $new = shift;
 307
 308   my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
 309               ? shift
 310               : $new->replace_old;
 311
 312   my $options =
 313     ( ref($_[0]) eq 'HASH' )
 314       ? shift
 315       : { @_ };
 316
 317   $options->{options} = {} unless defined($options->{options});
 318
 319   warn "FS::part_pkg::replace called on $new to replace $old with options".
 320        join(', ', map "$_ => ". $options->{$_}, keys %$options)
 321     if $DEBUG;
 322
 323   local $SIG{HUP} = 'IGNORE';
 324   local $SIG{INT} = 'IGNORE';
 325   local $SIG{QUIT} = 'IGNORE';
 326   local $SIG{TERM} = 'IGNORE';
 327   local $SIG{TSTP} = 'IGNORE';
 328   local $SIG{PIPE} = 'IGNORE';
 329
 330   my $oldAutoCommit = $FS::UID::AutoCommit;
 331   local $FS::UID::AutoCommit = 0;
 332   my $dbh = dbh;
 333
 334   #plandata shit stays in replace for upgrades until after 2.0 (or edit
 335   #_upgrade_data)
 336   warn "  saving legacy plandata" if $DEBUG;
 337   my $plandata = $new->get('plandata');
 338   $new->set('plandata', '');
 339
 340   warn "  deleting old part_pkg_option records" if $DEBUG;
 341   foreach my $part_pkg_option ( $old->part_pkg_option ) {
 342     my $error = $part_pkg_option->delete;
 343     if ( $error ) {
 344       $dbh->rollback if $oldAutoCommit;
 345       return $error;
 346     }
 347   }
 348
 349   warn "  replacing part_pkg record" if $DEBUG;
 350   my $error = $new->SUPER::replace($old, $options->{options} );
 351   if ( $error ) {
 352     $dbh->rollback if $oldAutoCommit;
 353     return $error;
 354   }
 355
 356   warn "  inserting part_pkg_option records for plandata: $plandata|" if $DEBUG;
 357   foreach my $part_pkg_option (
 358     map { /^(\w+)=(.*)$/ or do { $dbh->rollback if $oldAutoCommit;
 359                                  return "illegal plandata: $plandata";
 360                                };
 361           new FS::part_pkg_option {
 362             'pkgpart'     => $new->pkgpart,
 363             'optionname'  => $1,
 364             'optionvalue' => $2,
 365           };
 366         }
 367     split("\n", $plandata)
 368   ) {
 369     my $error = $part_pkg_option->insert;
 370     if ( $error ) {
 371       $dbh->rollback if $oldAutoCommit;
 372       return $error;
 373     }
 374   }
 375
 376   warn "  replacing pkg_svc records" if $DEBUG;
 377   my $pkg_svc = $options->{'pkg_svc'} || {};
 378   foreach my $part_svc ( qsearch('part_svc', {} ) ) {
 379     my $quantity = $pkg_svc->{$part_svc->svcpart} || 0;
 380     my $primary_svc =
 381       ( defined($options->{'primary_svc'}) && $options->{'primary_svc'}
 382         && $options->{'primary_svc'} == $part_svc->svcpart
 383       )
 384         ? 'Y'
 385         : '';
 386
 387
 388     my $old_pkg_svc = qsearchs('pkg_svc', {
 389       'pkgpart' => $old->pkgpart,
 390       'svcpart' => $part_svc->svcpart,
 391     } );
 392     my $old_quantity = $old_pkg_svc ? $old_pkg_svc->quantity : 0;
 393     my $old_primary_svc =
 394       ( $old_pkg_svc && $old_pkg_svc->dbdef_table->column('primary_svc') )
 395         ? $old_pkg_svc->primary_svc
 396         : '';
 397     next unless $old_quantity != $quantity || $old_primary_svc ne $primary_svc;
 398
 399     my $new_pkg_svc = new FS::pkg_svc( {
 400       'pkgsvcnum'   => ( $old_pkg_svc ? $old_pkg_svc->pkgsvcnum : '' ),
 401       'pkgpart'     => $new->pkgpart,
 402       'svcpart'     => $part_svc->svcpart,
 403       'quantity'    => $quantity,
 404       'primary_svc' => $primary_svc,
 405     } );
 406     my $error = $old_pkg_svc
 407                   ? $new_pkg_svc->replace($old_pkg_svc)
 408                   : $new_pkg_svc->insert;
 409     if ( $error ) {
 410       $dbh->rollback if $oldAutoCommit;
 411       return $error;
 412     }
 413   }
 414
 415   warn "  commiting transaction" if $DEBUG;
 416   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 417   '';
 418 }
 419
 420 =item check
 421
 422 Checks all fields to make sure this is a valid package definition.  If
 423 there is an error, returns the error, otherwise returns false.  Called by the
 424 insert and replace methods.
 425
 426 =cut
 427
 428 sub check {
 429   my $self = shift;
 430   warn "FS::part_pkg::check called on $self" if $DEBUG;
 431
 432   for (qw(setup recur plandata)) {
 433     #$self->set($_=>0) if $self->get($_) =~ /^\s*$/; }
 434     return "Use of $_ field is deprecated; set a plan and options: ".
 435            $self->get($_)
 436       if length($self->get($_));
 437     $self->set($_, '');
 438   }
 439
 440   if ( $self->dbdef_table->column('freq')->type =~ /(int)/i ) {
 441     my $error = $self->ut_number('freq');
 442     return $error if $error;
 443   } else {
 444     $self->freq =~ /^(\d+[hdw]?)$/
 445       or return "Illegal or empty freq: ". $self->freq;
 446     $self->freq($1);
 447   }
 448
 449   my @null_agentnum_right = ( 'Edit global package definitions' );
 450   push @null_agentnum_right, 'One-time charge'
 451     if $self->freq =~ /^0/;
 452   push @null_agentnum_right, 'Customize customer package'
 453     if $self->disabled eq 'Y'; #good enough
 454
 455   my $error = $self->ut_numbern('pkgpart')
 456     || $self->ut_text('pkg')
 457     || $self->ut_text('comment')
 458     || $self->ut_textn('promo_code')
 459     || $self->ut_alphan('plan')
 460     || $self->ut_enum('setuptax', [ '', 'Y' ] )
 461     || $self->ut_enum('recurtax', [ '', 'Y' ] )
 462     || $self->ut_textn('taxclass')
 463     || $self->ut_enum('disabled', [ '', 'Y' ] )
 464     || $self->ut_enum('custom', [ '', 'Y' ] )
 465     #|| $self->ut_moneyn('setup_cost')
 466     #|| $self->ut_moneyn('recur_cost')
 467     || $self->ut_floatn('setup_cost')
 468     || $self->ut_floatn('recur_cost')
 469     || $self->ut_floatn('pay_weight')
 470     || $self->ut_floatn('credit_weight')
 471     || $self->ut_numbern('taxproductnum')
 472     || $self->ut_foreign_keyn('taxproductnum',
 473                               'part_pkg_taxproduct',
 474                               'taxproductnum'
 475                              )
 476     || ( $setup_hack
 477            ? $self->ut_foreign_keyn('agentnum', 'agent', 'agentnum' )
 478            : $self->ut_agentnum_acl('agentnum', \@null_agentnum_right)
 479        )
 480     || $self->SUPER::check
 481   ;
 482   return $error if $error;
 483
 484   if ( $self->classnum !~ /^$/ ) {
 485     my $error = $self->ut_foreign_key('classnum', 'pkg_class', 'classnum');
 486     return $error if $error;
 487   } else {
 488     $self->classnum('');
 489   }
 490
 491   return 'Unknown plan '. $self->plan
 492     unless exists($plans{$self->plan});
 493
 494   my $conf = new FS::Conf;
 495   return 'Taxclass is required'
 496     if ! $self->taxclass && $conf->exists('require_taxclasses');
 497
 498   '';
 499 }
 500
 501 =item pkg_comment [ OPTION => VALUE... ]
 502
 503 Returns an (internal) string representing this package.  Currently,
 504 "pkgpart: pkg - comment", is returned.  "pkg - comment" may be returned in the
 505 future, omitting pkgpart.  The comment will have '(CUSTOM) ' prepended if
 506 custom is Y.
 507
 508 If the option nopkgpart is true then the "pkgpart: ' is omitted.
 509
 510 =cut
 511
 512 sub pkg_comment {
 513   my $self = shift;
 514   my %opt = @_;
 515
 516   #$self->pkg. ' - '. $self->comment;
 517   #$self->pkg. ' ('. $self->comment. ')';
 518   my $pre = $opt{nopkgpart} ? '' : $self->pkgpart. ': ';
 519   $pre. $self->pkg. ' - '. $self->custom_comment;
 520 }
 521
 522 sub custom_comment {
 523   my $self = shift;
 524   ( $self->custom ? '(CUSTOM) ' : '' ). $self->comment;
 525 }
 526
 527 =item pkg_class
 528
 529 Returns the package class, as an FS::pkg_class object, or the empty string
 530 if there is no package class.
 531
 532 =cut
 533
 534 sub pkg_class {
 535   my $self = shift;
 536   if ( $self->classnum ) {
 537     qsearchs('pkg_class', { 'classnum' => $self->classnum } );
 538   } else {
 539     return '';
 540   }
 541 }
 542
 543 =item categoryname
 544
 545 Returns the package category name, or the empty string if there is no package
 546 category.
 547
 548 =cut
 549
 550 sub categoryname {
 551   my $self = shift;
 552   my $pkg_class = $self->pkg_class;
 553   $pkg_class
 554     ? $pkg_class->categoryname
 555     : '';
 556 }
 557
 558 =item classname
 559
 560 Returns the package class name, or the empty string if there is no package
 561 class.
 562
 563 =cut
 564
 565 sub classname {
 566   my $self = shift;
 567   my $pkg_class = $self->pkg_class;
 568   $pkg_class
 569     ? $pkg_class->classname
 570     : '';
 571 }
 572
 573 =item agent
 574
 575 Returns the associated agent for this event, if any, as an FS::agent object.
 576
 577 =cut
 578
 579 sub agent {
 580   my $self = shift;
 581   qsearchs('agent', { 'agentnum' => $self->agentnum } );
 582 }
 583
 584 =item pkg_svc [ HASHREF | OPTION => VALUE ]
 585
 586 Returns all FS::pkg_svc objects (see L<FS::pkg_svc>) for this package
 587 definition (with non-zero quantity).
 588
 589 One option is available, I<disable_linked>.  If set true it will return the
 590 services for this package definition alone, omitting services from any add-on
 591 packages.
 592
 593 =cut
 594
 595 =item type_pkgs
 596
 597 Returns all FS::type_pkgs objects (see L<FS::type_pkgs>) for this package
 598 definition.
 599
 600 =cut
 601
 602 sub type_pkgs {
 603   my $self = shift;
 604   qsearch('type_pkgs', { 'pkgpart' => $self->pkgpart } );
 605 }
 606
 607 sub pkg_svc {
 608   my $self = shift;
 609
 610 #  #sort { $b->primary cmp $a->primary }
 611 #    grep { $_->quantity }
 612 #      qsearch( 'pkg_svc', { 'pkgpart' => $self->pkgpart } );
 613
 614   my $opt = ref($_[0]) ? $_[0] : { @_ };
 615   my %pkg_svc = map  { $_->svcpart => $_ }
 616                 grep { $_->quantity }
 617                 qsearch( 'pkg_svc', { 'pkgpart' => $self->pkgpart } );
 618
 619   unless ( $opt->{disable_linked} ) {
 620     foreach my $dst_pkg ( map $_->dst_pkg, $self->svc_part_pkg_link ) {
 621       my @pkg_svc = grep { $_->quantity }
 622                     qsearch( 'pkg_svc', { pkgpart=>$dst_pkg->pkgpart } );
 623       foreach my $pkg_svc ( @pkg_svc ) {
 624         if ( $pkg_svc{$pkg_svc->svcpart} ) {
 625           my $quantity = $pkg_svc{$pkg_svc->svcpart}->quantity;
 626           $pkg_svc{$pkg_svc->svcpart}->quantity($quantity + $pkg_svc->quantity);
 627         } else {
 628           $pkg_svc{$pkg_svc->svcpart} = $pkg_svc;
 629         }
 630       }
 631     }
 632   }
 633
 634   values(%pkg_svc);
 635
 636 }
 637
 638 =item svcpart [ SVCDB ]
 639
 640 Returns the svcpart of the primary service definition (see L<FS::part_svc>)
 641 associated with this package definition (see L<FS::pkg_svc>).  Returns
 642 false if there not a primary service definition or exactly one service
 643 definition with quantity 1, or if SVCDB is specified and does not match the
 644 svcdb of the service definition.  SVCDB can be specified as a scalar table
 645 name, such as 'svc_acct', or as an arrayref of possible table names.
 646
 647 =cut
 648
 649 sub svcpart {
 650   my $pkg_svc = shift->_primary_pkg_svc(@_);
 651   $pkg_svc ? $pkg_svc->svcpart : '';
 652 }
 653
 654 =item part_svc [ SVCDB ]
 655
 656 Like the B<svcpart> method, but returns the FS::part_svc object (see
 657 L<FS::part_svc>).
 658
 659 =cut
 660
 661 sub part_svc {
 662   my $pkg_svc = shift->_primary_pkg_svc(@_);
 663   $pkg_svc ? $pkg_svc->part_svc : '';
 664 }
 665
 666 sub _primary_pkg_svc {
 667   my $self = shift;
 668
 669   my $svcdb = scalar(@_) ? shift : [];
 670   $svcdb = ref($svcdb) ? $svcdb : [ $svcdb ];
 671   my %svcdb = map { $_=>1 } @$svcdb;
 672
 673   my @svcdb_pkg_svc =
 674     grep { !scalar(@$svcdb) || $svcdb{ $_->part_svc->svcdb } }
 675          $self->pkg_svc;
 676
 677   my @pkg_svc = grep { $_->primary_svc =~ /^Y/i } @svcdb_pkg_svc;
 678   @pkg_svc = grep {$_->quantity == 1 } @svcdb_pkg_svc
 679     unless @pkg_svc;
 680   return '' if scalar(@pkg_svc) != 1;
 681   $pkg_svc[0];
 682 }
 683
 684 =item svcpart_unique_svcdb SVCDB
 685
 686 Returns the svcpart of a service definition (see L<FS::part_svc>) matching
 687 SVCDB associated with this package definition (see L<FS::pkg_svc>).  Returns
 688 false if there not a primary service definition for SVCDB or there are multiple
 689 service definitions for SVCDB.
 690
 691 =cut
 692
 693 sub svcpart_unique_svcdb {
 694   my( $self, $svcdb ) = @_;
 695   my @svcdb_pkg_svc = grep { ( $svcdb eq $_->part_svc->svcdb ) } $self->pkg_svc;
 696   return '' if scalar(@svcdb_pkg_svc) != 1;
 697   $svcdb_pkg_svc[0]->svcpart;
 698 }
 699
 700 =item payby
 701
 702 Returns a list of the acceptable payment types for this package.  Eventually
 703 this should come out of a database table and be editable, but currently has the
 704 following logic instead:
 705
 706 If the package is free, the single item B<BILL> is
 707 returned, otherwise, the single item B<CARD> is returned.
 708
 709 (CHEK?  LEC?  Probably shouldn't accept those by default, prone to abuse)
 710
 711 =cut
 712
 713 sub payby {
 714   my $self = shift;
 715   if ( $self->is_free ) {
 716     ( 'BILL' );
 717   } else {
 718     ( 'CARD' );
 719   }
 720 }
 721
 722 =item is_free
 723
 724 Returns true if this package is free.
 725
 726 =cut
 727
 728 sub is_free {
 729   my $self = shift;
 730   unless ( $self->plan ) {
 731     $self->setup =~ /^\s*0+(\.0*)?\s*$/
 732       && $self->recur =~ /^\s*0+(\.0*)?\s*$/;
 733   } elsif ( $self->can('is_free_options') ) {
 734     not grep { $_ !~ /^\s*0*(\.0*)?\s*$/ }
 735          map { $self->option($_) }
 736              $self->is_free_options;
 737   } else {
 738     warn "FS::part_pkg::is_free: FS::part_pkg::". $self->plan. " subclass ".
 739          "provides neither is_free_options nor is_free method; returning false";
 740     0;
 741   }
 742 }
 743
 744
 745 sub freqs_href {
 746   #method, class method or sub? #my $self = shift;
 747
 748   tie my %freq, 'Tie::IxHash',
 749     '0'    => '(no recurring fee)',
 750     '1h'   => 'hourly',
 751     '1d'   => 'daily',
 752     '2d'   => 'every two days',
 753     '3d'   => 'every three days',
 754     '1w'   => 'weekly',
 755     '2w'   => 'biweekly (every 2 weeks)',
 756     '1'    => 'monthly',
 757     '45d'  => 'every 45 days',
 758     '2'    => 'bimonthly (every 2 months)',
 759     '3'    => 'quarterly (every 3 months)',
 760     '4'    => 'every 4 months',
 761     '137d' => 'every 4 1/2 months (137 days)',
 762     '6'    => 'semiannually (every 6 months)',
 763     '12'   => 'annually',
 764     '13'   => 'every 13 months (annually +1 month)',
 765     '24'   => 'biannually (every 2 years)',
 766     '36'   => 'triannually (every 3 years)',
 767     '48'   => '(every 4 years)',
 768     '60'   => '(every 5 years)',
 769     '120'  => '(every 10 years)',
 770   ;
 771
 772   \%freq;
 773
 774 }
 775
 776 =item freq_pretty
 777
 778 Returns an english representation of the I<freq> field, such as "monthly",
 779 "weekly", "semi-annually", etc.
 780
 781 =cut
 782
 783 sub freq_pretty {
 784   my $self = shift;
 785   my $freq = $self->freq;
 786
 787   #my $freqs_href = $self->freqs_href;
 788   my $freqs_href = freqs_href();
 789
 790   if ( exists($freqs_href->{$freq}) ) {
 791     $freqs_href->{$freq};
 792   } else {
 793     my $interval = 'month';
 794     if ( $freq =~ /^(\d+)([hdw])$/ ) {
 795       my %interval = ( 'h' => 'hour', 'd'=>'day', 'w'=>'week' );
 796       $interval = $interval{$2};
 797     }
 798     if ( $1 == 1 ) {
 799       "every $interval";
 800     } else {
 801       "every $freq ${interval}s";
 802     }
 803   }
 804 }
 805
 806 =item add_freq TIMESTAMP
 807
 808 Adds the frequency of this package to the provided timestamp and returns
 809 the resulting timestamp, or -1 if the frequency of this package could not be
 810 parsed (shouldn't happen).
 811
 812 =cut
 813
 814 sub add_freq {
 815   my( $self, $date ) = @_;
 816   my $freq = $self->freq;
 817
 818   #change this bit to use Date::Manip? CAREFUL with timezones (see
 819   # mailing list archive)
 820   my ($sec,$min,$hour,$mday,$mon,$year) = (localtime($date) )[0,1,2,3,4,5];
 821
 822   if ( $self->freq =~ /^\d+$/ ) {
 823     $mon += $self->freq;
 824     until ( $mon < 12 ) { $mon -= 12; $year++; }
 825   } elsif ( $self->freq =~ /^(\d+)w$/ ) {
 826     my $weeks = $1;
 827     $mday += $weeks * 7;
 828   } elsif ( $self->freq =~ /^(\d+)d$/ ) {
 829     my $days = $1;
 830     $mday += $days;
 831   } elsif ( $self->freq =~ /^(\d+)h$/ ) {
 832     my $hours = $1;
 833     $hour += $hours;
 834   } else {
 835     return -1;
 836   }
 837
 838   timelocal_nocheck($sec,$min,$hour,$mday,$mon,$year);
 839 }
 840
 841 =item plandata
 842
 843 For backwards compatibility, returns the plandata field as well as all options
 844 from FS::part_pkg_option.
 845
 846 =cut
 847
 848 sub plandata {
 849   my $self = shift;
 850   carp "plandata is deprecated";
 851   if ( @_ ) {
 852     $self->SUPER::plandata(@_);
 853   } else {
 854     my $plandata = $self->get('plandata');
 855     my %options = $self->options;
 856     $plandata .= join('', map { "$_=$options{$_}\n" } keys %options );
 857     $plandata;
 858   }
 859 }
 860
 861 =item part_pkg_option
 862
 863 Returns all options as FS::part_pkg_option objects (see
 864 L<FS::part_pkg_option>).
 865
 866 =cut
 867
 868 sub part_pkg_option {
 869   my $self = shift;
 870   qsearch('part_pkg_option', { 'pkgpart' => $self->pkgpart } );
 871 }
 872
 873 =item options
 874
 875 Returns a list of option names and values suitable for assigning to a hash.
 876
 877 =cut
 878
 879 sub options {
 880   my $self = shift;
 881   map { $_->optionname => $_->optionvalue } $self->part_pkg_option;
 882 }
 883
 884 =item option OPTIONNAME
 885
 886 Returns the option value for the given name, or the empty string.
 887
 888 =cut
 889
 890 sub option {
 891   my( $self, $opt, $ornull ) = @_;
 892   my $part_pkg_option =
 893     qsearchs('part_pkg_option', {
 894       pkgpart    => $self->pkgpart,
 895       optionname => $opt,
 896   } );
 897   return $part_pkg_option->optionvalue if $part_pkg_option;
 898   my %plandata = map { /^(\w+)=(.*)$/; ( $1 => $2 ); }
 899                      split("\n", $self->get('plandata') );
 900   return $plandata{$opt} if exists $plandata{$opt};
 901   cluck "WARNING: (pkgpart ". $self->pkgpart. ") Package def option $opt ".
 902         "not found in options or plandata!\n"
 903     unless $ornull;
 904   '';
 905 }
 906
 907 =item bill_part_pkg_link
 908
 909 Returns the associated part_pkg_link records (see L<FS::part_pkg_link>).
 910
 911 =cut
 912
 913 sub bill_part_pkg_link {
 914   shift->_part_pkg_link('bill', @_);
 915 }
 916
 917 =item svc_part_pkg_link
 918
 919 Returns the associated part_pkg_link records (see L<FS::part_pkg_link>).
 920
 921 =cut
 922
 923 sub svc_part_pkg_link {
 924   shift->_part_pkg_link('svc', @_);
 925 }
 926
 927 sub _part_pkg_link {
 928   my( $self, $type ) = @_;
 929   qsearch({ table    => 'part_pkg_link',
 930             hashref  => { 'src_pkgpart' => $self->pkgpart,
 931                           'link_type'   => $type,
 932                         },
 933             order_by => "ORDER BY hidden",
 934          });
 935 }
 936
 937 sub self_and_bill_linked {
 938   shift->_self_and_linked('bill', @_);
 939 }
 940
 941 sub _self_and_linked {
 942   my( $self, $type, $hidden ) = @_;
 943   $hidden ||= '';
 944
 945   my @result = ();
 946   foreach ( ( $self, map { $_->dst_pkg->_self_and_linked($type, $_->hidden) }
 947                      $self->_part_pkg_link($type) ) )
 948   {
 949     $_->hidden($hidden) if $hidden;
 950     push @result, $_;
 951   }
 952
 953   (@result);
 954 }
 955
 956 =item part_pkg_taxoverride [ CLASS ]
 957
 958 Returns all associated FS::part_pkg_taxoverride objects (see
 959 L<FS::part_pkg_taxoverride>).  Limits the returned set to those
 960 of class CLASS if defined.  Class may be one of 'setup', 'recur',
 961 the empty string (default), or a usage class number (see L<FS::usage_class>).
 962 When a class is specified, the empty string class (default) is returned
 963 if no more specific values exist.
 964
 965 =cut
 966
 967 sub part_pkg_taxoverride {
 968   my $self = shift;
 969   my $class = shift;
 970
 971   my $hashref = { 'pkgpart' => $self->pkgpart };
 972   $hashref->{'usage_class'} = $class if defined($class);
 973   my @overrides = qsearch('part_pkg_taxoverride', $hashref );
 974
 975   unless ( scalar(@overrides) || !defined($class) || !$class ){
 976     $hashref->{'usage_class'} = '';
 977     @overrides = qsearch('part_pkg_taxoverride', $hashref );
 978   }
 979
 980   @overrides;
 981 }
 982
 983 =item has_taxproduct
 984
 985 Returns true if this package has any taxproduct associated with it.
 986
 987 =cut
 988
 989 sub has_taxproduct {
 990   my $self = shift;
 991
 992   $self->taxproductnum ||
 993   scalar( grep { $_ =~/^usage_taxproductnum_/ && $self->option($_) }
 994           keys %{ {$self->options} }
 995   )
 996
 997 }
 998
 999
1000 =item taxproduct [ CLASS ]
1001
1002 Returns the associated tax product for this package definition (see
1003 L<FS::part_pkg_taxproduct>).  CLASS may be one of 'setup', 'recur' or
1004 the usage classnum (see L<FS::usage_class>).  Returns the default
1005 tax product for this record if the more specific CLASS value does
1006 not exist.
1007
1008 =cut
1009
1010 sub taxproduct {
1011   my $self = shift;
1012   my $class = shift;
1013
1014   my $part_pkg_taxproduct;
1015
1016   my $taxproductnum = $self->taxproductnum;
1017   if ($class) {
1018     my $class_taxproductnum = $self->option("usage_taxproductnum_$class", 1);
1019     $taxproductnum = $class_taxproductnum
1020       if $class_taxproductnum
1021   }
1022
1023   $part_pkg_taxproduct =
1024     qsearchs( 'part_pkg_taxproduct', { 'taxproductnum' => $taxproductnum } );
1025
1026   unless ($part_pkg_taxproduct || $taxproductnum eq $self->taxproductnum ) {
1027     $taxproductnum = $self->taxproductnum;
1028     $part_pkg_taxproduct =
1029       qsearchs( 'part_pkg_taxproduct', { 'taxproductnum' => $taxproductnum } );
1030   }
1031
1032   $part_pkg_taxproduct;
1033 }
1034
1035 =item taxproduct_description [ CLASS ]
1036
1037 Returns the description of the associated tax product for this package
1038 definition (see L<FS::part_pkg_taxproduct>).
1039
1040 =cut
1041
1042 sub taxproduct_description {
1043   my $self = shift;
1044   my $part_pkg_taxproduct = $self->taxproduct(@_);
1045   $part_pkg_taxproduct ? $part_pkg_taxproduct->description : '';
1046 }
1047
1048 =item part_pkg_taxrate DATA_PROVIDER, GEOCODE, [ CLASS ]
1049
1050 Returns the package to taxrate m2m records for this package in the location
1051 specified by GEOCODE (see L<FS::part_pkg_taxrate>) and usage class CLASS.
1052 CLASS may be one of 'setup', 'recur', or one of the usage classes numbers
1053 (see L<FS::usage_class>).
1054
1055 =cut
1056
1057 sub _expand_cch_taxproductnum {
1058   my $self = shift;
1059   my $class = shift;
1060   my $part_pkg_taxproduct = $self->taxproduct($class);
1061
1062   my ($a,$b,$c,$d) = ( $part_pkg_taxproduct
1063                          ? ( split ':', $part_pkg_taxproduct->taxproduct )
1064                          : ()
1065                      );
1066   $a = '' unless $a; $b = '' unless $b; $c = '' unless $c; $d = '' unless $d;
1067   my $extra_sql = "AND ( taxproduct = '$a:$b:$c:$d'
1068                       OR taxproduct = '$a:$b:$c:'
1069                       OR taxproduct = '$a:$b:".":$d'
1070                       OR taxproduct = '$a:$b:".":' )";
1071   map { $_->taxproductnum } qsearch( { 'table'     => 'part_pkg_taxproduct',
1072                                        'hashref'   => { 'data_vendor'=>'cch' },
1073                                        'extra_sql' => $extra_sql,
1074                                    } );
1075
1076 }
1077
1078 sub part_pkg_taxrate {
1079   my $self = shift;
1080   my ($data_vendor, $geocode, $class) = @_;
1081
1082   my $dbh = dbh;
1083   my $extra_sql = 'WHERE part_pkg_taxproduct.data_vendor = '.
1084                   dbh->quote($data_vendor);
1085
1086   # CCH oddness in m2m
1087   $extra_sql .= ' AND ('.
1088     join(' OR ', map{ 'geocode = '. $dbh->quote(substr($geocode, 0, $_)) }
1089                  qw(10 5 2)
1090         ).
1091     ')';
1092   # much more CCH oddness in m2m -- this is kludgy
1093   my @tpnums = $self->_expand_cch_taxproductnum($class);
1094   if (scalar(@tpnums)) {
1095     $extra_sql .= ' AND ('.
1096                             join(' OR ', map{ "taxproductnum = $_" } @tpnums ).
1097                        ')';
1098   } else {
1099     $extra_sql .= ' AND ( 0 = 1 )';
1100   }
1101
1102   my $addl_from = 'LEFT JOIN part_pkg_taxproduct USING ( taxproductnum )';
1103   my $order_by = 'ORDER BY taxclassnum, length(geocode) desc, length(taxproduct) desc';
1104   my $select   = 'DISTINCT ON(taxclassnum) *, taxproduct';
1105
1106   # should qsearch preface columns with the table to facilitate joins?
1107   qsearch( { 'table'     => 'part_pkg_taxrate',
1108              'select'    => $select,
1109              'hashref'   => { # 'data_vendor'   => $data_vendor,
1110                               # 'taxproductnum' => $self->taxproductnum,
1111                             },
1112              'addl_from' => $addl_from,
1113              'extra_sql' => $extra_sql,
1114              'order_by'  => $order_by,
1115          } );
1116 }
1117
1118 =item _rebless
1119
1120 Reblesses the object into the FS::part_pkg::PLAN class (if available), where
1121 PLAN is the object's I<plan> field.  There should be better docs
1122 on how to create new price plans, but until then, see L</NEW PLAN CLASSES>.
1123
1124 =cut
1125
1126 sub _rebless {
1127   my $self = shift;
1128   my $plan = $self->plan;
1129   unless ( $plan ) {
1130     cluck "no price plan found for pkgpart ". $self->pkgpart. "\n"
1131       if $DEBUG;
1132     return $self;
1133   }
1134   return $self if ref($self) =~ /::$plan$/; #already blessed into plan subclass
1135   my $class = ref($self). "::$plan";
1136   warn "reblessing $self into $class" if $DEBUG;
1137   eval "use $class;";
1138   die $@ if $@;
1139   bless($self, $class) unless $@;
1140   $self;
1141 }
1142
1143 #fallbacks that eval the setup and recur fields, for backwards compat
1144
1145 sub calc_setup {
1146   my $self = shift;
1147   warn 'no price plan class for '. $self->plan. ", eval-ing setup\n";
1148   $self->_calc_eval('setup', @_);
1149 }
1150
1151 sub calc_recur {
1152   my $self = shift;
1153   warn 'no price plan class for '. $self->plan. ", eval-ing recur\n";
1154   $self->_calc_eval('recur', @_);
1155 }
1156
1157 use vars qw( $sdate @details );
1158 sub _calc_eval {
1159   #my( $self, $field, $cust_pkg ) = @_;
1160   my( $self, $field, $cust_pkg, $sdateref, $detailsref ) = @_;
1161   *sdate = $sdateref;
1162   *details = $detailsref;
1163   $self->$field() =~ /^(.*)$/
1164     or die "Illegal $field (pkgpart ". $self->pkgpart. '): '.
1165             $self->$field(). "\n";
1166   my $prog = $1;
1167   return 0 if $prog =~ /^\s*$/;
1168   my $value = eval $prog;
1169   die $@ if $@;
1170   $value;
1171 }
1172
1173 #fallback that return 0 for old legacy packages with no plan
1174
1175 sub calc_remain { 0; }
1176 sub calc_cancel { 0; }
1177 sub calc_units  { 0; }
1178
1179 #fallback for everything except bulk.pm
1180 sub hide_svc_detail { 0; }
1181
1182 =item format OPTION DATA
1183
1184 Returns data formatted according to the function 'format' described
1185 in the plan info.  Returns DATA if no such function exists.
1186
1187 =cut
1188
1189 sub format {
1190   my ($self, $option, $data) = (shift, shift, shift);
1191   if (exists($plans{$self->plan}->{fields}->{$option}{format})) {
1192     &{$plans{$self->plan}->{fields}->{$option}{format}}($data);
1193   }else{
1194     $data;
1195   }
1196 }
1197
1198 =item parse OPTION DATA
1199
1200 Returns data parsed according to the function 'parse' described
1201 in the plan info.  Returns DATA if no such function exists.
1202
1203 =cut
1204
1205 sub parse {
1206   my ($self, $option, $data) = (shift, shift, shift);
1207   if (exists($plans{$self->plan}->{fields}->{$option}{parse})) {
1208     &{$plans{$self->plan}->{fields}->{$option}{parse}}($data);
1209   }else{
1210     $data;
1211   }
1212 }
1213
1214 =back
1215
1216 =cut
1217
1218 =head1 CLASS METHODS
1219
1220 =over 4
1221
1222 =cut
1223
1224 # _upgrade_data
1225 #
1226 # Used by FS::Upgrade to migrate to a new database.
1227
1228 sub _upgrade_data { # class method
1229   my($class, %opts) = @_;
1230
1231   warn "[FS::part_pkg] upgrading $class\n" if $DEBUG;
1232
1233   my @part_pkg = qsearch({
1234     'table'     => 'part_pkg',
1235     'extra_sql' => "WHERE ". join(' OR ',
1236                      ( map "($_ IS NOT NULL AND $_ != '' )",
1237                            qw( plandata setup recur ) ),
1238                      'plan IS NULL', "plan = '' ",
1239                    ),
1240   });
1241
1242   foreach my $part_pkg (@part_pkg) {
1243
1244     unless ( $part_pkg->plan ) {
1245       $part_pkg->plan('flat');
1246     }
1247
1248     if ( length($part_pkg->option('setup_fee')) == 0
1249          && $part_pkg->setup =~ /^\s*([\d\.]+)\s*$/ ) {
1250
1251       my $opt = new FS::part_pkg_option {
1252         'pkgpart'     => $part_pkg->pkgpart,
1253         'optionname'  => 'setup_fee',
1254         'optionvalue' => $1,
1255       };
1256       my $error = $opt->insert;
1257       die $error if $error;
1258
1259
1260       #} else {
1261       #  die "Can't parse part_pkg.setup for fee; convert pkgnum ".
1262       #      $part_pkg->pkgnum. " manually: ". $part_pkg->setup. "\n";
1263     }
1264     $part_pkg->setup('');
1265
1266     if ( length($part_pkg->option('recur_fee')) == 0
1267          && $part_pkg->recur =~ /^\s*([\d\.]+)\s*$/ ) {
1268
1269         my $opt = new FS::part_pkg_option {
1270           'pkgpart'     => $part_pkg->pkgpart,
1271           'optionname'  => 'recur_fee',
1272           'optionvalue' => $1,
1273         };
1274         my $error = $opt->insert;
1275         die $error if $error;
1276
1277
1278       #} else {
1279       #  die "Can't parse part_pkg.setup for fee; convert pkgnum ".
1280       #      $part_pkg->pkgnum. " manually: ". $part_pkg->setup. "\n";
1281     }
1282     $part_pkg->recur('');
1283
1284     $part_pkg->replace; #this should take care of plandata, right?
1285
1286   }
1287
1288   # now upgrade to the explicit custom flag
1289
1290   @part_pkg = qsearch({
1291     'table'     => 'part_pkg',
1292     'hashref'   => { disabled => 'Y', custom => '' },
1293     'extra_sql' => "AND comment LIKE '(CUSTOM) %'",
1294   });
1295
1296   foreach my $part_pkg (@part_pkg) {
1297     my $new = new FS::part_pkg { $part_pkg->hash };
1298     $new->custom('Y');
1299     my $comment = $part_pkg->comment;
1300     $comment =~ s/^\(CUSTOM\) //;
1301     $comment = '(none)' unless $comment =~ /\S/;
1302     $new->comment($comment);
1303
1304     my $pkg_svc = { map { $_->svcpart => $_->quantity } $part_pkg->pkg_svc };
1305     my $primary = $part_pkg->svcpart;
1306     my $options = { $part_pkg->options };
1307
1308     my $error = $new->replace( $part_pkg,
1309                                'pkg_svc'     => $pkg_svc,
1310                                'primary_svc' => $primary,
1311                                'options'     => $options,
1312                              );
1313     die $error if $error;
1314   }
1315
1316 }
1317
1318 =item curuser_pkgs_sql
1319
1320 Returns an SQL fragment for searching for packages the current user can
1321 use, either via part_pkg.agentnum directly, or via agent type (see
1322 L<FS::type_pkgs>).
1323
1324 =cut
1325
1326 sub curuser_pkgs_sql {
1327   my $class = shift;
1328
1329   $class->_pkgs_sql( $FS::CurrentUser::CurrentUser->agentnums );
1330
1331 }
1332
1333 =item agent_pkgs_sql AGENT | AGENTNUM, ...
1334
1335 Returns an SQL fragment for searching for packages the provided agent or agents
1336 can use, either via part_pkg.agentnum directly, or via agent type (see
1337 L<FS::type_pkgs>).
1338
1339 =cut
1340
1341 sub agent_pkgs_sql {
1342   my $class = shift;  #i'm a class method, not a sub (the question is... why??)
1343   my @agentnums = map { ref($_) ? $_->agentnum : $_ } @_;
1344
1345   $class->_pkgs_sql(@agentnums); #is this why
1346
1347 }
1348
1349 sub _pkgs_sql {
1350   my( $class, @agentnums ) = @_;
1351   my $agentnums = join(',', @agentnums);
1352
1353   "
1354     (
1355       ( agentnum IS NOT NULL AND agentnum IN ($agentnums) )
1356       OR ( agentnum IS NULL
1357            AND EXISTS ( SELECT 1
1358                           FROM type_pkgs
1359                             LEFT JOIN agent_type USING ( typenum )
1360                             LEFT JOIN agent AS typeagent USING ( typenum )
1361                           WHERE type_pkgs.pkgpart = part_pkg.pkgpart
1362                             AND typeagent.agentnum IN ($agentnums)
1363                       )
1364          )
1365     )
1366   ";
1367
1368 }
1369
1370 =back
1371
1372 =head1 SUBROUTINES
1373
1374 =over 4
1375
1376 =item plan_info
1377
1378 =cut
1379
1380 #false laziness w/part_export & cdr
1381 my %info;
1382 foreach my $INC ( @INC ) {
1383   warn "globbing $INC/FS/part_pkg/*.pm\n" if $DEBUG;
1384   foreach my $file ( glob("$INC/FS/part_pkg/*.pm") ) {
1385     warn "attempting to load plan info from $file\n" if $DEBUG;
1386     $file =~ /\/(\w+)\.pm$/ or do {
1387       warn "unrecognized file in $INC/FS/part_pkg/: $file\n";
1388       next;
1389     };
1390     my $mod = $1;
1391     my $info = eval "use FS::part_pkg::$mod; ".
1392                     "\\%FS::part_pkg::$mod\::info;";
1393     if ( $@ ) {
1394       die "error using FS::part_pkg::$mod (skipping): $@\n" if $@;
1395       next;
1396     }
1397     unless ( keys %$info ) {
1398       warn "no %info hash found in FS::part_pkg::$mod, skipping\n";
1399       next;
1400     }
1401     warn "got plan info from FS::part_pkg::$mod: $info\n" if $DEBUG;
1402     if ( exists($info->{'disabled'}) && $info->{'disabled'} ) {
1403       warn "skipping disabled plan FS::part_pkg::$mod" if $DEBUG;
1404       next;
1405     }
1406     $info{$mod} = $info;
1407   }
1408 }
1409
1410 tie %plans, 'Tie::IxHash',
1411   map  { $_ => $info{$_} }
1412   sort { $info{$a}->{'weight'} <=> $info{$b}->{'weight'} }
1413   keys %info;
1414
1415 sub plan_info {
1416   \%plans;
1417 }
1418
1419
1420 =back
1421
1422 =head1 NEW PLAN CLASSES
1423
1424 A module should be added in FS/FS/part_pkg/  Eventually, an example may be
1425 found in eg/plan_template.pm.  Until then, it is suggested that you use the
1426 other modules in FS/FS/part_pkg/ as a guide.
1427
1428 =head1 BUGS
1429
1430 The delete method is unimplemented.
1431
1432 setup and recur semantics are not yet defined (and are implemented in
1433 FS::cust_bill.  hmm.).  now they're deprecated and need to go.
1434
1435 plandata should go
1436
1437 part_pkg_taxrate is Pg specific
1438
1439 replace should be smarter about managing the related tables (options, pkg_svc)
1440
1441 =head1 SEE ALSO
1442
1443 L<FS::Record>, L<FS::cust_pkg>, L<FS::type_pkgs>, L<FS::pkg_svc>, L<Safe>.
1444 schema.html from the base documentation.
1445
1446 =cut
1447
1448 1;
1449