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