FS/FS/part_pkg.pm

   1 package FS::part_pkg;
   2
   3 use strict;
   4 use vars qw( @ISA %plans $DEBUG $setup_hack $skip_pkg_svc_hack );
   5 use Carp qw(carp cluck confess);
   6 use Scalar::Util qw( blessed );
   7 use Time::Local qw( timelocal_nocheck );
   8 use Tie::IxHash;
   9 use FS::Conf;
  10 use FS::Record qw( qsearch qsearchs dbh dbdef );
  11 use FS::pkg_svc;
  12 use FS::part_svc;
  13 use FS::cust_pkg;
  14 use FS::agent_type;
  15 use FS::type_pkgs;
  16 use FS::part_pkg_option;
  17 use FS::pkg_class;
  18 use FS::agent;
  19 use FS::part_pkg_taxrate;
  20 use FS::part_pkg_taxoverride;
  21 use FS::part_pkg_taxproduct;
  22 use FS::part_pkg_link;
  23 use FS::part_pkg_discount;
  24 use FS::part_pkg_usage;
  25 use FS::part_pkg_vendor;
  26
  27 @ISA = qw( FS::m2m_Common FS::option_Common );
  28 $DEBUG = 0;
  29 $setup_hack = 0;
  30 $skip_pkg_svc_hack = 0;
  31
  32 =head1 NAME
  33
  34 FS::part_pkg - Object methods for part_pkg objects
  35
  36 =head1 SYNOPSIS
  37
  38   use FS::part_pkg;
  39
  40   $record = new FS::part_pkg \%hash
  41   $record = new FS::part_pkg { 'column' => 'value' };
  42
  43   $custom_record = $template_record->clone;
  44
  45   $error = $record->insert;
  46
  47   $error = $new_record->replace($old_record);
  48
  49   $error = $record->delete;
  50
  51   $error = $record->check;
  52
  53   @pkg_svc = $record->pkg_svc;
  54
  55   $svcnum = $record->svcpart;
  56   $svcnum = $record->svcpart( 'svc_acct' );
  57
  58 =head1 DESCRIPTION
  59
  60 An FS::part_pkg object represents a package definition.  FS::part_pkg
  61 inherits from FS::Record.  The following fields are currently supported:
  62
  63 =over 4
  64
  65 =item pkgpart - primary key (assigned automatically for new package definitions)
  66
  67 =item pkg - Text name of this package definition (customer-viewable)
  68
  69 =item comment - Text name of this package definition (non-customer-viewable)
  70
  71 =item classnum - Optional package class (see L<FS::pkg_class>)
  72
  73 =item promo_code - Promotional code
  74
  75 =item setup - Setup fee expression (deprecated)
  76
  77 =item freq - Frequency of recurring fee
  78
  79 =item recur - Recurring fee expression (deprecated)
  80
  81 =item setuptax - Setup fee tax exempt flag, empty or `Y'
  82
  83 =item recurtax - Recurring fee tax exempt flag, empty or `Y'
  84
  85 =item taxclass - Tax class
  86
  87 =item plan - Price plan
  88
  89 =item plandata - Price plan data (deprecated - see L<FS::part_pkg_option> instead)
  90
  91 =item disabled - Disabled flag, empty or `Y'
  92
  93 =item custom - Custom flag, empty or `Y'
  94
  95 =item setup_cost - for cost tracking
  96
  97 =item recur_cost - for cost tracking
  98
  99 =item pay_weight - Weight (relative to credit_weight and other package definitions) that controls payment application to specific line items.
 100
 101 =item credit_weight - Weight (relative to other package definitions) that controls credit application to specific line items.
 102
 103 =item agentnum - Optional agentnum (see L<FS::agent>)
 104
 105 =item fcc_ds0s - Optional DS0 equivalency number for FCC form 477
 106
 107 =item fcc_voip_class - Which column of FCC form 477 part II.B this package
 108 belongs in.
 109
 110 =item successor - Foreign key for the part_pkg that replaced this record.
 111 If this record is not obsolete, will be null.
 112
 113 =item family_pkgpart - Foreign key for the part_pkg that was the earliest
 114 ancestor of this record.  If this record is not a successor to another
 115 part_pkg, will be equal to pkgpart.
 116
 117 =back
 118
 119 =head1 METHODS
 120
 121 =over 4
 122
 123 =item new HASHREF
 124
 125 Creates a new package definition.  To add the package definition to
 126 the database, see L<"insert">.
 127
 128 =cut
 129
 130 sub table { 'part_pkg'; }
 131
 132 =item clone
 133
 134 An alternate constructor.  Creates a new package definition by duplicating
 135 an existing definition.  A new pkgpart is assigned and the custom flag is
 136 set to Y.  To add the package definition to the database, see L<"insert">.
 137
 138 =cut
 139
 140 sub clone {
 141   my $self = shift;
 142   my $class = ref($self);
 143   my %hash = $self->hash;
 144   $hash{'pkgpart'} = '';
 145   $hash{'custom'} = 'Y';
 146   #new FS::part_pkg ( \%hash ); # ?
 147   new $class ( \%hash ); # ?
 148 }
 149
 150 =item insert [ , OPTION => VALUE ... ]
 151
 152 Adds this package definition to the database.  If there is an error,
 153 returns the error, otherwise returns false.
 154
 155 Currently available options are: I<pkg_svc>, I<primary_svc>, I<cust_pkg>,
 156 I<custnum_ref> and I<options>.
 157
 158 If I<pkg_svc> is set to a hashref with svcparts as keys and quantities as
 159 values, appropriate FS::pkg_svc records will be inserted.  I<hidden_svc> can
 160 be set to a hashref of svcparts and flag values ('Y' or '') to set the
 161 'hidden' field in these records.
 162
 163 If I<primary_svc> is set to the svcpart of the primary service, the appropriate
 164 FS::pkg_svc record will be updated.
 165
 166 If I<cust_pkg> is set to a pkgnum of a FS::cust_pkg record (or the FS::cust_pkg
 167 record itself), the object will be updated to point to this package definition.
 168
 169 In conjunction with I<cust_pkg>, if I<custnum_ref> is set to a scalar reference,
 170 the scalar will be updated with the custnum value from the cust_pkg record.
 171
 172 If I<tax_overrides> is set to a hashref with usage classes as keys and comma
 173 separated tax class numbers as values, appropriate FS::part_pkg_taxoverride
 174 records will be inserted.
 175
 176 If I<options> is set to a hashref of options, appropriate FS::part_pkg_option
 177 records will be inserted.
 178
 179 =cut
 180
 181 sub insert {
 182   my $self = shift;
 183   my %options = @_;
 184   warn "FS::part_pkg::insert called on $self with options ".
 185        join(', ', map "$_=>$options{$_}", keys %options)
 186     if $DEBUG;
 187
 188   local $SIG{HUP} = 'IGNORE';
 189   local $SIG{INT} = 'IGNORE';
 190   local $SIG{QUIT} = 'IGNORE';
 191   local $SIG{TERM} = 'IGNORE';
 192   local $SIG{TSTP} = 'IGNORE';
 193   local $SIG{PIPE} = 'IGNORE';
 194
 195   my $oldAutoCommit = $FS::UID::AutoCommit;
 196   local $FS::UID::AutoCommit = 0;
 197   my $dbh = dbh;
 198
 199   warn "  inserting part_pkg record" if $DEBUG;
 200   my $error = $self->SUPER::insert( $options{options} );
 201   if ( $error ) {
 202     $dbh->rollback if $oldAutoCommit;
 203     return $error;
 204   }
 205
 206   # set family_pkgpart
 207   if ( $self->get('family_pkgpart') eq '' ) {
 208     $self->set('family_pkgpart' => $self->pkgpart);
 209     $error = $self->SUPER::replace;
 210     if ( $error ) {
 211       $dbh->rollback if $oldAutoCommit;
 212       return $error;
 213     }
 214   }
 215
 216   my $conf = new FS::Conf;
 217   if ( $conf->exists('agent_defaultpkg') ) {
 218     warn "  agent_defaultpkg set; allowing all agents to purchase package"
 219       if $DEBUG;
 220     foreach my $agent_type ( qsearch('agent_type', {} ) ) {
 221       my $type_pkgs = new FS::type_pkgs({
 222         'typenum' => $agent_type->typenum,
 223         'pkgpart' => $self->pkgpart,
 224       });
 225       my $error = $type_pkgs->insert;
 226       if ( $error ) {
 227         $dbh->rollback if $oldAutoCommit;
 228         return $error;
 229       }
 230     }
 231   }
 232
 233   warn "  inserting part_pkg_taxoverride records" if $DEBUG;
 234   my %overrides = %{ $options{'tax_overrides'} || {} };
 235   foreach my $usage_class ( keys %overrides ) {
 236     my $override =
 237       ( exists($overrides{$usage_class}) && defined($overrides{$usage_class}) )
 238         ? $overrides{$usage_class}
 239         : '';
 240     my @overrides = (grep "$_", split(',', $override) );
 241     my $error = $self->process_m2m (
 242                   'link_table'   => 'part_pkg_taxoverride',
 243                   'target_table' => 'tax_class',
 244                   'hashref'      => { 'usage_class' => $usage_class },
 245                   'params'       => \@overrides,
 246                 );
 247     if ( $error ) {
 248       $dbh->rollback if $oldAutoCommit;
 249       return $error;
 250     }
 251   }
 252
 253   unless ( $skip_pkg_svc_hack ) {
 254
 255     warn "  inserting pkg_svc records" if $DEBUG;
 256     my $pkg_svc = $options{'pkg_svc'} || {};
 257     my $hidden_svc = $options{'hidden_svc'} || {};
 258     foreach my $part_svc ( qsearch('part_svc', {} ) ) {
 259       my $quantity = $pkg_svc->{$part_svc->svcpart} || 0;
 260       my $primary_svc =
 261         ( $options{'primary_svc'} && $options{'primary_svc'}==$part_svc->svcpart )
 262           ? 'Y'
 263           : '';
 264
 265       my $pkg_svc = new FS::pkg_svc( {
 266         'pkgpart'     => $self->pkgpart,
 267         'svcpart'     => $part_svc->svcpart,
 268         'quantity'    => $quantity,
 269         'primary_svc' => $primary_svc,
 270         'hidden'      => $hidden_svc->{$part_svc->svcpart},
 271       } );
 272       my $error = $pkg_svc->insert;
 273       if ( $error ) {
 274         $dbh->rollback if $oldAutoCommit;
 275         return $error;
 276       }
 277     }
 278
 279   }
 280
 281   if ( $options{'cust_pkg'} ) {
 282     warn "  updating cust_pkg record " if $DEBUG;
 283     my $old_cust_pkg =
 284       ref($options{'cust_pkg'})
 285         ? $options{'cust_pkg'}
 286         : qsearchs('cust_pkg', { pkgnum => $options{'cust_pkg'} } );
 287     ${ $options{'custnum_ref'} } = $old_cust_pkg->custnum
 288       if $options{'custnum_ref'};
 289     my %hash = $old_cust_pkg->hash;
 290     $hash{'pkgpart'} = $self->pkgpart,
 291     my $new_cust_pkg = new FS::cust_pkg \%hash;
 292     local($FS::cust_pkg::disable_agentcheck) = 1;
 293     my $error = $new_cust_pkg->replace($old_cust_pkg);
 294     if ( $error ) {
 295       $dbh->rollback if $oldAutoCommit;
 296       return "Error modifying cust_pkg record: $error";
 297     }
 298   }
 299
 300   if ( $options{'part_pkg_vendor'} ) {
 301       while ( my ($exportnum, $vendor_pkg_id) =
 302                 each %{ $options{part_pkg_vendor} }
 303             )
 304       {
 305             my $ppv = new FS::part_pkg_vendor( {
 306                     'pkgpart' => $self->pkgpart,
 307                     'exportnum' => $exportnum,
 308                     'vendor_pkg_id' => $vendor_pkg_id,
 309                 } );
 310             my $error = $ppv->insert;
 311             if ( $error ) {
 312               $dbh->rollback if $oldAutoCommit;
 313               return "Error inserting part_pkg_vendor record: $error";
 314             }
 315       }
 316   }
 317
 318   warn "  committing transaction" if $DEBUG and $oldAutoCommit;
 319   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 320
 321   '';
 322 }
 323
 324 =item delete
 325
 326 Currently unimplemented.
 327
 328 =cut
 329
 330 sub delete {
 331   return "Can't (yet?) delete package definitions.";
 332 # check & make sure the pkgpart isn't in cust_pkg or type_pkgs?
 333 }
 334
 335 =item replace OLD_RECORD [ , OPTION => VALUE ... ]
 336
 337 Replaces OLD_RECORD with this one in the database.  If there is an error,
 338 returns the error, otherwise returns false.
 339
 340 Currently available options are: I<pkg_svc>, I<hidden_svc>, I<primary_svc>
 341 and I<options>
 342
 343 If I<pkg_svc> is set to a hashref with svcparts as keys and quantities as
 344 values, the appropriate FS::pkg_svc records will be replaced.  I<hidden_svc>
 345 can be set to a hashref of svcparts and flag values ('Y' or '') to set the
 346 'hidden' field in these records.
 347
 348 If I<primary_svc> is set to the svcpart of the primary service, the appropriate
 349 FS::pkg_svc record will be updated.
 350
 351 If I<options> is set to a hashref, the appropriate FS::part_pkg_option records
 352 will be replaced.
 353
 354 =cut
 355
 356 sub replace {
 357   my $new = shift;
 358
 359   my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
 360               ? shift
 361               : $new->replace_old;
 362
 363   my $options =
 364     ( ref($_[0]) eq 'HASH' )
 365       ? shift
 366       : { @_ };
 367
 368   $options->{options} = { $old->options } unless defined($options->{options});
 369
 370   warn "FS::part_pkg::replace called on $new to replace $old with options".
 371        join(', ', map "$_ => ". $options->{$_}, keys %$options)
 372     if $DEBUG;
 373
 374   local $SIG{HUP} = 'IGNORE';
 375   local $SIG{INT} = 'IGNORE';
 376   local $SIG{QUIT} = 'IGNORE';
 377   local $SIG{TERM} = 'IGNORE';
 378   local $SIG{TSTP} = 'IGNORE';
 379   local $SIG{PIPE} = 'IGNORE';
 380
 381   my $oldAutoCommit = $FS::UID::AutoCommit;
 382   local $FS::UID::AutoCommit = 0;
 383   my $dbh = dbh;
 384
 385   my $conf = new FS::Conf;
 386   if ( $conf->exists('part_pkg-lineage') ) {
 387     if ( grep { $options->{options}->{$_} ne $old->option($_, 1) }
 388           qw(setup_fee recur_fee) #others? config?
 389         ) {
 390
 391       warn "  superseding package" if $DEBUG;
 392
 393       my $error = $new->supersede($old, %$options);
 394       if ( $error ) {
 395         $dbh->rollback if $oldAutoCommit;
 396         return $error;
 397       }
 398       else {
 399         warn "  committing transaction" if $DEBUG and $oldAutoCommit;
 400         $dbh->commit if $oldAutoCommit;
 401         return $error;
 402       }
 403     }
 404     #else nothing
 405   }
 406
 407   #plandata shit stays in replace for upgrades until after 2.0 (or edit
 408   #_upgrade_data)
 409   warn "  saving legacy plandata" if $DEBUG;
 410   my $plandata = $new->get('plandata');
 411   $new->set('plandata', '');
 412
 413   warn "  deleting old part_pkg_option records" if $DEBUG;
 414   foreach my $part_pkg_option ( $old->part_pkg_option ) {
 415     my $error = $part_pkg_option->delete;
 416     if ( $error ) {
 417       $dbh->rollback if $oldAutoCommit;
 418       return $error;
 419     }
 420   }
 421
 422   warn "  replacing part_pkg record" if $DEBUG;
 423   my $error = $new->SUPER::replace($old, $options->{options} );
 424   if ( $error ) {
 425     $dbh->rollback if $oldAutoCommit;
 426     return $error;
 427   }
 428
 429   warn "  inserting part_pkg_option records for plandata: $plandata|" if $DEBUG;
 430   foreach my $part_pkg_option (
 431     map { /^(\w+)=(.*)$/ or do { $dbh->rollback if $oldAutoCommit;
 432                                  return "illegal plandata: $plandata";
 433                                };
 434           new FS::part_pkg_option {
 435             'pkgpart'     => $new->pkgpart,
 436             'optionname'  => $1,
 437             'optionvalue' => $2,
 438           };
 439         }
 440     split("\n", $plandata)
 441   ) {
 442     my $error = $part_pkg_option->insert;
 443     if ( $error ) {
 444       $dbh->rollback if $oldAutoCommit;
 445       return $error;
 446     }
 447   }
 448
 449   warn "  replacing pkg_svc records" if $DEBUG;
 450   my $pkg_svc = $options->{'pkg_svc'};
 451   my $hidden_svc = $options->{'hidden_svc'} || {};
 452   if ( $pkg_svc ) { # if it wasn't passed, don't change existing pkg_svcs
 453     foreach my $part_svc ( qsearch('part_svc', {} ) ) {
 454       my $quantity = $pkg_svc->{$part_svc->svcpart} || 0;
 455       my $hidden = $hidden_svc->{$part_svc->svcpart} || '';
 456       my $primary_svc =
 457         ( defined($options->{'primary_svc'}) && $options->{'primary_svc'}
 458           && $options->{'primary_svc'} == $part_svc->svcpart
 459         )
 460           ? 'Y'
 461           : '';
 462
 463       my $old_pkg_svc = qsearchs('pkg_svc', {
 464           'pkgpart' => $old->pkgpart,
 465           'svcpart' => $part_svc->svcpart,
 466         }
 467       );
 468       my $old_quantity = 0;
 469       my $old_primary_svc = '';
 470       my $old_hidden = '';
 471       if ( $old_pkg_svc ) {
 472         $old_quantity = $old_pkg_svc->quantity;
 473         $old_primary_svc = $old_pkg_svc->primary_svc
 474           if $old_pkg_svc->dbdef_table->column('primary_svc'); # is this needed?
 475         $old_hidden = $old_pkg_svc->hidden;
 476       }
 477
 478       next unless $old_quantity != $quantity ||
 479                   $old_primary_svc ne $primary_svc ||
 480                   $old_hidden ne $hidden;
 481
 482       my $new_pkg_svc = new FS::pkg_svc( {
 483         'pkgsvcnum'   => ( $old_pkg_svc ? $old_pkg_svc->pkgsvcnum : '' ),
 484         'pkgpart'     => $new->pkgpart,
 485         'svcpart'     => $part_svc->svcpart,
 486         'quantity'    => $quantity,
 487         'primary_svc' => $primary_svc,
 488         'hidden'      => $hidden,
 489       } );
 490       my $error = $old_pkg_svc
 491                     ? $new_pkg_svc->replace($old_pkg_svc)
 492                     : $new_pkg_svc->insert;
 493       if ( $error ) {
 494         $dbh->rollback if $oldAutoCommit;
 495         return $error;
 496       }
 497     } #foreach $part_svc
 498   } #if $options->{pkg_svc}
 499
 500   my @part_pkg_vendor = $old->part_pkg_vendor;
 501   my @current_exportnum = ();
 502   if ( $options->{'part_pkg_vendor'} ) {
 503       my($exportnum,$vendor_pkg_id);
 504       while ( ($exportnum,$vendor_pkg_id)
 505                                 = each %{$options->{'part_pkg_vendor'}} ) {
 506           my $noinsert = 0;
 507           foreach my $part_pkg_vendor ( @part_pkg_vendor ) {
 508             if($exportnum == $part_pkg_vendor->exportnum
 509                 && $vendor_pkg_id ne $part_pkg_vendor->vendor_pkg_id) {
 510                 $part_pkg_vendor->vendor_pkg_id($vendor_pkg_id);
 511                 my $error = $part_pkg_vendor->replace;
 512                 if ( $error ) {
 513                   $dbh->rollback if $oldAutoCommit;
 514                   return "Error replacing part_pkg_vendor record: $error";
 515                 }
 516                 $noinsert = 1;
 517                 last;
 518             }
 519             elsif($exportnum == $part_pkg_vendor->exportnum
 520                 && $vendor_pkg_id eq $part_pkg_vendor->vendor_pkg_id) {
 521                 $noinsert = 1;
 522                 last;
 523             }
 524           }
 525           unless ( $noinsert ) {
 526             my $ppv = new FS::part_pkg_vendor( {
 527                     'pkgpart' => $new->pkgpart,
 528                     'exportnum' => $exportnum,
 529                     'vendor_pkg_id' => $vendor_pkg_id,
 530                 } );
 531             my $error = $ppv->insert;
 532             if ( $error ) {
 533               $dbh->rollback if $oldAutoCommit;
 534               return "Error inserting part_pkg_vendor record: $error";
 535             }
 536           }
 537           push @current_exportnum, $exportnum;
 538       }
 539   }
 540   foreach my $part_pkg_vendor ( @part_pkg_vendor ) {
 541       unless ( grep($_ eq $part_pkg_vendor->exportnum, @current_exportnum) ) {
 542         my $error = $part_pkg_vendor->delete;
 543         if ( $error ) {
 544           $dbh->rollback if $oldAutoCommit;
 545           return "Error deleting part_pkg_vendor record: $error";
 546         }
 547       }
 548   }
 549
 550   # propagate changes to certain core fields
 551   if ( $conf->exists('part_pkg-lineage') ) {
 552     warn "  propagating changes to family" if $DEBUG;
 553     my $error = $new->propagate($old);
 554     if ( $error ) {
 555       $dbh->rollback if $oldAutoCommit;
 556       return $error;
 557     }
 558   }
 559
 560   warn "  committing transaction" if $DEBUG and $oldAutoCommit;
 561   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 562   '';
 563 }
 564
 565 =item check
 566
 567 Checks all fields to make sure this is a valid package definition.  If
 568 there is an error, returns the error, otherwise returns false.  Called by the
 569 insert and replace methods.
 570
 571 =cut
 572
 573 sub check {
 574   my $self = shift;
 575   warn "FS::part_pkg::check called on $self" if $DEBUG;
 576
 577   for (qw(setup recur plandata)) {
 578     #$self->set($_=>0) if $self->get($_) =~ /^\s*$/; }
 579     return "Use of $_ field is deprecated; set a plan and options: ".
 580            $self->get($_)
 581       if length($self->get($_));
 582     $self->set($_, '');
 583   }
 584
 585   if ( $self->dbdef_table->column('freq')->type =~ /(int)/i ) {
 586     my $error = $self->ut_number('freq');
 587     return $error if $error;
 588   } else {
 589     $self->freq =~ /^(\d+[hdw]?)$/
 590       or return "Illegal or empty freq: ". $self->freq;
 591     $self->freq($1);
 592   }
 593
 594   my @null_agentnum_right = ( 'Edit global package definitions' );
 595   push @null_agentnum_right, 'One-time charge'
 596     if $self->freq =~ /^0/;
 597   push @null_agentnum_right, 'Customize customer package'
 598     if $self->disabled eq 'Y'; #good enough
 599
 600   my $error = $self->ut_numbern('pkgpart')
 601     || $self->ut_text('pkg')
 602     || $self->ut_text('comment')
 603     || $self->ut_textn('promo_code')
 604     || $self->ut_alphan('plan')
 605     || $self->ut_enum('setuptax', [ '', 'Y' ] )
 606     || $self->ut_enum('recurtax', [ '', 'Y' ] )
 607     || $self->ut_textn('taxclass')
 608     || $self->ut_enum('disabled', [ '', 'Y' ] )
 609     || $self->ut_enum('custom', [ '', 'Y' ] )
 610     || $self->ut_enum('no_auto', [ '', 'Y' ])
 611     || $self->ut_enum('recur_show_zero', [ '', 'Y' ])
 612     || $self->ut_enum('setup_show_zero', [ '', 'Y' ])
 613     #|| $self->ut_moneyn('setup_cost')
 614     #|| $self->ut_moneyn('recur_cost')
 615     || $self->ut_floatn('setup_cost')
 616     || $self->ut_floatn('recur_cost')
 617     || $self->ut_floatn('pay_weight')
 618     || $self->ut_floatn('credit_weight')
 619     || $self->ut_numbern('taxproductnum')
 620     || $self->ut_foreign_keyn('classnum',       'pkg_class', 'classnum')
 621     || $self->ut_foreign_keyn('addon_classnum', 'pkg_class', 'classnum')
 622     || $self->ut_foreign_keyn('taxproductnum',
 623                               'part_pkg_taxproduct',
 624                               'taxproductnum'
 625                              )
 626     || ( $setup_hack
 627            ? $self->ut_foreign_keyn('agentnum', 'agent', 'agentnum' )
 628            : $self->ut_agentnum_acl('agentnum', \@null_agentnum_right)
 629        )
 630     || $self->ut_numbern('fcc_ds0s')
 631     || $self->ut_numbern('fcc_voip_class')
 632     || $self->ut_foreign_keyn('successor', 'part_pkg', 'pkgpart')
 633     || $self->ut_foreign_keyn('family_pkgpart', 'part_pkg', 'pkgpart')
 634     || $self->SUPER::check
 635   ;
 636   return $error if $error;
 637
 638   return 'Unknown plan '. $self->plan
 639     unless exists($plans{$self->plan});
 640
 641   my $conf = new FS::Conf;
 642   return 'Taxclass is required'
 643     if ! $self->taxclass && $conf->exists('require_taxclasses');
 644
 645   '';
 646 }
 647
 648 =item supersede OLD [, OPTION => VALUE ... ]
 649
 650 Inserts this package as a successor to the package OLD.  All options are as
 651 for C<insert>.  After inserting, disables OLD and sets the new package as its
 652 successor.
 653
 654 =cut
 655
 656 sub supersede {
 657   my ($new, $old, %options) = @_;
 658   my $error;
 659
 660   $new->set('pkgpart' => '');
 661   $new->set('family_pkgpart' => $old->family_pkgpart);
 662   warn "    inserting successor package\n" if $DEBUG;
 663   $error = $new->insert(%options);
 664   return $error if $error;
 665
 666   warn "    disabling superseded package\n" if $DEBUG;
 667   $old->set('successor' => $new->pkgpart);
 668   $old->set('disabled' => 'Y');
 669   $error = $old->SUPER::replace; # don't change its options/pkg_svc records
 670   return $error if $error;
 671
 672   warn "  propagating changes to family" if $DEBUG;
 673   $new->propagate($old);
 674 }
 675
 676 =item propagate OLD
 677
 678 If any of certain fields have changed from OLD to this package, then,
 679 for all packages in the same lineage as this one, sets those fields
 680 to their values in this package.
 681
 682 =cut
 683
 684 my @propagate_fields = (
 685   qw( pkg classnum setup_cost recur_cost taxclass
 686   setuptax recurtax pay_weight credit_weight
 687   )
 688 );
 689
 690 sub propagate {
 691   my $new = shift;
 692   my $old = shift;
 693   my %fields = (
 694     map { $_ => $new->get($_) }
 695     grep { $new->get($_) ne $old->get($_) }
 696     @propagate_fields
 697   );
 698
 699   my @part_pkg = qsearch('part_pkg', {
 700       'family_pkgpart' => $new->family_pkgpart
 701   });
 702   my @error;
 703   foreach my $part_pkg ( @part_pkg ) {
 704     my $pkgpart = $part_pkg->pkgpart;
 705     next if $pkgpart == $new->pkgpart; # don't modify $new
 706     warn "    propagating to pkgpart $pkgpart\n" if $DEBUG;
 707     foreach ( keys %fields ) {
 708       $part_pkg->set($_, $fields{$_});
 709     }
 710     # SUPER::replace to avoid changing non-core fields
 711     my $error = $part_pkg->SUPER::replace;
 712     push @error, "pkgpart $pkgpart: $error"
 713       if $error;
 714   }
 715   join("\n", @error);
 716 }
 717
 718 =item pkg_comment [ OPTION => VALUE... ]
 719
 720 Returns an (internal) string representing this package.  Currently,
 721 "pkgpart: pkg - comment", is returned.  "pkg - comment" may be returned in the
 722 future, omitting pkgpart.  The comment will have '(CUSTOM) ' prepended if
 723 custom is Y.
 724
 725 If the option nopkgpart is true then the "pkgpart: ' is omitted.
 726
 727 =cut
 728
 729 sub pkg_comment {
 730   my $self = shift;
 731   my %opt = @_;
 732
 733   #$self->pkg. ' - '. $self->comment;
 734   #$self->pkg. ' ('. $self->comment. ')';
 735   my $pre = $opt{nopkgpart} ? '' : $self->pkgpart. ': ';
 736   $pre. $self->pkg. ' - '. $self->custom_comment;
 737 }
 738
 739 sub price_info { # safety, in case a part_pkg hasn't defined price_info
 740     '';
 741 }
 742
 743 sub custom_comment {
 744   my $self = shift;
 745   ( $self->custom ? '(CUSTOM) ' : '' ). $self->comment . ' ' . $self->price_info;
 746 }
 747
 748 =item pkg_class
 749
 750 Returns the package class, as an FS::pkg_class object, or the empty string
 751 if there is no package class.
 752
 753 =cut
 754
 755 sub pkg_class {
 756   my $self = shift;
 757   if ( $self->classnum ) {
 758     qsearchs('pkg_class', { 'classnum' => $self->classnum } );
 759   } else {
 760     return '';
 761   }
 762 }
 763
 764 =item addon_pkg_class
 765
 766 Returns the add-on package class, as an FS::pkg_class object, or the empty
 767 string if there is no add-on package class.
 768
 769 =cut
 770
 771 sub addon_pkg_class {
 772   my $self = shift;
 773   if ( $self->addon_classnum ) {
 774     qsearchs('pkg_class', { 'classnum' => $self->addon_classnum } );
 775   } else {
 776     return '';
 777   }
 778 }
 779
 780 =item categoryname
 781
 782 Returns the package category name, or the empty string if there is no package
 783 category.
 784
 785 =cut
 786
 787 sub categoryname {
 788   my $self = shift;
 789   my $pkg_class = $self->pkg_class;
 790   $pkg_class
 791     ? $pkg_class->categoryname
 792     : '';
 793 }
 794
 795 =item classname
 796
 797 Returns the package class name, or the empty string if there is no package
 798 class.
 799
 800 =cut
 801
 802 sub classname {
 803   my $self = shift;
 804   my $pkg_class = $self->pkg_class;
 805   $pkg_class
 806     ? $pkg_class->classname
 807     : '';
 808 }
 809
 810 =item addon_classname
 811
 812 Returns the add-on package class name, or the empty string if there is no
 813 add-on package class.
 814
 815 =cut
 816
 817 sub addon_classname {
 818   my $self = shift;
 819   my $pkg_class = $self->addon_pkg_class;
 820   $pkg_class
 821     ? $pkg_class->classname
 822     : '';
 823 }
 824
 825 =item agent
 826
 827 Returns the associated agent for this event, if any, as an FS::agent object.
 828
 829 =cut
 830
 831 sub agent {
 832   my $self = shift;
 833   qsearchs('agent', { 'agentnum' => $self->agentnum } );
 834 }
 835
 836 =item pkg_svc [ HASHREF | OPTION => VALUE ]
 837
 838 Returns all FS::pkg_svc objects (see L<FS::pkg_svc>) for this package
 839 definition (with non-zero quantity).
 840
 841 One option is available, I<disable_linked>.  If set true it will return the
 842 services for this package definition alone, omitting services from any add-on
 843 packages.
 844
 845 =cut
 846
 847 =item type_pkgs
 848
 849 Returns all FS::type_pkgs objects (see L<FS::type_pkgs>) for this package
 850 definition.
 851
 852 =cut
 853
 854 sub type_pkgs {
 855   my $self = shift;
 856   qsearch('type_pkgs', { 'pkgpart' => $self->pkgpart } );
 857 }
 858
 859 sub pkg_svc {
 860   my $self = shift;
 861
 862 #  #sort { $b->primary cmp $a->primary }
 863 #    grep { $_->quantity }
 864 #      qsearch( 'pkg_svc', { 'pkgpart' => $self->pkgpart } );
 865
 866   my $opt = ref($_[0]) ? $_[0] : { @_ };
 867   my %pkg_svc = map  { $_->svcpart => $_ }
 868                 grep { $_->quantity }
 869                 qsearch( 'pkg_svc', { 'pkgpart' => $self->pkgpart } );
 870
 871   unless ( $opt->{disable_linked} ) {
 872     foreach my $dst_pkg ( map $_->dst_pkg, $self->svc_part_pkg_link ) {
 873       my @pkg_svc = grep { $_->quantity }
 874                     qsearch( 'pkg_svc', { pkgpart=>$dst_pkg->pkgpart } );
 875       foreach my $pkg_svc ( @pkg_svc ) {
 876         if ( $pkg_svc{$pkg_svc->svcpart} ) {
 877           my $quantity = $pkg_svc{$pkg_svc->svcpart}->quantity;
 878           $pkg_svc{$pkg_svc->svcpart}->quantity($quantity + $pkg_svc->quantity);
 879         } else {
 880           $pkg_svc{$pkg_svc->svcpart} = $pkg_svc;
 881         }
 882       }
 883     }
 884   }
 885
 886   values(%pkg_svc);
 887
 888 }
 889
 890 =item svcpart [ SVCDB ]
 891
 892 Returns the svcpart of the primary service definition (see L<FS::part_svc>)
 893 associated with this package definition (see L<FS::pkg_svc>).  Returns
 894 false if there not a primary service definition or exactly one service
 895 definition with quantity 1, or if SVCDB is specified and does not match the
 896 svcdb of the service definition.  SVCDB can be specified as a scalar table
 897 name, such as 'svc_acct', or as an arrayref of possible table names.
 898
 899 =cut
 900
 901 sub svcpart {
 902   my $pkg_svc = shift->_primary_pkg_svc(@_);
 903   $pkg_svc ? $pkg_svc->svcpart : '';
 904 }
 905
 906 =item part_svc [ SVCDB ]
 907
 908 Like the B<svcpart> method, but returns the FS::part_svc object (see
 909 L<FS::part_svc>).
 910
 911 =cut
 912
 913 sub part_svc {
 914   my $pkg_svc = shift->_primary_pkg_svc(@_);
 915   $pkg_svc ? $pkg_svc->part_svc : '';
 916 }
 917
 918 sub _primary_pkg_svc {
 919   my $self = shift;
 920
 921   my $svcdb = scalar(@_) ? shift : [];
 922   $svcdb = ref($svcdb) ? $svcdb : [ $svcdb ];
 923   my %svcdb = map { $_=>1 } @$svcdb;
 924
 925   my @svcdb_pkg_svc =
 926     grep { !scalar(@$svcdb) || $svcdb{ $_->part_svc->svcdb } }
 927          $self->pkg_svc;
 928
 929   my @pkg_svc = grep { $_->primary_svc =~ /^Y/i } @svcdb_pkg_svc;
 930   @pkg_svc = grep {$_->quantity == 1 } @svcdb_pkg_svc
 931     unless @pkg_svc;
 932   return '' if scalar(@pkg_svc) != 1;
 933   $pkg_svc[0];
 934 }
 935
 936 =item svcpart_unique_svcdb SVCDB
 937
 938 Returns the svcpart of a service definition (see L<FS::part_svc>) matching
 939 SVCDB associated with this package definition (see L<FS::pkg_svc>).  Returns
 940 false if there not a primary service definition for SVCDB or there are multiple
 941 service definitions for SVCDB.
 942
 943 =cut
 944
 945 sub svcpart_unique_svcdb {
 946   my( $self, $svcdb ) = @_;
 947   my @svcdb_pkg_svc = grep { ( $svcdb eq $_->part_svc->svcdb ) } $self->pkg_svc;
 948   return '' if scalar(@svcdb_pkg_svc) != 1;
 949   $svcdb_pkg_svc[0]->svcpart;
 950 }
 951
 952 =item payby
 953
 954 Returns a list of the acceptable payment types for this package.  Eventually
 955 this should come out of a database table and be editable, but currently has the
 956 following logic instead:
 957
 958 If the package is free, the single item B<BILL> is
 959 returned, otherwise, the single item B<CARD> is returned.
 960
 961 (CHEK?  LEC?  Probably shouldn't accept those by default, prone to abuse)
 962
 963 =cut
 964
 965 sub payby {
 966   my $self = shift;
 967   if ( $self->is_free ) {
 968     ( 'BILL' );
 969   } else {
 970     ( 'CARD' );
 971   }
 972 }
 973
 974 =item is_free
 975
 976 Returns true if this package is free.
 977
 978 =cut
 979
 980 sub is_free {
 981   my $self = shift;
 982   if ( $self->can('is_free_options') ) {
 983     not grep { $_ !~ /^\s*0*(\.0*)?\s*$/ }
 984          map { $self->option($_) }
 985              $self->is_free_options;
 986   } else {
 987     warn "FS::part_pkg::is_free: FS::part_pkg::". $self->plan. " subclass ".
 988          "provides neither is_free_options nor is_free method; returning false";
 989     0;
 990   }
 991 }
 992
 993 sub can_discount { 0; }
 994
 995 sub can_start_date { 1; }
 996
 997 sub freqs_href {
 998   # moved to FS::Misc to make this accessible to other packages
 999   # at initialization
1000   FS::Misc::pkg_freqs();
1001 }
1002
1003 =item freq_pretty
1004
1005 Returns an english representation of the I<freq> field, such as "monthly",
1006 "weekly", "semi-annually", etc.
1007
1008 =cut
1009
1010 sub freq_pretty {
1011   my $self = shift;
1012   my $freq = $self->freq;
1013
1014   #my $freqs_href = $self->freqs_href;
1015   my $freqs_href = freqs_href();
1016
1017   if ( exists($freqs_href->{$freq}) ) {
1018     $freqs_href->{$freq};
1019   } else {
1020     my $interval = 'month';
1021     if ( $freq =~ /^(\d+)([hdw])$/ ) {
1022       my %interval = ( 'h' => 'hour', 'd'=>'day', 'w'=>'week' );
1023       $interval = $interval{$2};
1024     }
1025     if ( $1 == 1 ) {
1026       "every $interval";
1027     } else {
1028       "every $freq ${interval}s";
1029     }
1030   }
1031 }
1032
1033 =item add_freq TIMESTAMP [ FREQ ]
1034
1035 Adds a billing period of some frequency to the provided timestamp and
1036 returns the resulting timestamp, or -1 if the frequency could not be
1037 parsed (shouldn't happen).  By default, the frequency of this package
1038 will be used; to override this, pass a different frequency as a second
1039 argument.
1040
1041 =cut
1042
1043 sub add_freq {
1044   my( $self, $date, $freq ) = @_;
1045   $freq = $self->freq unless $freq;
1046
1047   #change this bit to use Date::Manip? CAREFUL with timezones (see
1048   # mailing list archive)
1049   my ($sec,$min,$hour,$mday,$mon,$year) = (localtime($date) )[0,1,2,3,4,5];
1050
1051   if ( $freq =~ /^\d+$/ ) {
1052     $mon += $freq;
1053     until ( $mon < 12 ) { $mon -= 12; $year++; }
1054   } elsif ( $freq =~ /^(\d+)w$/ ) {
1055     my $weeks = $1;
1056     $mday += $weeks * 7;
1057   } elsif ( $freq =~ /^(\d+)d$/ ) {
1058     my $days = $1;
1059     $mday += $days;
1060   } elsif ( $freq =~ /^(\d+)h$/ ) {
1061     my $hours = $1;
1062     $hour += $hours;
1063   } else {
1064     return -1;
1065   }
1066
1067   timelocal_nocheck($sec,$min,$hour,$mday,$mon,$year);
1068 }
1069
1070 =item plandata
1071
1072 For backwards compatibility, returns the plandata field as well as all options
1073 from FS::part_pkg_option.
1074
1075 =cut
1076
1077 sub plandata {
1078   my $self = shift;
1079   carp "plandata is deprecated";
1080   if ( @_ ) {
1081     $self->SUPER::plandata(@_);
1082   } else {
1083     my $plandata = $self->get('plandata');
1084     my %options = $self->options;
1085     $plandata .= join('', map { "$_=$options{$_}\n" } keys %options );
1086     $plandata;
1087   }
1088 }
1089
1090 =item part_pkg_vendor
1091
1092 Returns all vendor/external package ids as FS::part_pkg_vendor objects (see
1093 L<FS::part_pkg_vendor>).
1094
1095 =cut
1096
1097 sub part_pkg_vendor {
1098   my $self = shift;
1099   qsearch('part_pkg_vendor', { 'pkgpart' => $self->pkgpart } );
1100 }
1101
1102 =item vendor_pkg_ids
1103
1104 Returns a list of vendor/external package ids by exportnum
1105
1106 =cut
1107
1108 sub vendor_pkg_ids {
1109   my $self = shift;
1110   map { $_->exportnum => $_->vendor_pkg_id } $self->part_pkg_vendor;
1111 }
1112
1113 =item part_pkg_option
1114
1115 Returns all options as FS::part_pkg_option objects (see
1116 L<FS::part_pkg_option>).
1117
1118 =cut
1119
1120 sub part_pkg_option {
1121   my $self = shift;
1122   qsearch('part_pkg_option', { 'pkgpart' => $self->pkgpart } );
1123 }
1124
1125 =item options
1126
1127 Returns a list of option names and values suitable for assigning to a hash.
1128
1129 =cut
1130
1131 sub options {
1132   my $self = shift;
1133   map { $_->optionname => $_->optionvalue } $self->part_pkg_option;
1134 }
1135
1136 =item option OPTIONNAME [ QUIET ]
1137
1138 Returns the option value for the given name, or the empty string.  If a true
1139 value is passed as the second argument, warnings about missing the option
1140 will be suppressed.
1141
1142 =cut
1143
1144 sub option {
1145   my( $self, $opt, $ornull ) = @_;
1146   my $part_pkg_option =
1147     qsearchs('part_pkg_option', {
1148       pkgpart    => $self->pkgpart,
1149       optionname => $opt,
1150   } );
1151   return $part_pkg_option->optionvalue if $part_pkg_option;
1152   my %plandata = map { /^(\w+)=(.*)$/; ( $1 => $2 ); }
1153                      split("\n", $self->get('plandata') );
1154   return $plandata{$opt} if exists $plandata{$opt};
1155   cluck "WARNING: (pkgpart ". $self->pkgpart. ") Package def option $opt ".
1156         "not found in options or plandata!\n"
1157     unless $ornull;
1158   '';
1159 }
1160
1161 =item bill_part_pkg_link
1162
1163 Returns the associated part_pkg_link records (see L<FS::part_pkg_link>).
1164
1165 =cut
1166
1167 sub bill_part_pkg_link {
1168   shift->_part_pkg_link('bill', @_);
1169 }
1170
1171 =item svc_part_pkg_link
1172
1173 Returns the associated part_pkg_link records (see L<FS::part_pkg_link>).
1174
1175 =cut
1176
1177 sub svc_part_pkg_link {
1178   shift->_part_pkg_link('svc', @_);
1179 }
1180
1181 =item supp_part_pkg_link
1182
1183 Returns the associated part_pkg_link records of type 'supp' (supplemental
1184 packages).
1185
1186 =cut
1187
1188 sub supp_part_pkg_link {
1189   shift->_part_pkg_link('supp', @_);
1190 }
1191
1192 sub _part_pkg_link {
1193   my( $self, $type ) = @_;
1194   qsearch({ table    => 'part_pkg_link',
1195             hashref  => { 'src_pkgpart' => $self->pkgpart,
1196                           'link_type'   => $type,
1197                           #protection against infinite recursive links
1198                           'dst_pkgpart' => { op=>'!=', value=> $self->pkgpart },
1199                         },
1200             order_by => "ORDER BY hidden",
1201          });
1202 }
1203
1204 sub self_and_bill_linked {
1205   shift->_self_and_linked('bill', @_);
1206 }
1207
1208 sub self_and_svc_linked {
1209   shift->_self_and_linked('svc', @_);
1210 }
1211
1212 sub _self_and_linked {
1213   my( $self, $type, $hidden ) = @_;
1214   $hidden ||= '';
1215
1216   my @result = ();
1217   foreach ( ( $self, map { $_->dst_pkg->_self_and_linked($type, $_->hidden) }
1218                      $self->_part_pkg_link($type) ) )
1219   {
1220     $_->hidden($hidden) if $hidden;
1221     push @result, $_;
1222   }
1223
1224   (@result);
1225 }
1226
1227 =item part_pkg_taxoverride [ CLASS ]
1228
1229 Returns all associated FS::part_pkg_taxoverride objects (see
1230 L<FS::part_pkg_taxoverride>).  Limits the returned set to those
1231 of class CLASS if defined.  Class may be one of 'setup', 'recur',
1232 the empty string (default), or a usage class number (see L<FS::usage_class>).
1233 When a class is specified, the empty string class (default) is returned
1234 if no more specific values exist.
1235
1236 =cut
1237
1238 sub part_pkg_taxoverride {
1239   my $self = shift;
1240   my $class = shift;
1241
1242   my $hashref = { 'pkgpart' => $self->pkgpart };
1243   $hashref->{'usage_class'} = $class if defined($class);
1244   my @overrides = qsearch('part_pkg_taxoverride', $hashref );
1245
1246   unless ( scalar(@overrides) || !defined($class) || !$class ){
1247     $hashref->{'usage_class'} = '';
1248     @overrides = qsearch('part_pkg_taxoverride', $hashref );
1249   }
1250
1251   @overrides;
1252 }
1253
1254 =item has_taxproduct
1255
1256 Returns true if this package has any taxproduct associated with it.
1257
1258 =cut
1259
1260 sub has_taxproduct {
1261   my $self = shift;
1262
1263   $self->taxproductnum ||
1264   scalar( grep { $_ =~/^usage_taxproductnum_/ && $self->option($_) }
1265           keys %{ {$self->options} }
1266   )
1267
1268 }
1269
1270
1271 =item taxproduct [ CLASS ]
1272
1273 Returns the associated tax product for this package definition (see
1274 L<FS::part_pkg_taxproduct>).  CLASS may be one of 'setup', 'recur' or
1275 the usage classnum (see L<FS::usage_class>).  Returns the default
1276 tax product for this record if the more specific CLASS value does
1277 not exist.
1278
1279 =cut
1280
1281 sub taxproduct {
1282   my $self = shift;
1283   my $class = shift;
1284
1285   my $part_pkg_taxproduct;
1286
1287   my $taxproductnum = $self->taxproductnum;
1288   if ($class) {
1289     my $class_taxproductnum = $self->option("usage_taxproductnum_$class", 1);
1290     $taxproductnum = $class_taxproductnum
1291       if $class_taxproductnum
1292   }
1293
1294   $part_pkg_taxproduct =
1295     qsearchs( 'part_pkg_taxproduct', { 'taxproductnum' => $taxproductnum } );
1296
1297   unless ($part_pkg_taxproduct || $taxproductnum eq $self->taxproductnum ) {
1298     $taxproductnum = $self->taxproductnum;
1299     $part_pkg_taxproduct =
1300       qsearchs( 'part_pkg_taxproduct', { 'taxproductnum' => $taxproductnum } );
1301   }
1302
1303   $part_pkg_taxproduct;
1304 }
1305
1306 =item taxproduct_description [ CLASS ]
1307
1308 Returns the description of the associated tax product for this package
1309 definition (see L<FS::part_pkg_taxproduct>).
1310
1311 =cut
1312
1313 sub taxproduct_description {
1314   my $self = shift;
1315   my $part_pkg_taxproduct = $self->taxproduct(@_);
1316   $part_pkg_taxproduct ? $part_pkg_taxproduct->description : '';
1317 }
1318
1319 =item part_pkg_taxrate DATA_PROVIDER, GEOCODE, [ CLASS ]
1320
1321 Returns the package to taxrate m2m records for this package in the location
1322 specified by GEOCODE (see L<FS::part_pkg_taxrate>) and usage class CLASS.
1323 CLASS may be one of 'setup', 'recur', or one of the usage classes numbers
1324 (see L<FS::usage_class>).
1325
1326 =cut
1327
1328 sub _expand_cch_taxproductnum {
1329   my $self = shift;
1330   my $class = shift;
1331   my $part_pkg_taxproduct = $self->taxproduct($class);
1332
1333   my ($a,$b,$c,$d) = ( $part_pkg_taxproduct
1334                          ? ( split ':', $part_pkg_taxproduct->taxproduct )
1335                          : ()
1336                      );
1337   $a = '' unless $a; $b = '' unless $b; $c = '' unless $c; $d = '' unless $d;
1338   my $extra_sql = "AND ( taxproduct = '$a:$b:$c:$d'
1339                       OR taxproduct = '$a:$b:$c:'
1340                       OR taxproduct = '$a:$b:".":$d'
1341                       OR taxproduct = '$a:$b:".":' )";
1342   map { $_->taxproductnum } qsearch( { 'table'     => 'part_pkg_taxproduct',
1343                                        'hashref'   => { 'data_vendor'=>'cch' },
1344                                        'extra_sql' => $extra_sql,
1345                                    } );
1346
1347 }
1348
1349 sub part_pkg_taxrate {
1350   my $self = shift;
1351   my ($data_vendor, $geocode, $class) = @_;
1352
1353   my $dbh = dbh;
1354   my $extra_sql = 'WHERE part_pkg_taxproduct.data_vendor = '.
1355                   dbh->quote($data_vendor);
1356
1357   # CCH oddness in m2m
1358   $extra_sql .= ' AND ('.
1359     join(' OR ', map{ 'geocode = '. $dbh->quote(substr($geocode, 0, $_)) }
1360                  qw(10 5 2)
1361         ).
1362     ')';
1363   # much more CCH oddness in m2m -- this is kludgy
1364   my @tpnums = $self->_expand_cch_taxproductnum($class);
1365   if (scalar(@tpnums)) {
1366     $extra_sql .= ' AND ('.
1367                             join(' OR ', map{ "taxproductnum = $_" } @tpnums ).
1368                        ')';
1369   } else {
1370     $extra_sql .= ' AND ( 0 = 1 )';
1371   }
1372
1373   my $addl_from = 'LEFT JOIN part_pkg_taxproduct USING ( taxproductnum )';
1374   my $order_by = 'ORDER BY taxclassnum, length(geocode) desc, length(taxproduct) desc';
1375   my $select   = 'DISTINCT ON(taxclassnum) *, taxproduct';
1376
1377   # should qsearch preface columns with the table to facilitate joins?
1378   qsearch( { 'table'     => 'part_pkg_taxrate',
1379              'select'    => $select,
1380              'hashref'   => { # 'data_vendor'   => $data_vendor,
1381                               # 'taxproductnum' => $self->taxproductnum,
1382                             },
1383              'addl_from' => $addl_from,
1384              'extra_sql' => $extra_sql,
1385              'order_by'  => $order_by,
1386          } );
1387 }
1388
1389 =item part_pkg_discount
1390
1391 Returns the package to discount m2m records (see L<FS::part_pkg_discount>)
1392 for this package.
1393
1394 =cut
1395
1396 sub part_pkg_discount {
1397   my $self = shift;
1398   qsearch('part_pkg_discount', { 'pkgpart' => $self->pkgpart });
1399 }
1400
1401 =item part_pkg_usage
1402
1403 Returns the voice usage pools (see L<FS::part_pkg_usage>) defined for
1404 this package.
1405
1406 =cut
1407
1408 sub part_pkg_usage {
1409   my $self = shift;
1410   qsearch('part_pkg_usage', { 'pkgpart' => $self->pkgpart });
1411 }
1412
1413 =item _rebless
1414
1415 Reblesses the object into the FS::part_pkg::PLAN class (if available), where
1416 PLAN is the object's I<plan> field.  There should be better docs
1417 on how to create new price plans, but until then, see L</NEW PLAN CLASSES>.
1418
1419 =cut
1420
1421 sub _rebless {
1422   my $self = shift;
1423   my $plan = $self->plan;
1424   unless ( $plan ) {
1425     cluck "no price plan found for pkgpart ". $self->pkgpart. "\n"
1426       if $DEBUG;
1427     return $self;
1428   }
1429   return $self if ref($self) =~ /::$plan$/; #already blessed into plan subclass
1430   my $class = ref($self). "::$plan";
1431   warn "reblessing $self into $class" if $DEBUG > 1;
1432   eval "use $class;";
1433   die $@ if $@;
1434   bless($self, $class) unless $@;
1435   $self;
1436 }
1437
1438 #fatal fallbacks
1439 sub calc_setup { die 'no calc_setup for '. shift->plan. "\n"; }
1440 sub calc_recur { die 'no calc_recur for '. shift->plan. "\n"; }
1441
1442 #fallback that return 0 for old legacy packages with no plan
1443 sub calc_remain { 0; }
1444 sub calc_units  { 0; }
1445
1446 #fallback for everything not based on flat.pm
1447 sub recur_temporality { 'upcoming'; }
1448 sub calc_cancel { 0; }
1449
1450 #fallback for everything except bulk.pm
1451 sub hide_svc_detail { 0; }
1452
1453 #fallback for packages that can't/won't summarize usage
1454 sub sum_usage { 0; }
1455
1456 =item recur_cost_permonth CUST_PKG
1457
1458 recur_cost divided by freq (only supported for monthly and longer frequencies)
1459
1460 =cut
1461
1462 sub recur_cost_permonth {
1463   my($self, $cust_pkg) = @_;
1464   return 0 unless $self->freq =~ /^\d+$/ && $self->freq > 0;
1465   sprintf('%.2f', $self->recur_cost / $self->freq );
1466 }
1467
1468 =item cust_bill_pkg_recur CUST_PKG
1469
1470 Actual recurring charge for the specified customer package from customer's most
1471 recent invoice
1472
1473 =cut
1474
1475 sub cust_bill_pkg_recur {
1476   my($self, $cust_pkg) = @_;
1477   my $cust_bill_pkg = qsearchs({
1478     'table'     => 'cust_bill_pkg',
1479     'addl_from' => 'LEFT JOIN cust_bill USING ( invnum )',
1480     'hashref'   => { 'pkgnum' => $cust_pkg->pkgnum,
1481                      'recur'  => { op=>'>', value=>'0' },
1482                    },
1483     'order_by'  => 'ORDER BY cust_bill._date     DESC,
1484                              cust_bill_pkg.sdate DESC
1485                      LIMIT 1
1486                    ',
1487   }) or return 0; #die "use cust_bill_pkg_recur credits with once_perinv condition";
1488   $cust_bill_pkg->recur;
1489 }
1490
1491 =item format OPTION DATA
1492
1493 Returns data formatted according to the function 'format' described
1494 in the plan info.  Returns DATA if no such function exists.
1495
1496 =cut
1497
1498 sub format {
1499   my ($self, $option, $data) = (shift, shift, shift);
1500   if (exists($plans{$self->plan}->{fields}->{$option}{format})) {
1501     &{$plans{$self->plan}->{fields}->{$option}{format}}($data);
1502   }else{
1503     $data;
1504   }
1505 }
1506
1507 =item parse OPTION DATA
1508
1509 Returns data parsed according to the function 'parse' described
1510 in the plan info.  Returns DATA if no such function exists.
1511
1512 =cut
1513
1514 sub parse {
1515   my ($self, $option, $data) = (shift, shift, shift);
1516   if (exists($plans{$self->plan}->{fields}->{$option}{parse})) {
1517     &{$plans{$self->plan}->{fields}->{$option}{parse}}($data);
1518   }else{
1519     $data;
1520   }
1521 }
1522
1523 =back
1524
1525 =cut
1526
1527 =head1 CLASS METHODS
1528
1529 =over 4
1530
1531 =cut
1532
1533 # _upgrade_data
1534 #
1535 # Used by FS::Upgrade to migrate to a new database.
1536
1537 sub _upgrade_data { # class method
1538   my($class, %opts) = @_;
1539
1540   warn "[FS::part_pkg] upgrading $class\n" if $DEBUG;
1541
1542   my @part_pkg = qsearch({
1543     'table'     => 'part_pkg',
1544     'extra_sql' => "WHERE ". join(' OR ',
1545                      'plan IS NULL', "plan = '' ",
1546                    ),
1547   });
1548
1549   foreach my $part_pkg (@part_pkg) {
1550
1551     unless ( $part_pkg->plan ) {
1552       $part_pkg->plan('flat');
1553     }
1554
1555     $part_pkg->replace;
1556
1557   }
1558
1559   # now upgrade to the explicit custom flag
1560
1561   @part_pkg = qsearch({
1562     'table'     => 'part_pkg',
1563     'hashref'   => { disabled => 'Y', custom => '' },
1564     'extra_sql' => "AND comment LIKE '(CUSTOM) %'",
1565   });
1566
1567   foreach my $part_pkg (@part_pkg) {
1568     my $new = new FS::part_pkg { $part_pkg->hash };
1569     $new->custom('Y');
1570     my $comment = $part_pkg->comment;
1571     $comment =~ s/^\(CUSTOM\) //;
1572     $comment = '(none)' unless $comment =~ /\S/;
1573     $new->comment($comment);
1574
1575     my $pkg_svc = { map { $_->svcpart => $_->quantity } $part_pkg->pkg_svc };
1576     my $primary = $part_pkg->svcpart;
1577     my $options = { $part_pkg->options };
1578
1579     my $error = $new->replace( $part_pkg,
1580                                'pkg_svc'     => $pkg_svc,
1581                                'primary_svc' => $primary,
1582                                'options'     => $options,
1583                              );
1584     die $error if $error;
1585   }
1586
1587   # set family_pkgpart on any packages that don't have it
1588   @part_pkg = qsearch('part_pkg', { 'family_pkgpart' => '' });
1589   foreach my $part_pkg (@part_pkg) {
1590     $part_pkg->set('family_pkgpart' => $part_pkg->pkgpart);
1591     my $error = $part_pkg->SUPER::replace;
1592     die $error if $error;
1593   }
1594
1595   my @part_pkg_option = qsearch('part_pkg_option',
1596     { 'optionname'  => 'unused_credit',
1597       'optionvalue' => 1,
1598     });
1599   foreach my $old_opt (@part_pkg_option) {
1600     my $pkgpart = $old_opt->pkgpart;
1601     my $error = $old_opt->delete;
1602     die $error if $error;
1603
1604     foreach (qw(unused_credit_cancel unused_credit_change)) {
1605       my $new_opt = new FS::part_pkg_option {
1606         'pkgpart'     => $pkgpart,
1607         'optionname'  => $_,
1608         'optionvalue' => 1,
1609       };
1610       $error = $new_opt->insert;
1611       die $error if $error;
1612     }
1613   }
1614
1615   # migrate use_disposition_taqua and use_disposition to disposition_in
1616   @part_pkg_option = qsearch('part_pkg_option',
1617     { 'optionname'  => { op => 'LIKE',
1618                          value => 'use_disposition%',
1619                        },
1620       'optionvalue' => 1,
1621     });
1622   my %newopts = map { $_->pkgpart => $_ }
1623     qsearch('part_pkg_option',  { 'optionname'  => 'disposition_in', } );
1624   foreach my $old_opt (@part_pkg_option) {
1625         my $pkgpart = $old_opt->pkgpart;
1626         my $newval = $old_opt->optionname eq 'use_disposition_taqua' ? '100'
1627                                                                   : 'ANSWERED';
1628         my $error = $old_opt->delete;
1629         die $error if $error;
1630
1631         if ( exists($newopts{$pkgpart}) ) {
1632             my $opt = $newopts{$pkgpart};
1633             $opt->optionvalue($opt->optionvalue.",$newval");
1634             $error = $opt->replace;
1635             die $error if $error;
1636         } else {
1637             my $new_opt = new FS::part_pkg_option {
1638                 'pkgpart'     => $pkgpart,
1639                 'optionname'  => 'disposition_in',
1640                 'optionvalue' => $newval,
1641               };
1642               $error = $new_opt->insert;
1643               die $error if $error;
1644               $newopts{$pkgpart} = $new_opt;
1645         }
1646   }
1647
1648   # set any package with FCC voice lines to the "VoIP with broadband" category
1649   # for backward compatibility
1650   #
1651   # recover from a bad upgrade bug
1652   my $upgrade = 'part_pkg_fcc_voip_class_FIX';
1653   if (!FS::upgrade_journal->is_done($upgrade)) {
1654     my $bad_upgrade = qsearchs('upgrade_journal',
1655       { upgrade => 'part_pkg_fcc_voip_class' }
1656     );
1657     if ( $bad_upgrade ) {
1658       my $where = 'WHERE history_date <= '.$bad_upgrade->_date.
1659                   ' AND  history_date >  '.($bad_upgrade->_date - 3600);
1660       my @h_part_pkg_option = map { FS::part_pkg_option->new($_->hashref) }
1661         qsearch({
1662           'select'    => '*',
1663           'table'     => 'h_part_pkg_option',
1664           'hashref'   => {},
1665           'extra_sql' => "$where AND history_action = 'delete'",
1666           'order_by'  => 'ORDER BY history_date ASC',
1667         });
1668       my @h_pkg_svc = map { FS::pkg_svc->new($_->hashref) }
1669         qsearch({
1670           'select'    => '*',
1671           'table'     => 'h_pkg_svc',
1672           'hashref'   => {},
1673           'extra_sql' => "$where AND history_action = 'replace_old'",
1674           'order_by'  => 'ORDER BY history_date ASC',
1675         });
1676       my %opt;
1677       foreach my $deleted (@h_part_pkg_option, @h_pkg_svc) {
1678         my $pkgpart ||= $deleted->pkgpart;
1679         $opt{$pkgpart} ||= {
1680           options => {},
1681           pkg_svc => {},
1682           primary_svc => '',
1683           hidden_svc => {},
1684         };
1685         if ( $deleted->isa('FS::part_pkg_option') ) {
1686           $opt{$pkgpart}{options}{ $deleted->optionname } = $deleted->optionvalue;
1687         } else { # pkg_svc
1688           my $svcpart = $deleted->svcpart;
1689           $opt{$pkgpart}{pkg_svc}{$svcpart} = $deleted->quantity;
1690           $opt{$pkgpart}{hidden_svc}{$svcpart} ||= $deleted->hidden;
1691           $opt{$pkgpart}{primary_svc} = $svcpart if $deleted->primary_svc;
1692         }
1693       }
1694       foreach my $pkgpart (keys %opt) {
1695         my $part_pkg = FS::part_pkg->by_key($pkgpart);
1696         my $error = $part_pkg->replace( $part_pkg->replace_old, $opt{$pkgpart} );
1697         if ( $error ) {
1698           die "error recovering damaged pkgpart $pkgpart:\n$error\n";
1699         }
1700       }
1701     } # $bad_upgrade exists
1702     else { # do the original upgrade, but correctly this time
1703       @part_pkg = qsearch('part_pkg', {
1704           fcc_ds0s        => { op => '>', value => 0 },
1705           fcc_voip_class  => ''
1706       });
1707       foreach my $part_pkg (@part_pkg) {
1708         $part_pkg->set(fcc_voip_class => 2);
1709         my @pkg_svc = $part_pkg->pkg_svc;
1710         my %quantity = map {$_->svcpart, $_->quantity} @pkg_svc;
1711         my %hidden   = map {$_->svcpart, $_->hidden  } @pkg_svc;
1712         my $error = $part_pkg->replace(
1713           $part_pkg->replace_old,
1714           options     => { $part_pkg->options },
1715           pkg_svc     => \%quantity,
1716           hidden_svc  => \%hidden,
1717           primary_svc => ($part_pkg->svcpart || ''),
1718         );
1719         die $error if $error;
1720       }
1721     }
1722     FS::upgrade_journal->set_done($upgrade);
1723   }
1724
1725 }
1726
1727 =item curuser_pkgs_sql
1728
1729 Returns an SQL fragment for searching for packages the current user can
1730 use, either via part_pkg.agentnum directly, or via agent type (see
1731 L<FS::type_pkgs>).
1732
1733 =cut
1734
1735 sub curuser_pkgs_sql {
1736   my $class = shift;
1737
1738   $class->_pkgs_sql( $FS::CurrentUser::CurrentUser->agentnums );
1739
1740 }
1741
1742 =item agent_pkgs_sql AGENT | AGENTNUM, ...
1743
1744 Returns an SQL fragment for searching for packages the provided agent or agents
1745 can use, either via part_pkg.agentnum directly, or via agent type (see
1746 L<FS::type_pkgs>).
1747
1748 =cut
1749
1750 sub agent_pkgs_sql {
1751   my $class = shift;  #i'm a class method, not a sub (the question is... why??)
1752   my @agentnums = map { ref($_) ? $_->agentnum : $_ } @_;
1753
1754   $class->_pkgs_sql(@agentnums); #is this why
1755
1756 }
1757
1758 sub _pkgs_sql {
1759   my( $class, @agentnums ) = @_;
1760   my $agentnums = join(',', @agentnums);
1761
1762   "
1763     (
1764       ( agentnum IS NOT NULL AND agentnum IN ($agentnums) )
1765       OR ( agentnum IS NULL
1766            AND EXISTS ( SELECT 1
1767                           FROM type_pkgs
1768                             LEFT JOIN agent_type USING ( typenum )
1769                             LEFT JOIN agent AS typeagent USING ( typenum )
1770                           WHERE type_pkgs.pkgpart = part_pkg.pkgpart
1771                             AND typeagent.agentnum IN ($agentnums)
1772                       )
1773          )
1774     )
1775   ";
1776
1777 }
1778
1779 =back
1780
1781 =head1 SUBROUTINES
1782
1783 =over 4
1784
1785 =item plan_info
1786
1787 =cut
1788
1789 #false laziness w/part_export & cdr
1790 my %info;
1791 foreach my $INC ( @INC ) {
1792   warn "globbing $INC/FS/part_pkg/*.pm\n" if $DEBUG;
1793   foreach my $file ( glob("$INC/FS/part_pkg/*.pm") ) {
1794     warn "attempting to load plan info from $file\n" if $DEBUG;
1795     $file =~ /\/(\w+)\.pm$/ or do {
1796       warn "unrecognized file in $INC/FS/part_pkg/: $file\n";
1797       next;
1798     };
1799     my $mod = $1;
1800     my $info = eval "use FS::part_pkg::$mod; ".
1801                     "\\%FS::part_pkg::$mod\::info;";
1802     if ( $@ ) {
1803       die "error using FS::part_pkg::$mod (skipping): $@\n" if $@;
1804       next;
1805     }
1806     unless ( keys %$info ) {
1807       warn "no %info hash found in FS::part_pkg::$mod, skipping\n";
1808       next;
1809     }
1810     warn "got plan info from FS::part_pkg::$mod: $info\n" if $DEBUG;
1811     #if ( exists($info->{'disabled'}) && $info->{'disabled'} ) {
1812     #  warn "skipping disabled plan FS::part_pkg::$mod" if $DEBUG;
1813     #  next;
1814     #}
1815     $info{$mod} = $info;
1816     $info->{'weight'} ||= 0; # quiet warnings
1817   }
1818 }
1819
1820 # copy one level deep to allow replacement of fields and fieldorder
1821 tie %plans, 'Tie::IxHash',
1822   map  { my %infohash = %{ $info{$_} };
1823           $_ => \%infohash }
1824   sort { $info{$a}->{'weight'} <=> $info{$b}->{'weight'} }
1825   keys %info;
1826
1827 # inheritance of plan options
1828 foreach my $name (keys(%info)) {
1829   if (exists($info{$name}->{'disabled'}) and $info{$name}->{'disabled'}) {
1830     warn "skipping disabled plan FS::part_pkg::$name" if $DEBUG;
1831     delete $plans{$name};
1832     next;
1833   }
1834   my $parents = $info{$name}->{'inherit_fields'} || [];
1835   my (%fields, %field_exists, @fieldorder);
1836   foreach my $parent ($name, @$parents) {
1837     if ( !exists($info{$parent}) ) {
1838       warn "$name tried to inherit from nonexistent '$parent'\n";
1839       next;
1840     }
1841     %fields = ( # avoid replacing existing fields
1842       %{ $info{$parent}->{'fields'} || {} },
1843       %fields
1844     );
1845     foreach (@{ $info{$parent}->{'fieldorder'} || [] }) {
1846       # avoid duplicates
1847       next if $field_exists{$_};
1848       $field_exists{$_} = 1;
1849       # allow inheritors to remove inherited fields from the fieldorder
1850       push @fieldorder, $_ if !exists($fields{$_}) or
1851                               !exists($fields{$_}->{'disabled'});
1852     }
1853   }
1854   $plans{$name}->{'fields'} = \%fields;
1855   $plans{$name}->{'fieldorder'} = \@fieldorder;
1856 }
1857
1858 sub plan_info {
1859   \%plans;
1860 }
1861
1862
1863 =back
1864
1865 =head1 NEW PLAN CLASSES
1866
1867 A module should be added in FS/FS/part_pkg/  Eventually, an example may be
1868 found in eg/plan_template.pm.  Until then, it is suggested that you use the
1869 other modules in FS/FS/part_pkg/ as a guide.
1870
1871 =head1 BUGS
1872
1873 The delete method is unimplemented.
1874
1875 setup and recur semantics are not yet defined (and are implemented in
1876 FS::cust_bill.  hmm.).  now they're deprecated and need to go.
1877
1878 plandata should go
1879
1880 part_pkg_taxrate is Pg specific
1881
1882 replace should be smarter about managing the related tables (options, pkg_svc)
1883
1884 =head1 SEE ALSO
1885
1886 L<FS::Record>, L<FS::cust_pkg>, L<FS::type_pkgs>, L<FS::pkg_svc>, L<Safe>.
1887 schema.html from the base documentation.
1888
1889 =cut
1890
1891 1;
1892