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 sub _part_pkg_link {
1179   my( $self, $type ) = @_;
1180   qsearch({ table    => 'part_pkg_link',
1181             hashref  => { 'src_pkgpart' => $self->pkgpart,
1182                           'link_type'   => $type,
1183                           #protection against infinite recursive links
1184                           'dst_pkgpart' => { op=>'!=', value=> $self->pkgpart },
1185                         },
1186             order_by => "ORDER BY hidden",
1187          });
1188 }
1189
1190 sub self_and_bill_linked {
1191   shift->_self_and_linked('bill', @_);
1192 }
1193
1194 sub self_and_svc_linked {
1195   shift->_self_and_linked('svc', @_);
1196 }
1197
1198 sub _self_and_linked {
1199   my( $self, $type, $hidden ) = @_;
1200   $hidden ||= '';
1201
1202   my @result = ();
1203   foreach ( ( $self, map { $_->dst_pkg->_self_and_linked($type, $_->hidden) }
1204                      $self->_part_pkg_link($type) ) )
1205   {
1206     $_->hidden($hidden) if $hidden;
1207     push @result, $_;
1208   }
1209
1210   (@result);
1211 }
1212
1213 =item part_pkg_taxoverride [ CLASS ]
1214
1215 Returns all associated FS::part_pkg_taxoverride objects (see
1216 L<FS::part_pkg_taxoverride>).  Limits the returned set to those
1217 of class CLASS if defined.  Class may be one of 'setup', 'recur',
1218 the empty string (default), or a usage class number (see L<FS::usage_class>).
1219 When a class is specified, the empty string class (default) is returned
1220 if no more specific values exist.
1221
1222 =cut
1223
1224 sub part_pkg_taxoverride {
1225   my $self = shift;
1226   my $class = shift;
1227
1228   my $hashref = { 'pkgpart' => $self->pkgpart };
1229   $hashref->{'usage_class'} = $class if defined($class);
1230   my @overrides = qsearch('part_pkg_taxoverride', $hashref );
1231
1232   unless ( scalar(@overrides) || !defined($class) || !$class ){
1233     $hashref->{'usage_class'} = '';
1234     @overrides = qsearch('part_pkg_taxoverride', $hashref );
1235   }
1236
1237   @overrides;
1238 }
1239
1240 =item has_taxproduct
1241
1242 Returns true if this package has any taxproduct associated with it.
1243
1244 =cut
1245
1246 sub has_taxproduct {
1247   my $self = shift;
1248
1249   $self->taxproductnum ||
1250   scalar( grep { $_ =~/^usage_taxproductnum_/ && $self->option($_) }
1251           keys %{ {$self->options} }
1252   )
1253
1254 }
1255
1256
1257 =item taxproduct [ CLASS ]
1258
1259 Returns the associated tax product for this package definition (see
1260 L<FS::part_pkg_taxproduct>).  CLASS may be one of 'setup', 'recur' or
1261 the usage classnum (see L<FS::usage_class>).  Returns the default
1262 tax product for this record if the more specific CLASS value does
1263 not exist.
1264
1265 =cut
1266
1267 sub taxproduct {
1268   my $self = shift;
1269   my $class = shift;
1270
1271   my $part_pkg_taxproduct;
1272
1273   my $taxproductnum = $self->taxproductnum;
1274   if ($class) {
1275     my $class_taxproductnum = $self->option("usage_taxproductnum_$class", 1);
1276     $taxproductnum = $class_taxproductnum
1277       if $class_taxproductnum
1278   }
1279
1280   $part_pkg_taxproduct =
1281     qsearchs( 'part_pkg_taxproduct', { 'taxproductnum' => $taxproductnum } );
1282
1283   unless ($part_pkg_taxproduct || $taxproductnum eq $self->taxproductnum ) {
1284     $taxproductnum = $self->taxproductnum;
1285     $part_pkg_taxproduct =
1286       qsearchs( 'part_pkg_taxproduct', { 'taxproductnum' => $taxproductnum } );
1287   }
1288
1289   $part_pkg_taxproduct;
1290 }
1291
1292 =item taxproduct_description [ CLASS ]
1293
1294 Returns the description of the associated tax product for this package
1295 definition (see L<FS::part_pkg_taxproduct>).
1296
1297 =cut
1298
1299 sub taxproduct_description {
1300   my $self = shift;
1301   my $part_pkg_taxproduct = $self->taxproduct(@_);
1302   $part_pkg_taxproduct ? $part_pkg_taxproduct->description : '';
1303 }
1304
1305 =item part_pkg_taxrate DATA_PROVIDER, GEOCODE, [ CLASS ]
1306
1307 Returns the package to taxrate m2m records for this package in the location
1308 specified by GEOCODE (see L<FS::part_pkg_taxrate>) and usage class CLASS.
1309 CLASS may be one of 'setup', 'recur', or one of the usage classes numbers
1310 (see L<FS::usage_class>).
1311
1312 =cut
1313
1314 sub _expand_cch_taxproductnum {
1315   my $self = shift;
1316   my $class = shift;
1317   my $part_pkg_taxproduct = $self->taxproduct($class);
1318
1319   my ($a,$b,$c,$d) = ( $part_pkg_taxproduct
1320                          ? ( split ':', $part_pkg_taxproduct->taxproduct )
1321                          : ()
1322                      );
1323   $a = '' unless $a; $b = '' unless $b; $c = '' unless $c; $d = '' unless $d;
1324   my $extra_sql = "AND ( taxproduct = '$a:$b:$c:$d'
1325                       OR taxproduct = '$a:$b:$c:'
1326                       OR taxproduct = '$a:$b:".":$d'
1327                       OR taxproduct = '$a:$b:".":' )";
1328   map { $_->taxproductnum } qsearch( { 'table'     => 'part_pkg_taxproduct',
1329                                        'hashref'   => { 'data_vendor'=>'cch' },
1330                                        'extra_sql' => $extra_sql,
1331                                    } );
1332
1333 }
1334
1335 sub part_pkg_taxrate {
1336   my $self = shift;
1337   my ($data_vendor, $geocode, $class) = @_;
1338
1339   my $dbh = dbh;
1340   my $extra_sql = 'WHERE part_pkg_taxproduct.data_vendor = '.
1341                   dbh->quote($data_vendor);
1342
1343   # CCH oddness in m2m
1344   $extra_sql .= ' AND ('.
1345     join(' OR ', map{ 'geocode = '. $dbh->quote(substr($geocode, 0, $_)) }
1346                  qw(10 5 2)
1347         ).
1348     ')';
1349   # much more CCH oddness in m2m -- this is kludgy
1350   my @tpnums = $self->_expand_cch_taxproductnum($class);
1351   if (scalar(@tpnums)) {
1352     $extra_sql .= ' AND ('.
1353                             join(' OR ', map{ "taxproductnum = $_" } @tpnums ).
1354                        ')';
1355   } else {
1356     $extra_sql .= ' AND ( 0 = 1 )';
1357   }
1358
1359   my $addl_from = 'LEFT JOIN part_pkg_taxproduct USING ( taxproductnum )';
1360   my $order_by = 'ORDER BY taxclassnum, length(geocode) desc, length(taxproduct) desc';
1361   my $select   = 'DISTINCT ON(taxclassnum) *, taxproduct';
1362
1363   # should qsearch preface columns with the table to facilitate joins?
1364   qsearch( { 'table'     => 'part_pkg_taxrate',
1365              'select'    => $select,
1366              'hashref'   => { # 'data_vendor'   => $data_vendor,
1367                               # 'taxproductnum' => $self->taxproductnum,
1368                             },
1369              'addl_from' => $addl_from,
1370              'extra_sql' => $extra_sql,
1371              'order_by'  => $order_by,
1372          } );
1373 }
1374
1375 =item part_pkg_discount
1376
1377 Returns the package to discount m2m records (see L<FS::part_pkg_discount>)
1378 for this package.
1379
1380 =cut
1381
1382 sub part_pkg_discount {
1383   my $self = shift;
1384   qsearch('part_pkg_discount', { 'pkgpart' => $self->pkgpart });
1385 }
1386
1387 =item _rebless
1388
1389 Reblesses the object into the FS::part_pkg::PLAN class (if available), where
1390 PLAN is the object's I<plan> field.  There should be better docs
1391 on how to create new price plans, but until then, see L</NEW PLAN CLASSES>.
1392
1393 =cut
1394
1395 sub _rebless {
1396   my $self = shift;
1397   my $plan = $self->plan;
1398   unless ( $plan ) {
1399     cluck "no price plan found for pkgpart ". $self->pkgpart. "\n"
1400       if $DEBUG;
1401     return $self;
1402   }
1403   return $self if ref($self) =~ /::$plan$/; #already blessed into plan subclass
1404   my $class = ref($self). "::$plan";
1405   warn "reblessing $self into $class" if $DEBUG > 1;
1406   eval "use $class;";
1407   die $@ if $@;
1408   bless($self, $class) unless $@;
1409   $self;
1410 }
1411
1412 #fatal fallbacks
1413 sub calc_setup { die 'no calc_setup for '. shift->plan. "\n"; }
1414 sub calc_recur { die 'no calc_recur for '. shift->plan. "\n"; }
1415
1416 #fallback that return 0 for old legacy packages with no plan
1417 sub calc_remain { 0; }
1418 sub calc_units  { 0; }
1419
1420 #fallback for everything not based on flat.pm
1421 sub recur_temporality { 'upcoming'; }
1422 sub calc_cancel { 0; }
1423
1424 #fallback for everything except bulk.pm
1425 sub hide_svc_detail { 0; }
1426
1427 #fallback for packages that can't/won't summarize usage
1428 sub sum_usage { 0; }
1429
1430 =item recur_cost_permonth CUST_PKG
1431
1432 recur_cost divided by freq (only supported for monthly and longer frequencies)
1433
1434 =cut
1435
1436 sub recur_cost_permonth {
1437   my($self, $cust_pkg) = @_;
1438   return 0 unless $self->freq =~ /^\d+$/ && $self->freq > 0;
1439   sprintf('%.2f', $self->recur_cost / $self->freq );
1440 }
1441
1442 =item format OPTION DATA
1443
1444 Returns data formatted according to the function 'format' described
1445 in the plan info.  Returns DATA if no such function exists.
1446
1447 =cut
1448
1449 sub format {
1450   my ($self, $option, $data) = (shift, shift, shift);
1451   if (exists($plans{$self->plan}->{fields}->{$option}{format})) {
1452     &{$plans{$self->plan}->{fields}->{$option}{format}}($data);
1453   }else{
1454     $data;
1455   }
1456 }
1457
1458 =item parse OPTION DATA
1459
1460 Returns data parsed according to the function 'parse' described
1461 in the plan info.  Returns DATA if no such function exists.
1462
1463 =cut
1464
1465 sub parse {
1466   my ($self, $option, $data) = (shift, shift, shift);
1467   if (exists($plans{$self->plan}->{fields}->{$option}{parse})) {
1468     &{$plans{$self->plan}->{fields}->{$option}{parse}}($data);
1469   }else{
1470     $data;
1471   }
1472 }
1473
1474 =back
1475
1476 =cut
1477
1478 =head1 CLASS METHODS
1479
1480 =over 4
1481
1482 =cut
1483
1484 # _upgrade_data
1485 #
1486 # Used by FS::Upgrade to migrate to a new database.
1487
1488 sub _upgrade_data { # class method
1489   my($class, %opts) = @_;
1490
1491   warn "[FS::part_pkg] upgrading $class\n" if $DEBUG;
1492
1493   my @part_pkg = qsearch({
1494     'table'     => 'part_pkg',
1495     'extra_sql' => "WHERE ". join(' OR ',
1496                      'plan IS NULL', "plan = '' ",
1497                    ),
1498   });
1499
1500   foreach my $part_pkg (@part_pkg) {
1501
1502     unless ( $part_pkg->plan ) {
1503       $part_pkg->plan('flat');
1504     }
1505
1506     $part_pkg->replace;
1507
1508   }
1509
1510   # now upgrade to the explicit custom flag
1511
1512   @part_pkg = qsearch({
1513     'table'     => 'part_pkg',
1514     'hashref'   => { disabled => 'Y', custom => '' },
1515     'extra_sql' => "AND comment LIKE '(CUSTOM) %'",
1516   });
1517
1518   foreach my $part_pkg (@part_pkg) {
1519     my $new = new FS::part_pkg { $part_pkg->hash };
1520     $new->custom('Y');
1521     my $comment = $part_pkg->comment;
1522     $comment =~ s/^\(CUSTOM\) //;
1523     $comment = '(none)' unless $comment =~ /\S/;
1524     $new->comment($comment);
1525
1526     my $pkg_svc = { map { $_->svcpart => $_->quantity } $part_pkg->pkg_svc };
1527     my $primary = $part_pkg->svcpart;
1528     my $options = { $part_pkg->options };
1529
1530     my $error = $new->replace( $part_pkg,
1531                                'pkg_svc'     => $pkg_svc,
1532                                'primary_svc' => $primary,
1533                                'options'     => $options,
1534                              );
1535     die $error if $error;
1536   }
1537
1538   # set family_pkgpart on any packages that don't have it
1539   @part_pkg = qsearch('part_pkg', { 'family_pkgpart' => '' });
1540   foreach my $part_pkg (@part_pkg) {
1541     $part_pkg->set('family_pkgpart' => $part_pkg->pkgpart);
1542     my $error = $part_pkg->SUPER::replace;
1543     die $error if $error;
1544   }
1545
1546   my @part_pkg_option = qsearch('part_pkg_option',
1547     { 'optionname'  => 'unused_credit',
1548       'optionvalue' => 1,
1549     });
1550   foreach my $old_opt (@part_pkg_option) {
1551     my $pkgpart = $old_opt->pkgpart;
1552     my $error = $old_opt->delete;
1553     die $error if $error;
1554
1555     foreach (qw(unused_credit_cancel unused_credit_change)) {
1556       my $new_opt = new FS::part_pkg_option {
1557         'pkgpart'     => $pkgpart,
1558         'optionname'  => $_,
1559         'optionvalue' => 1,
1560       };
1561       $error = $new_opt->insert;
1562       die $error if $error;
1563     }
1564   }
1565
1566   # migrate use_disposition_taqua and use_disposition to disposition_in
1567   @part_pkg_option = qsearch('part_pkg_option',
1568     { 'optionname'  => { op => 'LIKE',
1569                          value => 'use_disposition%',
1570                        },
1571       'optionvalue' => 1,
1572     });
1573   my %newopts = map { $_->pkgpart => $_ }
1574     qsearch('part_pkg_option',  { 'optionname'  => 'disposition_in', } );
1575   foreach my $old_opt (@part_pkg_option) {
1576         my $pkgpart = $old_opt->pkgpart;
1577         my $newval = $old_opt->optionname eq 'use_disposition_taqua' ? '100'
1578                                                                   : 'ANSWERED';
1579         my $error = $old_opt->delete;
1580         die $error if $error;
1581
1582         if ( exists($newopts{$pkgpart}) ) {
1583             my $opt = $newopts{$pkgpart};
1584             $opt->optionvalue($opt->optionvalue.",$newval");
1585             $error = $opt->replace;
1586             die $error if $error;
1587         } else {
1588             my $new_opt = new FS::part_pkg_option {
1589                 'pkgpart'     => $pkgpart,
1590                 'optionname'  => 'disposition_in',
1591                 'optionvalue' => $newval,
1592               };
1593               $error = $new_opt->insert;
1594               die $error if $error;
1595               $newopts{$pkgpart} = $new_opt;
1596         }
1597   }
1598
1599   # set any package with FCC voice lines to the "VoIP with broadband" category
1600   # for backward compatibility
1601   my $journal = 'part_pkg_fcc_voip_class';
1602   if (!FS::upgrade_journal->is_done($journal)) {
1603     @part_pkg = qsearch('part_pkg', {
1604         fcc_ds0s        => { op => '>', value => 0 },
1605         fcc_voip_class  => ''
1606     });
1607     foreach my $part_pkg (@part_pkg) {
1608       $part_pkg->set(fcc_voip_class => 2);
1609       my $error = $part_pkg->replace;
1610       die $error if $error;
1611     }
1612     FS::upgrade_journal->set_done($journal);
1613   }
1614
1615 }
1616
1617 =item curuser_pkgs_sql
1618
1619 Returns an SQL fragment for searching for packages the current user can
1620 use, either via part_pkg.agentnum directly, or via agent type (see
1621 L<FS::type_pkgs>).
1622
1623 =cut
1624
1625 sub curuser_pkgs_sql {
1626   my $class = shift;
1627
1628   $class->_pkgs_sql( $FS::CurrentUser::CurrentUser->agentnums );
1629
1630 }
1631
1632 =item agent_pkgs_sql AGENT | AGENTNUM, ...
1633
1634 Returns an SQL fragment for searching for packages the provided agent or agents
1635 can use, either via part_pkg.agentnum directly, or via agent type (see
1636 L<FS::type_pkgs>).
1637
1638 =cut
1639
1640 sub agent_pkgs_sql {
1641   my $class = shift;  #i'm a class method, not a sub (the question is... why??)
1642   my @agentnums = map { ref($_) ? $_->agentnum : $_ } @_;
1643
1644   $class->_pkgs_sql(@agentnums); #is this why
1645
1646 }
1647
1648 sub _pkgs_sql {
1649   my( $class, @agentnums ) = @_;
1650   my $agentnums = join(',', @agentnums);
1651
1652   "
1653     (
1654       ( agentnum IS NOT NULL AND agentnum IN ($agentnums) )
1655       OR ( agentnum IS NULL
1656            AND EXISTS ( SELECT 1
1657                           FROM type_pkgs
1658                             LEFT JOIN agent_type USING ( typenum )
1659                             LEFT JOIN agent AS typeagent USING ( typenum )
1660                           WHERE type_pkgs.pkgpart = part_pkg.pkgpart
1661                             AND typeagent.agentnum IN ($agentnums)
1662                       )
1663          )
1664     )
1665   ";
1666
1667 }
1668
1669 =back
1670
1671 =head1 SUBROUTINES
1672
1673 =over 4
1674
1675 =item plan_info
1676
1677 =cut
1678
1679 #false laziness w/part_export & cdr
1680 my %info;
1681 foreach my $INC ( @INC ) {
1682   warn "globbing $INC/FS/part_pkg/*.pm\n" if $DEBUG;
1683   foreach my $file ( glob("$INC/FS/part_pkg/*.pm") ) {
1684     warn "attempting to load plan info from $file\n" if $DEBUG;
1685     $file =~ /\/(\w+)\.pm$/ or do {
1686       warn "unrecognized file in $INC/FS/part_pkg/: $file\n";
1687       next;
1688     };
1689     my $mod = $1;
1690     my $info = eval "use FS::part_pkg::$mod; ".
1691                     "\\%FS::part_pkg::$mod\::info;";
1692     if ( $@ ) {
1693       die "error using FS::part_pkg::$mod (skipping): $@\n" if $@;
1694       next;
1695     }
1696     unless ( keys %$info ) {
1697       warn "no %info hash found in FS::part_pkg::$mod, skipping\n";
1698       next;
1699     }
1700     warn "got plan info from FS::part_pkg::$mod: $info\n" if $DEBUG;
1701     #if ( exists($info->{'disabled'}) && $info->{'disabled'} ) {
1702     #  warn "skipping disabled plan FS::part_pkg::$mod" if $DEBUG;
1703     #  next;
1704     #}
1705     $info{$mod} = $info;
1706     $info->{'weight'} ||= 0; # quiet warnings
1707   }
1708 }
1709
1710 # copy one level deep to allow replacement of fields and fieldorder
1711 tie %plans, 'Tie::IxHash',
1712   map  { my %infohash = %{ $info{$_} };
1713           $_ => \%infohash }
1714   sort { $info{$a}->{'weight'} <=> $info{$b}->{'weight'} }
1715   keys %info;
1716
1717 # inheritance of plan options
1718 foreach my $name (keys(%info)) {
1719   if (exists($info{$name}->{'disabled'}) and $info{$name}->{'disabled'}) {
1720     warn "skipping disabled plan FS::part_pkg::$name" if $DEBUG;
1721     delete $plans{$name};
1722     next;
1723   }
1724   my $parents = $info{$name}->{'inherit_fields'} || [];
1725   my (%fields, %field_exists, @fieldorder);
1726   foreach my $parent ($name, @$parents) {
1727     if ( !exists($info{$parent}) ) {
1728       warn "$name tried to inherit from nonexistent '$parent'\n";
1729       next;
1730     }
1731     %fields = ( # avoid replacing existing fields
1732       %{ $info{$parent}->{'fields'} || {} },
1733       %fields
1734     );
1735     foreach (@{ $info{$parent}->{'fieldorder'} || [] }) {
1736       # avoid duplicates
1737       next if $field_exists{$_};
1738       $field_exists{$_} = 1;
1739       # allow inheritors to remove inherited fields from the fieldorder
1740       push @fieldorder, $_ if !exists($fields{$_}) or
1741                               !exists($fields{$_}->{'disabled'});
1742     }
1743   }
1744   $plans{$name}->{'fields'} = \%fields;
1745   $plans{$name}->{'fieldorder'} = \@fieldorder;
1746 }
1747
1748 sub plan_info {
1749   \%plans;
1750 }
1751
1752
1753 =back
1754
1755 =head1 NEW PLAN CLASSES
1756
1757 A module should be added in FS/FS/part_pkg/  Eventually, an example may be
1758 found in eg/plan_template.pm.  Until then, it is suggested that you use the
1759 other modules in FS/FS/part_pkg/ as a guide.
1760
1761 =head1 BUGS
1762
1763 The delete method is unimplemented.
1764
1765 setup and recur semantics are not yet defined (and are implemented in
1766 FS::cust_bill.  hmm.).  now they're deprecated and need to go.
1767
1768 plandata should go
1769
1770 part_pkg_taxrate is Pg specific
1771
1772 replace should be smarter about managing the related tables (options, pkg_svc)
1773
1774 =head1 SEE ALSO
1775
1776 L<FS::Record>, L<FS::cust_pkg>, L<FS::type_pkgs>, L<FS::pkg_svc>, L<Safe>.
1777 schema.html from the base documentation.
1778
1779 =cut
1780
1781 1;
1782