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 sub validate_number {
 697   my ($option, $valref) = @_;
 698   $$valref = 0 unless $$valref;
 699   return "Invalid $option"
 700     unless ($$valref) = ($$valref =~ /^\s*(\d+)\s*$/);
 701   return '';
 702 }
 703
 704 =item check
 705
 706 Checks all fields to make sure this is a valid package definition.  If
 707 there is an error, returns the error, otherwise returns false.  Called by the
 708 insert and replace methods.
 709
 710 =cut
 711
 712 sub check {
 713   my $self = shift;
 714   warn "FS::part_pkg::check called on $self" if $DEBUG;
 715
 716   for (qw(setup recur plandata)) {
 717     #$self->set($_=>0) if $self->get($_) =~ /^\s*$/; }
 718     return "Use of $_ field is deprecated; set a plan and options: ".
 719            $self->get($_)
 720       if length($self->get($_));
 721     $self->set($_, '');
 722   }
 723
 724   if ( $self->dbdef_table->column('freq')->type =~ /(int)/i ) {
 725     my $error = $self->ut_number('freq');
 726     return $error if $error;
 727   } else {
 728     $self->freq =~ /^(\d+[hdw]?)$/
 729       or return "Illegal or empty freq: ". $self->freq;
 730     $self->freq($1);
 731   }
 732
 733   my @null_agentnum_right = ( 'Edit global package definitions' );
 734   push @null_agentnum_right, 'One-time charge'
 735     if $self->freq =~ /^0/;
 736   push @null_agentnum_right, 'Customize customer package'
 737     if $self->disabled eq 'Y'; #good enough
 738
 739   my $error = $self->ut_numbern('pkgpart')
 740     || $self->ut_text('pkg')
 741     || $self->ut_textn('comment')
 742     || $self->ut_textn('promo_code')
 743     || $self->ut_alphan('plan')
 744     || $self->ut_flag('setuptax')
 745     || $self->ut_flag('recurtax')
 746     || $self->ut_textn('taxclass')
 747     || $self->ut_flag('disabled')
 748     || $self->ut_flag('custom')
 749     || $self->ut_flag('no_auto')
 750     || $self->ut_flag('recur_show_zero')
 751     || $self->ut_flag('setup_show_zero')
 752     || $self->ut_flag('start_on_hold')
 753     #|| $self->ut_moneyn('setup_cost')
 754     #|| $self->ut_moneyn('recur_cost')
 755     || $self->ut_floatn('setup_cost')
 756     || $self->ut_floatn('recur_cost')
 757     || $self->ut_floatn('pay_weight')
 758     || $self->ut_floatn('credit_weight')
 759     || $self->ut_numbern('taxproductnum')
 760     || $self->ut_foreign_keyn('classnum',       'pkg_class', 'classnum')
 761     || $self->ut_foreign_keyn('addon_classnum', 'pkg_class', 'classnum')
 762     || $self->ut_foreign_keyn('taxproductnum',
 763                               'part_pkg_taxproduct',
 764                               'taxproductnum'
 765                              )
 766     || ( $setup_hack
 767            ? $self->ut_foreign_keyn('agentnum', 'agent', 'agentnum' )
 768            : $self->ut_agentnum_acl('agentnum', \@null_agentnum_right)
 769        )
 770     || $self->ut_numbern('fcc_ds0s')
 771     || $self->ut_numbern('fcc_voip_class')
 772     || $self->ut_numbern('delay_start')
 773     || $self->ut_foreign_keyn('successor', 'part_pkg', 'pkgpart')
 774     || $self->ut_foreign_keyn('family_pkgpart', 'part_pkg', 'pkgpart')
 775     || $self->ut_numbern('expire_months')
 776     || $self->ut_numbern('adjourn_months')
 777     || $self->ut_numbern('contract_end_months')
 778     || $self->ut_numbern('change_to_pkgpart')
 779     || $self->ut_foreign_keyn('change_to_pkgpart', 'part_pkg', 'pkgpart')
 780     || $self->ut_alphan('agent_pkgpartid')
 781     || $self->SUPER::check
 782   ;
 783   return $error if $error;
 784
 785   return 'Unknown plan '. $self->plan
 786     unless exists($plans{$self->plan});
 787
 788   my $conf = new FS::Conf;
 789   return 'Taxclass is required'
 790     if ! $self->taxclass && $conf->exists('require_taxclasses');
 791
 792   '';
 793 }
 794
 795 =item check_options
 796
 797 Pass an I<$options> hashref that contains the values to be
 798 inserted or updated for any FS::part_pkg::MODULE.pm.
 799
 800 For each key in I<$options>, validates the value by calling
 801 the 'validate' subroutine defined for that option e.g.
 802 FS::part_pkg::MODULE::plan_info()->{$KEY}->{validate}.  The
 803 option validation function is only called when the hashkey for
 804 that option exists in I<$options>.
 805
 806 Then the module validation function is called, from
 807 FS::part_pkg::MODULE::plan_info()->{validate}
 808
 809 Returns error message, or empty string if valid.
 810
 811 Invoked by L</insert> and L</replace> via the equivalent
 812 methods in L<FS::option_Common>.
 813
 814 =cut
 815
 816 sub check_options {
 817   my ($self,$options) = @_;
 818   foreach my $option (keys %$options) {
 819     if (exists $plans{ $self->plan }->{fields}->{$option}) {
 820       if (exists($plans{$self->plan}->{fields}->{$option}->{'validate'})) {
 821         # pass option name for use in error message
 822         # pass a reference to the $options value, so it can be cleaned up
 823         my $error = &{$plans{$self->plan}->{fields}->{$option}->{'validate'}}($option,\($options->{$option}));
 824         return $error if $error;
 825       }
 826     } # else "option does not exist" error?
 827   }
 828   if (exists($plans{$self->plan}->{'validate'})) {
 829     my $error = &{$plans{$self->plan}->{'validate'}}($options);
 830     return $error if $error;
 831   }
 832   return '';
 833 }
 834
 835 =item check_pkg_svc
 836
 837 Checks pkg_svc records as a whole (for part_svc_link dependencies).
 838
 839 If there is an error, returns the error, otherwise returns false.
 840
 841 =cut
 842
 843 sub check_pkg_svc {
 844   my( $self, %opt ) = @_;
 845
 846   my $agentnum = $self->agentnum;
 847
 848   my %pkg_svc = map { $_->svcpart => $_ } $self->pkg_svc;
 849
 850   foreach my $svcpart ( keys %pkg_svc ) {
 851
 852     foreach my $part_svc_link ( $self->part_svc_link(
 853                                   'src_svcpart' => $svcpart,
 854                                   'link_type'   => 'part_pkg_restrict',
 855                                 )
 856     ) {
 857
 858       return $part_svc_link->dst_svc. ' must be included with '.
 859              $part_svc_link->src_svc
 860         unless $pkg_svc{ $part_svc_link->dst_svcpart };
 861     }
 862
 863   }
 864
 865   return '' if $opt{part_pkg_restrict_soft_override};
 866
 867   foreach my $svcpart ( keys %pkg_svc ) {
 868
 869     foreach my $part_svc_link ( $self->part_svc_link(
 870                                   'src_svcpart' => $svcpart,
 871                                   'link_type'   => 'part_pkg_restrict_soft',
 872                                 )
 873     ) {
 874       return $part_svc_link->dst_svc. ' is suggested with '.
 875              $part_svc_link->src_svc
 876         unless $pkg_svc{ $part_svc_link->dst_svcpart };
 877     }
 878
 879   }
 880
 881   '';
 882 }
 883
 884 =item part_svc_link OPTION => VALUE ...
 885
 886 Returns the service dependencies (see L<FS::part_svc_link>) for the given
 887 search options, taking into account this package definition's agent.
 888
 889 Available options are any field in part_svc_link.  Typically used options are
 890 src_svcpart and link_type.
 891
 892 =cut
 893
 894 sub part_svc_link {
 895   FS::part_svc_link->by_agentnum( shift->agentnum, @_ );
 896 }
 897
 898 =item supersede OLD [, OPTION => VALUE ... ]
 899
 900 Inserts this package as a successor to the package OLD.  All options are as
 901 for C<insert>.  After inserting, disables OLD and sets the new package as its
 902 successor.
 903
 904 =cut
 905
 906 sub supersede {
 907   my ($new, $old, %options) = @_;
 908   my $error;
 909
 910   $new->set('pkgpart' => '');
 911   $new->set('family_pkgpart' => $old->family_pkgpart);
 912   warn "    inserting successor package\n" if $DEBUG;
 913   $error = $new->insert(%options);
 914   return $error if $error;
 915
 916   warn "    disabling superseded package\n" if $DEBUG;
 917   $old->set('successor' => $new->pkgpart);
 918   $old->set('disabled' => 'Y');
 919   $error = $old->SUPER::replace; # don't change its options/pkg_svc records
 920   return $error if $error;
 921
 922   warn "  propagating changes to family" if $DEBUG;
 923   $new->propagate($old);
 924 }
 925
 926 =item propagate OLD
 927
 928 If any of certain fields have changed from OLD to this package, then,
 929 for all packages in the same lineage as this one, sets those fields
 930 to their values in this package.
 931
 932 =cut
 933
 934 my @propagate_fields = (
 935   qw( pkg classnum setup_cost recur_cost taxclass
 936   setuptax recurtax pay_weight credit_weight
 937   )
 938 );
 939
 940 sub propagate {
 941   my $new = shift;
 942   my $old = shift;
 943   my %fields = (
 944     map { $_ => $new->get($_) }
 945     grep { $new->get($_) ne $old->get($_) }
 946     @propagate_fields
 947   );
 948
 949   my @part_pkg = qsearch('part_pkg', {
 950       'family_pkgpart' => $new->family_pkgpart
 951   });
 952   my @error;
 953   foreach my $part_pkg ( @part_pkg ) {
 954     my $pkgpart = $part_pkg->pkgpart;
 955     next if $pkgpart == $new->pkgpart; # don't modify $new
 956     warn "    propagating to pkgpart $pkgpart\n" if $DEBUG;
 957     foreach ( keys %fields ) {
 958       $part_pkg->set($_, $fields{$_});
 959     }
 960     # SUPER::replace to avoid changing non-core fields
 961     my $error = $part_pkg->SUPER::replace;
 962     push @error, "pkgpart $pkgpart: $error"
 963       if $error;
 964   }
 965   join("\n", @error);
 966 }
 967
 968 =item set_fcc_options HASHREF
 969
 970 Sets the FCC options on this package definition to the values specified
 971 in HASHREF.
 972
 973 =cut
 974
 975 sub set_fcc_options {
 976   my $self = shift;
 977   my $pkgpart = $self->pkgpart;
 978   my $options;
 979   if (ref $_[0]) {
 980     $options = shift;
 981   } else {
 982     $options = { @_ };
 983   }
 984
 985   my %existing_num = map { $_->fccoptionname => $_->num }
 986                      qsearch('part_pkg_fcc_option', { pkgpart => $pkgpart });
 987
 988   local $FS::Record::nowarn_identical = 1;
 989   # set up params for process_o2m
 990   my $i = 0;
 991   my $params = {};
 992   foreach my $name (keys %$options ) {
 993     $params->{ "num$i" } = $existing_num{$name} || '';
 994     $params->{ "num$i".'_fccoptionname' } = $name;
 995     $params->{ "num$i".'_optionvalue'   } = $options->{$name};
 996     $i++;
 997   }
 998
 999   $self->process_o2m(
1000     table   => 'part_pkg_fcc_option',
1001     fields  => [qw( fccoptionname optionvalue )],
1002     params  => $params,
1003   );
1004 }
1005
1006 =item pkg_locale LOCALE
1007
1008 Returns a customer-viewable string representing this package for the given
1009 locale, from the part_pkg_msgcat table.  If the given locale is empty or no
1010 localized string is found, returns the base pkg field.
1011
1012 =cut
1013
1014 sub pkg_locale {
1015   my( $self, $locale ) = @_;
1016   return $self->pkg unless $locale;
1017   my $part_pkg_msgcat = $self->part_pkg_msgcat($locale) or return $self->pkg;
1018   $part_pkg_msgcat->pkg;
1019 }
1020
1021 =item part_pkg_msgcat LOCALE
1022
1023 Like pkg_locale, but returns the FS::part_pkg_msgcat object itself.
1024
1025 =cut
1026
1027 sub part_pkg_msgcat {
1028   my( $self, $locale ) = @_;
1029   qsearchs( 'part_pkg_msgcat', {
1030     pkgpart => $self->pkgpart,
1031     locale  => $locale,
1032   });
1033 }
1034
1035 =item pkg_comment [ OPTION => VALUE... ]
1036
1037 Returns an (internal) string representing this package.  Currently,
1038 "pkgpart: pkg - comment", is returned.  "pkg - comment" may be returned in the
1039 future, omitting pkgpart.  The comment will have '(CUSTOM) ' prepended if
1040 custom is Y.
1041
1042 If the option nopkgpart is true then the "pkgpart: ' is omitted.
1043
1044 =cut
1045
1046 sub pkg_comment {
1047   my $self = shift;
1048   my %opt = @_;
1049
1050   #$self->pkg. ' - '. $self->comment;
1051   #$self->pkg. ' ('. $self->comment. ')';
1052   my $pre = $opt{nopkgpart} ? '' : $self->pkgpart. ': ';
1053   my $custom_comment = $self->custom_comment(%opt);
1054   $pre. $self->pkg. ( $custom_comment ? " - $custom_comment" : '' );
1055 }
1056
1057 #without price info (so without hitting the DB again)
1058 sub pkg_comment_only {
1059   my $self = shift;
1060   my %opt = @_;
1061
1062   my $pre = $opt{nopkgpart} ? '' : $self->pkgpart. ': ';
1063   my $comment = $self->comment;
1064   $pre. $self->pkg. ( $comment ? " - $comment" : '' );
1065 }
1066
1067 sub price_info { # safety, in case a part_pkg hasn't defined price_info
1068     '';
1069 }
1070
1071 sub custom_comment {
1072   my $self = shift;
1073   my $price_info = $self->price_info(@_);
1074   ( $self->custom ? '(CUSTOM) ' : '' ).
1075     $self->comment.
1076     ( ($self->custom || $self->comment) ? ' - ' : '' ).
1077     ($price_info || 'No charge');
1078 }
1079
1080 sub pkg_price_info {
1081   my $self = shift;
1082   $self->pkg. ' - '. ($self->price_info || 'No charge');
1083 }
1084
1085 =item pkg_class
1086
1087 Returns the package class, as an FS::pkg_class object, or the empty string
1088 if there is no package class.
1089
1090 =item addon_pkg_class
1091
1092 Returns the add-on package class, as an FS::pkg_class object, or the empty
1093 string if there is no add-on package class.
1094
1095 =cut
1096
1097 sub addon_pkg_class {
1098   my $self = shift;
1099   if ( $self->addon_classnum ) {
1100     qsearchs('pkg_class', { 'classnum' => $self->addon_classnum } );
1101   } else {
1102     return '';
1103   }
1104 }
1105
1106 =item categoryname
1107
1108 Returns the package category name, or the empty string if there is no package
1109 category.
1110
1111 =cut
1112
1113 sub categoryname {
1114   my $self = shift;
1115   my $pkg_class = $self->pkg_class;
1116   $pkg_class
1117     ? $pkg_class->categoryname
1118     : '';
1119 }
1120
1121 =item classname
1122
1123 Returns the package class name, or the empty string if there is no package
1124 class.
1125
1126 =cut
1127
1128 sub classname {
1129   my $self = shift;
1130   my $pkg_class = $self->pkg_class;
1131   $pkg_class
1132     ? $pkg_class->classname
1133     : '';
1134 }
1135
1136 =item addon_classname
1137
1138 Returns the add-on package class name, or the empty string if there is no
1139 add-on package class.
1140
1141 =cut
1142
1143 sub addon_classname {
1144   my $self = shift;
1145   my $pkg_class = $self->addon_pkg_class;
1146   $pkg_class
1147     ? $pkg_class->classname
1148     : '';
1149 }
1150
1151 =item agent
1152
1153 Returns the associated agent for this event, if any, as an FS::agent object.
1154
1155 =item pkg_svc [ HASHREF | OPTION => VALUE ]
1156
1157 Returns all FS::pkg_svc objects (see L<FS::pkg_svc>) for this package
1158 definition (with non-zero quantity).
1159
1160 One option is available, I<disable_linked>.  If set true it will return the
1161 services for this package definition alone, omitting services from any add-on
1162 packages.
1163
1164 =cut
1165
1166 =item type_pkgs
1167
1168 Returns all FS::type_pkgs objects (see L<FS::type_pkgs>) for this package
1169 definition.
1170
1171 =cut
1172
1173 sub pkg_svc {
1174   my $self = shift;
1175
1176   return @{ $cache_pkg_svc{$self->pkgpart} }
1177     if $cache_enabled && $cache_pkg_svc{$self->pkgpart};
1178
1179 #  #sort { $b->primary cmp $a->primary }
1180 #    grep { $_->quantity }
1181 #      qsearch( 'pkg_svc', { 'pkgpart' => $self->pkgpart } );
1182
1183   my $opt = ref($_[0]) ? $_[0] : { @_ };
1184   my %pkg_svc = map  { $_->svcpart => $_ } $self->_pkg_svc;
1185
1186   unless ( $opt->{disable_linked} ) {
1187     foreach my $dst_pkg ( map $_->dst_pkg, $self->svc_part_pkg_link ) {
1188       my @pkg_svc = $dst_pkg->_pkg_svc;
1189       foreach my $pkg_svc ( @pkg_svc ) {
1190         if ( $pkg_svc{$pkg_svc->svcpart} ) {
1191           my $quantity = $pkg_svc{$pkg_svc->svcpart}->quantity;
1192           $pkg_svc{$pkg_svc->svcpart}->quantity($quantity + $pkg_svc->quantity);
1193         } else {
1194           $pkg_svc{$pkg_svc->svcpart} = $pkg_svc;
1195         }
1196       }
1197     }
1198   }
1199
1200   my @pkg_svc = values(%pkg_svc);
1201
1202   $cache_pkg_svc{$self->pkgpart} = \@pkg_svc if $cache_enabled;
1203
1204   @pkg_svc;
1205
1206 }
1207
1208 sub _pkg_svc {
1209   my $self = shift;
1210   grep { $_->quantity }
1211     qsearch({
1212       'select'    => 'pkg_svc.*, part_svc.*',
1213       'table'     => 'pkg_svc',
1214       'addl_from' => 'LEFT JOIN part_svc USING ( svcpart )',
1215       'hashref'   => { 'pkgpart' => $self->pkgpart },
1216     });
1217 }
1218
1219 =item svcpart [ SVCDB ]
1220
1221 Returns the svcpart of the primary service definition (see L<FS::part_svc>)
1222 associated with this package definition (see L<FS::pkg_svc>).  Returns
1223 false if there not a primary service definition or exactly one service
1224 definition with quantity 1, or if SVCDB is specified and does not match the
1225 svcdb of the service definition.  SVCDB can be specified as a scalar table
1226 name, such as 'svc_acct', or as an arrayref of possible table names.
1227
1228 =cut
1229
1230 sub svcpart {
1231   my $pkg_svc = shift->_primary_pkg_svc(@_);
1232   $pkg_svc ? $pkg_svc->svcpart : '';
1233 }
1234
1235 =item part_svc [ SVCDB ]
1236
1237 Like the B<svcpart> method, but returns the FS::part_svc object (see
1238 L<FS::part_svc>).
1239
1240 =cut
1241
1242 sub part_svc {
1243   my $pkg_svc = shift->_primary_pkg_svc(@_);
1244   $pkg_svc ? $pkg_svc->part_svc : '';
1245 }
1246
1247 sub _primary_pkg_svc {
1248   my $self = shift;
1249
1250   my $svcdb = scalar(@_) ? shift : [];
1251   $svcdb = ref($svcdb) ? $svcdb : [ $svcdb ];
1252   my %svcdb = map { $_=>1 } @$svcdb;
1253
1254   my @svcdb_pkg_svc =
1255     grep { !scalar(@$svcdb) || $svcdb{ $_->part_svc->svcdb } }
1256          $self->pkg_svc;
1257
1258   my @pkg_svc = grep { $_->primary_svc =~ /^Y/i } @svcdb_pkg_svc;
1259   @pkg_svc = grep {$_->quantity == 1 } @svcdb_pkg_svc
1260     unless @pkg_svc;
1261   return '' if scalar(@pkg_svc) != 1;
1262   $pkg_svc[0];
1263 }
1264
1265 =item svcpart_unique_svcdb SVCDB
1266
1267 Returns the svcpart of a service definition (see L<FS::part_svc>) matching
1268 SVCDB associated with this package definition (see L<FS::pkg_svc>).  Returns
1269 false if there not a primary service definition for SVCDB or there are multiple
1270 service definitions for SVCDB.
1271
1272 =cut
1273
1274 sub svcpart_unique_svcdb {
1275   my( $self, $svcdb ) = @_;
1276   my @svcdb_pkg_svc = grep { ( $svcdb eq $_->part_svc->svcdb ) } $self->pkg_svc;
1277   return '' if scalar(@svcdb_pkg_svc) != 1;
1278   $svcdb_pkg_svc[0]->svcpart;
1279 }
1280
1281 =item payby
1282
1283 Returns a list of the acceptable payment types for this package.  Eventually
1284 this should come out of a database table and be editable, but currently has the
1285 following logic instead:
1286
1287 If the package is free, the single item B<BILL> is
1288 returned, otherwise, the single item B<CARD> is returned.
1289
1290 (CHEK?  LEC?  Probably shouldn't accept those by default, prone to abuse)
1291
1292 =cut
1293
1294 sub payby {
1295   my $self = shift;
1296   if ( $self->is_free ) {
1297     ( 'BILL' );
1298   } else {
1299     ( 'CARD' );
1300   }
1301 }
1302
1303 =item is_free
1304
1305 Returns true if this package is free.
1306
1307 =cut
1308
1309 sub is_free {
1310   my $self = shift;
1311   if ( $self->can('is_free_options') ) {
1312     not grep { $_ !~ /^\s*0*(\.0*)?\s*$/ }
1313          map { $self->option($_) }
1314              $self->is_free_options;
1315   } else {
1316     warn "FS::part_pkg::is_free: FS::part_pkg::". $self->plan. " subclass ".
1317          "provides neither is_free_options nor is_free method; returning false";
1318     0;
1319   }
1320 }
1321
1322 # whether the plan allows discounts to be applied to this package
1323 sub can_discount { 0; }
1324
1325 # whether the plan allows changing the start date
1326 sub can_start_date {
1327   my $self = shift;
1328   $self->start_on_hold ? 0 : 1;
1329 }
1330
1331 # whether the plan supports part_pkg_usageprice add-ons (a specific kind of
1332 #  pre-selectable usage pricing, there's others this doesn't refer to)
1333 sub can_usageprice { 0; }
1334
1335 # the delay start date if present
1336 sub delay_start_date {
1337   my $self = shift;
1338
1339   my $delay = $self->delay_start or return '';
1340
1341   # avoid timelocal silliness
1342   my $dt = DateTime->today(time_zone => 'local');
1343   $dt->add(days => $delay);
1344   $dt->epoch;
1345 }
1346
1347 sub can_currency_exchange { 0; }
1348
1349 sub freqs_href {
1350   # moved to FS::Misc to make this accessible to other packages
1351   # at initialization
1352   FS::Misc::pkg_freqs();
1353 }
1354
1355 =item freq_pretty
1356
1357 Returns an english representation of the I<freq> field, such as "monthly",
1358 "weekly", "semi-annually", etc.
1359
1360 =cut
1361
1362 sub freq_pretty {
1363   my $self = shift;
1364   my $freq = $self->freq;
1365
1366   #my $freqs_href = $self->freqs_href;
1367   my $freqs_href = freqs_href();
1368
1369   if ( exists($freqs_href->{$freq}) ) {
1370     $freqs_href->{$freq};
1371   } else {
1372     my $interval = 'month';
1373     if ( $freq =~ /^(\d+)([hdw])$/ ) {
1374       my %interval = ( 'h' => 'hour', 'd'=>'day', 'w'=>'week' );
1375       $interval = $interval{$2};
1376     }
1377     if ( $1 == 1 ) {
1378       "every $interval";
1379     } else {
1380       "every $freq ${interval}s";
1381     }
1382   }
1383 }
1384
1385 =item add_freq TIMESTAMP [ FREQ ]
1386
1387 Adds a billing period of some frequency to the provided timestamp and
1388 returns the resulting timestamp, or -1 if the frequency could not be
1389 parsed (shouldn't happen).  By default, the frequency of this package
1390 will be used; to override this, pass a different frequency as a second
1391 argument.
1392
1393 =cut
1394
1395 sub add_freq {
1396   my( $self, $date, $freq ) = @_;
1397   $freq = $self->freq unless $freq;
1398
1399   #change this bit to use Date::Manip? CAREFUL with timezones (see
1400   # mailing list archive)
1401   my ($sec,$min,$hour,$mday,$mon,$year) = (localtime($date) )[0,1,2,3,4,5];
1402
1403   if ( $freq =~ /^\d+$/ ) {
1404     $mon += $freq;
1405     until ( $mon < 12 ) { $mon -= 12; $year++; }
1406
1407     $mday = 28 if $mday > 28 && FS::Conf->new->exists('anniversary-rollback');
1408
1409   } elsif ( $freq =~ /^(\d+)w$/ ) {
1410     my $weeks = $1;
1411     $mday += $weeks * 7;
1412   } elsif ( $freq =~ /^(\d+)d$/ ) {
1413     my $days = $1;
1414     $mday += $days;
1415   } elsif ( $freq =~ /^(\d+)h$/ ) {
1416     my $hours = $1;
1417     $hour += $hours;
1418   } else {
1419     return -1;
1420   }
1421
1422   timelocal_nocheck($sec,$min,$hour,$mday,$mon,$year);
1423 }
1424
1425 =item plandata
1426
1427 For backwards compatibility, returns the plandata field as well as all options
1428 from FS::part_pkg_option.
1429
1430 =cut
1431
1432 sub plandata {
1433   my $self = shift;
1434   carp "plandata is deprecated";
1435   if ( @_ ) {
1436     $self->SUPER::plandata(@_);
1437   } else {
1438     my $plandata = $self->get('plandata');
1439     my %options = $self->options;
1440     $plandata .= join('', map { "$_=$options{$_}\n" } keys %options );
1441     $plandata;
1442   }
1443 }
1444
1445 =item part_pkg_vendor
1446
1447 Returns all vendor/external package ids as FS::part_pkg_vendor objects (see
1448 L<FS::part_pkg_vendor>).
1449
1450 =item vendor_pkg_ids
1451
1452 Returns a list of vendor/external package ids by exportnum
1453
1454 =cut
1455
1456 sub vendor_pkg_ids {
1457   my $self = shift;
1458   map { $_->exportnum => $_->vendor_pkg_id } $self->part_pkg_vendor;
1459 }
1460
1461 =item part_pkg_option
1462
1463 Returns all options as FS::part_pkg_option objects (see
1464 L<FS::part_pkg_option>).
1465
1466 =item options
1467
1468 Returns a list of option names and values suitable for assigning to a hash.
1469
1470 =cut
1471
1472 sub options {
1473   my $self = shift;
1474   map { $_->optionname => $_->optionvalue } $self->part_pkg_option;
1475 }
1476
1477 =item option OPTIONNAME [ QUIET ]
1478
1479 Returns the option value for the given name, or the empty string.  If a true
1480 value is passed as the second argument, warnings about missing the option
1481 will be suppressed.
1482
1483 =cut
1484
1485 sub option {
1486   my( $self, $opt, $ornull ) = @_;
1487
1488   #cache: was pulled up in the original part_pkg query
1489   return $self->hashref->{"_opt_$opt"}
1490     if exists $self->hashref->{"_opt_$opt"};
1491
1492   cluck "$self -> option: searching for $opt" if $DEBUG;
1493   my $part_pkg_option =
1494     qsearchs('part_pkg_option', {
1495       pkgpart    => $self->pkgpart,
1496       optionname => $opt,
1497   } );
1498   return $part_pkg_option->optionvalue if $part_pkg_option;
1499
1500   my %plandata = map { /^(\w+)=(.*)$/; ( $1 => $2 ); }
1501                      split("\n", $self->get('plandata') );
1502   return $plandata{$opt} if exists $plandata{$opt};
1503
1504   # check whether the option is defined in plan info (if so, don't warn)
1505   if (exists $plans{ $self->plan }->{fields}->{$opt}) {
1506     return '';
1507   }
1508   cluck "WARNING: (pkgpart ". $self->pkgpart. ") Package def option $opt ".
1509         "not found in options or plandata!\n"
1510     unless $ornull;
1511
1512   '';
1513 }
1514
1515 =item part_pkg_currency [ CURRENCY ]
1516
1517 Returns all currency options as FS::part_pkg_currency objects (see
1518 L<FS::part_pkg_currency>), or, if a currency is specified, only return the
1519 objects for that currency.
1520
1521 =cut
1522
1523 sub part_pkg_currency {
1524   my $self = shift;
1525   my %hash = ( 'pkgpart' => $self->pkgpart );
1526   $hash{'currency'} = shift if @_;
1527   qsearch('part_pkg_currency', \%hash );
1528 }
1529
1530 =item part_pkg_currency_options CURRENCY
1531
1532 Returns a list of option names and values from FS::part_pkg_currency for the
1533 specified currency.
1534
1535 =cut
1536
1537 sub part_pkg_currency_options {
1538   my $self = shift;
1539   map { $_->optionname => $_->optionvalue } $self->part_pkg_currency(shift);
1540 }
1541
1542 =item part_pkg_currency_option CURRENCY OPTIONNAME
1543
1544 Returns the option value for the given name and currency.
1545
1546 =cut
1547
1548 sub part_pkg_currency_option {
1549   my( $self, $currency, $optionname ) = @_;
1550   my $part_pkg_currency =
1551     qsearchs('part_pkg_currency', { 'pkgpart'    => $self->pkgpart,
1552                                     'currency'   => $currency,
1553                                     'optionname' => $optionname,
1554                                   }
1555             )#;
1556   #fatal if not found?  that works for our use cases from
1557   #part_pkg/currency_fixed, but isn't how we would typically/expect the method
1558   #to behave.  have to catch it there if we change it here...
1559     or die "Unknown price for ". $self->pkg_comment. " in $currency\n";
1560
1561   $part_pkg_currency->optionvalue;
1562 }
1563
1564 =item fcc_option OPTIONNAME
1565
1566 Returns the FCC 477 report option value for the given name, or the empty
1567 string.
1568
1569 =cut
1570
1571 sub fcc_option {
1572   my ($self, $name) = @_;
1573   my $part_pkg_fcc_option =
1574     qsearchs('part_pkg_fcc_option', {
1575         pkgpart => $self->pkgpart,
1576         fccoptionname => $name,
1577     });
1578   $part_pkg_fcc_option ? $part_pkg_fcc_option->optionvalue : '';
1579 }
1580
1581 =item fcc_options
1582
1583 Returns all FCC 477 report options for this package, as a hash-like list.
1584
1585 =cut
1586
1587 sub fcc_options {
1588   my $self = shift;
1589   map { $_->fccoptionname => $_->optionvalue }
1590     qsearch('part_pkg_fcc_option', { pkgpart => $self->pkgpart });
1591 }
1592
1593 =item bill_part_pkg_link
1594
1595 Returns the associated part_pkg_link records (see L<FS::part_pkg_link>).
1596
1597 =cut
1598
1599 sub bill_part_pkg_link {
1600   shift->_part_pkg_link('bill', @_);
1601 }
1602
1603 =item svc_part_pkg_link
1604
1605 Returns the associated part_pkg_link records (see L<FS::part_pkg_link>).
1606
1607 =cut
1608
1609 sub svc_part_pkg_link {
1610   shift->_part_pkg_link('svc', @_);
1611 }
1612
1613 =item supp_part_pkg_link
1614
1615 Returns the associated part_pkg_link records of type 'supp' (supplemental
1616 packages).
1617
1618 =cut
1619
1620 sub supp_part_pkg_link {
1621   shift->_part_pkg_link('supp', @_);
1622 }
1623
1624 sub _part_pkg_link {
1625   my( $self, $type ) = @_;
1626
1627   return @{ $cache_link{$type}->{$self->pkgpart} }
1628     if $cache_enabled && $cache_link{$type}->{$self->pkgpart};
1629
1630   cluck $type.'_part_pkg_link called' if $DEBUG;
1631
1632   my @ppl =
1633     qsearch({ table    => 'part_pkg_link',
1634               hashref  => { src_pkgpart => $self->pkgpart,
1635                             link_type   => $type,
1636                             #protection against infinite recursive links
1637                             dst_pkgpart => { op=>'!=', value=> $self->pkgpart },
1638                           },
1639               order_by => "ORDER BY hidden",
1640            });
1641
1642   $cache_link{$type}->{$self->pkgpart} = \@ppl if $cache_enabled;
1643
1644   return @ppl;
1645 }
1646
1647 sub self_and_bill_linked {
1648   shift->_self_and_linked('bill', @_);
1649 }
1650
1651 sub self_and_svc_linked {
1652   shift->_self_and_linked('svc', @_);
1653 }
1654
1655 sub _self_and_linked {
1656   my( $self, $type, $hidden ) = @_;
1657   $hidden ||= '';
1658
1659   my @result = ();
1660   foreach ( ( $self, map { $_->dst_pkg->_self_and_linked($type, $_->hidden) }
1661                      $self->_part_pkg_link($type) ) )
1662   {
1663     $_->hidden($hidden) if $hidden;
1664     push @result, $_;
1665   }
1666
1667   (@result);
1668 }
1669
1670 =item part_pkg_taxoverride [ CLASS ]
1671
1672 Returns all associated FS::part_pkg_taxoverride objects (see
1673 L<FS::part_pkg_taxoverride>).  Limits the returned set to those
1674 of class CLASS if defined.  Class may be one of 'setup', 'recur',
1675 the empty string (default), or a usage class number (see L<FS::usage_class>).
1676 When a class is specified, the empty string class (default) is returned
1677 if no more specific values exist.
1678
1679 =cut
1680
1681 sub part_pkg_taxoverride {
1682   my $self = shift;
1683   my $class = shift;
1684
1685   my $hashref = { 'pkgpart' => $self->pkgpart };
1686   $hashref->{'usage_class'} = $class if defined($class);
1687   my @overrides = qsearch('part_pkg_taxoverride', $hashref );
1688
1689   unless ( scalar(@overrides) || !defined($class) || !$class ){
1690     $hashref->{'usage_class'} = '';
1691     @overrides = qsearch('part_pkg_taxoverride', $hashref );
1692   }
1693
1694   @overrides;
1695 }
1696
1697 =item has_taxproduct
1698
1699 Returns true if this package has any taxproduct associated with it.
1700
1701 =cut
1702
1703 sub has_taxproduct {
1704   my $self = shift;
1705
1706   $self->taxproductnum ||
1707   scalar( grep { $_ =~/^usage_taxproductnum_/ && $self->option($_) }
1708           keys %{ {$self->options} }
1709   )
1710
1711 }
1712
1713
1714 =item taxproduct [ CLASS ]
1715
1716 Returns the associated tax product for this package definition (see
1717 L<FS::part_pkg_taxproduct>).  CLASS may be one of 'setup', 'recur' or
1718 the usage classnum (see L<FS::usage_class>).  Returns the default
1719 tax product for this record if the more specific CLASS value does
1720 not exist.
1721
1722 =cut
1723
1724 sub taxproduct {
1725   my $self = shift;
1726   my $class = shift;
1727
1728   my $part_pkg_taxproduct;
1729
1730   my $taxproductnum = $self->taxproductnum;
1731   if ($class) {
1732     my $class_taxproductnum = $self->option("usage_taxproductnum_$class", 1);
1733     $taxproductnum = $class_taxproductnum
1734       if $class_taxproductnum
1735   }
1736
1737   $part_pkg_taxproduct =
1738     qsearchs( 'part_pkg_taxproduct', { 'taxproductnum' => $taxproductnum } );
1739
1740   unless ($part_pkg_taxproduct || $taxproductnum eq $self->taxproductnum ) {
1741     $taxproductnum = $self->taxproductnum;
1742     $part_pkg_taxproduct =
1743       qsearchs( 'part_pkg_taxproduct', { 'taxproductnum' => $taxproductnum } );
1744   }
1745
1746   $part_pkg_taxproduct;
1747 }
1748
1749 =item taxproduct_description [ CLASS ]
1750
1751 Returns the description of the associated tax product for this package
1752 definition (see L<FS::part_pkg_taxproduct>).
1753
1754 =cut
1755
1756 sub taxproduct_description {
1757   my $self = shift;
1758   my $part_pkg_taxproduct = $self->taxproduct(@_);
1759   $part_pkg_taxproduct ? $part_pkg_taxproduct->description : '';
1760 }
1761
1762
1763 =item tax_rates DATA_PROVIDER, GEOCODE, [ CLASS ]
1764
1765 Returns the tax table entries (L<FS::tax_rate> objects) that apply to this
1766 package in the location specified by GEOCODE, for usage class CLASS (one of
1767 'setup', 'recur', null, or a C<usage_class> number).
1768
1769 =cut
1770
1771 sub tax_rates {
1772   my $self = shift;
1773   my ($vendor, $geocode, $class) = @_;
1774   # if this part_pkg is overridden into a specific taxclass, get that class
1775   my @taxclassnums = map { $_->taxclassnum }
1776                      $self->part_pkg_taxoverride($class);
1777   # otherwise, get its tax product category
1778   if (!@taxclassnums) {
1779     my $part_pkg_taxproduct = $self->taxproduct($class);
1780     # If this isn't defined, then the class has no taxproduct designation,
1781     # so return no tax rates.
1782     return () if !$part_pkg_taxproduct;
1783
1784     # convert the taxproduct to the tax classes that might apply to it in
1785     # $geocode
1786     @taxclassnums = map { $_->taxclassnum }
1787                     grep { $_->taxable eq 'Y' } # why do we need this?
1788                     $part_pkg_taxproduct->part_pkg_taxrate($geocode);
1789   }
1790   return unless @taxclassnums;
1791
1792   # then look up the actual tax_rate entries
1793   warn "Found taxclassnum values of ". join(',', @taxclassnums) ."\n"
1794       if $DEBUG;
1795   my $extra_sql = "AND taxclassnum IN (". join(',', @taxclassnums) . ")";
1796   my @taxes = qsearch({ 'table'     => 'tax_rate',
1797                         'hashref'   => { 'geocode'     => $geocode,
1798                                          'data_vendor' => $vendor,
1799                                          'disabled'    => '' },
1800                         'extra_sql' => $extra_sql,
1801                       });
1802   warn "Found taxes ". join(',', map {$_->taxnum} @taxes) ."\n"
1803       if $DEBUG;
1804
1805   return @taxes;
1806 }
1807
1808 =item part_pkg_discount
1809
1810 Returns the package to discount m2m records (see L<FS::part_pkg_discount>)
1811 for this package.
1812
1813 =item part_pkg_usage
1814
1815 Returns the voice usage pools (see L<FS::part_pkg_usage>) defined for
1816 this package.
1817
1818 =item change_to_pkg
1819
1820 Returns the automatic transfer target for this package, or an empty string
1821 if there isn't one.
1822
1823 =cut
1824
1825 sub change_to_pkg {
1826   my $self = shift;
1827   my $pkgpart = $self->change_to_pkgpart or return '';
1828   FS::part_pkg->by_key($pkgpart);
1829 }
1830
1831 =item _rebless
1832
1833 Reblesses the object into the FS::part_pkg::PLAN class (if available), where
1834 PLAN is the object's I<plan> field.  There should be better docs
1835 on how to create new price plans, but until then, see L</NEW PLAN CLASSES>.
1836
1837 =cut
1838
1839 sub _rebless {
1840   my $self = shift;
1841   my $plan = $self->plan;
1842   unless ( $plan ) {
1843     cluck "no price plan found for pkgpart ". $self->pkgpart. "\n"
1844       if $DEBUG;
1845     return $self;
1846   }
1847   return $self if ref($self) =~ /::$plan$/; #already blessed into plan subclass
1848   my $class = ref($self). "::$plan";
1849   warn "reblessing $self into $class" if $DEBUG > 1;
1850   eval "use $class;";
1851   die $@ if $@;
1852   bless($self, $class) unless $@;
1853   $self;
1854 }
1855
1856 =item calc_setup CUST_PKG START_DATE DETAILS_ARRAYREF OPTIONS_HASHREF
1857
1858 =item calc_recur CUST_PKG START_DATE DETAILS_ARRAYREF OPTIONS_HASHREF
1859
1860 Calculates and returns the setup or recurring fees, respectively, for this
1861 package.  Implementation is in the FS::part_pkg:* module specific to this price
1862 plan.
1863
1864 Adds invoicing details to the passed-in DETAILS_ARRAYREF
1865
1866 Options are passed as a hashref.  Available options:
1867
1868 =over 4
1869
1870 =item freq_override
1871
1872 Frequency override (for calc_recur)
1873
1874 =item discounts
1875
1876 This option is filled in by the method rather than controlling its operation.
1877 It is an arrayref.  Applicable discounts will be added to the arrayref, as
1878 L<FS::cust_bill_pkg_discount|FS::cust_bill_pkg_discount records>.
1879
1880 =item real_pkgpart
1881
1882 For package add-ons, is the base L<FS::part_pkg|package definition>, otherwise
1883 no different than pkgpart.
1884
1885 =item precommit_hooks
1886
1887 This option is filled in by the method rather than controlling its operation.
1888 It is an arrayref.  Anonymous coderefs will be added to the arrayref.  They
1889 need to be called before completing the billing operation.  For calc_recur
1890 only.
1891
1892 =item increment_next_bill
1893
1894 Increment the next bill date (boolean, for calc_recur).  Typically true except
1895 for particular situations.
1896
1897 =item setup_fee
1898
1899 This option is filled in by the method rather than controlling its operation.
1900 It indicates a deferred setup fee that is billed at calc_recur time (see price
1901 plan option prorate_defer_bill).
1902
1903 =back
1904
1905 Note: Don't calculate prices when not actually billing the package.  For that,
1906 see the L</base_setup|base_setup> and L</base_recur|base_recur> methods.
1907
1908 =cut
1909
1910 #fatal fallbacks
1911 sub calc_setup { die 'no calc_setup for '. shift->plan. "\n"; }
1912 sub calc_recur { die 'no calc_recur for '. shift->plan. "\n"; }
1913
1914 =item calc_remain CUST_PKG [ OPTION => VALUE ... ]
1915
1916 Calculates and returns the remaining value to be credited upon package
1917 suspension, change, or cancellation, if enabled.
1918
1919 Options are passed as a list of keys and values.  Available options:
1920
1921 =over 4
1922
1923 =item time
1924
1925 Override for the current time
1926
1927 =item cust_credit_source_bill_pkg
1928
1929 This option is filled in by the method rather than controlling its operation.
1930 It is an arrayref.
1931 L<FS::cust_credit_source_bill_pkg|FS::cust_credit_source_bill_pkg> records will
1932 be added to the arrayref indicating the specific line items and amounts which
1933 are the source of this remaining credit.
1934
1935 =back
1936
1937 Note: Don't calculate prices when not actually suspending or cancelling the
1938 package.
1939
1940 =cut
1941
1942 #fallback that returns 0 for old legacy packages with no plan
1943 sub calc_remain { 0; }
1944
1945 =item calc_units CUST_PKG
1946
1947 This returns the number of provisioned svc_phone records, or, of the package
1948 count_available_phones option is set, the number available to be provisioned
1949 in the package.
1950
1951 =cut
1952
1953 sub calc_units {
1954   my($self, $cust_pkg ) = @_;
1955   my $count = 0;
1956   if ( $self->option('count_available_phones', 1)) {
1957     foreach my $pkg_svc ($cust_pkg->part_pkg->pkg_svc) {
1958       if ($pkg_svc->part_svc->svcdb eq 'svc_phone') { # svc_pbx?
1959         $count += $pkg_svc->quantity || 0;
1960       }
1961     }
1962     $count *= $cust_pkg->quantity;
1963   } else {
1964     $count =
1965       scalar(grep { $_->part_svc->svcdb eq 'svc_phone' } $cust_pkg->cust_svc);
1966   }
1967   $count;
1968 }
1969
1970 #fallback for everything not based on flat.pm
1971 sub recur_temporality { 'upcoming'; }
1972
1973 =item calc_cancel START_DATE DETAILS_ARRAYREF OPTIONS_HASHREF
1974
1975 Runs any necessary billing on cancellation: another recurring cycle for
1976 recur_temporailty 'preceding' pacakges with the bill_recur_on_cancel option
1977 set (calc_recur), or, any outstanding usage for pacakges with the
1978 bill_usage_on_cancel option set (calc_usage).
1979
1980 =cut
1981
1982 #fallback for everything not based on flat.pm, doesn't do this yet (which is
1983 #okay, nothing of ours not based on flat.pm does usage-on-cancel billing
1984 sub calc_cancel { 0; }
1985
1986 #fallback for everything except bulk.pm
1987 sub hide_svc_detail { 0; }
1988
1989 #fallback for packages that can't/won't summarize usage
1990 sub sum_usage { 0; }
1991
1992 =item recur_cost_permonth CUST_PKG
1993
1994 recur_cost divided by freq (only supported for monthly and longer frequencies)
1995
1996 =cut
1997
1998 sub recur_cost_permonth {
1999   my($self, $cust_pkg) = @_;
2000   return 0 unless $self->freq =~ /^\d+$/ && $self->freq > 0;
2001   sprintf('%.2f', ($self->recur_cost || 0) / $self->freq );
2002 }
2003
2004 =item cust_bill_pkg_recur CUST_PKG
2005
2006 Actual recurring charge for the specified customer package from customer's most
2007 recent invoice
2008
2009 =cut
2010
2011 sub cust_bill_pkg_recur {
2012   my($self, $cust_pkg) = @_;
2013   my $cust_bill_pkg = qsearchs({
2014     'table'     => 'cust_bill_pkg',
2015     'addl_from' => 'LEFT JOIN cust_bill USING ( invnum )',
2016     'hashref'   => { 'pkgnum' => $cust_pkg->pkgnum,
2017                      'recur'  => { op=>'>', value=>'0' },
2018                    },
2019     'order_by'  => 'ORDER BY cust_bill._date     DESC,
2020                              cust_bill_pkg.sdate DESC
2021                      LIMIT 1
2022                    ',
2023   }) or return 0; #die "use cust_bill_pkg_recur credits with once_perinv condition";
2024   $cust_bill_pkg->recur;
2025 }
2026
2027 =item unit_setup CUST_PKG
2028
2029 Returns the setup fee for one unit of the package.
2030
2031 =cut
2032
2033 sub unit_setup {
2034   my ($self, $cust_pkg) = @_;
2035   $self->option('setup_fee') || 0;
2036 }
2037
2038 =item setup_margin
2039
2040 unit_setup minus setup_cost
2041
2042 =cut
2043
2044 sub setup_margin {
2045   my $self = shift;
2046   $self->unit_setup(@_) - ($self->setup_cost || 0);
2047 }
2048
2049 =item recur_margin_permonth
2050
2051 base_recur_permonth minus recur_cost_permonth
2052
2053 =cut
2054
2055 sub recur_margin_permonth {
2056   my $self = shift;
2057   $self->base_recur_permonth(@_) - $self->recur_cost_permonth(@_);
2058 }
2059
2060 =item intro_end PACKAGE
2061
2062 Takes an L<FS::cust_pkg> object.  If this plan has an introductory rate,
2063 returns the expected date the intro period will end. If there is no intro
2064 rate, returns zero.
2065
2066 =cut
2067
2068 sub intro_end {
2069   0;
2070 }
2071
2072 =item format OPTION DATA
2073
2074 Returns data formatted according to the function 'format' described
2075 in the plan info.  Returns DATA if no such function exists.
2076
2077 =cut
2078
2079 sub format {
2080   my ($self, $option, $data) = (shift, shift, shift);
2081   if (exists($plans{$self->plan}->{fields}->{$option}{format})) {
2082     &{$plans{$self->plan}->{fields}->{$option}{format}}($data);
2083   }else{
2084     $data;
2085   }
2086 }
2087
2088 =item parse OPTION DATA
2089
2090 Returns data parsed according to the function 'parse' described
2091 in the plan info.  Returns DATA if no such function exists.
2092
2093 =cut
2094
2095 sub parse {
2096   my ($self, $option, $data) = (shift, shift, shift);
2097   if (exists($plans{$self->plan}->{fields}->{$option}{parse})) {
2098     &{$plans{$self->plan}->{fields}->{$option}{parse}}($data);
2099   }else{
2100     $data;
2101   }
2102 }
2103
2104 =back
2105
2106 =cut
2107
2108 =head1 CLASS METHODS
2109
2110 =over 4
2111
2112 =cut
2113
2114 # _upgrade_data
2115 #
2116 # Used by FS::Upgrade to migrate to a new database.
2117
2118 sub _upgrade_data { # class method
2119    my($class, %opts) = @_;
2120
2121   warn "[FS::part_pkg] upgrading $class\n" if $DEBUG;
2122
2123   my @part_pkg = qsearch({
2124     'table'     => 'part_pkg',
2125     'extra_sql' => "WHERE ". join(' OR ',
2126                      'plan IS NULL', "plan = '' ",
2127                    ),
2128   });
2129
2130   foreach my $part_pkg (@part_pkg) {
2131
2132     unless ( $part_pkg->plan ) {
2133       $part_pkg->plan('flat');
2134     }
2135
2136     $part_pkg->replace;
2137
2138   }
2139
2140   # Convert RADIUS accounting usage metrics from megabytes to gigabytes
2141   # (FS RT#28105)
2142   my $upgrade = 'part_pkg_gigabyte_usage';
2143   if (!FS::upgrade_journal->is_done($upgrade)) {
2144     foreach my $part_pkg (qsearch('part_pkg',
2145                                   { plan => 'sqlradacct_hour' })
2146                          ){
2147
2148       my $pkgpart = $part_pkg->pkgpart;
2149
2150       foreach my $opt (qsearch('part_pkg_option',
2151                                { 'optionname'  => { op => 'LIKE',
2152                                                     value => 'recur_included_%',
2153                                                   },
2154                                  pkgpart => $pkgpart,
2155                                })){
2156
2157         next if $opt->optionname eq 'recur_included_hours'; # unfortunately named field
2158         next if $opt->optionvalue == 0;
2159
2160         $opt->optionvalue($opt->optionvalue / 1024);
2161
2162         my $error = $opt->replace;
2163         die $error if $error;
2164       }
2165
2166       foreach my $opt (qsearch('part_pkg_option',
2167                                { 'optionname'  => { op => 'LIKE',
2168                                                     value => 'recur_%_charge',
2169                                                   },
2170                                  pkgpart => $pkgpart,
2171                                })){
2172         $opt->optionvalue($opt->optionvalue * 1024);
2173
2174         my $error = $opt->replace;
2175         die $error if $error;
2176       }
2177
2178     }
2179     FS::upgrade_journal->set_done($upgrade);
2180   }
2181
2182   # the rest can be done asynchronously
2183 }
2184
2185 sub queueable_upgrade {
2186   # now upgrade to the explicit custom flag
2187
2188   my $search = FS::Cursor->new({
2189     'table'     => 'part_pkg',
2190     'hashref'   => { disabled => 'Y', custom => '' },
2191     'extra_sql' => "AND comment LIKE '(CUSTOM) %'",
2192   });
2193   my $dbh = dbh;
2194
2195   while (my $part_pkg = $search->fetch) {
2196     my $new = new FS::part_pkg { $part_pkg->hash };
2197     $new->custom('Y');
2198     my $comment = $part_pkg->comment;
2199     $comment =~ s/^\(CUSTOM\) //;
2200     $comment = '(none)' unless $comment =~ /\S/;
2201     $new->comment($comment);
2202
2203     my $pkg_svc = { map { $_->svcpart => $_->quantity } $part_pkg->pkg_svc };
2204     my $primary = $part_pkg->svcpart;
2205     my $options = { $part_pkg->options };
2206
2207     my $error = $new->replace( $part_pkg,
2208                                'pkg_svc'     => $pkg_svc,
2209                                'primary_svc' => $primary,
2210                                'options'     => $options,
2211                              );
2212     if ($error) {
2213       warn "pkgpart#".$part_pkg->pkgpart.": $error\n";
2214       $dbh->rollback;
2215     } else {
2216       $dbh->commit;
2217     }
2218   }
2219
2220   # set family_pkgpart on any packages that don't have it
2221   $search = FS::Cursor->new('part_pkg', { 'family_pkgpart' => '' });
2222   while (my $part_pkg = $search->fetch) {
2223     $part_pkg->set('family_pkgpart' => $part_pkg->pkgpart);
2224     my $error = $part_pkg->SUPER::replace;
2225     if ($error) {
2226       warn "pkgpart#".$part_pkg->pkgpart.": $error\n";
2227       $dbh->rollback;
2228     } else {
2229       $dbh->commit;
2230     }
2231   }
2232
2233   my @part_pkg_option = qsearch('part_pkg_option',
2234     { 'optionname'  => 'unused_credit',
2235       'optionvalue' => 1,
2236     });
2237   foreach my $old_opt (@part_pkg_option) {
2238     my $pkgpart = $old_opt->pkgpart;
2239     my $error = $old_opt->delete;
2240     die $error if $error;
2241
2242     foreach (qw(unused_credit_cancel unused_credit_change)) {
2243       my $new_opt = new FS::part_pkg_option {
2244         'pkgpart'     => $pkgpart,
2245         'optionname'  => $_,
2246         'optionvalue' => 1,
2247       };
2248       $error = $new_opt->insert;
2249       die $error if $error;
2250     }
2251   }
2252
2253   # migrate use_disposition_taqua and use_disposition to disposition_in
2254   @part_pkg_option = qsearch('part_pkg_option',
2255     { 'optionname'  => { op => 'LIKE',
2256                          value => 'use_disposition%',
2257                        },
2258       'optionvalue' => 1,
2259     });
2260   my %newopts = map { $_->pkgpart => $_ }
2261     qsearch('part_pkg_option',  { 'optionname'  => 'disposition_in', } );
2262   foreach my $old_opt (@part_pkg_option) {
2263         my $pkgpart = $old_opt->pkgpart;
2264         my $newval = $old_opt->optionname eq 'use_disposition_taqua' ? '100'
2265                                                                   : 'ANSWERED';
2266         my $error = $old_opt->delete;
2267         die $error if $error;
2268
2269         if ( exists($newopts{$pkgpart}) ) {
2270             my $opt = $newopts{$pkgpart};
2271             $opt->optionvalue($opt->optionvalue.",$newval");
2272             $error = $opt->replace;
2273             die $error if $error;
2274         } else {
2275             my $new_opt = new FS::part_pkg_option {
2276                 'pkgpart'     => $pkgpart,
2277                 'optionname'  => 'disposition_in',
2278                 'optionvalue' => $newval,
2279               };
2280               $error = $new_opt->insert;
2281               die $error if $error;
2282               $newopts{$pkgpart} = $new_opt;
2283         }
2284   }
2285
2286   # set any package with FCC voice lines to the "VoIP with broadband" category
2287   # for backward compatibility
2288   #
2289   # recover from a bad upgrade bug
2290   my $upgrade = 'part_pkg_fcc_voip_class_FIX';
2291   if (!FS::upgrade_journal->is_done($upgrade)) {
2292     my $bad_upgrade = qsearchs('upgrade_journal',
2293       { upgrade => 'part_pkg_fcc_voip_class' }
2294     );
2295     if ( $bad_upgrade ) {
2296       my $where = 'WHERE history_date <= '.$bad_upgrade->_date.
2297                   ' AND  history_date >  '.($bad_upgrade->_date - 3600);
2298       my @h_part_pkg_option = map { FS::part_pkg_option->new($_->hashref) }
2299         qsearch({
2300           'select'    => '*',
2301           'table'     => 'h_part_pkg_option',
2302           'hashref'   => {},
2303           'extra_sql' => "$where AND history_action = 'delete'",
2304           'order_by'  => 'ORDER BY history_date ASC',
2305         });
2306       my @h_pkg_svc = map { FS::pkg_svc->new($_->hashref) }
2307         qsearch({
2308           'select'    => '*',
2309           'table'     => 'h_pkg_svc',
2310           'hashref'   => {},
2311           'extra_sql' => "$where AND history_action = 'replace_old'",
2312           'order_by'  => 'ORDER BY history_date ASC',
2313         });
2314       my %opt;
2315       foreach my $deleted (@h_part_pkg_option, @h_pkg_svc) {
2316         my $pkgpart ||= $deleted->pkgpart;
2317         $opt{$pkgpart} ||= {
2318           options => {},
2319           pkg_svc => {},
2320           primary_svc => '',
2321           hidden_svc => {},
2322         };
2323         if ( $deleted->isa('FS::part_pkg_option') ) {
2324           $opt{$pkgpart}{options}{ $deleted->optionname } = $deleted->optionvalue;
2325         } else { # pkg_svc
2326           my $svcpart = $deleted->svcpart;
2327           $opt{$pkgpart}{pkg_svc}{$svcpart} = $deleted->quantity;
2328           $opt{$pkgpart}{hidden_svc}{$svcpart} ||= $deleted->hidden;
2329           $opt{$pkgpart}{primary_svc} = $svcpart if $deleted->primary_svc;
2330         }
2331       }
2332       foreach my $pkgpart (keys %opt) {
2333         my $part_pkg = FS::part_pkg->by_key($pkgpart);
2334         my $error = $part_pkg->replace( $part_pkg->replace_old, $opt{$pkgpart} );
2335         if ( $error ) {
2336           die "error recovering damaged pkgpart $pkgpart:\n$error\n";
2337         }
2338       }
2339     } # $bad_upgrade exists
2340     else { # do the original upgrade, but correctly this time
2341       my @part_pkg = qsearch('part_pkg', {
2342           fcc_ds0s        => { op => '>', value => 0 },
2343           fcc_voip_class  => ''
2344       });
2345       foreach my $part_pkg (@part_pkg) {
2346         $part_pkg->set(fcc_voip_class => 2);
2347         my @pkg_svc = $part_pkg->pkg_svc;
2348         my %quantity = map {$_->svcpart, $_->quantity} @pkg_svc;
2349         my %hidden   = map {$_->svcpart, $_->hidden  } @pkg_svc;
2350         my $error = $part_pkg->replace(
2351           $part_pkg->replace_old,
2352           options     => { $part_pkg->options },
2353           pkg_svc     => \%quantity,
2354           hidden_svc  => \%hidden,
2355           primary_svc => ($part_pkg->svcpart || ''),
2356         );
2357         die $error if $error;
2358       }
2359     }
2360     FS::upgrade_journal->set_done($upgrade);
2361   }
2362
2363   # migrate adjourn_months, expire_months, and contract_end_months to
2364   # real fields
2365   foreach my $field (qw(adjourn_months expire_months contract_end_months)) {
2366     foreach my $option (qsearch('part_pkg_option', { optionname => $field })) {
2367       my $part_pkg = $option->part_pkg;
2368       my $error = $option->delete;
2369       if ( $option->optionvalue and $part_pkg->get($field) eq '' ) {
2370         $part_pkg->set($field, $option->optionvalue);
2371         $error ||= $part_pkg->replace;
2372       }
2373       die $error if $error;
2374     }
2375   }
2376
2377   # remove custom flag from one-time charge packages that were accidentally
2378   # flagged as custom
2379   $search = FS::Cursor->new({
2380     'table'   => 'part_pkg',
2381     'hashref' => { 'freq'   => '0',
2382                    'custom' => 'Y',
2383                    'family_pkgpart' => { op => '!=', value => '' },
2384                  },
2385     'addl_from' => ' JOIN
2386   (select pkgpart from cust_pkg group by pkgpart having count(*) = 1)
2387     AS singular_pkg USING (pkgpart)',
2388   });
2389   my @fields = grep {     $_ ne 'pkgpart'
2390                       and $_ ne 'custom'
2391                       and $_ ne 'disabled' } FS::part_pkg->fields;
2392   PKGPART: while (my $part_pkg = $search->fetch) {
2393     # can't merge the package back into its parent (too late for that)
2394     # but we can remove the custom flag if it's not actually customized,
2395     # i.e. nothing has been changed.
2396
2397     my $family_pkgpart = $part_pkg->family_pkgpart;
2398     next PKGPART if $family_pkgpart == $part_pkg->pkgpart;
2399     my $parent_pkg = FS::part_pkg->by_key($family_pkgpart);
2400     foreach my $field (@fields) {
2401       if ($part_pkg->get($field) ne $parent_pkg->get($field)) {
2402         next PKGPART;
2403       }
2404     }
2405     # options have to be identical too
2406     # but links, FCC options, discount plans, and usage packages can't be
2407     # changed through the "modify charge" UI, so skip them
2408     my %newopt = $part_pkg->options;
2409     my %oldopt = $parent_pkg->options;
2410     OPTION: foreach my $option (keys %newopt) {
2411       if (delete $newopt{$option} ne delete $oldopt{$option}) {
2412         next PKGPART;
2413       }
2414     }
2415     if (keys(%newopt) or keys(%oldopt)) {
2416       next PKGPART;
2417     }
2418     # okay, now replace it
2419     warn "Removing custom flag from part_pkg#".$part_pkg->pkgpart."\n";
2420     $part_pkg->set('custom', '');
2421     my $error = $part_pkg->replace;
2422     die $error if $error;
2423   } # $search->fetch
2424
2425   return;
2426 }
2427
2428 =item curuser_pkgs_sql
2429
2430 Returns an SQL fragment for searching for packages the current user can
2431 use, either via part_pkg.agentnum directly, or via agent type (see
2432 L<FS::type_pkgs>).
2433
2434 =cut
2435
2436 sub curuser_pkgs_sql {
2437   my $class = shift;
2438
2439   $class->_pkgs_sql( $FS::CurrentUser::CurrentUser->agentnums );
2440
2441 }
2442
2443 =item agent_pkgs_sql AGENT | AGENTNUM, ...
2444
2445 Returns an SQL fragment for searching for packages the provided agent or agents
2446 can use, either via part_pkg.agentnum directly, or via agent type (see
2447 L<FS::type_pkgs>).
2448
2449 =cut
2450
2451 sub agent_pkgs_sql {
2452   my $class = shift;  #i'm a class method, not a sub (the question is... why??)
2453   my @agentnums = map { ref($_) ? $_->agentnum : $_ } @_;
2454
2455   $class->_pkgs_sql(@agentnums); #is this why
2456
2457 }
2458
2459 sub _pkgs_sql {
2460   my( $class, @agentnums ) = @_;
2461   my $agentnums = join(',', @agentnums);
2462
2463   "
2464     (
2465       ( agentnum IS NOT NULL AND agentnum IN ($agentnums) )
2466       OR ( agentnum IS NULL
2467            AND EXISTS ( SELECT 1
2468                           FROM type_pkgs
2469                             LEFT JOIN agent_type USING ( typenum )
2470                             LEFT JOIN agent AS typeagent USING ( typenum )
2471                           WHERE type_pkgs.pkgpart = part_pkg.pkgpart
2472                             AND typeagent.agentnum IN ($agentnums)
2473                       )
2474          )
2475     )
2476   ";
2477
2478 }
2479
2480 =item join_options_sql
2481
2482 Returns an SQL fragment for JOINing the part_pkg_option records for this
2483 package's setup_fee and recur_fee (as setup_option and recur_option,
2484 respectively).  Useful for optimization.
2485
2486 =cut
2487
2488 sub join_options_sql {
2489   #my $class = shift;
2490   "
2491     LEFT JOIN part_pkg_option AS setup_option
2492       ON (     part_pkg.pkgpart = setup_option.pkgpart
2493            AND setup_option.optionname = 'setup_fee' )
2494     LEFT JOIN part_pkg_option AS recur_option
2495       ON (     part_pkg.pkgpart = recur_option.pkgpart
2496            AND recur_option.optionname = 'recur_fee' )
2497   ";
2498 }
2499
2500 =back
2501
2502 =head1 SUBROUTINES
2503
2504 =over 4
2505
2506 =item plan_info
2507
2508 =cut
2509
2510 #false laziness w/part_export & cdr
2511 my %info;
2512 foreach my $INC ( @INC ) {
2513   warn "globbing $INC/FS/part_pkg/[a-z]*.pm\n" if $DEBUG;
2514   foreach my $file ( glob("$INC/FS/part_pkg/[a-z]*.pm") ) {
2515     warn "attempting to load plan info from $file\n" if $DEBUG;
2516     $file =~ /\/(\w+)\.pm$/ or do {
2517       warn "unrecognized file in $INC/FS/part_pkg/: $file\n";
2518       next;
2519     };
2520     my $mod = $1;
2521     my $info = eval "use FS::part_pkg::$mod; ".
2522                     "\\%FS::part_pkg::$mod\::info;";
2523     if ( $@ ) {
2524       die "error using FS::part_pkg::$mod (skipping): $@\n" if $@;
2525       next;
2526     }
2527     unless ( keys %$info ) {
2528       warn "no %info hash found in FS::part_pkg::$mod, skipping\n";
2529       next;
2530     }
2531     warn "got plan info from FS::part_pkg::$mod: $info\n" if $DEBUG;
2532     #if ( exists($info->{'disabled'}) && $info->{'disabled'} ) {
2533     #  warn "skipping disabled plan FS::part_pkg::$mod" if $DEBUG;
2534     #  next;
2535     #}
2536     $info{$mod} = $info;
2537     $info->{'weight'} ||= 0; # quiet warnings
2538   }
2539 }
2540
2541 # copy one level deep to allow replacement of fields and fieldorder
2542 tie %plans, 'Tie::IxHash',
2543   map  { my %infohash = %{ $info{$_} };
2544           $_ => \%infohash }
2545   sort { $info{$a}->{'weight'} <=> $info{$b}->{'weight'} }
2546   keys %info;
2547
2548 # inheritance of plan options
2549 foreach my $name (keys(%info)) {
2550   if (exists($info{$name}->{'disabled'}) and $info{$name}->{'disabled'}) {
2551     warn "skipping disabled plan FS::part_pkg::$name" if $DEBUG;
2552     delete $plans{$name};
2553     next;
2554   }
2555   my $parents = $info{$name}->{'inherit_fields'} || [];
2556   my (%fields, %field_exists, @fieldorder);
2557   foreach my $parent ($name, @$parents) {
2558     if ( !exists($info{$parent}) ) {
2559       warn "$name tried to inherit from nonexistent '$parent'\n";
2560       next;
2561     }
2562     %fields = ( # avoid replacing existing fields
2563       %{ $info{$parent}->{'fields'} || {} },
2564       %fields
2565     );
2566     foreach (@{ $info{$parent}->{'fieldorder'} || [] }) {
2567       # avoid duplicates
2568       next if $field_exists{$_};
2569       $field_exists{$_} = 1;
2570       # allow inheritors to remove inherited fields from the fieldorder
2571       push @fieldorder, $_ if !exists($fields{$_}) or
2572                               !exists($fields{$_}->{'disabled'});
2573     }
2574   }
2575   $plans{$name}->{'fields'} = \%fields;
2576   $plans{$name}->{'fieldorder'} = \@fieldorder;
2577 }
2578
2579 sub plan_info {
2580   \%plans;
2581 }
2582
2583
2584 =back
2585
2586 =head1 NEW PLAN CLASSES
2587
2588 A module should be added in FS/FS/part_pkg/  Eventually, an example may be
2589 found in eg/plan_template.pm.  Until then, it is suggested that you use the
2590 other modules in FS/FS/part_pkg/ as a guide.
2591
2592 =head1 BUGS
2593
2594 The delete method is unimplemented.
2595
2596 setup and recur semantics are not yet defined (and are implemented in
2597 FS::cust_bill.  hmm.).  now they're deprecated and need to go.
2598
2599 plandata should go
2600
2601 part_pkg_taxrate is Pg specific
2602
2603 replace should be smarter about managing the related tables (options, pkg_svc)
2604
2605 =head1 SEE ALSO
2606
2607 L<FS::Record>, L<FS::cust_pkg>, L<FS::type_pkgs>, L<FS::pkg_svc>, L<Safe>.
2608 schema.html from the base documentation.
2609
2610 =cut
2611
2612 1;