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