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