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