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