2 use base qw( FS::m2m_Common FS::o2m_Common FS::option_Common );
5 use vars qw( %plans $DEBUG $setup_hack $skip_pkg_svc_hack );
6 use Carp qw(carp cluck confess);
7 use Scalar::Util qw( blessed );
9 use Time::Local qw( timelocal timelocal_nocheck ); # eventually replace with DateTime
12 use FS::Record qw( qsearch qsearchs dbh dbdef );
13 use FS::Cursor; # for upgrade
19 use FS::part_pkg_option;
20 use FS::part_pkg_fcc_option;
23 use FS::part_pkg_msgcat;
24 use FS::part_pkg_taxrate;
25 use FS::part_pkg_taxoverride;
26 use FS::part_pkg_taxproduct;
27 use FS::part_pkg_link;
28 use FS::part_pkg_discount;
29 use FS::part_pkg_vendor;
30 use FS::part_pkg_currency;
34 $skip_pkg_svc_hack = 0;
38 FS::part_pkg - Object methods for part_pkg objects
44 $record = new FS::part_pkg \%hash
45 $record = new FS::part_pkg { 'column' => 'value' };
47 $custom_record = $template_record->clone;
49 $error = $record->insert;
51 $error = $new_record->replace($old_record);
53 $error = $record->delete;
55 $error = $record->check;
57 @pkg_svc = $record->pkg_svc;
59 $svcnum = $record->svcpart;
60 $svcnum = $record->svcpart( 'svc_acct' );
64 An FS::part_pkg object represents a package definition. FS::part_pkg
65 inherits from FS::Record. The following fields are currently supported:
69 =item pkgpart - primary key (assigned automatically for new package definitions)
71 =item pkg - Text name of this package definition (customer-viewable)
73 =item comment - Text name of this package definition (non-customer-viewable)
75 =item classnum - Optional package class (see L<FS::pkg_class>)
77 =item promo_code - Promotional code
79 =item setup - Setup fee expression (deprecated)
81 =item freq - Frequency of recurring fee
83 =item recur - Recurring fee expression (deprecated)
85 =item setuptax - Setup fee tax exempt flag, empty or `Y'
87 =item recurtax - Recurring fee tax exempt flag, empty or `Y'
89 =item taxclass - Tax class
91 =item plan - Price plan
93 =item plandata - Price plan data (deprecated - see L<FS::part_pkg_option> instead)
95 =item disabled - Disabled flag, empty or `Y'
97 =item custom - Custom flag, empty or `Y'
99 =item setup_cost - for cost tracking
101 =item recur_cost - for cost tracking
103 =item pay_weight - Weight (relative to credit_weight and other package definitions) that controls payment application to specific line items.
105 =item credit_weight - Weight (relative to other package definitions) that controls credit application to specific line items.
107 =item agentnum - Optional agentnum (see L<FS::agent>)
109 =item fcc_ds0s - Optional DS0 equivalency number for FCC form 477
111 =item fcc_voip_class - Which column of FCC form 477 part II.B this package
114 =item successor - Foreign key for the part_pkg that replaced this record.
115 If this record is not obsolete, will be null.
117 =item family_pkgpart - Foreign key for the part_pkg that was the earliest
118 ancestor of this record. If this record is not a successor to another
119 part_pkg, will be equal to pkgpart.
121 =item delay_start - Number of days to delay package start, by default
131 Creates a new package definition. To add the package definition to
132 the database, see L<"insert">.
136 sub table { 'part_pkg'; }
140 An alternate constructor. Creates a new package definition by duplicating
141 an existing definition. A new pkgpart is assigned and the custom flag is
142 set to Y. To add the package definition to the database, see L<"insert">.
148 my $class = ref($self);
149 my %hash = $self->hash;
150 $hash{'pkgpart'} = '';
151 $hash{'custom'} = 'Y';
152 #new FS::part_pkg ( \%hash ); # ?
153 new $class ( \%hash ); # ?
156 =item insert [ , OPTION => VALUE ... ]
158 Adds this package definition to the database. If there is an error,
159 returns the error, otherwise returns false.
161 Currently available options are: I<pkg_svc>, I<primary_svc>, I<cust_pkg>,
162 I<custnum_ref> and I<options>.
164 If I<pkg_svc> is set to a hashref with svcparts as keys and quantities as
165 values, appropriate FS::pkg_svc records will be inserted. I<hidden_svc> can
166 be set to a hashref of svcparts and flag values ('Y' or '') to set the
167 'hidden' field in these records.
169 If I<primary_svc> is set to the svcpart of the primary service, the appropriate
170 FS::pkg_svc record will be updated.
172 If I<cust_pkg> is set to a pkgnum of a FS::cust_pkg record (or the FS::cust_pkg
173 record itself), the object will be updated to point to this package definition.
175 In conjunction with I<cust_pkg>, if I<custnum_ref> is set to a scalar reference,
176 the scalar will be updated with the custnum value from the cust_pkg record.
178 If I<tax_overrides> is set to a hashref with usage classes as keys and comma
179 separated tax class numbers as values, appropriate FS::part_pkg_taxoverride
180 records will be inserted.
182 If I<options> is set to a hashref of options, appropriate FS::part_pkg_option
183 records will be inserted.
185 If I<part_pkg_currency> is set to a hashref of options (with the keys as
186 option_CURRENCY), appropriate FS::part_pkg::currency records will be inserted.
193 warn "FS::part_pkg::insert called on $self with options ".
194 join(', ', map "$_=>$options{$_}", keys %options)
197 local $SIG{HUP} = 'IGNORE';
198 local $SIG{INT} = 'IGNORE';
199 local $SIG{QUIT} = 'IGNORE';
200 local $SIG{TERM} = 'IGNORE';
201 local $SIG{TSTP} = 'IGNORE';
202 local $SIG{PIPE} = 'IGNORE';
204 my $oldAutoCommit = $FS::UID::AutoCommit;
205 local $FS::UID::AutoCommit = 0;
208 warn " inserting part_pkg record" if $DEBUG;
209 my $error = $self->SUPER::insert( $options{options} );
211 $dbh->rollback if $oldAutoCommit;
216 if ( $self->get('family_pkgpart') eq '' ) {
217 $self->set('family_pkgpart' => $self->pkgpart);
218 $error = $self->SUPER::replace;
220 $dbh->rollback if $oldAutoCommit;
225 warn " inserting part_pkg_taxoverride records" if $DEBUG;
226 my %overrides = %{ $options{'tax_overrides'} || {} };
227 foreach my $usage_class ( keys %overrides ) {
229 ( exists($overrides{$usage_class}) && defined($overrides{$usage_class}) )
230 ? $overrides{$usage_class}
232 my @overrides = (grep "$_", split(',', $override) );
233 my $error = $self->process_m2m (
234 'link_table' => 'part_pkg_taxoverride',
235 'target_table' => 'tax_class',
236 'hashref' => { 'usage_class' => $usage_class },
237 'params' => \@overrides,
240 $dbh->rollback if $oldAutoCommit;
245 warn " inserting part_pkg_currency records" if $DEBUG;
246 my %part_pkg_currency = %{ $options{'part_pkg_currency'} || {} };
247 foreach my $key ( keys %part_pkg_currency ) {
248 $key =~ /^(.+)_([A-Z]{3})$/ or next;
249 my( $optionname, $currency ) = ( $1, $2 );
250 if ( $part_pkg_currency{$key} =~ /^\s*$/ ) {
251 if ( $self->option($optionname) == 0 ) {
252 $part_pkg_currency{$key} = '0';
254 $dbh->rollback if $oldAutoCommit;
255 ( my $thing = $optionname ) =~ s/_/ /g;
256 return ucfirst($thing). " $currency is required";
259 my $part_pkg_currency = new FS::part_pkg_currency {
260 'pkgpart' => $self->pkgpart,
261 'optionname' => $optionname,
262 'currency' => $currency,
263 'optionvalue' => $part_pkg_currency{$key},
265 my $error = $part_pkg_currency->insert;
267 $dbh->rollback if $oldAutoCommit;
272 unless ( $skip_pkg_svc_hack ) {
274 warn " inserting pkg_svc records" if $DEBUG;
275 my $pkg_svc = $options{'pkg_svc'} || {};
276 my $hidden_svc = $options{'hidden_svc'} || {};
277 foreach my $part_svc ( qsearch('part_svc', {} ) ) {
278 my $quantity = $pkg_svc->{$part_svc->svcpart} || 0;
280 ( $options{'primary_svc'} && $options{'primary_svc'}==$part_svc->svcpart )
284 my $pkg_svc = new FS::pkg_svc( {
285 'pkgpart' => $self->pkgpart,
286 'svcpart' => $part_svc->svcpart,
287 'quantity' => $quantity,
288 'primary_svc' => $primary_svc,
289 'hidden' => $hidden_svc->{$part_svc->svcpart},
291 my $error = $pkg_svc->insert;
293 $dbh->rollback if $oldAutoCommit;
300 if ( $options{'cust_pkg'} ) {
301 warn " updating cust_pkg record " if $DEBUG;
303 ref($options{'cust_pkg'})
304 ? $options{'cust_pkg'}
305 : qsearchs('cust_pkg', { pkgnum => $options{'cust_pkg'} } );
306 ${ $options{'custnum_ref'} } = $old_cust_pkg->custnum
307 if $options{'custnum_ref'};
308 my %hash = $old_cust_pkg->hash;
309 $hash{'pkgpart'} = $self->pkgpart,
310 my $new_cust_pkg = new FS::cust_pkg \%hash;
311 local($FS::cust_pkg::disable_agentcheck) = 1;
312 my $error = $new_cust_pkg->replace($old_cust_pkg);
314 $dbh->rollback if $oldAutoCommit;
315 return "Error modifying cust_pkg record: $error";
319 if ( $options{'part_pkg_vendor'} ) {
320 while ( my ($exportnum, $vendor_pkg_id) =
321 each %{ $options{part_pkg_vendor} }
324 my $ppv = new FS::part_pkg_vendor( {
325 'pkgpart' => $self->pkgpart,
326 'exportnum' => $exportnum,
327 'vendor_pkg_id' => $vendor_pkg_id,
329 my $error = $ppv->insert;
331 $dbh->rollback if $oldAutoCommit;
332 return "Error inserting part_pkg_vendor record: $error";
337 if ( $options{fcc_options} ) {
338 warn " updating fcc options " if $DEBUG;
339 $self->process_fcc_options( $options{fcc_options} );
342 warn " committing transaction" if $DEBUG and $oldAutoCommit;
343 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
350 Currently unimplemented.
355 return "Can't (yet?) delete package definitions.";
356 # check & make sure the pkgpart isn't in cust_pkg or type_pkgs?
359 =item replace OLD_RECORD [ , OPTION => VALUE ... ]
361 Replaces OLD_RECORD with this one in the database. If there is an error,
362 returns the error, otherwise returns false.
364 Currently available options are: I<pkg_svc>, I<hidden_svc>, I<primary_svc>
367 If I<pkg_svc> is set to a hashref with svcparts as keys and quantities as
368 values, the appropriate FS::pkg_svc records will be replaced. I<hidden_svc>
369 can be set to a hashref of svcparts and flag values ('Y' or '') to set the
370 'hidden' field in these records. I<bulk_skip> can be set to a hashref of
371 svcparts and flag values ('Y' or '') to set the 'bulk_skip' field in those
374 If I<primary_svc> is set to the svcpart of the primary service, the appropriate
375 FS::pkg_svc record will be updated.
377 If I<options> is set to a hashref, the appropriate FS::part_pkg_option records
380 If I<part_pkg_currency> is set to a hashref of options (with the keys as
381 option_CURRENCY), appropriate FS::part_pkg::currency records will be replaced.
388 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
393 ( ref($_[0]) eq 'HASH' )
397 $options->{options} = { $old->options } unless defined($options->{options});
399 warn "FS::part_pkg::replace called on $new to replace $old with options".
400 join(', ', map "$_ => ". $options->{$_}, keys %$options)
403 local $SIG{HUP} = 'IGNORE';
404 local $SIG{INT} = 'IGNORE';
405 local $SIG{QUIT} = 'IGNORE';
406 local $SIG{TERM} = 'IGNORE';
407 local $SIG{TSTP} = 'IGNORE';
408 local $SIG{PIPE} = 'IGNORE';
410 my $oldAutoCommit = $FS::UID::AutoCommit;
411 local $FS::UID::AutoCommit = 0;
414 my $conf = new FS::Conf;
415 if ( $conf->exists('part_pkg-lineage') ) {
416 if ( grep { $options->{options}->{$_} ne $old->option($_, 1) }
417 qw(setup_fee recur_fee) #others? config?
420 warn " superseding package" if $DEBUG;
422 my $error = $new->supersede($old, %$options);
424 $dbh->rollback if $oldAutoCommit;
428 warn " committing transaction" if $DEBUG and $oldAutoCommit;
429 $dbh->commit if $oldAutoCommit;
436 #plandata shit stays in replace for upgrades until after 2.0 (or edit
438 warn " saving legacy plandata" if $DEBUG;
439 my $plandata = $new->get('plandata');
440 $new->set('plandata', '');
442 warn " deleting old part_pkg_option records" if $DEBUG;
443 foreach my $part_pkg_option ( $old->part_pkg_option ) {
444 my $error = $part_pkg_option->delete;
446 $dbh->rollback if $oldAutoCommit;
451 warn " replacing part_pkg record" if $DEBUG;
452 my $error = $new->SUPER::replace($old, $options->{options} );
454 $dbh->rollback if $oldAutoCommit;
458 warn " inserting part_pkg_option records for plandata: $plandata|" if $DEBUG;
459 foreach my $part_pkg_option (
460 map { /^(\w+)=(.*)$/ or do { $dbh->rollback if $oldAutoCommit;
461 return "illegal plandata: $plandata";
463 new FS::part_pkg_option {
464 'pkgpart' => $new->pkgpart,
469 split("\n", $plandata)
471 my $error = $part_pkg_option->insert;
473 $dbh->rollback if $oldAutoCommit;
478 #trivial nit: not the most efficient to delete and reinsert
479 warn " deleting old part_pkg_currency records" if $DEBUG;
480 foreach my $part_pkg_currency ( $old->part_pkg_currency ) {
481 my $error = $part_pkg_currency->delete;
483 $dbh->rollback if $oldAutoCommit;
484 return "error deleting part_pkg_currency record: $error";
488 warn " inserting new part_pkg_currency records" if $DEBUG;
489 my %part_pkg_currency = %{ $options->{'part_pkg_currency'} || {} };
490 foreach my $key ( keys %part_pkg_currency ) {
491 $key =~ /^(.+)_([A-Z]{3})$/ or next;
492 my $part_pkg_currency = new FS::part_pkg_currency {
493 'pkgpart' => $new->pkgpart,
496 'optionvalue' => $part_pkg_currency{$key},
498 my $error = $part_pkg_currency->insert;
500 $dbh->rollback if $oldAutoCommit;
501 return "error inserting part_pkg_currency record: $error";
506 warn " replacing pkg_svc records" if $DEBUG;
507 my $pkg_svc = $options->{'pkg_svc'};
508 my $hidden_svc = $options->{'hidden_svc'} || {};
509 my $bulk_skip = $options->{'bulk_skip'} || {};
510 if ( $pkg_svc ) { # if it wasn't passed, don't change existing pkg_svcs
511 foreach my $part_svc ( qsearch('part_svc', {} ) ) {
512 my $quantity = $pkg_svc->{$part_svc->svcpart} || 0;
513 my $hidden = $hidden_svc->{$part_svc->svcpart} || '';
514 my $bulk_skip = $bulk_skip->{$part_svc->svcpart} || '';
516 ( defined($options->{'primary_svc'}) && $options->{'primary_svc'}
517 && $options->{'primary_svc'} == $part_svc->svcpart
522 my $old_pkg_svc = qsearchs('pkg_svc', {
523 'pkgpart' => $old->pkgpart,
524 'svcpart' => $part_svc->svcpart,
527 my $old_quantity = 0;
528 my $old_primary_svc = '';
530 my $old_bulk_skip = '';
531 if ( $old_pkg_svc ) {
532 $old_quantity = $old_pkg_svc->quantity;
533 $old_primary_svc = $old_pkg_svc->primary_svc
534 if $old_pkg_svc->dbdef_table->column('primary_svc'); # is this needed?
535 $old_hidden = $old_pkg_svc->hidden;
536 $old_bulk_skip = $old_pkg_svc->old_bulk_skip;
539 next unless $old_quantity != $quantity
540 || $old_primary_svc ne $primary_svc
541 || $old_hidden ne $hidden
542 || $old_bulk_skip ne $bulk_skip;
544 my $new_pkg_svc = new FS::pkg_svc( {
545 'pkgsvcnum' => ( $old_pkg_svc ? $old_pkg_svc->pkgsvcnum : '' ),
546 'pkgpart' => $new->pkgpart,
547 'svcpart' => $part_svc->svcpart,
548 'quantity' => $quantity,
549 'primary_svc' => $primary_svc,
551 'bulk_skip' => $bulk_skip,
553 my $error = $old_pkg_svc
554 ? $new_pkg_svc->replace($old_pkg_svc)
555 : $new_pkg_svc->insert;
557 $dbh->rollback if $oldAutoCommit;
561 } #if $options->{pkg_svc}
563 my @part_pkg_vendor = $old->part_pkg_vendor;
564 my @current_exportnum = ();
565 if ( $options->{'part_pkg_vendor'} ) {
566 my($exportnum,$vendor_pkg_id);
567 while ( ($exportnum,$vendor_pkg_id)
568 = each %{$options->{'part_pkg_vendor'}} ) {
570 foreach my $part_pkg_vendor ( @part_pkg_vendor ) {
571 if($exportnum == $part_pkg_vendor->exportnum
572 && $vendor_pkg_id ne $part_pkg_vendor->vendor_pkg_id) {
573 $part_pkg_vendor->vendor_pkg_id($vendor_pkg_id);
574 my $error = $part_pkg_vendor->replace;
576 $dbh->rollback if $oldAutoCommit;
577 return "Error replacing part_pkg_vendor record: $error";
582 elsif($exportnum == $part_pkg_vendor->exportnum
583 && $vendor_pkg_id eq $part_pkg_vendor->vendor_pkg_id) {
588 unless ( $noinsert ) {
589 my $ppv = new FS::part_pkg_vendor( {
590 'pkgpart' => $new->pkgpart,
591 'exportnum' => $exportnum,
592 'vendor_pkg_id' => $vendor_pkg_id,
594 my $error = $ppv->insert;
596 $dbh->rollback if $oldAutoCommit;
597 return "Error inserting part_pkg_vendor record: $error";
600 push @current_exportnum, $exportnum;
603 foreach my $part_pkg_vendor ( @part_pkg_vendor ) {
604 unless ( grep($_ eq $part_pkg_vendor->exportnum, @current_exportnum) ) {
605 my $error = $part_pkg_vendor->delete;
607 $dbh->rollback if $oldAutoCommit;
608 return "Error deleting part_pkg_vendor record: $error";
613 # propagate changes to certain core fields
614 if ( $conf->exists('part_pkg-lineage') ) {
615 warn " propagating changes to family" if $DEBUG;
616 my $error = $new->propagate($old);
618 $dbh->rollback if $oldAutoCommit;
623 if ( $options->{fcc_options} ) {
624 warn " updating fcc options " if $DEBUG;
625 $new->process_fcc_options( $options->{fcc_options} );
628 warn " committing transaction" if $DEBUG and $oldAutoCommit;
629 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
635 Checks all fields to make sure this is a valid package definition. If
636 there is an error, returns the error, otherwise returns false. Called by the
637 insert and replace methods.
643 warn "FS::part_pkg::check called on $self" if $DEBUG;
645 for (qw(setup recur plandata)) {
646 #$self->set($_=>0) if $self->get($_) =~ /^\s*$/; }
647 return "Use of $_ field is deprecated; set a plan and options: ".
649 if length($self->get($_));
653 if ( $self->dbdef_table->column('freq')->type =~ /(int)/i ) {
654 my $error = $self->ut_number('freq');
655 return $error if $error;
657 $self->freq =~ /^(\d+[hdw]?)$/
658 or return "Illegal or empty freq: ". $self->freq;
662 my @null_agentnum_right = ( 'Edit global package definitions' );
663 push @null_agentnum_right, 'One-time charge'
664 if $self->freq =~ /^0/;
665 push @null_agentnum_right, 'Customize customer package'
666 if $self->disabled eq 'Y'; #good enough
668 my $error = $self->ut_numbern('pkgpart')
669 || $self->ut_text('pkg')
670 || $self->ut_textn('comment')
671 || $self->ut_textn('promo_code')
672 || $self->ut_alphan('plan')
673 || $self->ut_enum('setuptax', [ '', 'Y' ] )
674 || $self->ut_enum('recurtax', [ '', 'Y' ] )
675 || $self->ut_textn('taxclass')
676 || $self->ut_enum('disabled', [ '', 'Y' ] )
677 || $self->ut_enum('custom', [ '', 'Y' ] )
678 || $self->ut_enum('no_auto', [ '', 'Y' ])
679 || $self->ut_enum('recur_show_zero', [ '', 'Y' ])
680 || $self->ut_enum('setup_show_zero', [ '', 'Y' ])
681 #|| $self->ut_moneyn('setup_cost')
682 #|| $self->ut_moneyn('recur_cost')
683 || $self->ut_floatn('setup_cost')
684 || $self->ut_floatn('recur_cost')
685 || $self->ut_floatn('pay_weight')
686 || $self->ut_floatn('credit_weight')
687 || $self->ut_numbern('taxproductnum')
688 || $self->ut_foreign_keyn('classnum', 'pkg_class', 'classnum')
689 || $self->ut_foreign_keyn('addon_classnum', 'pkg_class', 'classnum')
690 || $self->ut_foreign_keyn('taxproductnum',
691 'part_pkg_taxproduct',
695 ? $self->ut_foreign_keyn('agentnum', 'agent', 'agentnum' )
696 : $self->ut_agentnum_acl('agentnum', \@null_agentnum_right)
698 || $self->ut_numbern('fcc_ds0s')
699 || $self->ut_numbern('fcc_voip_class')
700 || $self->ut_numbern('delay_start')
701 || $self->ut_foreign_keyn('successor', 'part_pkg', 'pkgpart')
702 || $self->ut_foreign_keyn('family_pkgpart', 'part_pkg', 'pkgpart')
703 || $self->ut_alphan('agent_pkgpartid')
704 || $self->SUPER::check
706 return $error if $error;
708 return 'Unknown plan '. $self->plan
709 unless exists($plans{$self->plan});
711 my $conf = new FS::Conf;
712 return 'Taxclass is required'
713 if ! $self->taxclass && $conf->exists('require_taxclasses');
718 =item supersede OLD [, OPTION => VALUE ... ]
720 Inserts this package as a successor to the package OLD. All options are as
721 for C<insert>. After inserting, disables OLD and sets the new package as its
727 my ($new, $old, %options) = @_;
730 $new->set('pkgpart' => '');
731 $new->set('family_pkgpart' => $old->family_pkgpart);
732 warn " inserting successor package\n" if $DEBUG;
733 $error = $new->insert(%options);
734 return $error if $error;
736 warn " disabling superseded package\n" if $DEBUG;
737 $old->set('successor' => $new->pkgpart);
738 $old->set('disabled' => 'Y');
739 $error = $old->SUPER::replace; # don't change its options/pkg_svc records
740 return $error if $error;
742 warn " propagating changes to family" if $DEBUG;
743 $new->propagate($old);
748 If any of certain fields have changed from OLD to this package, then,
749 for all packages in the same lineage as this one, sets those fields
750 to their values in this package.
754 my @propagate_fields = (
755 qw( pkg classnum setup_cost recur_cost taxclass
756 setuptax recurtax pay_weight credit_weight
764 map { $_ => $new->get($_) }
765 grep { $new->get($_) ne $old->get($_) }
769 my @part_pkg = qsearch('part_pkg', {
770 'family_pkgpart' => $new->family_pkgpart
773 foreach my $part_pkg ( @part_pkg ) {
774 my $pkgpart = $part_pkg->pkgpart;
775 next if $pkgpart == $new->pkgpart; # don't modify $new
776 warn " propagating to pkgpart $pkgpart\n" if $DEBUG;
777 foreach ( keys %fields ) {
778 $part_pkg->set($_, $fields{$_});
780 # SUPER::replace to avoid changing non-core fields
781 my $error = $part_pkg->SUPER::replace;
782 push @error, "pkgpart $pkgpart: $error"
788 =item process_fcc_options HASHREF
790 Sets the FCC options on this package definition to the values specified
791 in HASHREF. Names are as in L<FS::part_pkg_fcc_option/info>.
795 sub process_fcc_options {
797 my $pkgpart = $self->pkgpart;
805 my %existing_num = map { $_->fccoptionname => $_->num }
806 qsearch('part_pkg_fcc_option', { pkgpart => $pkgpart });
808 # set up params for process_o2m
811 foreach my $name (keys %$options ) {
812 $params->{ "num$i" } = $existing_num{$name} || '';
813 $params->{ "num$i".'_fccoptionname' } = $name;
814 $params->{ "num$i".'_optionvalue' } = $options->{$name};
819 table => 'part_pkg_fcc_option',
820 fields => [qw( fccoptionname optionvalue )],
825 =item pkg_locale LOCALE
827 Returns a customer-viewable string representing this package for the given
828 locale, from the part_pkg_msgcat table. If the given locale is empty or no
829 localized string is found, returns the base pkg field.
834 my( $self, $locale ) = @_;
835 return $self->pkg unless $locale;
836 my $part_pkg_msgcat = $self->part_pkg_msgcat($locale) or return $self->pkg;
837 $part_pkg_msgcat->pkg;
840 =item part_pkg_msgcat LOCALE
842 Like pkg_locale, but returns the FS::part_pkg_msgcat object itself.
846 sub part_pkg_msgcat {
847 my( $self, $locale ) = @_;
848 qsearchs( 'part_pkg_msgcat', {
849 pkgpart => $self->pkgpart,
854 =item pkg_comment [ OPTION => VALUE... ]
856 Returns an (internal) string representing this package. Currently,
857 "pkgpart: pkg - comment", is returned. "pkg - comment" may be returned in the
858 future, omitting pkgpart. The comment will have '(CUSTOM) ' prepended if
861 If the option nopkgpart is true then the "pkgpart: ' is omitted.
869 #$self->pkg. ' - '. $self->comment;
870 #$self->pkg. ' ('. $self->comment. ')';
871 my $pre = $opt{nopkgpart} ? '' : $self->pkgpart. ': ';
872 my $custom_comment = $self->custom_comment(%opt);
873 $pre. $self->pkg. ( $custom_comment ? " - $custom_comment" : '' );
876 #without price info (so without hitting the DB again)
877 sub pkg_comment_only {
881 my $pre = $opt{nopkgpart} ? '' : $self->pkgpart. ': ';
882 my $comment = $self->comment;
883 $pre. $self->pkg. ( $comment ? " - $comment" : '' );
886 sub price_info { # safety, in case a part_pkg hasn't defined price_info
892 my $price_info = $self->price_info(@_);
893 ( $self->custom ? '(CUSTOM) ' : '' ).
895 ( ($self->custom || $self->comment) ? ' - ' : '' ).
896 ($price_info || 'No charge');
901 $self->pkg. ' - '. ($self->price_info || 'No charge');
906 Returns the package class, as an FS::pkg_class object, or the empty string
907 if there is no package class.
909 =item addon_pkg_class
911 Returns the add-on package class, as an FS::pkg_class object, or the empty
912 string if there is no add-on package class.
916 sub addon_pkg_class {
918 if ( $self->addon_classnum ) {
919 qsearchs('pkg_class', { 'classnum' => $self->addon_classnum } );
927 Returns the package category name, or the empty string if there is no package
934 my $pkg_class = $self->pkg_class;
936 ? $pkg_class->categoryname
942 Returns the package class name, or the empty string if there is no package
949 my $pkg_class = $self->pkg_class;
951 ? $pkg_class->classname
955 =item addon_classname
957 Returns the add-on package class name, or the empty string if there is no
958 add-on package class.
962 sub addon_classname {
964 my $pkg_class = $self->addon_pkg_class;
966 ? $pkg_class->classname
972 Returns the associated agent for this event, if any, as an FS::agent object.
974 =item pkg_svc [ HASHREF | OPTION => VALUE ]
976 Returns all FS::pkg_svc objects (see L<FS::pkg_svc>) for this package
977 definition (with non-zero quantity).
979 One option is available, I<disable_linked>. If set true it will return the
980 services for this package definition alone, omitting services from any add-on
987 Returns all FS::type_pkgs objects (see L<FS::type_pkgs>) for this package
995 # #sort { $b->primary cmp $a->primary }
996 # grep { $_->quantity }
997 # qsearch( 'pkg_svc', { 'pkgpart' => $self->pkgpart } );
999 my $opt = ref($_[0]) ? $_[0] : { @_ };
1000 my %pkg_svc = map { $_->svcpart => $_ }
1001 grep { $_->quantity }
1002 qsearch( 'pkg_svc', { 'pkgpart' => $self->pkgpart } );
1004 unless ( $opt->{disable_linked} ) {
1005 foreach my $dst_pkg ( map $_->dst_pkg, $self->svc_part_pkg_link ) {
1006 my @pkg_svc = grep { $_->quantity }
1007 qsearch( 'pkg_svc', { pkgpart=>$dst_pkg->pkgpart } );
1008 foreach my $pkg_svc ( @pkg_svc ) {
1009 if ( $pkg_svc{$pkg_svc->svcpart} ) {
1010 my $quantity = $pkg_svc{$pkg_svc->svcpart}->quantity;
1011 $pkg_svc{$pkg_svc->svcpart}->quantity($quantity + $pkg_svc->quantity);
1013 $pkg_svc{$pkg_svc->svcpart} = $pkg_svc;
1023 =item svcpart [ SVCDB ]
1025 Returns the svcpart of the primary service definition (see L<FS::part_svc>)
1026 associated with this package definition (see L<FS::pkg_svc>). Returns
1027 false if there not a primary service definition or exactly one service
1028 definition with quantity 1, or if SVCDB is specified and does not match the
1029 svcdb of the service definition. SVCDB can be specified as a scalar table
1030 name, such as 'svc_acct', or as an arrayref of possible table names.
1035 my $pkg_svc = shift->_primary_pkg_svc(@_);
1036 $pkg_svc ? $pkg_svc->svcpart : '';
1039 =item part_svc [ SVCDB ]
1041 Like the B<svcpart> method, but returns the FS::part_svc object (see
1047 my $pkg_svc = shift->_primary_pkg_svc(@_);
1048 $pkg_svc ? $pkg_svc->part_svc : '';
1051 sub _primary_pkg_svc {
1054 my $svcdb = scalar(@_) ? shift : [];
1055 $svcdb = ref($svcdb) ? $svcdb : [ $svcdb ];
1056 my %svcdb = map { $_=>1 } @$svcdb;
1059 grep { !scalar(@$svcdb) || $svcdb{ $_->part_svc->svcdb } }
1062 my @pkg_svc = grep { $_->primary_svc =~ /^Y/i } @svcdb_pkg_svc;
1063 @pkg_svc = grep {$_->quantity == 1 } @svcdb_pkg_svc
1065 return '' if scalar(@pkg_svc) != 1;
1069 =item svcpart_unique_svcdb SVCDB
1071 Returns the svcpart of a service definition (see L<FS::part_svc>) matching
1072 SVCDB associated with this package definition (see L<FS::pkg_svc>). Returns
1073 false if there not a primary service definition for SVCDB or there are multiple
1074 service definitions for SVCDB.
1078 sub svcpart_unique_svcdb {
1079 my( $self, $svcdb ) = @_;
1080 my @svcdb_pkg_svc = grep { ( $svcdb eq $_->part_svc->svcdb ) } $self->pkg_svc;
1081 return '' if scalar(@svcdb_pkg_svc) != 1;
1082 $svcdb_pkg_svc[0]->svcpart;
1087 Returns a list of the acceptable payment types for this package. Eventually
1088 this should come out of a database table and be editable, but currently has the
1089 following logic instead:
1091 If the package is free, the single item B<BILL> is
1092 returned, otherwise, the single item B<CARD> is returned.
1094 (CHEK? LEC? Probably shouldn't accept those by default, prone to abuse)
1100 if ( $self->is_free ) {
1109 Returns true if this package is free.
1115 if ( $self->can('is_free_options') ) {
1116 not grep { $_ !~ /^\s*0*(\.0*)?\s*$/ }
1117 map { $self->option($_) }
1118 $self->is_free_options;
1120 warn "FS::part_pkg::is_free: FS::part_pkg::". $self->plan. " subclass ".
1121 "provides neither is_free_options nor is_free method; returning false";
1126 # whether the plan allows discounts to be applied to this package
1127 sub can_discount { 0; }
1129 # whether the plan allows changing the start date
1130 sub can_start_date { 1; }
1132 # whether the plan supports part_pkg_usageprice add-ons (a specific kind of
1133 # pre-selectable usage pricing, there's others this doesn't refer to)
1134 sub can_usageprice { 0; }
1136 # the delay start date if present
1137 sub delay_start_date {
1140 my $delay = $self->delay_start or return '';
1142 # avoid timelocal silliness
1143 my $dt = DateTime->today(time_zone => 'local');
1144 $dt->add(days => $delay);
1148 sub can_currency_exchange { 0; }
1151 # moved to FS::Misc to make this accessible to other packages
1153 FS::Misc::pkg_freqs();
1158 Returns an english representation of the I<freq> field, such as "monthly",
1159 "weekly", "semi-annually", etc.
1165 my $freq = $self->freq;
1167 #my $freqs_href = $self->freqs_href;
1168 my $freqs_href = freqs_href();
1170 if ( exists($freqs_href->{$freq}) ) {
1171 $freqs_href->{$freq};
1173 my $interval = 'month';
1174 if ( $freq =~ /^(\d+)([hdw])$/ ) {
1175 my %interval = ( 'h' => 'hour', 'd'=>'day', 'w'=>'week' );
1176 $interval = $interval{$2};
1181 "every $freq ${interval}s";
1186 =item add_freq TIMESTAMP [ FREQ ]
1188 Adds a billing period of some frequency to the provided timestamp and
1189 returns the resulting timestamp, or -1 if the frequency could not be
1190 parsed (shouldn't happen). By default, the frequency of this package
1191 will be used; to override this, pass a different frequency as a second
1197 my( $self, $date, $freq ) = @_;
1198 $freq = $self->freq unless $freq;
1200 #change this bit to use Date::Manip? CAREFUL with timezones (see
1201 # mailing list archive)
1202 my ($sec,$min,$hour,$mday,$mon,$year) = (localtime($date) )[0,1,2,3,4,5];
1204 if ( $freq =~ /^\d+$/ ) {
1206 until ( $mon < 12 ) { $mon -= 12; $year++; }
1208 $mday = 28 if $mday > 28 && FS::Conf->new->exists('anniversary-rollback');
1210 } elsif ( $freq =~ /^(\d+)w$/ ) {
1212 $mday += $weeks * 7;
1213 } elsif ( $freq =~ /^(\d+)d$/ ) {
1216 } elsif ( $freq =~ /^(\d+)h$/ ) {
1223 timelocal_nocheck($sec,$min,$hour,$mday,$mon,$year);
1228 For backwards compatibility, returns the plandata field as well as all options
1229 from FS::part_pkg_option.
1235 carp "plandata is deprecated";
1237 $self->SUPER::plandata(@_);
1239 my $plandata = $self->get('plandata');
1240 my %options = $self->options;
1241 $plandata .= join('', map { "$_=$options{$_}\n" } keys %options );
1246 =item part_pkg_vendor
1248 Returns all vendor/external package ids as FS::part_pkg_vendor objects (see
1249 L<FS::part_pkg_vendor>).
1251 =item vendor_pkg_ids
1253 Returns a list of vendor/external package ids by exportnum
1257 sub vendor_pkg_ids {
1259 map { $_->exportnum => $_->vendor_pkg_id } $self->part_pkg_vendor;
1262 =item part_pkg_option
1264 Returns all options as FS::part_pkg_option objects (see
1265 L<FS::part_pkg_option>).
1269 Returns a list of option names and values suitable for assigning to a hash.
1275 map { $_->optionname => $_->optionvalue } $self->part_pkg_option;
1278 =item option OPTIONNAME [ QUIET ]
1280 Returns the option value for the given name, or the empty string. If a true
1281 value is passed as the second argument, warnings about missing the option
1287 my( $self, $opt, $ornull ) = @_;
1288 cluck "$self -> option: searching for $opt"
1290 my $part_pkg_option =
1291 qsearchs('part_pkg_option', {
1292 pkgpart => $self->pkgpart,
1295 return $part_pkg_option->optionvalue if $part_pkg_option;
1296 my %plandata = map { /^(\w+)=(.*)$/; ( $1 => $2 ); }
1297 split("\n", $self->get('plandata') );
1298 return $plandata{$opt} if exists $plandata{$opt};
1299 cluck "WARNING: (pkgpart ". $self->pkgpart. ") Package def option $opt ".
1300 "not found in options or plandata!\n"
1305 =item part_pkg_currency [ CURRENCY ]
1307 Returns all currency options as FS::part_pkg_currency objects (see
1308 L<FS::part_pkg_currency>), or, if a currency is specified, only return the
1309 objects for that currency.
1313 sub part_pkg_currency {
1315 my %hash = ( 'pkgpart' => $self->pkgpart );
1316 $hash{'currency'} = shift if @_;
1317 qsearch('part_pkg_currency', \%hash );
1320 =item part_pkg_currency_options CURRENCY
1322 Returns a list of option names and values from FS::part_pkg_currency for the
1327 sub part_pkg_currency_options {
1329 map { $_->optionname => $_->optionvalue } $self->part_pkg_currency(shift);
1332 =item part_pkg_currency_option CURRENCY OPTIONNAME
1334 Returns the option value for the given name and currency.
1338 sub part_pkg_currency_option {
1339 my( $self, $currency, $optionname ) = @_;
1340 my $part_pkg_currency =
1341 qsearchs('part_pkg_currency', { 'pkgpart' => $self->pkgpart,
1342 'currency' => $currency,
1343 'optionname' => $optionname,
1346 #fatal if not found? that works for our use cases from
1347 #part_pkg/currency_fixed, but isn't how we would typically/expect the method
1348 #to behave. have to catch it there if we change it here...
1349 or die "Unknown price for ". $self->pkg_comment. " in $currency\n";
1351 $part_pkg_currency->optionvalue;
1354 =item fcc_option OPTIONNAME
1356 Returns the FCC 477 report option value for the given name, or the empty
1362 my ($self, $name) = @_;
1363 my $part_pkg_fcc_option =
1364 qsearchs('part_pkg_fcc_option', {
1365 pkgpart => $self->pkgpart,
1366 fccoptionname => $name,
1368 $part_pkg_fcc_option ? $part_pkg_fcc_option->optionvalue : '';
1373 Returns all FCC 477 report options for this package, as a hash-like list.
1379 map { $_->fccoptionname => $_->optionvalue }
1380 qsearch('part_pkg_fcc_option', { pkgpart => $self->pkgpart });
1383 =item bill_part_pkg_link
1385 Returns the associated part_pkg_link records (see L<FS::part_pkg_link>).
1389 sub bill_part_pkg_link {
1390 shift->_part_pkg_link('bill', @_);
1393 =item svc_part_pkg_link
1395 Returns the associated part_pkg_link records (see L<FS::part_pkg_link>).
1399 sub svc_part_pkg_link {
1400 shift->_part_pkg_link('svc', @_);
1403 =item supp_part_pkg_link
1405 Returns the associated part_pkg_link records of type 'supp' (supplemental
1410 sub supp_part_pkg_link {
1411 shift->_part_pkg_link('supp', @_);
1414 sub _part_pkg_link {
1415 my( $self, $type ) = @_;
1416 qsearch({ table => 'part_pkg_link',
1417 hashref => { 'src_pkgpart' => $self->pkgpart,
1418 'link_type' => $type,
1419 #protection against infinite recursive links
1420 'dst_pkgpart' => { op=>'!=', value=> $self->pkgpart },
1422 order_by => "ORDER BY hidden",
1426 sub self_and_bill_linked {
1427 shift->_self_and_linked('bill', @_);
1430 sub self_and_svc_linked {
1431 shift->_self_and_linked('svc', @_);
1434 sub _self_and_linked {
1435 my( $self, $type, $hidden ) = @_;
1439 foreach ( ( $self, map { $_->dst_pkg->_self_and_linked($type, $_->hidden) }
1440 $self->_part_pkg_link($type) ) )
1442 $_->hidden($hidden) if $hidden;
1449 =item part_pkg_taxoverride [ CLASS ]
1451 Returns all associated FS::part_pkg_taxoverride objects (see
1452 L<FS::part_pkg_taxoverride>). Limits the returned set to those
1453 of class CLASS if defined. Class may be one of 'setup', 'recur',
1454 the empty string (default), or a usage class number (see L<FS::usage_class>).
1455 When a class is specified, the empty string class (default) is returned
1456 if no more specific values exist.
1460 sub part_pkg_taxoverride {
1464 my $hashref = { 'pkgpart' => $self->pkgpart };
1465 $hashref->{'usage_class'} = $class if defined($class);
1466 my @overrides = qsearch('part_pkg_taxoverride', $hashref );
1468 unless ( scalar(@overrides) || !defined($class) || !$class ){
1469 $hashref->{'usage_class'} = '';
1470 @overrides = qsearch('part_pkg_taxoverride', $hashref );
1476 =item has_taxproduct
1478 Returns true if this package has any taxproduct associated with it.
1482 sub has_taxproduct {
1485 $self->taxproductnum ||
1486 scalar( grep { $_ =~/^usage_taxproductnum_/ && $self->option($_) }
1487 keys %{ {$self->options} }
1493 =item taxproduct [ CLASS ]
1495 Returns the associated tax product for this package definition (see
1496 L<FS::part_pkg_taxproduct>). CLASS may be one of 'setup', 'recur' or
1497 the usage classnum (see L<FS::usage_class>). Returns the default
1498 tax product for this record if the more specific CLASS value does
1507 my $part_pkg_taxproduct;
1509 my $taxproductnum = $self->taxproductnum;
1511 my $class_taxproductnum = $self->option("usage_taxproductnum_$class", 1);
1512 $taxproductnum = $class_taxproductnum
1513 if $class_taxproductnum
1516 $part_pkg_taxproduct =
1517 qsearchs( 'part_pkg_taxproduct', { 'taxproductnum' => $taxproductnum } );
1519 unless ($part_pkg_taxproduct || $taxproductnum eq $self->taxproductnum ) {
1520 $taxproductnum = $self->taxproductnum;
1521 $part_pkg_taxproduct =
1522 qsearchs( 'part_pkg_taxproduct', { 'taxproductnum' => $taxproductnum } );
1525 $part_pkg_taxproduct;
1528 =item taxproduct_description [ CLASS ]
1530 Returns the description of the associated tax product for this package
1531 definition (see L<FS::part_pkg_taxproduct>).
1535 sub taxproduct_description {
1537 my $part_pkg_taxproduct = $self->taxproduct(@_);
1538 $part_pkg_taxproduct ? $part_pkg_taxproduct->description : '';
1542 =item tax_rates DATA_PROVIDER, GEOCODE, [ CLASS ]
1544 Returns the tax table entries (L<FS::tax_rate> objects) that apply to this
1545 package in the location specified by GEOCODE, for usage class CLASS (one of
1546 'setup', 'recur', null, or a C<usage_class> number).
1552 my ($vendor, $geocode, $class) = @_;
1553 my @taxclassnums = map { $_->taxclassnum }
1554 $self->part_pkg_taxoverride($class);
1555 if (!@taxclassnums) {
1556 my $part_pkg_taxproduct = $self->taxproduct($class);
1557 # If this isn't defined, then the class has no taxproduct designation,
1558 # so return no tax rates.
1559 return () if !$part_pkg_taxproduct;
1561 # convert the taxproduct to the tax classes that might apply to it in
1563 @taxclassnums = map { $_->taxclassnum }
1564 grep { $_->taxable eq 'Y' } # why do we need this?
1565 $part_pkg_taxproduct->part_pkg_taxrate($geocode);
1567 return unless @taxclassnums;
1569 # then look up the actual tax_rate entries
1570 warn "Found taxclassnum values of ". join(',', @taxclassnums) ."\n"
1572 my $extra_sql = "AND taxclassnum IN (". join(',', @taxclassnums) . ")";
1573 my @taxes = qsearch({ 'table' => 'tax_rate',
1574 'hashref' => { 'geocode' => $geocode,
1575 'data_vendor' => $vendor },
1576 'extra_sql' => $extra_sql,
1578 warn "Found taxes ". join(',', map {$_->taxnum} @taxes) ."\n"
1584 =item part_pkg_discount
1586 Returns the package to discount m2m records (see L<FS::part_pkg_discount>)
1589 =item part_pkg_usage
1591 Returns the voice usage pools (see L<FS::part_pkg_usage>) defined for
1596 Reblesses the object into the FS::part_pkg::PLAN class (if available), where
1597 PLAN is the object's I<plan> field. There should be better docs
1598 on how to create new price plans, but until then, see L</NEW PLAN CLASSES>.
1604 my $plan = $self->plan;
1606 cluck "no price plan found for pkgpart ". $self->pkgpart. "\n"
1610 return $self if ref($self) =~ /::$plan$/; #already blessed into plan subclass
1611 my $class = ref($self). "::$plan";
1612 warn "reblessing $self into $class" if $DEBUG > 1;
1615 bless($self, $class) unless $@;
1620 sub calc_setup { die 'no calc_setup for '. shift->plan. "\n"; }
1621 sub calc_recur { die 'no calc_recur for '. shift->plan. "\n"; }
1623 #fallback that return 0 for old legacy packages with no plan
1624 sub calc_remain { 0; }
1625 sub calc_units { 0; }
1627 #fallback for everything not based on flat.pm
1628 sub recur_temporality { 'upcoming'; }
1629 sub calc_cancel { 0; }
1631 #fallback for everything except bulk.pm
1632 sub hide_svc_detail { 0; }
1634 #fallback for packages that can't/won't summarize usage
1635 sub sum_usage { 0; }
1637 =item recur_cost_permonth CUST_PKG
1639 recur_cost divided by freq (only supported for monthly and longer frequencies)
1643 sub recur_cost_permonth {
1644 my($self, $cust_pkg) = @_;
1645 return 0 unless $self->freq =~ /^\d+$/ && $self->freq > 0;
1646 sprintf('%.2f', $self->recur_cost / $self->freq );
1649 =item cust_bill_pkg_recur CUST_PKG
1651 Actual recurring charge for the specified customer package from customer's most
1656 sub cust_bill_pkg_recur {
1657 my($self, $cust_pkg) = @_;
1658 my $cust_bill_pkg = qsearchs({
1659 'table' => 'cust_bill_pkg',
1660 'addl_from' => 'LEFT JOIN cust_bill USING ( invnum )',
1661 'hashref' => { 'pkgnum' => $cust_pkg->pkgnum,
1662 'recur' => { op=>'>', value=>'0' },
1664 'order_by' => 'ORDER BY cust_bill._date DESC,
1665 cust_bill_pkg.sdate DESC
1668 }) or return 0; #die "use cust_bill_pkg_recur credits with once_perinv condition";
1669 $cust_bill_pkg->recur;
1672 =item unit_setup CUST_PKG
1674 Returns the setup fee for one unit of the package.
1679 my ($self, $cust_pkg) = @_;
1680 $self->option('setup_fee') || 0;
1685 unit_setup minus setup_cost
1691 $self->unit_setup(@_) - $self->setup_cost;
1694 =item recur_margin_permonth
1696 base_recur_permonth minus recur_cost_permonth
1700 sub recur_margin_permonth {
1702 $self->base_recur_permonth(@_) - $self->recur_cost_permonth(@_);
1705 =item format OPTION DATA
1707 Returns data formatted according to the function 'format' described
1708 in the plan info. Returns DATA if no such function exists.
1713 my ($self, $option, $data) = (shift, shift, shift);
1714 if (exists($plans{$self->plan}->{fields}->{$option}{format})) {
1715 &{$plans{$self->plan}->{fields}->{$option}{format}}($data);
1721 =item parse OPTION DATA
1723 Returns data parsed according to the function 'parse' described
1724 in the plan info. Returns DATA if no such function exists.
1729 my ($self, $option, $data) = (shift, shift, shift);
1730 if (exists($plans{$self->plan}->{fields}->{$option}{parse})) {
1731 &{$plans{$self->plan}->{fields}->{$option}{parse}}($data);
1741 =head1 CLASS METHODS
1749 # Used by FS::Upgrade to migrate to a new database.
1751 sub _upgrade_data { # class method
1752 my($class, %opts) = @_;
1754 warn "[FS::part_pkg] upgrading $class\n" if $DEBUG;
1756 my @part_pkg = qsearch({
1757 'table' => 'part_pkg',
1758 'extra_sql' => "WHERE ". join(' OR ',
1759 'plan IS NULL', "plan = '' ",
1763 foreach my $part_pkg (@part_pkg) {
1765 unless ( $part_pkg->plan ) {
1766 $part_pkg->plan('flat');
1772 # the rest can be done asynchronously
1775 sub queueable_upgrade {
1776 # now upgrade to the explicit custom flag
1778 my $search = FS::Cursor->new({
1779 'table' => 'part_pkg',
1780 'hashref' => { disabled => 'Y', custom => '' },
1781 'extra_sql' => "AND comment LIKE '(CUSTOM) %'",
1785 while (my $part_pkg = $search->fetch) {
1786 my $new = new FS::part_pkg { $part_pkg->hash };
1788 my $comment = $part_pkg->comment;
1789 $comment =~ s/^\(CUSTOM\) //;
1790 $comment = '(none)' unless $comment =~ /\S/;
1791 $new->comment($comment);
1793 my $pkg_svc = { map { $_->svcpart => $_->quantity } $part_pkg->pkg_svc };
1794 my $primary = $part_pkg->svcpart;
1795 my $options = { $part_pkg->options };
1797 my $error = $new->replace( $part_pkg,
1798 'pkg_svc' => $pkg_svc,
1799 'primary_svc' => $primary,
1800 'options' => $options,
1803 warn "pkgpart#".$part_pkg->pkgpart.": $error\n";
1810 # set family_pkgpart on any packages that don't have it
1811 $search = FS::Cursor->new('part_pkg', { 'family_pkgpart' => '' });
1812 while (my $part_pkg = $search->fetch) {
1813 $part_pkg->set('family_pkgpart' => $part_pkg->pkgpart);
1814 my $error = $part_pkg->SUPER::replace;
1816 warn "pkgpart#".$part_pkg->pkgpart.": $error\n";
1823 my @part_pkg_option = qsearch('part_pkg_option',
1824 { 'optionname' => 'unused_credit',
1827 foreach my $old_opt (@part_pkg_option) {
1828 my $pkgpart = $old_opt->pkgpart;
1829 my $error = $old_opt->delete;
1830 die $error if $error;
1832 foreach (qw(unused_credit_cancel unused_credit_change)) {
1833 my $new_opt = new FS::part_pkg_option {
1834 'pkgpart' => $pkgpart,
1838 $error = $new_opt->insert;
1839 die $error if $error;
1843 # migrate use_disposition_taqua and use_disposition to disposition_in
1844 @part_pkg_option = qsearch('part_pkg_option',
1845 { 'optionname' => { op => 'LIKE',
1846 value => 'use_disposition%',
1850 my %newopts = map { $_->pkgpart => $_ }
1851 qsearch('part_pkg_option', { 'optionname' => 'disposition_in', } );
1852 foreach my $old_opt (@part_pkg_option) {
1853 my $pkgpart = $old_opt->pkgpart;
1854 my $newval = $old_opt->optionname eq 'use_disposition_taqua' ? '100'
1856 my $error = $old_opt->delete;
1857 die $error if $error;
1859 if ( exists($newopts{$pkgpart}) ) {
1860 my $opt = $newopts{$pkgpart};
1861 $opt->optionvalue($opt->optionvalue.",$newval");
1862 $error = $opt->replace;
1863 die $error if $error;
1865 my $new_opt = new FS::part_pkg_option {
1866 'pkgpart' => $pkgpart,
1867 'optionname' => 'disposition_in',
1868 'optionvalue' => $newval,
1870 $error = $new_opt->insert;
1871 die $error if $error;
1872 $newopts{$pkgpart} = $new_opt;
1876 # set any package with FCC voice lines to the "VoIP with broadband" category
1877 # for backward compatibility
1879 # recover from a bad upgrade bug
1880 my $upgrade = 'part_pkg_fcc_voip_class_FIX';
1881 if (!FS::upgrade_journal->is_done($upgrade)) {
1882 my $bad_upgrade = qsearchs('upgrade_journal',
1883 { upgrade => 'part_pkg_fcc_voip_class' }
1885 if ( $bad_upgrade ) {
1886 my $where = 'WHERE history_date <= '.$bad_upgrade->_date.
1887 ' AND history_date > '.($bad_upgrade->_date - 3600);
1888 my @h_part_pkg_option = map { FS::part_pkg_option->new($_->hashref) }
1891 'table' => 'h_part_pkg_option',
1893 'extra_sql' => "$where AND history_action = 'delete'",
1894 'order_by' => 'ORDER BY history_date ASC',
1896 my @h_pkg_svc = map { FS::pkg_svc->new($_->hashref) }
1899 'table' => 'h_pkg_svc',
1901 'extra_sql' => "$where AND history_action = 'replace_old'",
1902 'order_by' => 'ORDER BY history_date ASC',
1905 foreach my $deleted (@h_part_pkg_option, @h_pkg_svc) {
1906 my $pkgpart ||= $deleted->pkgpart;
1907 $opt{$pkgpart} ||= {
1913 if ( $deleted->isa('FS::part_pkg_option') ) {
1914 $opt{$pkgpart}{options}{ $deleted->optionname } = $deleted->optionvalue;
1916 my $svcpart = $deleted->svcpart;
1917 $opt{$pkgpart}{pkg_svc}{$svcpart} = $deleted->quantity;
1918 $opt{$pkgpart}{hidden_svc}{$svcpart} ||= $deleted->hidden;
1919 $opt{$pkgpart}{primary_svc} = $svcpart if $deleted->primary_svc;
1922 foreach my $pkgpart (keys %opt) {
1923 my $part_pkg = FS::part_pkg->by_key($pkgpart);
1924 my $error = $part_pkg->replace( $part_pkg->replace_old, $opt{$pkgpart} );
1926 die "error recovering damaged pkgpart $pkgpart:\n$error\n";
1929 } # $bad_upgrade exists
1930 else { # do the original upgrade, but correctly this time
1931 my @part_pkg = qsearch('part_pkg', {
1932 fcc_ds0s => { op => '>', value => 0 },
1933 fcc_voip_class => ''
1935 foreach my $part_pkg (@part_pkg) {
1936 $part_pkg->set(fcc_voip_class => 2);
1937 my @pkg_svc = $part_pkg->pkg_svc;
1938 my %quantity = map {$_->svcpart, $_->quantity} @pkg_svc;
1939 my %hidden = map {$_->svcpart, $_->hidden } @pkg_svc;
1940 my $error = $part_pkg->replace(
1941 $part_pkg->replace_old,
1942 options => { $part_pkg->options },
1943 pkg_svc => \%quantity,
1944 hidden_svc => \%hidden,
1945 primary_svc => ($part_pkg->svcpart || ''),
1947 die $error if $error;
1950 FS::upgrade_journal->set_done($upgrade);
1955 =item curuser_pkgs_sql
1957 Returns an SQL fragment for searching for packages the current user can
1958 use, either via part_pkg.agentnum directly, or via agent type (see
1963 sub curuser_pkgs_sql {
1966 $class->_pkgs_sql( $FS::CurrentUser::CurrentUser->agentnums );
1970 =item agent_pkgs_sql AGENT | AGENTNUM, ...
1972 Returns an SQL fragment for searching for packages the provided agent or agents
1973 can use, either via part_pkg.agentnum directly, or via agent type (see
1978 sub agent_pkgs_sql {
1979 my $class = shift; #i'm a class method, not a sub (the question is... why??)
1980 my @agentnums = map { ref($_) ? $_->agentnum : $_ } @_;
1982 $class->_pkgs_sql(@agentnums); #is this why
1987 my( $class, @agentnums ) = @_;
1988 my $agentnums = join(',', @agentnums);
1992 ( agentnum IS NOT NULL AND agentnum IN ($agentnums) )
1993 OR ( agentnum IS NULL
1994 AND EXISTS ( SELECT 1
1996 LEFT JOIN agent_type USING ( typenum )
1997 LEFT JOIN agent AS typeagent USING ( typenum )
1998 WHERE type_pkgs.pkgpart = part_pkg.pkgpart
1999 AND typeagent.agentnum IN ($agentnums)
2017 #false laziness w/part_export & cdr
2019 foreach my $INC ( @INC ) {
2020 warn "globbing $INC/FS/part_pkg/*.pm\n" if $DEBUG;
2021 foreach my $file ( glob("$INC/FS/part_pkg/*.pm") ) {
2022 warn "attempting to load plan info from $file\n" if $DEBUG;
2023 $file =~ /\/(\w+)\.pm$/ or do {
2024 warn "unrecognized file in $INC/FS/part_pkg/: $file\n";
2028 my $info = eval "use FS::part_pkg::$mod; ".
2029 "\\%FS::part_pkg::$mod\::info;";
2031 die "error using FS::part_pkg::$mod (skipping): $@\n" if $@;
2034 unless ( keys %$info ) {
2035 warn "no %info hash found in FS::part_pkg::$mod, skipping\n";
2038 warn "got plan info from FS::part_pkg::$mod: $info\n" if $DEBUG;
2039 #if ( exists($info->{'disabled'}) && $info->{'disabled'} ) {
2040 # warn "skipping disabled plan FS::part_pkg::$mod" if $DEBUG;
2043 $info{$mod} = $info;
2044 $info->{'weight'} ||= 0; # quiet warnings
2048 # copy one level deep to allow replacement of fields and fieldorder
2049 tie %plans, 'Tie::IxHash',
2050 map { my %infohash = %{ $info{$_} };
2052 sort { $info{$a}->{'weight'} <=> $info{$b}->{'weight'} }
2055 # inheritance of plan options
2056 foreach my $name (keys(%info)) {
2057 if (exists($info{$name}->{'disabled'}) and $info{$name}->{'disabled'}) {
2058 warn "skipping disabled plan FS::part_pkg::$name" if $DEBUG;
2059 delete $plans{$name};
2062 my $parents = $info{$name}->{'inherit_fields'} || [];
2063 my (%fields, %field_exists, @fieldorder);
2064 foreach my $parent ($name, @$parents) {
2065 if ( !exists($info{$parent}) ) {
2066 warn "$name tried to inherit from nonexistent '$parent'\n";
2069 %fields = ( # avoid replacing existing fields
2070 %{ $info{$parent}->{'fields'} || {} },
2073 foreach (@{ $info{$parent}->{'fieldorder'} || [] }) {
2075 next if $field_exists{$_};
2076 $field_exists{$_} = 1;
2077 # allow inheritors to remove inherited fields from the fieldorder
2078 push @fieldorder, $_ if !exists($fields{$_}) or
2079 !exists($fields{$_}->{'disabled'});
2082 $plans{$name}->{'fields'} = \%fields;
2083 $plans{$name}->{'fieldorder'} = \@fieldorder;
2093 =head1 NEW PLAN CLASSES
2095 A module should be added in FS/FS/part_pkg/ Eventually, an example may be
2096 found in eg/plan_template.pm. Until then, it is suggested that you use the
2097 other modules in FS/FS/part_pkg/ as a guide.
2101 The delete method is unimplemented.
2103 setup and recur semantics are not yet defined (and are implemented in
2104 FS::cust_bill. hmm.). now they're deprecated and need to go.
2108 part_pkg_taxrate is Pg specific
2110 replace should be smarter about managing the related tables (options, pkg_svc)
2114 L<FS::Record>, L<FS::cust_pkg>, L<FS::type_pkgs>, L<FS::pkg_svc>, L<Safe>.
2115 schema.html from the base documentation.