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