FS/FS/part_pkg.pm

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