FS/FS/part_pkg.pm

   1 package FS::part_pkg;
   2 use base qw( FS::part_pkg::API
   3              FS::m2m_Common FS::o2m_Common FS::option_Common
   4            );
   5
   6 use strict;
   7 use vars qw( %plans $DEBUG $setup_hack $skip_pkg_svc_hack
   8              $cache_enabled %cache_link %cache_pkg_svc
   9            );
  10 use Carp qw(carp cluck confess);
  11 use Scalar::Util qw( blessed );
  12 use DateTime;
  13 use Time::Local qw( timelocal timelocal_nocheck ); # eventually replace with DateTime
  14 use Tie::IxHash;
  15 use FS::Conf;
  16 use FS::Record qw( qsearch qsearchs dbh dbdef );
  17 use FS::Cursor; # for upgrade
  18 use FS::pkg_svc;
  19 use FS::part_svc;
  20 use FS::cust_pkg;
  21 use FS::agent_type;
  22 use FS::type_pkgs;
  23 use FS::part_pkg_option;
  24 use FS::part_pkg_fcc_option;
  25 use FS::pkg_class;
  26 use FS::agent;
  27 use FS::part_pkg_msgcat;
  28 use FS::part_pkg_taxrate;
  29 use FS::part_pkg_taxoverride;
  30 use FS::part_pkg_taxproduct;
  31 use FS::part_pkg_link;
  32 use FS::part_pkg_discount;
  33 use FS::part_pkg_vendor;
  34 use FS::part_pkg_currency;
  35 use FS::part_svc_link;
  36
  37 $DEBUG = 0;
  38
  39 $setup_hack = 0;
  40 $skip_pkg_svc_hack = 0;
  41
  42 $cache_enabled = 0;
  43 %cache_link = ();
  44 %cache_pkg_svc = ();
  45
  46 =head1 NAME
  47
  48 FS::part_pkg - Object methods for part_pkg objects
  49
  50 =head1 SYNOPSIS
  51
  52   use FS::part_pkg;
  53
  54   $record = new FS::part_pkg \%hash
  55   $record = new FS::part_pkg { 'column' => 'value' };
  56
  57   $custom_record = $template_record->clone;
  58
  59   $error = $record->insert;
  60
  61   $error = $new_record->replace($old_record);
  62
  63   $error = $record->delete;
  64
  65   $error = $record->check;
  66
  67   @pkg_svc = $record->pkg_svc;
  68
  69   $svcnum = $record->svcpart;
  70   $svcnum = $record->svcpart( 'svc_acct' );
  71
  72 =head1 DESCRIPTION
  73
  74 An FS::part_pkg object represents a package definition.  FS::part_pkg
  75 inherits from FS::Record.  The following fields are currently supported:
  76
  77 =over 4
  78
  79 =item pkgpart - primary key (assigned automatically for new package definitions)
  80
  81 =item pkg - Text name of this package definition (customer-viewable)
  82
  83 =item comment - Text name of this package definition (non-customer-viewable)
  84
  85 =item classnum - Optional package class (see L<FS::pkg_class>)
  86
  87 =item promo_code - Promotional code
  88
  89 =item setup - Setup fee expression (deprecated)
  90
  91 =item freq - Frequency of recurring fee
  92
  93 =item recur - Recurring fee expression (deprecated)
  94
  95 =item setuptax - Setup fee tax exempt flag, empty or `Y'
  96
  97 =item recurtax - Recurring fee tax exempt flag, empty or `Y'
  98
  99 =item taxclass - Tax class
 100
 101 =item plan - Price plan
 102
 103 =item plandata - Price plan data (deprecated - see L<FS::part_pkg_option> instead)
 104
 105 =item disabled - Disabled flag, empty or `Y'
 106
 107 =item custom - Custom flag, empty or `Y'
 108
 109 =item setup_cost - for cost tracking
 110
 111 =item recur_cost - for cost tracking
 112
 113 =item pay_weight - Weight (relative to credit_weight and other package definitions) that controls payment application to specific line items.
 114
 115 =item credit_weight - Weight (relative to other package definitions) that controls credit application to specific line items.
 116
 117 =item agentnum - Optional agentnum (see L<FS::agent>)
 118
 119 =item fcc_ds0s - Optional DS0 equivalency number for FCC form 477
 120
 121 =item fcc_voip_class - Which column of FCC form 477 part II.B this package
 122 belongs in.
 123
 124 =item successor - Foreign key for the part_pkg that replaced this record.
 125 If this record is not obsolete, will be null.
 126
 127 =item family_pkgpart - Foreign key for the part_pkg that was the earliest
 128 ancestor of this record.  If this record is not a successor to another
 129 part_pkg, will be equal to pkgpart.
 130
 131 =item delay_start - Number of days to delay package start, by default
 132
 133 =item start_on_hold - 'Y' to suspend this package immediately when it is
 134 ordered. The package will not start billing or have a setup fee charged
 135 until it is manually unsuspended.
 136
 137 =item change_to_pkgpart - When this package is ordered, schedule a future
 138 package change. The 'expire_months' field will determine when the package
 139 change occurs.
 140
 141 =item expire_months - Number of months until this package expires (or changes
 142 to another package).
 143
 144 =item adjourn_months - Number of months until this package becomes suspended.
 145
 146 =item contract_end_months - Number of months until the package's contract
 147 ends.
 148
 149 =back
 150
 151 =head1 METHODS
 152
 153 =over 4
 154
 155 =item new HASHREF
 156
 157 Creates a new package definition.  To add the package definition to
 158 the database, see L<"insert">.
 159
 160 =cut
 161
 162 sub table { 'part_pkg'; }
 163
 164 =item clone
 165
 166 An alternate constructor.  Creates a new package definition by duplicating
 167 an existing definition.  A new pkgpart is assigned and the custom flag is
 168 set to Y.  To add the package definition to the database, see L<"insert">.
 169
 170 =cut
 171
 172 sub clone {
 173   my $self = shift;
 174   my $class = ref($self);
 175   my %hash = $self->hash;
 176   $hash{'pkgpart'} = '';
 177   $hash{'custom'} = 'Y';
 178   #new FS::part_pkg ( \%hash ); # ?
 179   new $class ( \%hash ); # ?
 180 }
 181
 182 =item insert [ , OPTION => VALUE ... ]
 183
 184 Adds this package definition to the database.  If there is an error,
 185 returns the error, otherwise returns false.
 186
 187 Currently available options are: I<pkg_svc>, I<primary_svc>, I<cust_pkg>,
 188 I<custnum_ref> and I<options>.
 189
 190 If I<pkg_svc> is set to a hashref with svcparts as keys and quantities as
 191 values, appropriate FS::pkg_svc records will be inserted.  I<hidden_svc> can
 192 be set to a hashref of svcparts and flag values ('Y' or '') to set the
 193 'hidden' field in these records, and I<provision_hold> can be set similarly
 194 for the 'provision_hold' field in these records.
 195
 196 If I<primary_svc> is set to the svcpart of the primary service, the appropriate
 197 FS::pkg_svc record will be updated.
 198
 199 If I<cust_pkg> is set to a pkgnum of a FS::cust_pkg record (or the FS::cust_pkg
 200 record itself), the object will be updated to point to this package definition.
 201
 202 In conjunction with I<cust_pkg>, if I<custnum_ref> is set to a scalar reference,
 203 the scalar will be updated with the custnum value from the cust_pkg record.
 204
 205 If I<tax_overrides> is set to a hashref with usage classes as keys and comma
 206 separated tax class numbers as values, appropriate FS::part_pkg_taxoverride
 207 records will be inserted.
 208
 209 If I<options> is set to a hashref of options, appropriate FS::part_pkg_option
 210 records will be inserted.
 211
 212 If I<part_pkg_currency> is set to a hashref of options (with the keys as
 213 option_CURRENCY), appropriate FS::part_pkg::currency records will be inserted.
 214
 215 =cut
 216
 217 sub insert {
 218   my $self = shift;
 219   my %options = @_;
 220   warn "FS::part_pkg::insert called on $self with options ".
 221        join(', ', map "$_=>$options{$_}", keys %options)
 222     if $DEBUG;
 223
 224   local $SIG{HUP} = 'IGNORE';
 225   local $SIG{INT} = 'IGNORE';
 226   local $SIG{QUIT} = 'IGNORE';
 227   local $SIG{TERM} = 'IGNORE';
 228   local $SIG{TSTP} = 'IGNORE';
 229   local $SIG{PIPE} = 'IGNORE';
 230
 231   my $oldAutoCommit = $FS::UID::AutoCommit;
 232   local $FS::UID::AutoCommit = 0;
 233   my $dbh = dbh;
 234
 235   if ( length($self->classnum) && $self->classnum !~ /^(\d+)$/ ) {
 236     my $pkg_class = qsearchs('pkg_class', { 'classname' => $self->classnum } )
 237                  || new FS::pkg_class { classname => $self->classnum };
 238     unless ( $pkg_class->classnum ) {
 239       my $error = $pkg_class->insert;
 240       if ( $error ) {
 241         $dbh->rollback if $oldAutoCommit;
 242         return $error;
 243       }
 244     }
 245     $self->classnum( $pkg_class->classnum );
 246   }
 247
 248   warn "  inserting part_pkg record" if $DEBUG;
 249   my $error = $self->SUPER::insert( $options{options} );
 250   if ( $error ) {
 251     $dbh->rollback if $oldAutoCommit;
 252     return $error;
 253   }
 254
 255   # set family_pkgpart
 256   if ( $self->get('family_pkgpart') eq '' ) {
 257     $self->set('family_pkgpart' => $self->pkgpart);
 258     $error = $self->SUPER::replace;
 259     if ( $error ) {
 260       $dbh->rollback if $oldAutoCommit;
 261       return $error;
 262     }
 263   }
 264
 265   warn "  inserting part_pkg_taxoverride records" if $DEBUG;
 266   my %overrides = %{ $options{'tax_overrides'} || {} };
 267   foreach my $usage_class ( keys %overrides ) {
 268     my $override =
 269       ( exists($overrides{$usage_class}) && defined($overrides{$usage_class}) )
 270         ? $overrides{$usage_class}
 271         : '';
 272     my @overrides = (grep "$_", split(',', $override) );
 273     my $error = $self->process_m2m (
 274                   'link_table'   => 'part_pkg_taxoverride',
 275                   'target_table' => 'tax_class',
 276                   'hashref'      => { 'usage_class' => $usage_class },
 277                   'params'       => \@overrides,
 278                 );
 279     if ( $error ) {
 280       $dbh->rollback if $oldAutoCommit;
 281       return $error;
 282     }
 283   }
 284
 285   warn "  inserting part_pkg_currency records" if $DEBUG;
 286   my %part_pkg_currency = %{ $options{'part_pkg_currency'} || {} };
 287   foreach my $key ( keys %part_pkg_currency ) {
 288     $key =~ /^(.+)_([A-Z]{3})$/ or next;
 289     my( $optionname, $currency ) = ( $1, $2 );
 290     if ( $part_pkg_currency{$key} =~ /^\s*$/ ) {
 291       if ( $self->option($optionname) == 0 ) {
 292         $part_pkg_currency{$key} = '0';
 293       } else {
 294         $dbh->rollback if $oldAutoCommit;
 295         ( my $thing = $optionname ) =~ s/_/ /g;
 296         return ucfirst($thing). " $currency is required";
 297       }
 298     }
 299     my $part_pkg_currency = new FS::part_pkg_currency {
 300       'pkgpart'     => $self->pkgpart,
 301       'optionname'  => $optionname,
 302       'currency'    => $currency,
 303       'optionvalue' => $part_pkg_currency{$key},
 304     };
 305     my $error = $part_pkg_currency->insert;
 306     if ( $error ) {
 307       $dbh->rollback if $oldAutoCommit;
 308       return $error;
 309     }
 310   }
 311
 312   unless ( $skip_pkg_svc_hack ) {
 313
 314     warn "  inserting pkg_svc records" if $DEBUG;
 315     my $pkg_svc = $options{'pkg_svc'} || {};
 316     my $hidden_svc = $options{'hidden_svc'} || {};
 317     my $provision_hold = $options{'provision_hold'} || {};
 318     foreach my $part_svc ( qsearch('part_svc', {} ) ) {
 319       my $quantity = $pkg_svc->{$part_svc->svcpart} || 0;
 320       my $primary_svc =
 321         ( $options{'primary_svc'} && $options{'primary_svc'}==$part_svc->svcpart )
 322           ? 'Y'
 323           : '';
 324
 325       my $pkg_svc = new FS::pkg_svc( {
 326         'pkgpart'     => $self->pkgpart,
 327         'svcpart'     => $part_svc->svcpart,
 328         'quantity'    => $quantity,
 329         'primary_svc' => $primary_svc,
 330         'hidden'      => $hidden_svc->{$part_svc->svcpart},
 331         'provision_hold' => $provision_hold->{$part_svc->svcpart},
 332       } );
 333       my $error = $pkg_svc->insert;
 334       if ( $error ) {
 335         $dbh->rollback if $oldAutoCommit;
 336         return $error;
 337       }
 338     }
 339
 340     my $error = $self->check_pkg_svc(%options);
 341     if ( $error ) {
 342       $dbh->rollback if $oldAutoCommit;
 343       return $error;
 344     }
 345
 346   }
 347
 348   if ( $options{'cust_pkg'} ) {
 349     warn "  updating cust_pkg record " if $DEBUG;
 350     my $old_cust_pkg =
 351       ref($options{'cust_pkg'})
 352         ? $options{'cust_pkg'}
 353         : qsearchs('cust_pkg', { pkgnum => $options{'cust_pkg'} } );
 354     ${ $options{'custnum_ref'} } = $old_cust_pkg->custnum
 355       if $options{'custnum_ref'};
 356     my %hash = $old_cust_pkg->hash;
 357     $hash{'pkgpart'} = $self->pkgpart,
 358     my $new_cust_pkg = new FS::cust_pkg \%hash;
 359     local($FS::cust_pkg::disable_agentcheck) = 1;
 360     my $error = $new_cust_pkg->replace($old_cust_pkg);
 361     if ( $error ) {
 362       $dbh->rollback if $oldAutoCommit;
 363       return "Error modifying cust_pkg record: $error";
 364     }
 365   }
 366
 367   if ( $options{'part_pkg_vendor'} ) {
 368       while ( my ($exportnum, $vendor_pkg_id) =
 369                 each %{ $options{part_pkg_vendor} }
 370             )
 371       {
 372             my $ppv = new FS::part_pkg_vendor( {
 373                     'pkgpart' => $self->pkgpart,
 374                     'exportnum' => $exportnum,
 375                     'vendor_pkg_id' => $vendor_pkg_id,
 376                 } );
 377             my $error = $ppv->insert;
 378             if ( $error ) {
 379               $dbh->rollback if $oldAutoCommit;
 380               return "Error inserting part_pkg_vendor record: $error";
 381             }
 382       }
 383   }
 384
 385   if ( $options{fcc_options} ) {
 386     warn "  updating fcc options " if $DEBUG;
 387     $self->set_fcc_options( $options{fcc_options} );
 388   }
 389
 390   warn "  committing transaction" if $DEBUG and $oldAutoCommit;
 391   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 392
 393   '';
 394 }
 395
 396 =item delete
 397
 398 Currently unimplemented.
 399
 400 =cut
 401
 402 sub delete {
 403   return "Can't (yet?) delete package definitions.";
 404 # check & make sure the pkgpart isn't in cust_pkg or type_pkgs?
 405 }
 406
 407 =item replace OLD_RECORD [ , OPTION => VALUE ... ]
 408
 409 Replaces OLD_RECORD with this one in the database.  If there is an error,
 410 returns the error, otherwise returns false.
 411
 412 Currently available options are: I<pkg_svc>, I<hidden_svc>, I<primary_svc>,
 413 I<bulk_skip>, I<provision_hold> and I<options>
 414
 415 If I<pkg_svc> is set to a hashref with svcparts as keys and quantities as
 416 values, the appropriate FS::pkg_svc records will be replaced.  I<hidden_svc>
 417 can be set to a hashref of svcparts and flag values ('Y' or '') to set the
 418 'hidden' field in these records.  I<bulk_skip> and I<provision_hold> can be
 419 set to a hashref of svcparts and flag values ('Y' or '') to set the
 420 respective field in those records.
 421
 422 If I<primary_svc> is set to the svcpart of the primary service, the
 423 appropriate FS::pkg_svc record will be updated.
 424
 425 If I<options> is set to a hashref, the appropriate FS::part_pkg_option
 426 records will be replaced.
 427
 428 If I<part_pkg_currency> is set to a hashref of options (with the keys as
 429 option_CURRENCY), appropriate FS::part_pkg::currency records will be
 430 replaced.
 431
 432 =cut
 433
 434 sub replace {
 435   my $new = shift;
 436
 437   my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
 438               ? shift
 439               : $new->replace_old;
 440
 441   my $options =
 442     ( ref($_[0]) eq 'HASH' )
 443       ? shift
 444       : { @_ };
 445
 446   $options->{options} = { $old->options } unless defined($options->{options});
 447
 448   warn "FS::part_pkg::replace called on $new to replace $old with options".
 449        join(', ', map "$_ => ". $options->{$_}, keys %$options)
 450     if $DEBUG;
 451
 452   local $SIG{HUP} = 'IGNORE';
 453   local $SIG{INT} = 'IGNORE';
 454   local $SIG{QUIT} = 'IGNORE';
 455   local $SIG{TERM} = 'IGNORE';
 456   local $SIG{TSTP} = 'IGNORE';
 457   local $SIG{PIPE} = 'IGNORE';
 458
 459   my $oldAutoCommit = $FS::UID::AutoCommit;
 460   local $FS::UID::AutoCommit = 0;
 461   my $dbh = dbh;
 462
 463   my $conf = new FS::Conf;
 464   if ( $conf->exists('part_pkg-lineage') ) {
 465     if ( grep { $options->{options}->{$_} ne $old->option($_, 1) }
 466           qw(setup_fee recur_fee) #others? config?
 467         ) {
 468
 469       warn "  superseding package" if $DEBUG;
 470
 471       my $error = $new->supersede($old, %$options);
 472       if ( $error ) {
 473         $dbh->rollback if $oldAutoCommit;
 474         return $error;
 475       }
 476       else {
 477         warn "  committing transaction" if $DEBUG and $oldAutoCommit;
 478         $dbh->commit if $oldAutoCommit;
 479         return $error;
 480       }
 481     }
 482     #else nothing
 483   }
 484
 485   #plandata shit stays in replace for upgrades until after 2.0 (or edit
 486   #_upgrade_data)
 487   warn "  saving legacy plandata" if $DEBUG;
 488   my $plandata = $new->get('plandata');
 489   $new->set('plandata', '');
 490
 491   warn "  deleting old part_pkg_option records" if $DEBUG;
 492   foreach my $part_pkg_option ( $old->part_pkg_option ) {
 493     my $error = $part_pkg_option->delete;
 494     if ( $error ) {
 495       $dbh->rollback if $oldAutoCommit;
 496       return $error;
 497     }
 498   }
 499
 500   warn "  replacing part_pkg record" if $DEBUG;
 501   my $error = $new->SUPER::replace($old, $options->{options} );
 502   if ( $error ) {
 503     $dbh->rollback if $oldAutoCommit;
 504     return $error;
 505   }
 506
 507   warn "  inserting part_pkg_option records for plandata: $plandata|" if $DEBUG;
 508   foreach my $part_pkg_option (
 509     map { /^(\w+)=(.*)$/ or do { $dbh->rollback if $oldAutoCommit;
 510                                  return "illegal plandata: $plandata";
 511                                };
 512           new FS::part_pkg_option {
 513             'pkgpart'     => $new->pkgpart,
 514             'optionname'  => $1,
 515             'optionvalue' => $2,
 516           };
 517         }
 518     split("\n", $plandata)
 519   ) {
 520     my $error = $part_pkg_option->insert;
 521     if ( $error ) {
 522       $dbh->rollback if $oldAutoCommit;
 523       return $error;
 524     }
 525   }
 526
 527   #trivial nit: not the most efficient to delete and reinsert
 528   warn "  deleting old part_pkg_currency records" if $DEBUG;
 529   foreach my $part_pkg_currency ( $old->part_pkg_currency ) {
 530     my $error = $part_pkg_currency->delete;
 531     if ( $error ) {
 532       $dbh->rollback if $oldAutoCommit;
 533       return "error deleting part_pkg_currency record: $error";
 534     }
 535   }
 536
 537   warn "  inserting new part_pkg_currency records" if $DEBUG;
 538   my %part_pkg_currency = %{ $options->{'part_pkg_currency'} || {} };
 539   foreach my $key ( keys %part_pkg_currency ) {
 540     $key =~ /^(.+)_([A-Z]{3})$/ or next;
 541     my $part_pkg_currency = new FS::part_pkg_currency {
 542       'pkgpart'     => $new->pkgpart,
 543       'optionname'  => $1,
 544       'currency'    => $2,
 545       'optionvalue' => $part_pkg_currency{$key},
 546     };
 547     my $error = $part_pkg_currency->insert;
 548     if ( $error ) {
 549       $dbh->rollback if $oldAutoCommit;
 550       return "error inserting part_pkg_currency record: $error";
 551     }
 552   }
 553
 554
 555   warn "  replacing pkg_svc records" if $DEBUG;
 556   my $pkg_svc = $options->{'pkg_svc'};
 557   my $hidden_svc = $options->{'hidden_svc'} || {};
 558   my $bulk_skip  = $options->{'bulk_skip'} || {};
 559   my $provision_hold = $options->{'provision_hold'} || {};
 560   if ( $pkg_svc ) { # if it wasn't passed, don't change existing pkg_svcs
 561
 562     foreach my $part_svc ( qsearch('part_svc', {} ) ) {
 563       my $quantity  = $pkg_svc->{$part_svc->svcpart} || 0;
 564       my $hidden    = $hidden_svc->{$part_svc->svcpart} || '';
 565       my $bulk_skip = $bulk_skip->{$part_svc->svcpart} || '';
 566       my $provision_hold = $provision_hold->{$part_svc->svcpart} || '';
 567       my $primary_svc =
 568         ( defined($options->{'primary_svc'}) && $options->{'primary_svc'}
 569           && $options->{'primary_svc'} == $part_svc->svcpart
 570         )
 571           ? 'Y'
 572           : '';
 573
 574       my $old_pkg_svc = qsearchs('pkg_svc', {
 575           'pkgpart' => $old->pkgpart,
 576           'svcpart' => $part_svc->svcpart,
 577         }
 578       );
 579       my $old_quantity = 0;
 580       my $old_primary_svc = '';
 581       my $old_hidden = '';
 582       my $old_bulk_skip = '';
 583       my $old_provision_hold = '';
 584       if ( $old_pkg_svc ) {
 585         $old_quantity = $old_pkg_svc->quantity;
 586         $old_primary_svc = $old_pkg_svc->primary_svc
 587           if $old_pkg_svc->dbdef_table->column('primary_svc'); # is this needed?
 588         $old_hidden = $old_pkg_svc->hidden;
 589         $old_bulk_skip = $old_pkg_svc->old_bulk_skip; # should this just be bulk_skip?
 590         $old_provision_hold = $old_pkg_svc->provision_hold;
 591       }
 592
 593       next unless $old_quantity    != $quantity
 594                || $old_primary_svc ne $primary_svc
 595                || $old_hidden      ne $hidden
 596                || $old_bulk_skip   ne $bulk_skip
 597                || $old_provision_hold ne $provision_hold;
 598
 599       my $new_pkg_svc = new FS::pkg_svc( {
 600         'pkgsvcnum'   => ( $old_pkg_svc ? $old_pkg_svc->pkgsvcnum : '' ),
 601         'pkgpart'     => $new->pkgpart,
 602         'svcpart'     => $part_svc->svcpart,
 603         'quantity'    => $quantity,
 604         'primary_svc' => $primary_svc,
 605         'hidden'      => $hidden,
 606         'bulk_skip'   => $bulk_skip,
 607         'provision_hold' => $provision_hold,
 608       } );
 609       my $error = $old_pkg_svc
 610                     ? $new_pkg_svc->replace($old_pkg_svc)
 611                     : $new_pkg_svc->insert;
 612       if ( $error ) {
 613         $dbh->rollback if $oldAutoCommit;
 614         return $error;
 615       }
 616     } #foreach $part_svc
 617
 618     my $error = $new->check_pkg_svc(%$options);
 619     if ( $error ) {
 620       $dbh->rollback if $oldAutoCommit;
 621       return $error;
 622     }
 623
 624   } #if $options->{pkg_svc}
 625
 626   my @part_pkg_vendor = $old->part_pkg_vendor;
 627   my @current_exportnum = ();
 628   if ( $options->{'part_pkg_vendor'} ) {
 629       my($exportnum,$vendor_pkg_id);
 630       while ( ($exportnum,$vendor_pkg_id)
 631                                 = each %{$options->{'part_pkg_vendor'}} ) {
 632           my $noinsert = 0;
 633           foreach my $part_pkg_vendor ( @part_pkg_vendor ) {
 634             if($exportnum == $part_pkg_vendor->exportnum
 635                 && $vendor_pkg_id ne $part_pkg_vendor->vendor_pkg_id) {
 636                 $part_pkg_vendor->vendor_pkg_id($vendor_pkg_id);
 637                 my $error = $part_pkg_vendor->replace;
 638                 if ( $error ) {
 639                   $dbh->rollback if $oldAutoCommit;
 640                   return "Error replacing part_pkg_vendor record: $error";
 641                 }
 642                 $noinsert = 1;
 643                 last;
 644             }
 645             elsif($exportnum == $part_pkg_vendor->exportnum
 646                 && $vendor_pkg_id eq $part_pkg_vendor->vendor_pkg_id) {
 647                 $noinsert = 1;
 648                 last;
 649             }
 650           }
 651           unless ( $noinsert ) {
 652             my $ppv = new FS::part_pkg_vendor( {
 653                     'pkgpart' => $new->pkgpart,
 654                     'exportnum' => $exportnum,
 655                     'vendor_pkg_id' => $vendor_pkg_id,
 656                 } );
 657             my $error = $ppv->insert;
 658             if ( $error ) {
 659               $dbh->rollback if $oldAutoCommit;
 660               return "Error inserting part_pkg_vendor record: $error";
 661             }
 662           }
 663           push @current_exportnum, $exportnum;
 664       }
 665   }
 666   foreach my $part_pkg_vendor ( @part_pkg_vendor ) {
 667       unless ( grep($_ eq $part_pkg_vendor->exportnum, @current_exportnum) ) {
 668         my $error = $part_pkg_vendor->delete;
 669         if ( $error ) {
 670           $dbh->rollback if $oldAutoCommit;
 671           return "Error deleting part_pkg_vendor record: $error";
 672         }
 673       }
 674   }
 675
 676   # propagate changes to certain core fields
 677   if ( $conf->exists('part_pkg-lineage') ) {
 678     warn "  propagating changes to family" if $DEBUG;
 679     my $error = $new->propagate($old);
 680     if ( $error ) {
 681       $dbh->rollback if $oldAutoCommit;
 682       return $error;
 683     }
 684   }
 685
 686   if ( $options->{fcc_options} ) {
 687     warn "  updating fcc options " if $DEBUG;
 688     $new->set_fcc_options( $options->{fcc_options} );
 689   }
 690
 691   warn "  committing transaction" if $DEBUG and $oldAutoCommit;
 692   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 693   '';
 694 }
 695
 696 =item check
 697
 698 Checks all fields to make sure this is a valid package definition.  If
 699 there is an error, returns the error, otherwise returns false.  Called by the
 700 insert and replace methods.
 701
 702 =cut
 703
 704 sub check {
 705   my $self = shift;
 706   warn "FS::part_pkg::check called on $self" if $DEBUG;
 707
 708   for (qw(setup recur plandata)) {
 709     #$self->set($_=>0) if $self->get($_) =~ /^\s*$/; }
 710     return "Use of $_ field is deprecated; set a plan and options: ".
 711            $self->get($_)
 712       if length($self->get($_));
 713     $self->set($_, '');
 714   }
 715
 716   if ( $self->dbdef_table->column('freq')->type =~ /(int)/i ) {
 717     my $error = $self->ut_number('freq');
 718     return $error if $error;
 719   } else {
 720     $self->freq =~ /^(\d+[hdw]?)$/
 721       or return "Illegal or empty freq: ". $self->freq;
 722     $self->freq($1);
 723   }
 724
 725   my @null_agentnum_right = ( 'Edit global package definitions' );
 726   push @null_agentnum_right, 'One-time charge'
 727     if $self->freq =~ /^0/;
 728   push @null_agentnum_right, 'Customize customer package'
 729     if $self->disabled eq 'Y'; #good enough
 730
 731   my $error = $self->ut_numbern('pkgpart')
 732     || $self->ut_text('pkg')
 733     || $self->ut_textn('comment')
 734     || $self->ut_textn('promo_code')
 735     || $self->ut_alphan('plan')
 736     || $self->ut_flag('setuptax')
 737     || $self->ut_flag('recurtax')
 738     || $self->ut_textn('taxclass')
 739     || $self->ut_flag('disabled')
 740     || $self->ut_flag('custom')
 741     || $self->ut_flag('no_auto')
 742     || $self->ut_flag('recur_show_zero')
 743     || $self->ut_flag('setup_show_zero')
 744     || $self->ut_flag('start_on_hold')
 745     #|| $self->ut_moneyn('setup_cost')
 746     #|| $self->ut_moneyn('recur_cost')
 747     || $self->ut_floatn('setup_cost')
 748     || $self->ut_floatn('recur_cost')
 749     || $self->ut_floatn('pay_weight')
 750     || $self->ut_floatn('credit_weight')
 751     || $self->ut_numbern('taxproductnum')
 752     || $self->ut_numbern('units_taxproductnum')
 753     || $self->ut_foreign_keyn('classnum',       'pkg_class', 'classnum')
 754     || $self->ut_foreign_keyn('addon_classnum', 'pkg_class', 'classnum')
 755     || $self->ut_foreign_keyn('taxproductnum',
 756                               'part_pkg_taxproduct',
 757                               'taxproductnum'
 758                              )
 759     || ( $setup_hack
 760            ? $self->ut_foreign_keyn('agentnum', 'agent', 'agentnum' )
 761            : $self->ut_agentnum_acl('agentnum', \@null_agentnum_right)
 762        )
 763     || $self->ut_numbern('fcc_ds0s')
 764     || $self->ut_numbern('fcc_voip_class')
 765     || $self->ut_numbern('delay_start')
 766     || $self->ut_foreign_keyn('successor', 'part_pkg', 'pkgpart')
 767     || $self->ut_foreign_keyn('family_pkgpart', 'part_pkg', 'pkgpart')
 768     || $self->ut_numbern('expire_months')
 769     || $self->ut_numbern('adjourn_months')
 770     || $self->ut_numbern('contract_end_months')
 771     || $self->ut_numbern('change_to_pkgpart')
 772     || $self->ut_foreign_keyn('change_to_pkgpart', 'part_pkg', 'pkgpart')
 773     || $self->ut_alphan('agent_pkgpartid')
 774     || $self->SUPER::check
 775   ;
 776   return $error if $error;
 777
 778   return 'Unknown plan '. $self->plan
 779     unless exists($plans{$self->plan});
 780
 781   my $conf = new FS::Conf;
 782   return 'Taxclass is required'
 783     if ! $self->taxclass && $conf->exists('require_taxclasses');
 784
 785   '';
 786 }
 787
 788 =item check_options
 789
 790 Pass an I<$options> hashref that contains the values to be
 791 inserted or updated for any FS::part_pkg::MODULE.pm.
 792
 793 For each key in I<$options>, validates the value by calling
 794 the 'validate' subroutine defined for that option e.g.
 795 FS::part_pkg::MODULE::plan_info()->{$KEY}->{validate}.  The
 796 option validation function is only called when the hashkey for
 797 that option exists in I<$options>.
 798
 799 Then the module validation function is called, from
 800 FS::part_pkg::MODULE::plan_info()->{validate}
 801
 802 Returns error message, or empty string if valid.
 803
 804 Invoked by L</insert> and L</replace> via the equivalent
 805 methods in L<FS::option_Common>.
 806
 807 =cut
 808
 809 sub check_options {
 810   my ($self,$options) = @_;
 811   foreach my $option (keys %$options) {
 812     if (exists $plans{ $self->plan }->{fields}->{$option}) {
 813       if (exists($plans{$self->plan}->{fields}->{$option}->{'validate'})) {
 814         # pass option name for use in error message
 815         # pass a reference to the $options value, so it can be cleaned up
 816         my $error = &{$plans{$self->plan}->{fields}->{$option}->{'validate'}}($option,\($options->{$option}));
 817         return $error if $error;
 818       }
 819     } # else "option does not exist" error?
 820   }
 821   if (exists($plans{$self->plan}->{'validate'})) {
 822     my $error = &{$plans{$self->plan}->{'validate'}}($options);
 823     return $error if $error;
 824   }
 825   return '';
 826 }
 827
 828 =item check_pkg_svc
 829
 830 Checks pkg_svc records as a whole (for part_svc_link dependencies).
 831
 832 If there is an error, returns the error, otherwise returns false.
 833
 834 =cut
 835
 836 sub check_pkg_svc {
 837   my( $self, %opt ) = @_;
 838
 839   my $agentnum = $self->agentnum;
 840
 841   my %pkg_svc = map { $_->svcpart => $_ } $self->pkg_svc;
 842
 843   foreach my $svcpart ( keys %pkg_svc ) {
 844
 845     foreach my $part_svc_link ( $self->part_svc_link(
 846                                   'src_svcpart' => $svcpart,
 847                                   'link_type'   => 'part_pkg_restrict',
 848                                 )
 849     ) {
 850
 851       return $part_svc_link->dst_svc. ' must be included with '.
 852              $part_svc_link->src_svc
 853         unless $pkg_svc{ $part_svc_link->dst_svcpart };
 854     }
 855
 856   }
 857
 858   return '' if $opt{part_pkg_restrict_soft_override};
 859
 860   foreach my $svcpart ( keys %pkg_svc ) {
 861
 862     foreach my $part_svc_link ( $self->part_svc_link(
 863                                   'src_svcpart' => $svcpart,
 864                                   'link_type'   => 'part_pkg_restrict_soft',
 865                                 )
 866     ) {
 867       return $part_svc_link->dst_svc. ' is suggested with '.
 868              $part_svc_link->src_svc
 869         unless $pkg_svc{ $part_svc_link->dst_svcpart };
 870     }
 871
 872   }
 873
 874   '';
 875 }
 876
 877 =item part_svc_link OPTION => VALUE ...
 878
 879 Returns the service dependencies (see L<FS::part_svc_link>) for the given
 880 search options, taking into account this package definition's agent.
 881
 882 Available options are any field in part_svc_link.  Typically used options are
 883 src_svcpart and link_type.
 884
 885 =cut
 886
 887 sub part_svc_link {
 888   FS::part_svc_link->by_agentnum( shift->agentnum, @_ );
 889 }
 890
 891 =item supersede OLD [, OPTION => VALUE ... ]
 892
 893 Inserts this package as a successor to the package OLD.  All options are as
 894 for C<insert>.  After inserting, disables OLD and sets the new package as its
 895 successor.
 896
 897 =cut
 898
 899 sub supersede {
 900   my ($new, $old, %options) = @_;
 901   my $error;
 902
 903   $new->set('pkgpart' => '');
 904   $new->set('family_pkgpart' => $old->family_pkgpart);
 905   warn "    inserting successor package\n" if $DEBUG;
 906   $error = $new->insert(%options);
 907   return $error if $error;
 908
 909   warn "    disabling superseded package\n" if $DEBUG;
 910   $old->set('successor' => $new->pkgpart);
 911   $old->set('disabled' => 'Y');
 912   $error = $old->SUPER::replace; # don't change its options/pkg_svc records
 913   return $error if $error;
 914
 915   warn "  propagating changes to family" if $DEBUG;
 916   $new->propagate($old);
 917 }
 918
 919 =item propagate OLD
 920
 921 If any of certain fields have changed from OLD to this package, then,
 922 for all packages in the same lineage as this one, sets those fields
 923 to their values in this package.
 924
 925 =cut
 926
 927 my @propagate_fields = (
 928   qw( pkg classnum setup_cost recur_cost taxclass
 929   setuptax recurtax pay_weight credit_weight
 930   )
 931 );
 932
 933 sub propagate {
 934   my $new = shift;
 935   my $old = shift;
 936   my %fields = (
 937     map { $_ => $new->get($_) }
 938     grep { $new->get($_) ne $old->get($_) }
 939     @propagate_fields
 940   );
 941
 942   my @part_pkg = qsearch('part_pkg', {
 943       'family_pkgpart' => $new->family_pkgpart
 944   });
 945   my @error;
 946   foreach my $part_pkg ( @part_pkg ) {
 947     my $pkgpart = $part_pkg->pkgpart;
 948     next if $pkgpart == $new->pkgpart; # don't modify $new
 949     warn "    propagating to pkgpart $pkgpart\n" if $DEBUG;
 950     foreach ( keys %fields ) {
 951       $part_pkg->set($_, $fields{$_});
 952     }
 953     # SUPER::replace to avoid changing non-core fields
 954     my $error = $part_pkg->SUPER::replace;
 955     push @error, "pkgpart $pkgpart: $error"
 956       if $error;
 957   }
 958   join("\n", @error);
 959 }
 960
 961 =item set_fcc_options HASHREF
 962
 963 Sets the FCC options on this package definition to the values specified
 964 in HASHREF.
 965
 966 =cut
 967
 968 sub set_fcc_options {
 969   my $self = shift;
 970   my $pkgpart = $self->pkgpart;
 971   my $options;
 972   if (ref $_[0]) {
 973     $options = shift;
 974   } else {
 975     $options = { @_ };
 976   }
 977
 978   my %existing_num = map { $_->fccoptionname => $_->num }
 979                      qsearch('part_pkg_fcc_option', { pkgpart => $pkgpart });
 980
 981   local $FS::Record::nowarn_identical = 1;
 982   # set up params for process_o2m
 983   my $i = 0;
 984   my $params = {};
 985   foreach my $name (keys %$options ) {
 986     $params->{ "num$i" } = $existing_num{$name} || '';
 987     $params->{ "num$i".'_fccoptionname' } = $name;
 988     $params->{ "num$i".'_optionvalue'   } = $options->{$name};
 989     $i++;
 990   }
 991
 992   $self->process_o2m(
 993     table   => 'part_pkg_fcc_option',
 994     fields  => [qw( fccoptionname optionvalue )],
 995     params  => $params,
 996   );
 997 }
 998
 999 =item pkg_locale LOCALE
1000
1001 Returns a customer-viewable string representing this package for the given
1002 locale, from the part_pkg_msgcat table.  If the given locale is empty or no
1003 localized string is found, returns the base pkg field.
1004
1005 =cut
1006
1007 sub pkg_locale {
1008   my( $self, $locale ) = @_;
1009   return $self->pkg unless $locale;
1010   my $part_pkg_msgcat = $self->part_pkg_msgcat($locale) or return $self->pkg;
1011   $part_pkg_msgcat->pkg;
1012 }
1013
1014 =item part_pkg_msgcat LOCALE
1015
1016 Like pkg_locale, but returns the FS::part_pkg_msgcat object itself.
1017
1018 =cut
1019
1020 sub part_pkg_msgcat {
1021   my( $self, $locale ) = @_;
1022   qsearchs( 'part_pkg_msgcat', {
1023     pkgpart => $self->pkgpart,
1024     locale  => $locale,
1025   });
1026 }
1027
1028 =item pkg_comment [ OPTION => VALUE... ]
1029
1030 Returns an (internal) string representing this package.  Currently,
1031 "pkgpart: pkg - comment", is returned.  "pkg - comment" may be returned in the
1032 future, omitting pkgpart.  The comment will have '(CUSTOM) ' prepended if
1033 custom is Y.
1034
1035 If the option nopkgpart is true then the "pkgpart: ' is omitted.
1036
1037 =cut
1038
1039 sub pkg_comment {
1040   my $self = shift;
1041   my %opt = @_;
1042
1043   #$self->pkg. ' - '. $self->comment;
1044   #$self->pkg. ' ('. $self->comment. ')';
1045   my $pre = $opt{nopkgpart} ? '' : $self->pkgpart. ': ';
1046   my $custom_comment = $self->custom_comment(%opt);
1047   $pre. $self->pkg. ( $custom_comment ? " - $custom_comment" : '' );
1048 }
1049
1050 #without price info (so without hitting the DB again)
1051 sub pkg_comment_only {
1052   my $self = shift;
1053   my %opt = @_;
1054
1055   my $pre = $opt{nopkgpart} ? '' : $self->pkgpart. ': ';
1056   my $comment = $self->comment;
1057   $pre. $self->pkg. ( $comment ? " - $comment" : '' );
1058 }
1059
1060 sub price_info { # safety, in case a part_pkg hasn't defined price_info
1061     '';
1062 }
1063
1064 sub custom_comment {
1065   my $self = shift;
1066   my $price_info = $self->price_info(@_);
1067   ( $self->custom ? '(CUSTOM) ' : '' ).
1068     $self->comment.
1069     ( ($self->custom || $self->comment) ? ' - ' : '' ).
1070     ($price_info || 'No charge');
1071 }
1072
1073 sub pkg_price_info {
1074   my $self = shift;
1075   $self->pkg. ' - '. ($self->price_info || 'No charge');
1076 }
1077
1078 =item pkg_class
1079
1080 Returns the package class, as an FS::pkg_class object, or the empty string
1081 if there is no package class.
1082
1083 =item addon_pkg_class
1084
1085 Returns the add-on package class, as an FS::pkg_class object, or the empty
1086 string if there is no add-on package class.
1087
1088 =cut
1089
1090 sub addon_pkg_class {
1091   my $self = shift;
1092   if ( $self->addon_classnum ) {
1093     qsearchs('pkg_class', { 'classnum' => $self->addon_classnum } );
1094   } else {
1095     return '';
1096   }
1097 }
1098
1099 =item categoryname
1100
1101 Returns the package category name, or the empty string if there is no package
1102 category.
1103
1104 =cut
1105
1106 sub categoryname {
1107   my $self = shift;
1108   my $pkg_class = $self->pkg_class;
1109   $pkg_class
1110     ? $pkg_class->categoryname
1111     : '';
1112 }
1113
1114 =item classname
1115
1116 Returns the package class name, or the empty string if there is no package
1117 class.
1118
1119 =cut
1120
1121 sub classname {
1122   my $self = shift;
1123   my $pkg_class = $self->pkg_class;
1124   $pkg_class
1125     ? $pkg_class->classname
1126     : '';
1127 }
1128
1129 =item addon_classname
1130
1131 Returns the add-on package class name, or the empty string if there is no
1132 add-on package class.
1133
1134 =cut
1135
1136 sub addon_classname {
1137   my $self = shift;
1138   my $pkg_class = $self->addon_pkg_class;
1139   $pkg_class
1140     ? $pkg_class->classname
1141     : '';
1142 }
1143
1144 =item agent
1145
1146 Returns the associated agent for this event, if any, as an FS::agent object.
1147
1148 =item pkg_svc [ HASHREF | OPTION => VALUE ]
1149
1150 Returns all FS::pkg_svc objects (see L<FS::pkg_svc>) for this package
1151 definition (with non-zero quantity).
1152
1153 One option is available, I<disable_linked>.  If set true it will return the
1154 services for this package definition alone, omitting services from any add-on
1155 packages.
1156
1157 =cut
1158
1159 =item type_pkgs
1160
1161 Returns all FS::type_pkgs objects (see L<FS::type_pkgs>) for this package
1162 definition.
1163
1164 =cut
1165
1166 sub pkg_svc {
1167   my $self = shift;
1168
1169   return @{ $cache_pkg_svc{$self->pkgpart} }
1170     if $cache_enabled && $cache_pkg_svc{$self->pkgpart};
1171
1172 #  #sort { $b->primary cmp $a->primary }
1173 #    grep { $_->quantity }
1174 #      qsearch( 'pkg_svc', { 'pkgpart' => $self->pkgpart } );
1175
1176   my $opt = ref($_[0]) ? $_[0] : { @_ };
1177   my %pkg_svc = map  { $_->svcpart => $_ } $self->_pkg_svc;
1178
1179   unless ( $opt->{disable_linked} ) {
1180     foreach my $dst_pkg ( map $_->dst_pkg, $self->svc_part_pkg_link ) {
1181       my @pkg_svc = $dst_pkg->_pkg_svc;
1182       foreach my $pkg_svc ( @pkg_svc ) {
1183         if ( $pkg_svc{$pkg_svc->svcpart} ) {
1184           my $quantity = $pkg_svc{$pkg_svc->svcpart}->quantity;
1185           $pkg_svc{$pkg_svc->svcpart}->quantity($quantity + $pkg_svc->quantity);
1186         } else {
1187           $pkg_svc{$pkg_svc->svcpart} = $pkg_svc;
1188         }
1189       }
1190     }
1191   }
1192
1193   my @pkg_svc = values(%pkg_svc);
1194
1195   $cache_pkg_svc{$self->pkgpart} = \@pkg_svc if $cache_enabled;
1196
1197   @pkg_svc;
1198
1199 }
1200
1201 sub _pkg_svc {
1202   my $self = shift;
1203   grep { $_->quantity }
1204     qsearch({
1205       'select'    => 'pkg_svc.*, part_svc.*',
1206       'table'     => 'pkg_svc',
1207       'addl_from' => 'LEFT JOIN part_svc USING ( svcpart )',
1208       'hashref'   => { 'pkgpart' => $self->pkgpart },
1209     });
1210 }
1211
1212 =item svcpart [ SVCDB ]
1213
1214 Returns the svcpart of the primary service definition (see L<FS::part_svc>)
1215 associated with this package definition (see L<FS::pkg_svc>).  Returns
1216 false if there not a primary service definition or exactly one service
1217 definition with quantity 1, or if SVCDB is specified and does not match the
1218 svcdb of the service definition.  SVCDB can be specified as a scalar table
1219 name, such as 'svc_acct', or as an arrayref of possible table names.
1220
1221 =cut
1222
1223 sub svcpart {
1224   my $pkg_svc = shift->_primary_pkg_svc(@_);
1225   $pkg_svc ? $pkg_svc->svcpart : '';
1226 }
1227
1228 =item part_svc [ SVCDB ]
1229
1230 Like the B<svcpart> method, but returns the FS::part_svc object (see
1231 L<FS::part_svc>).
1232
1233 =cut
1234
1235 sub part_svc {
1236   my $pkg_svc = shift->_primary_pkg_svc(@_);
1237   $pkg_svc ? $pkg_svc->part_svc : '';
1238 }
1239
1240 sub _primary_pkg_svc {
1241   my $self = shift;
1242
1243   my $svcdb = scalar(@_) ? shift : [];
1244   $svcdb = ref($svcdb) ? $svcdb : [ $svcdb ];
1245   my %svcdb = map { $_=>1 } @$svcdb;
1246
1247   my @svcdb_pkg_svc =
1248     grep { !scalar(@$svcdb) || $svcdb{ $_->part_svc->svcdb } }
1249          $self->pkg_svc;
1250
1251   my @pkg_svc = grep { $_->primary_svc =~ /^Y/i } @svcdb_pkg_svc;
1252   @pkg_svc = grep {$_->quantity == 1 } @svcdb_pkg_svc
1253     unless @pkg_svc;
1254   return '' if scalar(@pkg_svc) != 1;
1255   $pkg_svc[0];
1256 }
1257
1258 =item svcpart_unique_svcdb SVCDB
1259
1260 Returns the svcpart of a service definition (see L<FS::part_svc>) matching
1261 SVCDB associated with this package definition (see L<FS::pkg_svc>).  Returns
1262 false if there not a primary service definition for SVCDB or there are multiple
1263 service definitions for SVCDB.
1264
1265 =cut
1266
1267 sub svcpart_unique_svcdb {
1268   my( $self, $svcdb ) = @_;
1269   my @svcdb_pkg_svc = grep { ( $svcdb eq $_->part_svc->svcdb ) } $self->pkg_svc;
1270   return '' if scalar(@svcdb_pkg_svc) != 1;
1271   $svcdb_pkg_svc[0]->svcpart;
1272 }
1273
1274 =item payby
1275
1276 Returns a list of the acceptable payment types for this package.  Eventually
1277 this should come out of a database table and be editable, but currently has the
1278 following logic instead:
1279
1280 If the package is free, the single item B<BILL> is
1281 returned, otherwise, the single item B<CARD> is returned.
1282
1283 (CHEK?  LEC?  Probably shouldn't accept those by default, prone to abuse)
1284
1285 =cut
1286
1287 sub payby {
1288   my $self = shift;
1289   if ( $self->is_free ) {
1290     ( 'BILL' );
1291   } else {
1292     ( 'CARD' );
1293   }
1294 }
1295
1296 =item is_free
1297
1298 Returns true if this package is free.
1299
1300 =cut
1301
1302 sub is_free {
1303   my $self = shift;
1304   if ( $self->can('is_free_options') ) {
1305     not grep { $_ !~ /^\s*0*(\.0*)?\s*$/ }
1306          map { $self->option($_) }
1307              $self->is_free_options;
1308   } else {
1309     warn "FS::part_pkg::is_free: FS::part_pkg::". $self->plan. " subclass ".
1310          "provides neither is_free_options nor is_free method; returning false";
1311     0;
1312   }
1313 }
1314
1315 # whether the plan allows discounts to be applied to this package
1316 sub can_discount { 0; }
1317
1318 # whether the plan allows changing the start date
1319 sub can_start_date {
1320   my $self = shift;
1321   $self->start_on_hold ? 0 : 1;
1322 }
1323
1324 # whether the plan supports part_pkg_usageprice add-ons (a specific kind of
1325 #  pre-selectable usage pricing, there's others this doesn't refer to)
1326 sub can_usageprice { 0; }
1327
1328 # the delay start date if present
1329 sub delay_start_date {
1330   my $self = shift;
1331
1332   my $delay = $self->delay_start or return '';
1333
1334   # avoid timelocal silliness
1335   my $dt = DateTime->today(time_zone => 'local');
1336   $dt->add(days => $delay);
1337   $dt->epoch;
1338 }
1339
1340 sub can_currency_exchange { 0; }
1341
1342 sub freqs_href {
1343   # moved to FS::Misc to make this accessible to other packages
1344   # at initialization
1345   FS::Misc::pkg_freqs();
1346 }
1347
1348 =item freq_pretty
1349
1350 Returns an english representation of the I<freq> field, such as "monthly",
1351 "weekly", "semi-annually", etc.
1352
1353 =cut
1354
1355 sub freq_pretty {
1356   my $self = shift;
1357   my $freq = $self->freq;
1358
1359   #my $freqs_href = $self->freqs_href;
1360   my $freqs_href = freqs_href();
1361
1362   if ( exists($freqs_href->{$freq}) ) {
1363     $freqs_href->{$freq};
1364   } else {
1365     my $interval = 'month';
1366     if ( $freq =~ /^(\d+)([hdw])$/ ) {
1367       my %interval = ( 'h' => 'hour', 'd'=>'day', 'w'=>'week' );
1368       $interval = $interval{$2};
1369     }
1370     if ( $1 == 1 ) {
1371       "every $interval";
1372     } else {
1373       "every $freq ${interval}s";
1374     }
1375   }
1376 }
1377
1378 =item add_freq TIMESTAMP [ FREQ ]
1379
1380 Adds a billing period of some frequency to the provided timestamp and
1381 returns the resulting timestamp, or -1 if the frequency could not be
1382 parsed (shouldn't happen).  By default, the frequency of this package
1383 will be used; to override this, pass a different frequency as a second
1384 argument.
1385
1386 =cut
1387
1388 sub add_freq {
1389   my( $self, $date, $freq ) = @_;
1390   $freq = $self->freq unless $freq;
1391
1392   #change this bit to use Date::Manip? CAREFUL with timezones (see
1393   # mailing list archive)
1394   my ($sec,$min,$hour,$mday,$mon,$year) = (localtime($date) )[0,1,2,3,4,5];
1395
1396   if ( $freq =~ /^\d+$/ ) {
1397     $mon += $freq;
1398     until ( $mon < 12 ) { $mon -= 12; $year++; }
1399
1400     $mday = 28 if $mday > 28 && FS::Conf->new->exists('anniversary-rollback');
1401
1402   } elsif ( $freq =~ /^(\d+)w$/ ) {
1403     my $weeks = $1;
1404     $mday += $weeks * 7;
1405   } elsif ( $freq =~ /^(\d+)d$/ ) {
1406     my $days = $1;
1407     $mday += $days;
1408   } elsif ( $freq =~ /^(\d+)h$/ ) {
1409     my $hours = $1;
1410     $hour += $hours;
1411   } else {
1412     return -1;
1413   }
1414
1415   timelocal_nocheck($sec,$min,$hour,$mday,$mon,$year);
1416 }
1417
1418 =item plandata
1419
1420 For backwards compatibility, returns the plandata field as well as all options
1421 from FS::part_pkg_option.
1422
1423 =cut
1424
1425 sub plandata {
1426   my $self = shift;
1427   carp "plandata is deprecated";
1428   if ( @_ ) {
1429     $self->SUPER::plandata(@_);
1430   } else {
1431     my $plandata = $self->get('plandata');
1432     my %options = $self->options;
1433     $plandata .= join('', map { "$_=$options{$_}\n" } keys %options );
1434     $plandata;
1435   }
1436 }
1437
1438 =item part_pkg_vendor
1439
1440 Returns all vendor/external package ids as FS::part_pkg_vendor objects (see
1441 L<FS::part_pkg_vendor>).
1442
1443 =item vendor_pkg_ids
1444
1445 Returns a list of vendor/external package ids by exportnum
1446
1447 =cut
1448
1449 sub vendor_pkg_ids {
1450   my $self = shift;
1451   map { $_->exportnum => $_->vendor_pkg_id } $self->part_pkg_vendor;
1452 }
1453
1454 =item part_pkg_option
1455
1456 Returns all options as FS::part_pkg_option objects (see
1457 L<FS::part_pkg_option>).
1458
1459 =item options
1460
1461 Returns a list of option names and values suitable for assigning to a hash.
1462
1463 =cut
1464
1465 sub options {
1466   my $self = shift;
1467   map { $_->optionname => $_->optionvalue } $self->part_pkg_option;
1468 }
1469
1470 =item option OPTIONNAME [ QUIET ]
1471
1472 Returns the option value for the given name, or the empty string.  If a true
1473 value is passed as the second argument, warnings about missing the option
1474 will be suppressed.
1475
1476 =cut
1477
1478 sub option {
1479   my( $self, $opt, $ornull ) = @_;
1480
1481   #cache: was pulled up in the original part_pkg query
1482   return $self->hashref->{"_opt_$opt"}
1483     if exists $self->hashref->{"_opt_$opt"};
1484
1485   cluck "$self -> option: searching for $opt" if $DEBUG;
1486   my $part_pkg_option =
1487     qsearchs('part_pkg_option', {
1488       pkgpart    => $self->pkgpart,
1489       optionname => $opt,
1490   } );
1491   return $part_pkg_option->optionvalue if $part_pkg_option;
1492
1493   my %plandata = map { /^(\w+)=(.*)$/; ( $1 => $2 ); }
1494                      split("\n", $self->get('plandata') );
1495   return $plandata{$opt} if exists $plandata{$opt};
1496
1497   # check whether the option is defined in plan info (if so, don't warn)
1498   if (exists $plans{ $self->plan }->{fields}->{$opt}) {
1499     return '';
1500   }
1501   cluck "WARNING: (pkgpart ". $self->pkgpart. ") Package def option $opt ".
1502         "not found in options or plandata!\n"
1503     unless $ornull;
1504
1505   '';
1506 }
1507
1508 =item part_pkg_currency [ CURRENCY ]
1509
1510 Returns all currency options as FS::part_pkg_currency objects (see
1511 L<FS::part_pkg_currency>), or, if a currency is specified, only return the
1512 objects for that currency.
1513
1514 =cut
1515
1516 sub part_pkg_currency {
1517   my $self = shift;
1518   my %hash = ( 'pkgpart' => $self->pkgpart );
1519   $hash{'currency'} = shift if @_;
1520   qsearch('part_pkg_currency', \%hash );
1521 }
1522
1523 =item part_pkg_currency_options CURRENCY
1524
1525 Returns a list of option names and values from FS::part_pkg_currency for the
1526 specified currency.
1527
1528 =cut
1529
1530 sub part_pkg_currency_options {
1531   my $self = shift;
1532   map { $_->optionname => $_->optionvalue } $self->part_pkg_currency(shift);
1533 }
1534
1535 =item part_pkg_currency_option CURRENCY OPTIONNAME
1536
1537 Returns the option value for the given name and currency.
1538
1539 =cut
1540
1541 sub part_pkg_currency_option {
1542   my( $self, $currency, $optionname ) = @_;
1543   my $part_pkg_currency =
1544     qsearchs('part_pkg_currency', { 'pkgpart'    => $self->pkgpart,
1545                                     'currency'   => $currency,
1546                                     'optionname' => $optionname,
1547                                   }
1548             )#;
1549   #fatal if not found?  that works for our use cases from
1550   #part_pkg/currency_fixed, but isn't how we would typically/expect the method
1551   #to behave.  have to catch it there if we change it here...
1552     or die "Unknown price for ". $self->pkg_comment. " in $currency\n";
1553
1554   $part_pkg_currency->optionvalue;
1555 }
1556
1557 =item fcc_option OPTIONNAME
1558
1559 Returns the FCC 477 report option value for the given name, or the empty
1560 string.
1561
1562 =cut
1563
1564 sub fcc_option {
1565   my ($self, $name) = @_;
1566   my $part_pkg_fcc_option =
1567     qsearchs('part_pkg_fcc_option', {
1568         pkgpart => $self->pkgpart,
1569         fccoptionname => $name,
1570     });
1571   $part_pkg_fcc_option ? $part_pkg_fcc_option->optionvalue : '';
1572 }
1573
1574 =item fcc_options
1575
1576 Returns all FCC 477 report options for this package, as a hash-like list.
1577
1578 =cut
1579
1580 sub fcc_options {
1581   my $self = shift;
1582   map { $_->fccoptionname => $_->optionvalue }
1583     qsearch('part_pkg_fcc_option', { pkgpart => $self->pkgpart });
1584 }
1585
1586 =item bill_part_pkg_link
1587
1588 Returns the associated part_pkg_link records (see L<FS::part_pkg_link>).
1589
1590 =cut
1591
1592 sub bill_part_pkg_link {
1593   shift->_part_pkg_link('bill', @_);
1594 }
1595
1596 =item svc_part_pkg_link
1597
1598 Returns the associated part_pkg_link records (see L<FS::part_pkg_link>).
1599
1600 =cut
1601
1602 sub svc_part_pkg_link {
1603   shift->_part_pkg_link('svc', @_);
1604 }
1605
1606 =item supp_part_pkg_link
1607
1608 Returns the associated part_pkg_link records of type 'supp' (supplemental
1609 packages).
1610
1611 =cut
1612
1613 sub supp_part_pkg_link {
1614   shift->_part_pkg_link('supp', @_);
1615 }
1616
1617 sub _part_pkg_link {
1618   my( $self, $type ) = @_;
1619
1620   return @{ $cache_link{$type}->{$self->pkgpart} }
1621     if $cache_enabled && $cache_link{$type}->{$self->pkgpart};
1622
1623   cluck $type.'_part_pkg_link called' if $DEBUG;
1624
1625   my @ppl =
1626     qsearch({ table    => 'part_pkg_link',
1627               hashref  => { src_pkgpart => $self->pkgpart,
1628                             link_type   => $type,
1629                             #protection against infinite recursive links
1630                             dst_pkgpart => { op=>'!=', value=> $self->pkgpart },
1631                           },
1632               order_by => "ORDER BY hidden",
1633            });
1634
1635   $cache_link{$type}->{$self->pkgpart} = \@ppl if $cache_enabled;
1636
1637   return @ppl;
1638 }
1639
1640 sub self_and_bill_linked {
1641   shift->_self_and_linked('bill', @_);
1642 }
1643
1644 sub self_and_svc_linked {
1645   shift->_self_and_linked('svc', @_);
1646 }
1647
1648 sub _self_and_linked {
1649   my( $self, $type, $hidden ) = @_;
1650   $hidden ||= '';
1651
1652   my @result = ();
1653   foreach ( ( $self, map { $_->dst_pkg->_self_and_linked($type, $_->hidden) }
1654                      $self->_part_pkg_link($type) ) )
1655   {
1656     $_->hidden($hidden) if $hidden;
1657     push @result, $_;
1658   }
1659
1660   (@result);
1661 }
1662
1663 =item part_pkg_taxoverride [ CLASS ]
1664
1665 Returns all associated FS::part_pkg_taxoverride objects (see
1666 L<FS::part_pkg_taxoverride>).  Limits the returned set to those
1667 of class CLASS if defined.  Class may be one of 'setup', 'recur',
1668 the empty string (default), or a usage class number (see L<FS::usage_class>).
1669 When a class is specified, the empty string class (default) is returned
1670 if no more specific values exist.
1671
1672 =cut
1673
1674 sub part_pkg_taxoverride {
1675   my $self = shift;
1676   my $class = shift;
1677
1678   my $hashref = { 'pkgpart' => $self->pkgpart };
1679   $hashref->{'usage_class'} = $class if defined($class);
1680   my @overrides = qsearch('part_pkg_taxoverride', $hashref );
1681
1682   unless ( scalar(@overrides) || !defined($class) || !$class ){
1683     $hashref->{'usage_class'} = '';
1684     @overrides = qsearch('part_pkg_taxoverride', $hashref );
1685   }
1686
1687   @overrides;
1688 }
1689
1690 =item has_taxproduct
1691
1692 Returns true if this package has any taxproduct associated with it.
1693
1694 =cut
1695
1696 sub has_taxproduct {
1697   my $self = shift;
1698
1699   $self->taxproductnum ||
1700   scalar( grep { $_ =~/^usage_taxproductnum_/ && $self->option($_) }
1701           keys %{ {$self->options} }
1702   )
1703
1704 }
1705
1706
1707 =item taxproduct [ CLASS ]
1708
1709 Returns the associated tax product for this package definition (see
1710 L<FS::part_pkg_taxproduct>).  CLASS may be one of 'setup', 'recur' or
1711 the usage classnum (see L<FS::usage_class>).  Returns the default
1712 tax product for this record if the more specific CLASS value does
1713 not exist.
1714
1715 =cut
1716
1717 sub taxproduct {
1718   my $self = shift;
1719   my $class = shift;
1720
1721   my $part_pkg_taxproduct;
1722
1723   my $taxproductnum = $self->taxproductnum;
1724   if ($class) {
1725     my $class_taxproductnum = $self->option("usage_taxproductnum_$class", 1);
1726     $taxproductnum = $class_taxproductnum
1727       if $class_taxproductnum
1728   }
1729
1730   $part_pkg_taxproduct =
1731     qsearchs( 'part_pkg_taxproduct', { 'taxproductnum' => $taxproductnum } );
1732
1733   unless ($part_pkg_taxproduct || $taxproductnum eq $self->taxproductnum ) {
1734     $taxproductnum = $self->taxproductnum;
1735     $part_pkg_taxproduct =
1736       qsearchs( 'part_pkg_taxproduct', { 'taxproductnum' => $taxproductnum } );
1737   }
1738
1739   $part_pkg_taxproduct;
1740 }
1741
1742 =item taxproduct_description [ CLASS ]
1743
1744 Returns the description of the associated tax product for this package
1745 definition (see L<FS::part_pkg_taxproduct>).
1746
1747 =cut
1748
1749 sub taxproduct_description {
1750   my $self = shift;
1751   my $part_pkg_taxproduct = $self->taxproduct(@_);
1752   $part_pkg_taxproduct ? $part_pkg_taxproduct->description : '';
1753 }
1754
1755 =item units_taxproduct
1756
1757 Returns the L<FS::part_pkg_taxproduct> record used to report the taxable
1758 service units (usually phone lines) on this package.
1759
1760 =cut
1761
1762 sub units_taxproduct {
1763   my $self = shift;
1764   $self->units_taxproductnum
1765     ? FS::part_pkg_taxproduct->by_key($self->units_taxproductnum)
1766     : '';
1767 }
1768
1769 =item tax_rates DATA_PROVIDER, GEOCODE, [ CLASS ]
1770
1771 Returns the tax table entries (L<FS::tax_rate> objects) that apply to this
1772 package in the location specified by GEOCODE, for usage class CLASS (one of
1773 'setup', 'recur', null, or a C<usage_class> number).
1774
1775 =cut
1776
1777 sub tax_rates {
1778   my $self = shift;
1779   my ($vendor, $geocode, $class) = @_;
1780   # if this part_pkg is overridden into a specific taxclass, get that class
1781   my @taxclassnums = map { $_->taxclassnum }
1782                      $self->part_pkg_taxoverride($class);
1783   # otherwise, get its tax product category
1784   if (!@taxclassnums) {
1785     my $part_pkg_taxproduct = $self->taxproduct($class);
1786     # If this isn't defined, then the class has no taxproduct designation,
1787     # so return no tax rates.
1788     return () if !$part_pkg_taxproduct;
1789
1790     # convert the taxproduct to the tax classes that might apply to it in
1791     # $geocode
1792     @taxclassnums = map { $_->taxclassnum }
1793                     grep { $_->taxable eq 'Y' } # why do we need this?
1794                     $part_pkg_taxproduct->part_pkg_taxrate($geocode);
1795   }
1796   return unless @taxclassnums;
1797
1798   # then look up the actual tax_rate entries
1799   warn "Found taxclassnum values of ". join(',', @taxclassnums) ."\n"
1800       if $DEBUG;
1801   my $extra_sql = "AND taxclassnum IN (". join(',', @taxclassnums) . ")";
1802   my @taxes = qsearch({ 'table'     => 'tax_rate',
1803                         'hashref'   => { 'geocode'     => $geocode,
1804                                          'data_vendor' => $vendor,
1805                                          'disabled'    => '' },
1806                         'extra_sql' => $extra_sql,
1807                       });
1808   warn "Found taxes ". join(',', map {$_->taxnum} @taxes) ."\n"
1809       if $DEBUG;
1810
1811   return @taxes;
1812 }
1813
1814 =item part_pkg_discount
1815
1816 Returns the package to discount m2m records (see L<FS::part_pkg_discount>)
1817 for this package.
1818
1819 =item part_pkg_usage
1820
1821 Returns the voice usage pools (see L<FS::part_pkg_usage>) defined for
1822 this package.
1823
1824 =item change_to_pkg
1825
1826 Returns the automatic transfer target for this package, or an empty string
1827 if there isn't one.
1828
1829 =cut
1830
1831 sub change_to_pkg {
1832   my $self = shift;
1833   my $pkgpart = $self->change_to_pkgpart or return '';
1834   FS::part_pkg->by_key($pkgpart);
1835 }
1836
1837 =item _rebless
1838
1839 Reblesses the object into the FS::part_pkg::PLAN class (if available), where
1840 PLAN is the object's I<plan> field.  There should be better docs
1841 on how to create new price plans, but until then, see L</NEW PLAN CLASSES>.
1842
1843 =cut
1844
1845 sub _rebless {
1846   my $self = shift;
1847   my $plan = $self->plan;
1848   unless ( $plan ) {
1849     cluck "no price plan found for pkgpart ". $self->pkgpart. "\n"
1850       if $DEBUG;
1851     return $self;
1852   }
1853   return $self if ref($self) =~ /::$plan$/; #already blessed into plan subclass
1854   my $class = ref($self). "::$plan";
1855   warn "reblessing $self into $class" if $DEBUG > 1;
1856   eval "use $class;";
1857   die $@ if $@;
1858   bless($self, $class) unless $@;
1859   $self;
1860 }
1861
1862 =item calc_setup CUST_PKG START_DATE DETAILS_ARRAYREF OPTIONS_HASHREF
1863
1864 =item calc_recur CUST_PKG START_DATE DETAILS_ARRAYREF OPTIONS_HASHREF
1865
1866 Calculates and returns the setup or recurring fees, respectively, for this
1867 package.  Implementation is in the FS::part_pkg:* module specific to this price
1868 plan.
1869
1870 Adds invoicing details to the passed-in DETAILS_ARRAYREF
1871
1872 Options are passed as a hashref.  Available options:
1873
1874 =over 4
1875
1876 =item freq_override
1877
1878 Frequency override (for calc_recur)
1879
1880 =item discounts
1881
1882 This option is filled in by the method rather than controlling its operation.
1883 It is an arrayref.  Applicable discounts will be added to the arrayref, as
1884 L<FS::cust_bill_pkg_discount|FS::cust_bill_pkg_discount records>.
1885
1886 =item real_pkgpart
1887
1888 For package add-ons, is the base L<FS::part_pkg|package definition>, otherwise
1889 no different than pkgpart.
1890
1891 =item precommit_hooks
1892
1893 This option is filled in by the method rather than controlling its operation.
1894 It is an arrayref.  Anonymous coderefs will be added to the arrayref.  They
1895 need to be called before completing the billing operation.  For calc_recur
1896 only.
1897
1898 =item increment_next_bill
1899
1900 Increment the next bill date (boolean, for calc_recur).  Typically true except
1901 for particular situations.
1902
1903 =item setup_fee
1904
1905 This option is filled in by the method rather than controlling its operation.
1906 It indicates a deferred setup fee that is billed at calc_recur time (see price
1907 plan option prorate_defer_bill).
1908
1909 =back
1910
1911 Note: Don't calculate prices when not actually billing the package.  For that,
1912 see the L</base_setup|base_setup> and L</base_recur|base_recur> methods.
1913
1914 =cut
1915
1916 #fatal fallbacks
1917 sub calc_setup { die 'no calc_setup for '. shift->plan. "\n"; }
1918 sub calc_recur { die 'no calc_recur for '. shift->plan. "\n"; }
1919
1920 =item calc_remain CUST_PKG [ OPTION => VALUE ... ]
1921
1922 Calculates and returns the remaining value to be credited upon package
1923 suspension, change, or cancellation, if enabled.
1924
1925 Options are passed as a list of keys and values.  Available options:
1926
1927 =over 4
1928
1929 =item time
1930
1931 Override for the current time
1932
1933 =item cust_credit_source_bill_pkg
1934
1935 This option is filled in by the method rather than controlling its operation.
1936 It is an arrayref.
1937 L<FS::cust_credit_source_bill_pkg|FS::cust_credit_source_bill_pkg> records will
1938 be added to the arrayref indicating the specific line items and amounts which
1939 are the source of this remaining credit.
1940
1941 =back
1942
1943 Note: Don't calculate prices when not actually suspending or cancelling the
1944 package.
1945
1946 =cut
1947
1948 #fallback that returns 0 for old legacy packages with no plan
1949 sub calc_remain { 0; }
1950
1951 =item calc_units CUST_PKG
1952
1953 This returns the number of provisioned svc_phone records, or, of the package
1954 count_available_phones option is set, the number available to be provisioned
1955 in the package.
1956
1957 =cut
1958
1959 sub calc_units {
1960   my($self, $cust_pkg ) = @_;
1961   my $count = 0;
1962   if ( $self->option('count_available_phones', 1)) {
1963     foreach my $pkg_svc ($cust_pkg->part_pkg->pkg_svc) {
1964       if ($pkg_svc->part_svc->svcdb eq 'svc_phone') { # svc_pbx?
1965         $count += $pkg_svc->quantity || 0;
1966       }
1967     }
1968     $count *= $cust_pkg->quantity;
1969   } else {
1970     $count =
1971       scalar(grep { $_->part_svc->svcdb eq 'svc_phone' } $cust_pkg->cust_svc);
1972   }
1973   $count;
1974 }
1975
1976 #fallback for everything not based on flat.pm
1977 sub recur_temporality { 'upcoming'; }
1978
1979 =item calc_cancel START_DATE DETAILS_ARRAYREF OPTIONS_HASHREF
1980
1981 Runs any necessary billing on cancellation: another recurring cycle for
1982 recur_temporailty 'preceding' pacakges with the bill_recur_on_cancel option
1983 set (calc_recur), or, any outstanding usage for pacakges with the
1984 bill_usage_on_cancel option set (calc_usage).
1985
1986 =cut
1987
1988 #fallback for everything not based on flat.pm, doesn't do this yet (which is
1989 #okay, nothing of ours not based on flat.pm does usage-on-cancel billing
1990 sub calc_cancel { 0; }
1991
1992 #fallback for everything except bulk.pm
1993 sub hide_svc_detail { 0; }
1994
1995 #fallback for packages that can't/won't summarize usage
1996 sub sum_usage { 0; }
1997
1998 =item recur_cost_permonth CUST_PKG
1999
2000 recur_cost divided by freq (only supported for monthly and longer frequencies)
2001
2002 =cut
2003
2004 sub recur_cost_permonth {
2005   my($self, $cust_pkg) = @_;
2006   return 0 unless $self->freq =~ /^\d+$/ && $self->freq > 0;
2007   sprintf('%.2f', ($self->recur_cost || 0) / $self->freq );
2008 }
2009
2010 =item cust_bill_pkg_recur CUST_PKG
2011
2012 Actual recurring charge for the specified customer package from customer's most
2013 recent invoice
2014
2015 =cut
2016
2017 sub cust_bill_pkg_recur {
2018   my($self, $cust_pkg) = @_;
2019   my $cust_bill_pkg = qsearchs({
2020     'table'     => 'cust_bill_pkg',
2021     'addl_from' => 'LEFT JOIN cust_bill USING ( invnum )',
2022     'hashref'   => { 'pkgnum' => $cust_pkg->pkgnum,
2023                      'recur'  => { op=>'>', value=>'0' },
2024                    },
2025     'order_by'  => 'ORDER BY cust_bill._date     DESC,
2026                              cust_bill_pkg.sdate DESC
2027                      LIMIT 1
2028                    ',
2029   }) or return 0; #die "use cust_bill_pkg_recur credits with once_perinv condition";
2030   $cust_bill_pkg->recur;
2031 }
2032
2033 =item unit_setup CUST_PKG
2034
2035 Returns the setup fee for one unit of the package.
2036
2037 =cut
2038
2039 sub unit_setup {
2040   my ($self, $cust_pkg) = @_;
2041   $self->option('setup_fee') || 0;
2042 }
2043
2044 =item setup_margin
2045
2046 unit_setup minus setup_cost
2047
2048 =cut
2049
2050 sub setup_margin {
2051   my $self = shift;
2052   $self->unit_setup(@_) - ($self->setup_cost || 0);
2053 }
2054
2055 =item recur_margin_permonth
2056
2057 base_recur_permonth minus recur_cost_permonth
2058
2059 =cut
2060
2061 sub recur_margin_permonth {
2062   my $self = shift;
2063   $self->base_recur_permonth(@_) - $self->recur_cost_permonth(@_);
2064 }
2065
2066 =item intro_end PACKAGE
2067
2068 Takes an L<FS::cust_pkg> object.  If this plan has an introductory rate,
2069 returns the expected date the intro period will end. If there is no intro
2070 rate, returns zero.
2071
2072 =cut
2073
2074 sub intro_end {
2075   0;
2076 }
2077
2078 =item format OPTION DATA
2079
2080 Returns data formatted according to the function 'format' described
2081 in the plan info.  Returns DATA if no such function exists.
2082
2083 =cut
2084
2085 sub format {
2086   my ($self, $option, $data) = (shift, shift, shift);
2087   if (exists($plans{$self->plan}->{fields}->{$option}{format})) {
2088     &{$plans{$self->plan}->{fields}->{$option}{format}}($data);
2089   }else{
2090     $data;
2091   }
2092 }
2093
2094 =item parse OPTION DATA
2095
2096 Returns data parsed according to the function 'parse' described
2097 in the plan info.  Returns DATA if no such function exists.
2098
2099 =cut
2100
2101 sub parse {
2102   my ($self, $option, $data) = (shift, shift, shift);
2103   if (exists($plans{$self->plan}->{fields}->{$option}{parse})) {
2104     &{$plans{$self->plan}->{fields}->{$option}{parse}}($data);
2105   }else{
2106     $data;
2107   }
2108 }
2109
2110 =back
2111
2112 =cut
2113
2114 =head1 CLASS METHODS
2115
2116 =over 4
2117
2118 =cut
2119
2120 # _upgrade_data
2121 #
2122 # Used by FS::Upgrade to migrate to a new database.
2123
2124 sub _upgrade_data { # class method
2125    my($class, %opts) = @_;
2126
2127   warn "[FS::part_pkg] upgrading $class\n" if $DEBUG;
2128
2129   my @part_pkg = qsearch({
2130     'table'     => 'part_pkg',
2131     'extra_sql' => "WHERE ". join(' OR ',
2132                      'plan IS NULL', "plan = '' ",
2133                    ),
2134   });
2135
2136   foreach my $part_pkg (@part_pkg) {
2137
2138     unless ( $part_pkg->plan ) {
2139       $part_pkg->plan('flat');
2140     }
2141
2142     $part_pkg->replace;
2143
2144   }
2145
2146   # Convert RADIUS accounting usage metrics from megabytes to gigabytes
2147   # (FS RT#28105)
2148   my $upgrade = 'part_pkg_gigabyte_usage';
2149   if (!FS::upgrade_journal->is_done($upgrade)) {
2150     foreach my $part_pkg (qsearch('part_pkg',
2151                                   { plan => 'sqlradacct_hour' })
2152                          ){
2153
2154       my $pkgpart = $part_pkg->pkgpart;
2155
2156       foreach my $opt (qsearch('part_pkg_option',
2157                                { 'optionname'  => { op => 'LIKE',
2158                                                     value => 'recur_included_%',
2159                                                   },
2160                                  pkgpart => $pkgpart,
2161                                })){
2162
2163         next if $opt->optionname eq 'recur_included_hours'; # unfortunately named field
2164         next if $opt->optionvalue == 0;
2165
2166         $opt->optionvalue($opt->optionvalue / 1024);
2167
2168         my $error = $opt->replace;
2169         die $error if $error;
2170       }
2171
2172       foreach my $opt (qsearch('part_pkg_option',
2173                                { 'optionname'  => { op => 'LIKE',
2174                                                     value => 'recur_%_charge',
2175                                                   },
2176                                  pkgpart => $pkgpart,
2177                                })){
2178         $opt->optionvalue($opt->optionvalue * 1024);
2179
2180         my $error = $opt->replace;
2181         die $error if $error;
2182       }
2183
2184     }
2185     FS::upgrade_journal->set_done($upgrade);
2186   }
2187
2188   # the rest can be done asynchronously
2189 }
2190
2191 sub queueable_upgrade {
2192   # now upgrade to the explicit custom flag
2193
2194   my $search = FS::Cursor->new({
2195     'table'     => 'part_pkg',
2196     'hashref'   => { disabled => 'Y', custom => '' },
2197     'extra_sql' => "AND comment LIKE '(CUSTOM) %'",
2198   });
2199   my $dbh = dbh;
2200
2201   while (my $part_pkg = $search->fetch) {
2202     my $new = new FS::part_pkg { $part_pkg->hash };
2203     $new->custom('Y');
2204     my $comment = $part_pkg->comment;
2205     $comment =~ s/^\(CUSTOM\) //;
2206     $comment = '(none)' unless $comment =~ /\S/;
2207     $new->comment($comment);
2208
2209     my $pkg_svc = { map { $_->svcpart => $_->quantity } $part_pkg->pkg_svc };
2210     my $primary = $part_pkg->svcpart;
2211     my $options = { $part_pkg->options };
2212
2213     my $error = $new->replace( $part_pkg,
2214                                'pkg_svc'     => $pkg_svc,
2215                                'primary_svc' => $primary,
2216                                'options'     => $options,
2217                              );
2218     if ($error) {
2219       warn "pkgpart#".$part_pkg->pkgpart.": $error\n";
2220       $dbh->rollback;
2221     } else {
2222       $dbh->commit;
2223     }
2224   }
2225
2226   # set family_pkgpart on any packages that don't have it
2227   $search = FS::Cursor->new('part_pkg', { 'family_pkgpart' => '' });
2228   while (my $part_pkg = $search->fetch) {
2229     $part_pkg->set('family_pkgpart' => $part_pkg->pkgpart);
2230     my $error = $part_pkg->SUPER::replace;
2231     if ($error) {
2232       warn "pkgpart#".$part_pkg->pkgpart.": $error\n";
2233       $dbh->rollback;
2234     } else {
2235       $dbh->commit;
2236     }
2237   }
2238
2239   my @part_pkg_option = qsearch('part_pkg_option',
2240     { 'optionname'  => 'unused_credit',
2241       'optionvalue' => 1,
2242     });
2243   foreach my $old_opt (@part_pkg_option) {
2244     my $pkgpart = $old_opt->pkgpart;
2245     my $error = $old_opt->delete;
2246     die $error if $error;
2247
2248     foreach (qw(unused_credit_cancel unused_credit_change)) {
2249       my $new_opt = new FS::part_pkg_option {
2250         'pkgpart'     => $pkgpart,
2251         'optionname'  => $_,
2252         'optionvalue' => 1,
2253       };
2254       $error = $new_opt->insert;
2255       die $error if $error;
2256     }
2257   }
2258
2259   # migrate use_disposition_taqua and use_disposition to disposition_in
2260   @part_pkg_option = qsearch('part_pkg_option',
2261     { 'optionname'  => { op => 'LIKE',
2262                          value => 'use_disposition%',
2263                        },
2264       'optionvalue' => 1,
2265     });
2266   my %newopts = map { $_->pkgpart => $_ }
2267     qsearch('part_pkg_option',  { 'optionname'  => 'disposition_in', } );
2268   foreach my $old_opt (@part_pkg_option) {
2269         my $pkgpart = $old_opt->pkgpart;
2270         my $newval = $old_opt->optionname eq 'use_disposition_taqua' ? '100'
2271                                                                   : 'ANSWERED';
2272         my $error = $old_opt->delete;
2273         die $error if $error;
2274
2275         if ( exists($newopts{$pkgpart}) ) {
2276             my $opt = $newopts{$pkgpart};
2277             $opt->optionvalue($opt->optionvalue.",$newval");
2278             $error = $opt->replace;
2279             die $error if $error;
2280         } else {
2281             my $new_opt = new FS::part_pkg_option {
2282                 'pkgpart'     => $pkgpart,
2283                 'optionname'  => 'disposition_in',
2284                 'optionvalue' => $newval,
2285               };
2286               $error = $new_opt->insert;
2287               die $error if $error;
2288               $newopts{$pkgpart} = $new_opt;
2289         }
2290   }
2291
2292   # set any package with FCC voice lines to the "VoIP with broadband" category
2293   # for backward compatibility
2294   #
2295   # recover from a bad upgrade bug
2296   my $upgrade = 'part_pkg_fcc_voip_class_FIX';
2297   if (!FS::upgrade_journal->is_done($upgrade)) {
2298     my $bad_upgrade = qsearchs('upgrade_journal',
2299       { upgrade => 'part_pkg_fcc_voip_class' }
2300     );
2301     if ( $bad_upgrade ) {
2302       my $where = 'WHERE history_date <= '.$bad_upgrade->_date.
2303                   ' AND  history_date >  '.($bad_upgrade->_date - 3600);
2304       my @h_part_pkg_option = map { FS::part_pkg_option->new($_->hashref) }
2305         qsearch({
2306           'select'    => '*',
2307           'table'     => 'h_part_pkg_option',
2308           'hashref'   => {},
2309           'extra_sql' => "$where AND history_action = 'delete'",
2310           'order_by'  => 'ORDER BY history_date ASC',
2311         });
2312       my @h_pkg_svc = map { FS::pkg_svc->new($_->hashref) }
2313         qsearch({
2314           'select'    => '*',
2315           'table'     => 'h_pkg_svc',
2316           'hashref'   => {},
2317           'extra_sql' => "$where AND history_action = 'replace_old'",
2318           'order_by'  => 'ORDER BY history_date ASC',
2319         });
2320       my %opt;
2321       foreach my $deleted (@h_part_pkg_option, @h_pkg_svc) {
2322         my $pkgpart ||= $deleted->pkgpart;
2323         $opt{$pkgpart} ||= {
2324           options => {},
2325           pkg_svc => {},
2326           primary_svc => '',
2327           hidden_svc => {},
2328         };
2329         if ( $deleted->isa('FS::part_pkg_option') ) {
2330           $opt{$pkgpart}{options}{ $deleted->optionname } = $deleted->optionvalue;
2331         } else { # pkg_svc
2332           my $svcpart = $deleted->svcpart;
2333           $opt{$pkgpart}{pkg_svc}{$svcpart} = $deleted->quantity;
2334           $opt{$pkgpart}{hidden_svc}{$svcpart} ||= $deleted->hidden;
2335           $opt{$pkgpart}{primary_svc} = $svcpart if $deleted->primary_svc;
2336         }
2337       }
2338       foreach my $pkgpart (keys %opt) {
2339         my $part_pkg = FS::part_pkg->by_key($pkgpart);
2340         my $error = $part_pkg->replace( $part_pkg->replace_old, $opt{$pkgpart} );
2341         if ( $error ) {
2342           die "error recovering damaged pkgpart $pkgpart:\n$error\n";
2343         }
2344       }
2345     } # $bad_upgrade exists
2346     else { # do the original upgrade, but correctly this time
2347       my @part_pkg = qsearch('part_pkg', {
2348           fcc_ds0s        => { op => '>', value => 0 },
2349           fcc_voip_class  => ''
2350       });
2351       foreach my $part_pkg (@part_pkg) {
2352         $part_pkg->set(fcc_voip_class => 2);
2353         my @pkg_svc = $part_pkg->pkg_svc;
2354         my %quantity = map {$_->svcpart, $_->quantity} @pkg_svc;
2355         my %hidden   = map {$_->svcpart, $_->hidden  } @pkg_svc;
2356         my $error = $part_pkg->replace(
2357           $part_pkg->replace_old,
2358           options     => { $part_pkg->options },
2359           pkg_svc     => \%quantity,
2360           hidden_svc  => \%hidden,
2361           primary_svc => ($part_pkg->svcpart || ''),
2362         );
2363         die $error if $error;
2364       }
2365     }
2366     FS::upgrade_journal->set_done($upgrade);
2367   }
2368
2369   # migrate adjourn_months, expire_months, and contract_end_months to
2370   # real fields
2371   foreach my $field (qw(adjourn_months expire_months contract_end_months)) {
2372     foreach my $option (qsearch('part_pkg_option', { optionname => $field })) {
2373       my $part_pkg = $option->part_pkg;
2374       my $error = $option->delete;
2375       if ( $option->optionvalue and $part_pkg->get($field) eq '' ) {
2376         $part_pkg->set($field, $option->optionvalue);
2377         $error ||= $part_pkg->replace;
2378       }
2379       die $error if $error;
2380     }
2381   }
2382
2383   # remove custom flag from one-time charge packages that were accidentally
2384   # flagged as custom
2385   $search = FS::Cursor->new({
2386     'table'   => 'part_pkg',
2387     'hashref' => { 'freq'   => '0',
2388                    'custom' => 'Y',
2389                    'family_pkgpart' => { op => '!=', value => '' },
2390                  },
2391     'addl_from' => ' JOIN
2392   (select pkgpart from cust_pkg group by pkgpart having count(*) = 1)
2393     AS singular_pkg USING (pkgpart)',
2394   });
2395   my @fields = grep {     $_ ne 'pkgpart'
2396                       and $_ ne 'custom'
2397                       and $_ ne 'disabled' } FS::part_pkg->fields;
2398   PKGPART: while (my $part_pkg = $search->fetch) {
2399     # can't merge the package back into its parent (too late for that)
2400     # but we can remove the custom flag if it's not actually customized,
2401     # i.e. nothing has been changed.
2402
2403     my $family_pkgpart = $part_pkg->family_pkgpart;
2404     next PKGPART if $family_pkgpart == $part_pkg->pkgpart;
2405     my $parent_pkg = FS::part_pkg->by_key($family_pkgpart);
2406     foreach my $field (@fields) {
2407       if ($part_pkg->get($field) ne $parent_pkg->get($field)) {
2408         next PKGPART;
2409       }
2410     }
2411     # options have to be identical too
2412     # but links, FCC options, discount plans, and usage packages can't be
2413     # changed through the "modify charge" UI, so skip them
2414     my %newopt = $part_pkg->options;
2415     my %oldopt = $parent_pkg->options;
2416     OPTION: foreach my $option (keys %newopt) {
2417       if (delete $newopt{$option} ne delete $oldopt{$option}) {
2418         next PKGPART;
2419       }
2420     }
2421     if (keys(%newopt) or keys(%oldopt)) {
2422       next PKGPART;
2423     }
2424     # okay, now replace it
2425     warn "Removing custom flag from part_pkg#".$part_pkg->pkgpart."\n";
2426     $part_pkg->set('custom', '');
2427     my $error = $part_pkg->replace;
2428     die $error if $error;
2429   } # $search->fetch
2430
2431   return;
2432 }
2433
2434 =item curuser_pkgs_sql
2435
2436 Returns an SQL fragment for searching for packages the current user can
2437 use, either via part_pkg.agentnum directly, or via agent type (see
2438 L<FS::type_pkgs>).
2439
2440 =cut
2441
2442 sub curuser_pkgs_sql {
2443   my $class = shift;
2444
2445   $class->_pkgs_sql( $FS::CurrentUser::CurrentUser->agentnums );
2446
2447 }
2448
2449 =item agent_pkgs_sql AGENT | AGENTNUM, ...
2450
2451 Returns an SQL fragment for searching for packages the provided agent or agents
2452 can use, either via part_pkg.agentnum directly, or via agent type (see
2453 L<FS::type_pkgs>).
2454
2455 =cut
2456
2457 sub agent_pkgs_sql {
2458   my $class = shift;  #i'm a class method, not a sub (the question is... why??)
2459   my @agentnums = map { ref($_) ? $_->agentnum : $_ } @_;
2460
2461   $class->_pkgs_sql(@agentnums); #is this why
2462
2463 }
2464
2465 sub _pkgs_sql {
2466   my( $class, @agentnums ) = @_;
2467   my $agentnums = join(',', @agentnums);
2468
2469   "
2470     (
2471       ( agentnum IS NOT NULL AND agentnum IN ($agentnums) )
2472       OR ( agentnum IS NULL
2473            AND EXISTS ( SELECT 1
2474                           FROM type_pkgs
2475                             LEFT JOIN agent_type USING ( typenum )
2476                             LEFT JOIN agent AS typeagent USING ( typenum )
2477                           WHERE type_pkgs.pkgpart = part_pkg.pkgpart
2478                             AND typeagent.agentnum IN ($agentnums)
2479                       )
2480          )
2481     )
2482   ";
2483
2484 }
2485
2486 =item join_options_sql
2487
2488 Returns an SQL fragment for JOINing the part_pkg_option records for this
2489 package's setup_fee and recur_fee (as setup_option and recur_option,
2490 respectively).  Useful for optimization.
2491
2492 =cut
2493
2494 sub join_options_sql {
2495   #my $class = shift;
2496   "
2497     LEFT JOIN part_pkg_option AS setup_option
2498       ON (     part_pkg.pkgpart = setup_option.pkgpart
2499            AND setup_option.optionname = 'setup_fee' )
2500     LEFT JOIN part_pkg_option AS recur_option
2501       ON (     part_pkg.pkgpart = recur_option.pkgpart
2502            AND recur_option.optionname = 'recur_fee' )
2503   ";
2504 }
2505
2506 =back
2507
2508 =head1 SUBROUTINES
2509
2510 =over 4
2511
2512 =item plan_info
2513
2514 =cut
2515
2516 #false laziness w/part_export & cdr
2517 my %info;
2518 foreach my $INC ( @INC ) {
2519   warn "globbing $INC/FS/part_pkg/[a-z]*.pm\n" if $DEBUG;
2520   foreach my $file ( glob("$INC/FS/part_pkg/[a-z]*.pm") ) {
2521     warn "attempting to load plan info from $file\n" if $DEBUG;
2522     $file =~ /\/(\w+)\.pm$/ or do {
2523       warn "unrecognized file in $INC/FS/part_pkg/: $file\n";
2524       next;
2525     };
2526     my $mod = $1;
2527     my $info = eval "use FS::part_pkg::$mod; ".
2528                     "\\%FS::part_pkg::$mod\::info;";
2529     if ( $@ ) {
2530       die "error using FS::part_pkg::$mod (skipping): $@\n" if $@;
2531       next;
2532     }
2533     unless ( keys %$info ) {
2534       warn "no %info hash found in FS::part_pkg::$mod, skipping\n";
2535       next;
2536     }
2537     warn "got plan info from FS::part_pkg::$mod: $info\n" if $DEBUG;
2538     #if ( exists($info->{'disabled'}) && $info->{'disabled'} ) {
2539     #  warn "skipping disabled plan FS::part_pkg::$mod" if $DEBUG;
2540     #  next;
2541     #}
2542     $info{$mod} = $info;
2543     $info->{'weight'} ||= 0; # quiet warnings
2544   }
2545 }
2546
2547 # copy one level deep to allow replacement of fields and fieldorder
2548 tie %plans, 'Tie::IxHash',
2549   map  { my %infohash = %{ $info{$_} };
2550           $_ => \%infohash }
2551   sort { $info{$a}->{'weight'} <=> $info{$b}->{'weight'} }
2552   keys %info;
2553
2554 # inheritance of plan options
2555 foreach my $name (keys(%info)) {
2556   if (exists($info{$name}->{'disabled'}) and $info{$name}->{'disabled'}) {
2557     warn "skipping disabled plan FS::part_pkg::$name" if $DEBUG;
2558     delete $plans{$name};
2559     next;
2560   }
2561   my $parents = $info{$name}->{'inherit_fields'} || [];
2562   my (%fields, %field_exists, @fieldorder);
2563   foreach my $parent ($name, @$parents) {
2564     if ( !exists($info{$parent}) ) {
2565       warn "$name tried to inherit from nonexistent '$parent'\n";
2566       next;
2567     }
2568     %fields = ( # avoid replacing existing fields
2569       %{ $info{$parent}->{'fields'} || {} },
2570       %fields
2571     );
2572     foreach (@{ $info{$parent}->{'fieldorder'} || [] }) {
2573       # avoid duplicates
2574       next if $field_exists{$_};
2575       $field_exists{$_} = 1;
2576       # allow inheritors to remove inherited fields from the fieldorder
2577       push @fieldorder, $_ if !exists($fields{$_}) or
2578                               !exists($fields{$_}->{'disabled'});
2579     }
2580   }
2581   $plans{$name}->{'fields'} = \%fields;
2582   $plans{$name}->{'fieldorder'} = \@fieldorder;
2583 }
2584
2585 sub plan_info {
2586   \%plans;
2587 }
2588
2589
2590 =back
2591
2592 =head1 NEW PLAN CLASSES
2593
2594 A module should be added in FS/FS/part_pkg/  Eventually, an example may be
2595 found in eg/plan_template.pm.  Until then, it is suggested that you use the
2596 other modules in FS/FS/part_pkg/ as a guide.
2597
2598 =head1 BUGS
2599
2600 The delete method is unimplemented.
2601
2602 setup and recur semantics are not yet defined (and are implemented in
2603 FS::cust_bill.  hmm.).  now they're deprecated and need to go.
2604
2605 plandata should go
2606
2607 part_pkg_taxrate is Pg specific
2608
2609 replace should be smarter about managing the related tables (options, pkg_svc)
2610
2611 =head1 SEE ALSO
2612
2613 L<FS::Record>, L<FS::cust_pkg>, L<FS::type_pkgs>, L<FS::pkg_svc>, L<Safe>.
2614 schema.html from the base documentation.
2615
2616 =cut
2617
2618 1;