FS/FS/part_pkg.pm

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