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