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