2 use base qw( FS::part_pkg::API
3 FS::m2m_Common FS::o2m_Common FS::option_Common
7 use vars qw( %plans $DEBUG $setup_hack $skip_pkg_svc_hack );
8 use Carp qw(carp cluck confess);
9 use Scalar::Util qw( blessed );
11 use Time::Local qw( timelocal timelocal_nocheck ); # eventually replace with DateTime
14 use FS::Record qw( qsearch qsearchs dbh dbdef );
15 use FS::Cursor; # for upgrade
21 use FS::part_pkg_option;
22 use FS::part_pkg_fcc_option;
25 use FS::part_pkg_msgcat;
26 use FS::part_pkg_taxrate;
27 use FS::part_pkg_taxoverride;
28 use FS::part_pkg_taxproduct;
29 use FS::part_pkg_link;
30 use FS::part_pkg_discount;
31 use FS::part_pkg_vendor;
32 use FS::part_pkg_currency;
33 use FS::part_svc_link;
37 $skip_pkg_svc_hack = 0;
41 FS::part_pkg - Object methods for part_pkg objects
47 $record = new FS::part_pkg \%hash
48 $record = new FS::part_pkg { 'column' => 'value' };
50 $custom_record = $template_record->clone;
52 $error = $record->insert;
54 $error = $new_record->replace($old_record);
56 $error = $record->delete;
58 $error = $record->check;
60 @pkg_svc = $record->pkg_svc;
62 $svcnum = $record->svcpart;
63 $svcnum = $record->svcpart( 'svc_acct' );
67 An FS::part_pkg object represents a package definition. FS::part_pkg
68 inherits from FS::Record. The following fields are currently supported:
72 =item pkgpart - primary key (assigned automatically for new package definitions)
74 =item pkg - Text name of this package definition (customer-viewable)
76 =item comment - Text name of this package definition (non-customer-viewable)
78 =item classnum - Optional package class (see L<FS::pkg_class>)
80 =item promo_code - Promotional code
82 =item setup - Setup fee expression (deprecated)
84 =item freq - Frequency of recurring fee
86 =item recur - Recurring fee expression (deprecated)
88 =item setuptax - Setup fee tax exempt flag, empty or `Y'
90 =item recurtax - Recurring fee tax exempt flag, empty or `Y'
92 =item taxclass - Tax class
94 =item plan - Price plan
96 =item plandata - Price plan data (deprecated - see L<FS::part_pkg_option> instead)
98 =item disabled - Disabled flag, empty or `Y'
100 =item custom - Custom flag, empty or `Y'
102 =item setup_cost - for cost tracking
104 =item recur_cost - for cost tracking
106 =item pay_weight - Weight (relative to credit_weight and other package definitions) that controls payment application to specific line items.
108 =item credit_weight - Weight (relative to other package definitions) that controls credit application to specific line items.
110 =item agentnum - Optional agentnum (see L<FS::agent>)
112 =item fcc_ds0s - Optional DS0 equivalency number for FCC form 477
114 =item fcc_voip_class - Which column of FCC form 477 part II.B this package
117 =item successor - Foreign key for the part_pkg that replaced this record.
118 If this record is not obsolete, will be null.
120 =item family_pkgpart - Foreign key for the part_pkg that was the earliest
121 ancestor of this record. If this record is not a successor to another
122 part_pkg, will be equal to pkgpart.
124 =item delay_start - Number of days to delay package start, by default
126 =item start_on_hold - 'Y' to suspend this package immediately when it is
127 ordered. The package will not start billing or have a setup fee charged
128 until it is manually unsuspended.
130 =item change_to_pkgpart - When this package is ordered, schedule a future
131 package change. The 'expire_months' field will determine when the package
134 =item expire_months - Number of months until this package expires (or changes
137 =item adjourn_months - Number of months until this package becomes suspended.
139 =item contract_end_months - Number of months until the package's contract
150 Creates a new package definition. To add the package definition to
151 the database, see L<"insert">.
155 sub table { 'part_pkg'; }
159 An alternate constructor. Creates a new package definition by duplicating
160 an existing definition. A new pkgpart is assigned and the custom flag is
161 set to Y. To add the package definition to the database, see L<"insert">.
167 my $class = ref($self);
168 my %hash = $self->hash;
169 $hash{'pkgpart'} = '';
170 $hash{'custom'} = 'Y';
171 #new FS::part_pkg ( \%hash ); # ?
172 new $class ( \%hash ); # ?
175 =item insert [ , OPTION => VALUE ... ]
177 Adds this package definition to the database. If there is an error,
178 returns the error, otherwise returns false.
180 Currently available options are: I<pkg_svc>, I<primary_svc>, I<cust_pkg>,
181 I<custnum_ref> and I<options>.
183 If I<pkg_svc> is set to a hashref with svcparts as keys and quantities as
184 values, appropriate FS::pkg_svc records will be inserted. I<hidden_svc> can
185 be set to a hashref of svcparts and flag values ('Y' or '') to set the
186 'hidden' field in these records, and I<provision_hold> can be set similarly
187 for the 'provision_hold' field in these records.
189 If I<primary_svc> is set to the svcpart of the primary service, the appropriate
190 FS::pkg_svc record will be updated.
192 If I<cust_pkg> is set to a pkgnum of a FS::cust_pkg record (or the FS::cust_pkg
193 record itself), the object will be updated to point to this package definition.
195 In conjunction with I<cust_pkg>, if I<custnum_ref> is set to a scalar reference,
196 the scalar will be updated with the custnum value from the cust_pkg record.
198 If I<tax_overrides> is set to a hashref with usage classes as keys and comma
199 separated tax class numbers as values, appropriate FS::part_pkg_taxoverride
200 records will be inserted.
202 If I<options> is set to a hashref of options, appropriate FS::part_pkg_option
203 records will be inserted.
205 If I<part_pkg_currency> is set to a hashref of options (with the keys as
206 option_CURRENCY), appropriate FS::part_pkg::currency records will be inserted.
213 warn "FS::part_pkg::insert called on $self with options ".
214 join(', ', map "$_=>$options{$_}", keys %options)
217 local $SIG{HUP} = 'IGNORE';
218 local $SIG{INT} = 'IGNORE';
219 local $SIG{QUIT} = 'IGNORE';
220 local $SIG{TERM} = 'IGNORE';
221 local $SIG{TSTP} = 'IGNORE';
222 local $SIG{PIPE} = 'IGNORE';
224 my $oldAutoCommit = $FS::UID::AutoCommit;
225 local $FS::UID::AutoCommit = 0;
228 warn " inserting part_pkg record" if $DEBUG;
229 my $error = $self->SUPER::insert( $options{options} );
231 $dbh->rollback if $oldAutoCommit;
236 if ( $self->get('family_pkgpart') eq '' ) {
237 $self->set('family_pkgpart' => $self->pkgpart);
238 $error = $self->SUPER::replace;
240 $dbh->rollback if $oldAutoCommit;
245 warn " inserting part_pkg_taxoverride records" if $DEBUG;
246 my %overrides = %{ $options{'tax_overrides'} || {} };
247 foreach my $usage_class ( keys %overrides ) {
249 ( exists($overrides{$usage_class}) && defined($overrides{$usage_class}) )
250 ? $overrides{$usage_class}
252 my @overrides = (grep "$_", split(',', $override) );
253 my $error = $self->process_m2m (
254 'link_table' => 'part_pkg_taxoverride',
255 'target_table' => 'tax_class',
256 'hashref' => { 'usage_class' => $usage_class },
257 'params' => \@overrides,
260 $dbh->rollback if $oldAutoCommit;
265 warn " inserting part_pkg_currency records" if $DEBUG;
266 my %part_pkg_currency = %{ $options{'part_pkg_currency'} || {} };
267 foreach my $key ( keys %part_pkg_currency ) {
268 $key =~ /^(.+)_([A-Z]{3})$/ or next;
269 my( $optionname, $currency ) = ( $1, $2 );
270 if ( $part_pkg_currency{$key} =~ /^\s*$/ ) {
271 if ( $self->option($optionname) == 0 ) {
272 $part_pkg_currency{$key} = '0';
274 $dbh->rollback if $oldAutoCommit;
275 ( my $thing = $optionname ) =~ s/_/ /g;
276 return ucfirst($thing). " $currency is required";
279 my $part_pkg_currency = new FS::part_pkg_currency {
280 'pkgpart' => $self->pkgpart,
281 'optionname' => $optionname,
282 'currency' => $currency,
283 'optionvalue' => $part_pkg_currency{$key},
285 my $error = $part_pkg_currency->insert;
287 $dbh->rollback if $oldAutoCommit;
292 unless ( $skip_pkg_svc_hack ) {
294 warn " inserting pkg_svc records" if $DEBUG;
295 my $pkg_svc = $options{'pkg_svc'} || {};
296 my $hidden_svc = $options{'hidden_svc'} || {};
297 my $provision_hold = $options{'provision_hold'} || {};
298 foreach my $part_svc ( qsearch('part_svc', {} ) ) {
299 my $quantity = $pkg_svc->{$part_svc->svcpart} || 0;
301 ( $options{'primary_svc'} && $options{'primary_svc'}==$part_svc->svcpart )
305 my $pkg_svc = new FS::pkg_svc( {
306 'pkgpart' => $self->pkgpart,
307 'svcpart' => $part_svc->svcpart,
308 'quantity' => $quantity,
309 'primary_svc' => $primary_svc,
310 'hidden' => $hidden_svc->{$part_svc->svcpart},
311 'provision_hold' => $provision_hold->{$part_svc->svcpart},
313 my $error = $pkg_svc->insert;
315 $dbh->rollback if $oldAutoCommit;
320 my $error = $self->check_pkg_svc(%options);
322 $dbh->rollback if $oldAutoCommit;
328 if ( $options{'cust_pkg'} ) {
329 warn " updating cust_pkg record " if $DEBUG;
331 ref($options{'cust_pkg'})
332 ? $options{'cust_pkg'}
333 : qsearchs('cust_pkg', { pkgnum => $options{'cust_pkg'} } );
334 ${ $options{'custnum_ref'} } = $old_cust_pkg->custnum
335 if $options{'custnum_ref'};
336 my %hash = $old_cust_pkg->hash;
337 $hash{'pkgpart'} = $self->pkgpart,
338 my $new_cust_pkg = new FS::cust_pkg \%hash;
339 local($FS::cust_pkg::disable_agentcheck) = 1;
340 my $error = $new_cust_pkg->replace($old_cust_pkg);
342 $dbh->rollback if $oldAutoCommit;
343 return "Error modifying cust_pkg record: $error";
347 if ( $options{'part_pkg_vendor'} ) {
348 while ( my ($exportnum, $vendor_pkg_id) =
349 each %{ $options{part_pkg_vendor} }
352 my $ppv = new FS::part_pkg_vendor( {
353 'pkgpart' => $self->pkgpart,
354 'exportnum' => $exportnum,
355 'vendor_pkg_id' => $vendor_pkg_id,
357 my $error = $ppv->insert;
359 $dbh->rollback if $oldAutoCommit;
360 return "Error inserting part_pkg_vendor record: $error";
365 if ( $options{fcc_options} ) {
366 warn " updating fcc options " if $DEBUG;
367 $self->set_fcc_options( $options{fcc_options} );
370 warn " committing transaction" if $DEBUG and $oldAutoCommit;
371 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
378 Currently unimplemented.
383 return "Can't (yet?) delete package definitions.";
384 # check & make sure the pkgpart isn't in cust_pkg or type_pkgs?
387 =item replace OLD_RECORD [ , OPTION => VALUE ... ]
389 Replaces OLD_RECORD with this one in the database. If there is an error,
390 returns the error, otherwise returns false.
392 Currently available options are: I<pkg_svc>, I<hidden_svc>, I<primary_svc>,
393 I<bulk_skip>, I<provision_hold> and I<options>
395 If I<pkg_svc> is set to a hashref with svcparts as keys and quantities as
396 values, the appropriate FS::pkg_svc records will be replaced. I<hidden_svc>
397 can be set to a hashref of svcparts and flag values ('Y' or '') to set the
398 'hidden' field in these records. I<bulk_skip> and I<provision_hold> can be set
399 to a hashref of svcparts and flag values ('Y' or '') to set the respective field
402 If I<primary_svc> is set to the svcpart of the primary service, the appropriate
403 FS::pkg_svc record will be updated.
405 If I<options> is set to a hashref, the appropriate FS::part_pkg_option records
408 If I<part_pkg_currency> is set to a hashref of options (with the keys as
409 option_CURRENCY), appropriate FS::part_pkg::currency records will be replaced.
416 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
421 ( ref($_[0]) eq 'HASH' )
425 $options->{options} = { $old->options } unless defined($options->{options});
427 warn "FS::part_pkg::replace called on $new to replace $old with options".
428 join(', ', map "$_ => ". $options->{$_}, keys %$options)
431 local $SIG{HUP} = 'IGNORE';
432 local $SIG{INT} = 'IGNORE';
433 local $SIG{QUIT} = 'IGNORE';
434 local $SIG{TERM} = 'IGNORE';
435 local $SIG{TSTP} = 'IGNORE';
436 local $SIG{PIPE} = 'IGNORE';
438 my $oldAutoCommit = $FS::UID::AutoCommit;
439 local $FS::UID::AutoCommit = 0;
442 my $conf = new FS::Conf;
443 if ( $conf->exists('part_pkg-lineage') ) {
444 if ( grep { $options->{options}->{$_} ne $old->option($_, 1) }
445 qw(setup_fee recur_fee) #others? config?
448 warn " superseding package" if $DEBUG;
450 my $error = $new->supersede($old, %$options);
452 $dbh->rollback if $oldAutoCommit;
456 warn " committing transaction" if $DEBUG and $oldAutoCommit;
457 $dbh->commit if $oldAutoCommit;
464 #plandata shit stays in replace for upgrades until after 2.0 (or edit
466 warn " saving legacy plandata" if $DEBUG;
467 my $plandata = $new->get('plandata');
468 $new->set('plandata', '');
470 warn " deleting old part_pkg_option records" if $DEBUG;
471 foreach my $part_pkg_option ( $old->part_pkg_option ) {
472 my $error = $part_pkg_option->delete;
474 $dbh->rollback if $oldAutoCommit;
479 warn " replacing part_pkg record" if $DEBUG;
480 my $error = $new->SUPER::replace($old, $options->{options} );
482 $dbh->rollback if $oldAutoCommit;
486 warn " inserting part_pkg_option records for plandata: $plandata|" if $DEBUG;
487 foreach my $part_pkg_option (
488 map { /^(\w+)=(.*)$/ or do { $dbh->rollback if $oldAutoCommit;
489 return "illegal plandata: $plandata";
491 new FS::part_pkg_option {
492 'pkgpart' => $new->pkgpart,
497 split("\n", $plandata)
499 my $error = $part_pkg_option->insert;
501 $dbh->rollback if $oldAutoCommit;
506 #trivial nit: not the most efficient to delete and reinsert
507 warn " deleting old part_pkg_currency records" if $DEBUG;
508 foreach my $part_pkg_currency ( $old->part_pkg_currency ) {
509 my $error = $part_pkg_currency->delete;
511 $dbh->rollback if $oldAutoCommit;
512 return "error deleting part_pkg_currency record: $error";
516 warn " inserting new part_pkg_currency records" if $DEBUG;
517 my %part_pkg_currency = %{ $options->{'part_pkg_currency'} || {} };
518 foreach my $key ( keys %part_pkg_currency ) {
519 $key =~ /^(.+)_([A-Z]{3})$/ or next;
520 my $part_pkg_currency = new FS::part_pkg_currency {
521 'pkgpart' => $new->pkgpart,
524 'optionvalue' => $part_pkg_currency{$key},
526 my $error = $part_pkg_currency->insert;
528 $dbh->rollback if $oldAutoCommit;
529 return "error inserting part_pkg_currency record: $error";
534 warn " replacing pkg_svc records" if $DEBUG;
535 my $pkg_svc = $options->{'pkg_svc'};
536 my $hidden_svc = $options->{'hidden_svc'} || {};
537 my $bulk_skip = $options->{'bulk_skip'} || {};
538 my $provision_hold = $options->{'provision_hold'} || {};
539 if ( $pkg_svc ) { # if it wasn't passed, don't change existing pkg_svcs
541 foreach my $part_svc ( qsearch('part_svc', {} ) ) {
542 my $quantity = $pkg_svc->{$part_svc->svcpart} || 0;
543 my $hidden = $hidden_svc->{$part_svc->svcpart} || '';
544 my $bulk_skip = $bulk_skip->{$part_svc->svcpart} || '';
545 my $provision_hold = $provision_hold->{$part_svc->svcpart} || '';
547 ( defined($options->{'primary_svc'}) && $options->{'primary_svc'}
548 && $options->{'primary_svc'} == $part_svc->svcpart
553 my $old_pkg_svc = qsearchs('pkg_svc', {
554 'pkgpart' => $old->pkgpart,
555 'svcpart' => $part_svc->svcpart,
558 my $old_quantity = 0;
559 my $old_primary_svc = '';
561 my $old_bulk_skip = '';
562 my $old_provision_hold = '';
563 if ( $old_pkg_svc ) {
564 $old_quantity = $old_pkg_svc->quantity;
565 $old_primary_svc = $old_pkg_svc->primary_svc
566 if $old_pkg_svc->dbdef_table->column('primary_svc'); # is this needed?
567 $old_hidden = $old_pkg_svc->hidden;
568 $old_bulk_skip = $old_pkg_svc->old_bulk_skip; # should this just be bulk_skip?
569 $old_provision_hold = $old_pkg_svc->provision_hold;
572 next unless $old_quantity != $quantity
573 || $old_primary_svc ne $primary_svc
574 || $old_hidden ne $hidden
575 || $old_bulk_skip ne $bulk_skip
576 || $old_provision_hold ne $provision_hold;
578 my $new_pkg_svc = new FS::pkg_svc( {
579 'pkgsvcnum' => ( $old_pkg_svc ? $old_pkg_svc->pkgsvcnum : '' ),
580 'pkgpart' => $new->pkgpart,
581 'svcpart' => $part_svc->svcpart,
582 'quantity' => $quantity,
583 'primary_svc' => $primary_svc,
585 'bulk_skip' => $bulk_skip,
586 'provision_hold' => $provision_hold,
588 my $error = $old_pkg_svc
589 ? $new_pkg_svc->replace($old_pkg_svc)
590 : $new_pkg_svc->insert;
592 $dbh->rollback if $oldAutoCommit;
597 my $error = $new->check_pkg_svc(%$options);
599 $dbh->rollback if $oldAutoCommit;
603 } #if $options->{pkg_svc}
605 my @part_pkg_vendor = $old->part_pkg_vendor;
606 my @current_exportnum = ();
607 if ( $options->{'part_pkg_vendor'} ) {
608 my($exportnum,$vendor_pkg_id);
609 while ( ($exportnum,$vendor_pkg_id)
610 = each %{$options->{'part_pkg_vendor'}} ) {
612 foreach my $part_pkg_vendor ( @part_pkg_vendor ) {
613 if($exportnum == $part_pkg_vendor->exportnum
614 && $vendor_pkg_id ne $part_pkg_vendor->vendor_pkg_id) {
615 $part_pkg_vendor->vendor_pkg_id($vendor_pkg_id);
616 my $error = $part_pkg_vendor->replace;
618 $dbh->rollback if $oldAutoCommit;
619 return "Error replacing part_pkg_vendor record: $error";
624 elsif($exportnum == $part_pkg_vendor->exportnum
625 && $vendor_pkg_id eq $part_pkg_vendor->vendor_pkg_id) {
630 unless ( $noinsert ) {
631 my $ppv = new FS::part_pkg_vendor( {
632 'pkgpart' => $new->pkgpart,
633 'exportnum' => $exportnum,
634 'vendor_pkg_id' => $vendor_pkg_id,
636 my $error = $ppv->insert;
638 $dbh->rollback if $oldAutoCommit;
639 return "Error inserting part_pkg_vendor record: $error";
642 push @current_exportnum, $exportnum;
645 foreach my $part_pkg_vendor ( @part_pkg_vendor ) {
646 unless ( grep($_ eq $part_pkg_vendor->exportnum, @current_exportnum) ) {
647 my $error = $part_pkg_vendor->delete;
649 $dbh->rollback if $oldAutoCommit;
650 return "Error deleting part_pkg_vendor record: $error";
655 # propagate changes to certain core fields
656 if ( $conf->exists('part_pkg-lineage') ) {
657 warn " propagating changes to family" if $DEBUG;
658 my $error = $new->propagate($old);
660 $dbh->rollback if $oldAutoCommit;
665 if ( $options->{fcc_options} ) {
666 warn " updating fcc options " if $DEBUG;
667 $new->set_fcc_options( $options->{fcc_options} );
670 warn " committing transaction" if $DEBUG and $oldAutoCommit;
671 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
677 Checks all fields to make sure this is a valid package definition. If
678 there is an error, returns the error, otherwise returns false. Called by the
679 insert and replace methods.
685 warn "FS::part_pkg::check called on $self" if $DEBUG;
687 for (qw(setup recur plandata)) {
688 #$self->set($_=>0) if $self->get($_) =~ /^\s*$/; }
689 return "Use of $_ field is deprecated; set a plan and options: ".
691 if length($self->get($_));
695 if ( $self->dbdef_table->column('freq')->type =~ /(int)/i ) {
696 my $error = $self->ut_number('freq');
697 return $error if $error;
699 $self->freq =~ /^(\d+[hdw]?)$/
700 or return "Illegal or empty freq: ". $self->freq;
704 my @null_agentnum_right = ( 'Edit global package definitions' );
705 push @null_agentnum_right, 'One-time charge'
706 if $self->freq =~ /^0/;
707 push @null_agentnum_right, 'Customize customer package'
708 if $self->disabled eq 'Y'; #good enough
710 my $error = $self->ut_numbern('pkgpart')
711 || $self->ut_text('pkg')
712 || $self->ut_textn('comment')
713 || $self->ut_textn('promo_code')
714 || $self->ut_alphan('plan')
715 || $self->ut_flag('setuptax')
716 || $self->ut_flag('recurtax')
717 || $self->ut_textn('taxclass')
718 || $self->ut_flag('disabled')
719 || $self->ut_flag('custom')
720 || $self->ut_flag('no_auto')
721 || $self->ut_flag('recur_show_zero')
722 || $self->ut_flag('setup_show_zero')
723 || $self->ut_flag('start_on_hold')
724 #|| $self->ut_moneyn('setup_cost')
725 #|| $self->ut_moneyn('recur_cost')
726 || $self->ut_floatn('setup_cost')
727 || $self->ut_floatn('recur_cost')
728 || $self->ut_floatn('pay_weight')
729 || $self->ut_floatn('credit_weight')
730 || $self->ut_numbern('taxproductnum')
731 || $self->ut_foreign_keyn('classnum', 'pkg_class', 'classnum')
732 || $self->ut_foreign_keyn('addon_classnum', 'pkg_class', 'classnum')
733 || $self->ut_foreign_keyn('taxproductnum',
734 'part_pkg_taxproduct',
738 ? $self->ut_foreign_keyn('agentnum', 'agent', 'agentnum' )
739 : $self->ut_agentnum_acl('agentnum', \@null_agentnum_right)
741 || $self->ut_numbern('fcc_ds0s')
742 || $self->ut_numbern('fcc_voip_class')
743 || $self->ut_numbern('delay_start')
744 || $self->ut_foreign_keyn('successor', 'part_pkg', 'pkgpart')
745 || $self->ut_foreign_keyn('family_pkgpart', 'part_pkg', 'pkgpart')
746 || $self->ut_numbern('expire_months')
747 || $self->ut_numbern('adjourn_months')
748 || $self->ut_numbern('contract_end_months')
749 || $self->ut_numbern('change_to_pkgpart')
750 || $self->ut_foreign_keyn('change_to_pkgpart', 'part_pkg', 'pkgpart')
751 || $self->ut_alphan('agent_pkgpartid')
752 || $self->SUPER::check
754 return $error if $error;
756 return 'Unknown plan '. $self->plan
757 unless exists($plans{$self->plan});
759 my $conf = new FS::Conf;
760 return 'Taxclass is required'
761 if ! $self->taxclass && $conf->exists('require_taxclasses');
768 Checks pkg_svc records as a whole (for part_svc_link dependencies).
770 If there is an error, returns the error, otherwise returns false.
775 my( $self, %opt ) = @_;
777 my $agentnum = $self->agentnum;
779 my %pkg_svc = map { $_->svcpart => $_ } $self->pkg_svc;
781 foreach my $svcpart ( keys %pkg_svc ) {
783 foreach my $part_svc_link ( $self->part_svc_link(
784 'src_svcpart' => $svcpart,
785 'link_type' => 'part_pkg_restrict',
789 return $part_svc_link->dst_svc. ' must be included with '.
790 $part_svc_link->src_svc
791 unless $pkg_svc{ $part_svc_link->dst_svcpart };
796 return '' if $opt{part_pkg_restrict_soft_override};
798 foreach my $svcpart ( keys %pkg_svc ) {
800 foreach my $part_svc_link ( $self->part_svc_link(
801 'src_svcpart' => $svcpart,
802 'link_type' => 'part_pkg_restrict_soft',
805 return $part_svc_link->dst_svc. ' is suggested with '.
806 $part_svc_link->src_svc
807 unless $pkg_svc{ $part_svc_link->dst_svcpart };
815 =item part_svc_link OPTION => VALUE ...
817 Returns the service dependencies (see L<FS::part_svc_link>) for the given
818 search options, taking into account this package definition's agent.
820 Available options are any field in part_svc_link. Typically used options are
821 src_svcpart and link_type.
826 FS::part_svc_link->by_agentnum( shift->agentnum, @_ );
829 =item supersede OLD [, OPTION => VALUE ... ]
831 Inserts this package as a successor to the package OLD. All options are as
832 for C<insert>. After inserting, disables OLD and sets the new package as its
838 my ($new, $old, %options) = @_;
841 $new->set('pkgpart' => '');
842 $new->set('family_pkgpart' => $old->family_pkgpart);
843 warn " inserting successor package\n" if $DEBUG;
844 $error = $new->insert(%options);
845 return $error if $error;
847 warn " disabling superseded package\n" if $DEBUG;
848 $old->set('successor' => $new->pkgpart);
849 $old->set('disabled' => 'Y');
850 $error = $old->SUPER::replace; # don't change its options/pkg_svc records
851 return $error if $error;
853 warn " propagating changes to family" if $DEBUG;
854 $new->propagate($old);
859 If any of certain fields have changed from OLD to this package, then,
860 for all packages in the same lineage as this one, sets those fields
861 to their values in this package.
865 my @propagate_fields = (
866 qw( pkg classnum setup_cost recur_cost taxclass
867 setuptax recurtax pay_weight credit_weight
875 map { $_ => $new->get($_) }
876 grep { $new->get($_) ne $old->get($_) }
880 my @part_pkg = qsearch('part_pkg', {
881 'family_pkgpart' => $new->family_pkgpart
884 foreach my $part_pkg ( @part_pkg ) {
885 my $pkgpart = $part_pkg->pkgpart;
886 next if $pkgpart == $new->pkgpart; # don't modify $new
887 warn " propagating to pkgpart $pkgpart\n" if $DEBUG;
888 foreach ( keys %fields ) {
889 $part_pkg->set($_, $fields{$_});
891 # SUPER::replace to avoid changing non-core fields
892 my $error = $part_pkg->SUPER::replace;
893 push @error, "pkgpart $pkgpart: $error"
899 =item set_fcc_options HASHREF
901 Sets the FCC options on this package definition to the values specified
906 sub set_fcc_options {
908 my $pkgpart = $self->pkgpart;
916 my %existing_num = map { $_->fccoptionname => $_->num }
917 qsearch('part_pkg_fcc_option', { pkgpart => $pkgpart });
919 local $FS::Record::nowarn_identical = 1;
920 # set up params for process_o2m
923 foreach my $name (keys %$options ) {
924 $params->{ "num$i" } = $existing_num{$name} || '';
925 $params->{ "num$i".'_fccoptionname' } = $name;
926 $params->{ "num$i".'_optionvalue' } = $options->{$name};
931 table => 'part_pkg_fcc_option',
932 fields => [qw( fccoptionname optionvalue )],
937 =item pkg_locale LOCALE
939 Returns a customer-viewable string representing this package for the given
940 locale, from the part_pkg_msgcat table. If the given locale is empty or no
941 localized string is found, returns the base pkg field.
946 my( $self, $locale ) = @_;
947 return $self->pkg unless $locale;
948 my $part_pkg_msgcat = $self->part_pkg_msgcat($locale) or return $self->pkg;
949 $part_pkg_msgcat->pkg;
952 =item part_pkg_msgcat LOCALE
954 Like pkg_locale, but returns the FS::part_pkg_msgcat object itself.
958 sub part_pkg_msgcat {
959 my( $self, $locale ) = @_;
960 qsearchs( 'part_pkg_msgcat', {
961 pkgpart => $self->pkgpart,
966 =item pkg_comment [ OPTION => VALUE... ]
968 Returns an (internal) string representing this package. Currently,
969 "pkgpart: pkg - comment", is returned. "pkg - comment" may be returned in the
970 future, omitting pkgpart. The comment will have '(CUSTOM) ' prepended if
973 If the option nopkgpart is true then the "pkgpart: ' is omitted.
981 #$self->pkg. ' - '. $self->comment;
982 #$self->pkg. ' ('. $self->comment. ')';
983 my $pre = $opt{nopkgpart} ? '' : $self->pkgpart. ': ';
984 my $custom_comment = $self->custom_comment(%opt);
985 $pre. $self->pkg. ( $custom_comment ? " - $custom_comment" : '' );
988 #without price info (so without hitting the DB again)
989 sub pkg_comment_only {
993 my $pre = $opt{nopkgpart} ? '' : $self->pkgpart. ': ';
994 my $comment = $self->comment;
995 $pre. $self->pkg. ( $comment ? " - $comment" : '' );
998 sub price_info { # safety, in case a part_pkg hasn't defined price_info
1002 sub custom_comment {
1004 my $price_info = $self->price_info(@_);
1005 ( $self->custom ? '(CUSTOM) ' : '' ).
1007 ( ($self->custom || $self->comment) ? ' - ' : '' ).
1008 ($price_info || 'No charge');
1011 sub pkg_price_info {
1013 $self->pkg. ' - '. ($self->price_info || 'No charge');
1018 Returns the package class, as an FS::pkg_class object, or the empty string
1019 if there is no package class.
1021 =item addon_pkg_class
1023 Returns the add-on package class, as an FS::pkg_class object, or the empty
1024 string if there is no add-on package class.
1028 sub addon_pkg_class {
1030 if ( $self->addon_classnum ) {
1031 qsearchs('pkg_class', { 'classnum' => $self->addon_classnum } );
1039 Returns the package category name, or the empty string if there is no package
1046 my $pkg_class = $self->pkg_class;
1048 ? $pkg_class->categoryname
1054 Returns the package class name, or the empty string if there is no package
1061 my $pkg_class = $self->pkg_class;
1063 ? $pkg_class->classname
1067 =item addon_classname
1069 Returns the add-on package class name, or the empty string if there is no
1070 add-on package class.
1074 sub addon_classname {
1076 my $pkg_class = $self->addon_pkg_class;
1078 ? $pkg_class->classname
1084 Returns the associated agent for this event, if any, as an FS::agent object.
1086 =item pkg_svc [ HASHREF | OPTION => VALUE ]
1088 Returns all FS::pkg_svc objects (see L<FS::pkg_svc>) for this package
1089 definition (with non-zero quantity).
1091 One option is available, I<disable_linked>. If set true it will return the
1092 services for this package definition alone, omitting services from any add-on
1099 Returns all FS::type_pkgs objects (see L<FS::type_pkgs>) for this package
1107 # #sort { $b->primary cmp $a->primary }
1108 # grep { $_->quantity }
1109 # qsearch( 'pkg_svc', { 'pkgpart' => $self->pkgpart } );
1111 my $opt = ref($_[0]) ? $_[0] : { @_ };
1112 my %pkg_svc = map { $_->svcpart => $_ }
1113 grep { $_->quantity }
1114 qsearch( 'pkg_svc', { 'pkgpart' => $self->pkgpart } );
1116 unless ( $opt->{disable_linked} ) {
1117 foreach my $dst_pkg ( map $_->dst_pkg, $self->svc_part_pkg_link ) {
1118 my @pkg_svc = grep { $_->quantity }
1119 qsearch( 'pkg_svc', { pkgpart=>$dst_pkg->pkgpart } );
1120 foreach my $pkg_svc ( @pkg_svc ) {
1121 if ( $pkg_svc{$pkg_svc->svcpart} ) {
1122 my $quantity = $pkg_svc{$pkg_svc->svcpart}->quantity;
1123 $pkg_svc{$pkg_svc->svcpart}->quantity($quantity + $pkg_svc->quantity);
1125 $pkg_svc{$pkg_svc->svcpart} = $pkg_svc;
1135 =item svcpart [ SVCDB ]
1137 Returns the svcpart of the primary service definition (see L<FS::part_svc>)
1138 associated with this package definition (see L<FS::pkg_svc>). Returns
1139 false if there not a primary service definition or exactly one service
1140 definition with quantity 1, or if SVCDB is specified and does not match the
1141 svcdb of the service definition. SVCDB can be specified as a scalar table
1142 name, such as 'svc_acct', or as an arrayref of possible table names.
1147 my $pkg_svc = shift->_primary_pkg_svc(@_);
1148 $pkg_svc ? $pkg_svc->svcpart : '';
1151 =item part_svc [ SVCDB ]
1153 Like the B<svcpart> method, but returns the FS::part_svc object (see
1159 my $pkg_svc = shift->_primary_pkg_svc(@_);
1160 $pkg_svc ? $pkg_svc->part_svc : '';
1163 sub _primary_pkg_svc {
1166 my $svcdb = scalar(@_) ? shift : [];
1167 $svcdb = ref($svcdb) ? $svcdb : [ $svcdb ];
1168 my %svcdb = map { $_=>1 } @$svcdb;
1171 grep { !scalar(@$svcdb) || $svcdb{ $_->part_svc->svcdb } }
1174 my @pkg_svc = grep { $_->primary_svc =~ /^Y/i } @svcdb_pkg_svc;
1175 @pkg_svc = grep {$_->quantity == 1 } @svcdb_pkg_svc
1177 return '' if scalar(@pkg_svc) != 1;
1181 =item svcpart_unique_svcdb SVCDB
1183 Returns the svcpart of a service definition (see L<FS::part_svc>) matching
1184 SVCDB associated with this package definition (see L<FS::pkg_svc>). Returns
1185 false if there not a primary service definition for SVCDB or there are multiple
1186 service definitions for SVCDB.
1190 sub svcpart_unique_svcdb {
1191 my( $self, $svcdb ) = @_;
1192 my @svcdb_pkg_svc = grep { ( $svcdb eq $_->part_svc->svcdb ) } $self->pkg_svc;
1193 return '' if scalar(@svcdb_pkg_svc) != 1;
1194 $svcdb_pkg_svc[0]->svcpart;
1199 Returns a list of the acceptable payment types for this package. Eventually
1200 this should come out of a database table and be editable, but currently has the
1201 following logic instead:
1203 If the package is free, the single item B<BILL> is
1204 returned, otherwise, the single item B<CARD> is returned.
1206 (CHEK? LEC? Probably shouldn't accept those by default, prone to abuse)
1212 if ( $self->is_free ) {
1221 Returns true if this package is free.
1227 if ( $self->can('is_free_options') ) {
1228 not grep { $_ !~ /^\s*0*(\.0*)?\s*$/ }
1229 map { $self->option($_) }
1230 $self->is_free_options;
1232 warn "FS::part_pkg::is_free: FS::part_pkg::". $self->plan. " subclass ".
1233 "provides neither is_free_options nor is_free method; returning false";
1238 # whether the plan allows discounts to be applied to this package
1239 sub can_discount { 0; }
1241 # whether the plan allows changing the start date
1242 sub can_start_date {
1244 $self->start_on_hold ? 0 : 1;
1247 # whether the plan supports part_pkg_usageprice add-ons (a specific kind of
1248 # pre-selectable usage pricing, there's others this doesn't refer to)
1249 sub can_usageprice { 0; }
1251 # the delay start date if present
1252 sub delay_start_date {
1255 my $delay = $self->delay_start or return '';
1257 # avoid timelocal silliness
1258 my $dt = DateTime->today(time_zone => 'local');
1259 $dt->add(days => $delay);
1263 sub can_currency_exchange { 0; }
1266 # moved to FS::Misc to make this accessible to other packages
1268 FS::Misc::pkg_freqs();
1273 Returns an english representation of the I<freq> field, such as "monthly",
1274 "weekly", "semi-annually", etc.
1280 my $freq = $self->freq;
1282 #my $freqs_href = $self->freqs_href;
1283 my $freqs_href = freqs_href();
1285 if ( exists($freqs_href->{$freq}) ) {
1286 $freqs_href->{$freq};
1288 my $interval = 'month';
1289 if ( $freq =~ /^(\d+)([hdw])$/ ) {
1290 my %interval = ( 'h' => 'hour', 'd'=>'day', 'w'=>'week' );
1291 $interval = $interval{$2};
1296 "every $freq ${interval}s";
1301 =item add_freq TIMESTAMP [ FREQ ]
1303 Adds a billing period of some frequency to the provided timestamp and
1304 returns the resulting timestamp, or -1 if the frequency could not be
1305 parsed (shouldn't happen). By default, the frequency of this package
1306 will be used; to override this, pass a different frequency as a second
1312 my( $self, $date, $freq ) = @_;
1313 $freq = $self->freq unless $freq;
1315 #change this bit to use Date::Manip? CAREFUL with timezones (see
1316 # mailing list archive)
1317 my ($sec,$min,$hour,$mday,$mon,$year) = (localtime($date) )[0,1,2,3,4,5];
1319 if ( $freq =~ /^\d+$/ ) {
1321 until ( $mon < 12 ) { $mon -= 12; $year++; }
1323 $mday = 28 if $mday > 28 && FS::Conf->new->exists('anniversary-rollback');
1325 } elsif ( $freq =~ /^(\d+)w$/ ) {
1327 $mday += $weeks * 7;
1328 } elsif ( $freq =~ /^(\d+)d$/ ) {
1331 } elsif ( $freq =~ /^(\d+)h$/ ) {
1338 timelocal_nocheck($sec,$min,$hour,$mday,$mon,$year);
1343 For backwards compatibility, returns the plandata field as well as all options
1344 from FS::part_pkg_option.
1350 carp "plandata is deprecated";
1352 $self->SUPER::plandata(@_);
1354 my $plandata = $self->get('plandata');
1355 my %options = $self->options;
1356 $plandata .= join('', map { "$_=$options{$_}\n" } keys %options );
1361 =item part_pkg_vendor
1363 Returns all vendor/external package ids as FS::part_pkg_vendor objects (see
1364 L<FS::part_pkg_vendor>).
1366 =item vendor_pkg_ids
1368 Returns a list of vendor/external package ids by exportnum
1372 sub vendor_pkg_ids {
1374 map { $_->exportnum => $_->vendor_pkg_id } $self->part_pkg_vendor;
1377 =item part_pkg_option
1379 Returns all options as FS::part_pkg_option objects (see
1380 L<FS::part_pkg_option>).
1384 Returns a list of option names and values suitable for assigning to a hash.
1390 map { $_->optionname => $_->optionvalue } $self->part_pkg_option;
1393 =item option OPTIONNAME [ QUIET ]
1395 Returns the option value for the given name, or the empty string. If a true
1396 value is passed as the second argument, warnings about missing the option
1402 my( $self, $opt, $ornull ) = @_;
1404 #cache: was pulled up in the original part_pkg query
1405 if ( $opt =~ /^(setup|recur)_fee$/ && defined($self->hashref->{"_$opt"}) ) {
1406 return $self->hashref->{"_$opt"};
1409 cluck "$self -> option: searching for $opt"
1411 my $part_pkg_option =
1412 qsearchs('part_pkg_option', {
1413 pkgpart => $self->pkgpart,
1416 return $part_pkg_option->optionvalue if $part_pkg_option;
1418 my %plandata = map { /^(\w+)=(.*)$/; ( $1 => $2 ); }
1419 split("\n", $self->get('plandata') );
1420 return $plandata{$opt} if exists $plandata{$opt};
1422 # check whether the option is defined in plan info (if so, don't warn)
1423 if (exists $plans{ $self->plan }->{fields}->{$opt}) {
1426 cluck "WARNING: (pkgpart ". $self->pkgpart. ") Package def option $opt ".
1427 "not found in options or plandata!\n"
1433 =item part_pkg_currency [ CURRENCY ]
1435 Returns all currency options as FS::part_pkg_currency objects (see
1436 L<FS::part_pkg_currency>), or, if a currency is specified, only return the
1437 objects for that currency.
1441 sub part_pkg_currency {
1443 my %hash = ( 'pkgpart' => $self->pkgpart );
1444 $hash{'currency'} = shift if @_;
1445 qsearch('part_pkg_currency', \%hash );
1448 =item part_pkg_currency_options CURRENCY
1450 Returns a list of option names and values from FS::part_pkg_currency for the
1455 sub part_pkg_currency_options {
1457 map { $_->optionname => $_->optionvalue } $self->part_pkg_currency(shift);
1460 =item part_pkg_currency_option CURRENCY OPTIONNAME
1462 Returns the option value for the given name and currency.
1466 sub part_pkg_currency_option {
1467 my( $self, $currency, $optionname ) = @_;
1468 my $part_pkg_currency =
1469 qsearchs('part_pkg_currency', { 'pkgpart' => $self->pkgpart,
1470 'currency' => $currency,
1471 'optionname' => $optionname,
1474 #fatal if not found? that works for our use cases from
1475 #part_pkg/currency_fixed, but isn't how we would typically/expect the method
1476 #to behave. have to catch it there if we change it here...
1477 or die "Unknown price for ". $self->pkg_comment. " in $currency\n";
1479 $part_pkg_currency->optionvalue;
1482 =item fcc_option OPTIONNAME
1484 Returns the FCC 477 report option value for the given name, or the empty
1490 my ($self, $name) = @_;
1491 my $part_pkg_fcc_option =
1492 qsearchs('part_pkg_fcc_option', {
1493 pkgpart => $self->pkgpart,
1494 fccoptionname => $name,
1496 $part_pkg_fcc_option ? $part_pkg_fcc_option->optionvalue : '';
1501 Returns all FCC 477 report options for this package, as a hash-like list.
1507 map { $_->fccoptionname => $_->optionvalue }
1508 qsearch('part_pkg_fcc_option', { pkgpart => $self->pkgpart });
1511 =item bill_part_pkg_link
1513 Returns the associated part_pkg_link records (see L<FS::part_pkg_link>).
1517 sub bill_part_pkg_link {
1518 shift->_part_pkg_link('bill', @_);
1521 =item svc_part_pkg_link
1523 Returns the associated part_pkg_link records (see L<FS::part_pkg_link>).
1527 sub svc_part_pkg_link {
1528 shift->_part_pkg_link('svc', @_);
1531 =item supp_part_pkg_link
1533 Returns the associated part_pkg_link records of type 'supp' (supplemental
1538 sub supp_part_pkg_link {
1539 shift->_part_pkg_link('supp', @_);
1542 sub _part_pkg_link {
1543 my( $self, $type ) = @_;
1544 qsearch({ table => 'part_pkg_link',
1545 hashref => { 'src_pkgpart' => $self->pkgpart,
1546 'link_type' => $type,
1547 #protection against infinite recursive links
1548 'dst_pkgpart' => { op=>'!=', value=> $self->pkgpart },
1550 order_by => "ORDER BY hidden",
1554 sub self_and_bill_linked {
1555 shift->_self_and_linked('bill', @_);
1558 sub self_and_svc_linked {
1559 shift->_self_and_linked('svc', @_);
1562 sub _self_and_linked {
1563 my( $self, $type, $hidden ) = @_;
1567 foreach ( ( $self, map { $_->dst_pkg->_self_and_linked($type, $_->hidden) }
1568 $self->_part_pkg_link($type) ) )
1570 $_->hidden($hidden) if $hidden;
1577 =item part_pkg_taxoverride [ CLASS ]
1579 Returns all associated FS::part_pkg_taxoverride objects (see
1580 L<FS::part_pkg_taxoverride>). Limits the returned set to those
1581 of class CLASS if defined. Class may be one of 'setup', 'recur',
1582 the empty string (default), or a usage class number (see L<FS::usage_class>).
1583 When a class is specified, the empty string class (default) is returned
1584 if no more specific values exist.
1588 sub part_pkg_taxoverride {
1592 my $hashref = { 'pkgpart' => $self->pkgpart };
1593 $hashref->{'usage_class'} = $class if defined($class);
1594 my @overrides = qsearch('part_pkg_taxoverride', $hashref );
1596 unless ( scalar(@overrides) || !defined($class) || !$class ){
1597 $hashref->{'usage_class'} = '';
1598 @overrides = qsearch('part_pkg_taxoverride', $hashref );
1604 =item has_taxproduct
1606 Returns true if this package has any taxproduct associated with it.
1610 sub has_taxproduct {
1613 $self->taxproductnum ||
1614 scalar( grep { $_ =~/^usage_taxproductnum_/ && $self->option($_) }
1615 keys %{ {$self->options} }
1621 =item taxproduct [ CLASS ]
1623 Returns the associated tax product for this package definition (see
1624 L<FS::part_pkg_taxproduct>). CLASS may be one of 'setup', 'recur' or
1625 the usage classnum (see L<FS::usage_class>). Returns the default
1626 tax product for this record if the more specific CLASS value does
1635 my $part_pkg_taxproduct;
1637 my $taxproductnum = $self->taxproductnum;
1639 my $class_taxproductnum = $self->option("usage_taxproductnum_$class", 1);
1640 $taxproductnum = $class_taxproductnum
1641 if $class_taxproductnum
1644 $part_pkg_taxproduct =
1645 qsearchs( 'part_pkg_taxproduct', { 'taxproductnum' => $taxproductnum } );
1647 unless ($part_pkg_taxproduct || $taxproductnum eq $self->taxproductnum ) {
1648 $taxproductnum = $self->taxproductnum;
1649 $part_pkg_taxproduct =
1650 qsearchs( 'part_pkg_taxproduct', { 'taxproductnum' => $taxproductnum } );
1653 $part_pkg_taxproduct;
1656 =item taxproduct_description [ CLASS ]
1658 Returns the description of the associated tax product for this package
1659 definition (see L<FS::part_pkg_taxproduct>).
1663 sub taxproduct_description {
1665 my $part_pkg_taxproduct = $self->taxproduct(@_);
1666 $part_pkg_taxproduct ? $part_pkg_taxproduct->description : '';
1670 =item tax_rates DATA_PROVIDER, GEOCODE, [ CLASS ]
1672 Returns the tax table entries (L<FS::tax_rate> objects) that apply to this
1673 package in the location specified by GEOCODE, for usage class CLASS (one of
1674 'setup', 'recur', null, or a C<usage_class> number).
1680 my ($vendor, $geocode, $class) = @_;
1681 # if this part_pkg is overridden into a specific taxclass, get that class
1682 my @taxclassnums = map { $_->taxclassnum }
1683 $self->part_pkg_taxoverride($class);
1684 # otherwise, get its tax product category
1685 if (!@taxclassnums) {
1686 my $part_pkg_taxproduct = $self->taxproduct($class);
1687 # If this isn't defined, then the class has no taxproduct designation,
1688 # so return no tax rates.
1689 return () if !$part_pkg_taxproduct;
1691 # convert the taxproduct to the tax classes that might apply to it in
1693 @taxclassnums = map { $_->taxclassnum }
1694 grep { $_->taxable eq 'Y' } # why do we need this?
1695 $part_pkg_taxproduct->part_pkg_taxrate($geocode);
1697 return unless @taxclassnums;
1699 # then look up the actual tax_rate entries
1700 warn "Found taxclassnum values of ". join(',', @taxclassnums) ."\n"
1702 my $extra_sql = "AND taxclassnum IN (". join(',', @taxclassnums) . ")";
1703 my @taxes = qsearch({ 'table' => 'tax_rate',
1704 'hashref' => { 'geocode' => $geocode,
1705 'data_vendor' => $vendor,
1707 'extra_sql' => $extra_sql,
1709 warn "Found taxes ". join(',', map {$_->taxnum} @taxes) ."\n"
1715 =item part_pkg_discount
1717 Returns the package to discount m2m records (see L<FS::part_pkg_discount>)
1720 =item part_pkg_usage
1722 Returns the voice usage pools (see L<FS::part_pkg_usage>) defined for
1727 Returns the automatic transfer target for this package, or an empty string
1734 my $pkgpart = $self->change_to_pkgpart or return '';
1735 FS::part_pkg->by_key($pkgpart);
1740 Reblesses the object into the FS::part_pkg::PLAN class (if available), where
1741 PLAN is the object's I<plan> field. There should be better docs
1742 on how to create new price plans, but until then, see L</NEW PLAN CLASSES>.
1748 my $plan = $self->plan;
1750 cluck "no price plan found for pkgpart ". $self->pkgpart. "\n"
1754 return $self if ref($self) =~ /::$plan$/; #already blessed into plan subclass
1755 my $class = ref($self). "::$plan";
1756 warn "reblessing $self into $class" if $DEBUG > 1;
1759 bless($self, $class) unless $@;
1763 =item calc_setup CUST_PKG START_DATE DETAILS_ARRAYREF OPTIONS_HASHREF
1765 =item calc_recur CUST_PKG START_DATE DETAILS_ARRAYREF OPTIONS_HASHREF
1767 Calculates and returns the setup or recurring fees, respectively, for this
1768 package. Implementation is in the FS::part_pkg:* module specific to this price
1771 Adds invoicing details to the passed-in DETAILS_ARRAYREF
1773 Options are passed as a hashref. Available options:
1779 Frequency override (for calc_recur)
1783 This option is filled in by the method rather than controlling its operation.
1784 It is an arrayref. Applicable discounts will be added to the arrayref, as
1785 L<FS::cust_bill_pkg_discount|FS::cust_bill_pkg_discount records>.
1789 For package add-ons, is the base L<FS::part_pkg|package definition>, otherwise
1790 no different than pkgpart.
1792 =item precommit_hooks
1794 This option is filled in by the method rather than controlling its operation.
1795 It is an arrayref. Anonymous coderefs will be added to the arrayref. They
1796 need to be called before completing the billing operation. For calc_recur
1799 =item increment_next_bill
1801 Increment the next bill date (boolean, for calc_recur). Typically true except
1802 for particular situations.
1806 This option is filled in by the method rather than controlling its operation.
1807 It indicates a deferred setup fee that is billed at calc_recur time (see price
1808 plan option prorate_defer_bill).
1812 Note: Don't calculate prices when not actually billing the package. For that,
1813 see the L</base_setup|base_setup> and L</base_recur|base_recur> methods.
1818 sub calc_setup { die 'no calc_setup for '. shift->plan. "\n"; }
1819 sub calc_recur { die 'no calc_recur for '. shift->plan. "\n"; }
1821 =item calc_remain CUST_PKG [ OPTION => VALUE ... ]
1823 Calculates and returns the remaining value to be credited upon package
1824 suspension, change, or cancellation, if enabled.
1826 Options are passed as a list of keys and values. Available options:
1832 Override for the current time
1834 =item cust_credit_source_bill_pkg
1836 This option is filled in by the method rather than controlling its operation.
1838 L<FS::cust_credit_source_bill_pkg|FS::cust_credit_source_bill_pkg> records will
1839 be added to the arrayref indicating the specific line items and amounts which
1840 are the source of this remaining credit.
1844 Note: Don't calculate prices when not actually suspending or cancelling the
1849 #fallback that returns 0 for old legacy packages with no plan
1850 sub calc_remain { 0; }
1852 =item calc_units CUST_PKG
1854 This returns the number of provisioned svc_phone records, or, of the package
1855 count_available_phones option is set, the number available to be provisoined
1860 #fallback that returns 0 for old legacy packages with no plan
1861 sub calc_units { 0; }
1863 #fallback for everything not based on flat.pm
1864 sub recur_temporality { 'upcoming'; }
1866 =item calc_cancel START_DATE DETAILS_ARRAYREF OPTIONS_HASHREF
1868 Runs any necessary billing on cancellation: another recurring cycle for
1869 recur_temporailty 'preceding' pacakges with the bill_recur_on_cancel option
1870 set (calc_recur), or, any outstanding usage for pacakges with the
1871 bill_usage_on_cancel option set (calc_usage).
1875 #fallback for everything not based on flat.pm, doesn't do this yet (which is
1876 #okay, nothing of ours not based on flat.pm does usage-on-cancel billing
1877 sub calc_cancel { 0; }
1879 #fallback for everything except bulk.pm
1880 sub hide_svc_detail { 0; }
1882 #fallback for packages that can't/won't summarize usage
1883 sub sum_usage { 0; }
1885 =item recur_cost_permonth CUST_PKG
1887 recur_cost divided by freq (only supported for monthly and longer frequencies)
1891 sub recur_cost_permonth {
1892 my($self, $cust_pkg) = @_;
1893 return 0 unless $self->freq =~ /^\d+$/ && $self->freq > 0;
1894 sprintf('%.2f', ($self->recur_cost || 0) / $self->freq );
1897 =item cust_bill_pkg_recur CUST_PKG
1899 Actual recurring charge for the specified customer package from customer's most
1904 sub cust_bill_pkg_recur {
1905 my($self, $cust_pkg) = @_;
1906 my $cust_bill_pkg = qsearchs({
1907 'table' => 'cust_bill_pkg',
1908 'addl_from' => 'LEFT JOIN cust_bill USING ( invnum )',
1909 'hashref' => { 'pkgnum' => $cust_pkg->pkgnum,
1910 'recur' => { op=>'>', value=>'0' },
1912 'order_by' => 'ORDER BY cust_bill._date DESC,
1913 cust_bill_pkg.sdate DESC
1916 }) or return 0; #die "use cust_bill_pkg_recur credits with once_perinv condition";
1917 $cust_bill_pkg->recur;
1920 =item unit_setup CUST_PKG
1922 Returns the setup fee for one unit of the package.
1927 my ($self, $cust_pkg) = @_;
1928 $self->option('setup_fee') || 0;
1933 unit_setup minus setup_cost
1939 $self->unit_setup(@_) - ($self->setup_cost || 0);
1942 =item recur_margin_permonth
1944 base_recur_permonth minus recur_cost_permonth
1948 sub recur_margin_permonth {
1950 $self->base_recur_permonth(@_) - $self->recur_cost_permonth(@_);
1953 =item format OPTION DATA
1955 Returns data formatted according to the function 'format' described
1956 in the plan info. Returns DATA if no such function exists.
1961 my ($self, $option, $data) = (shift, shift, shift);
1962 if (exists($plans{$self->plan}->{fields}->{$option}{format})) {
1963 &{$plans{$self->plan}->{fields}->{$option}{format}}($data);
1969 =item parse OPTION DATA
1971 Returns data parsed according to the function 'parse' described
1972 in the plan info. Returns DATA if no such function exists.
1977 my ($self, $option, $data) = (shift, shift, shift);
1978 if (exists($plans{$self->plan}->{fields}->{$option}{parse})) {
1979 &{$plans{$self->plan}->{fields}->{$option}{parse}}($data);
1989 =head1 CLASS METHODS
1997 # Used by FS::Upgrade to migrate to a new database.
1999 sub _upgrade_data { # class method
2000 my($class, %opts) = @_;
2002 warn "[FS::part_pkg] upgrading $class\n" if $DEBUG;
2004 my @part_pkg = qsearch({
2005 'table' => 'part_pkg',
2006 'extra_sql' => "WHERE ". join(' OR ',
2007 'plan IS NULL', "plan = '' ",
2011 foreach my $part_pkg (@part_pkg) {
2013 unless ( $part_pkg->plan ) {
2014 $part_pkg->plan('flat');
2021 # Convert RADIUS accounting usage metrics from megabytes to gigabytes
2023 my $upgrade = 'part_pkg_gigabyte_usage';
2024 if (!FS::upgrade_journal->is_done($upgrade)) {
2025 foreach my $part_pkg (qsearch('part_pkg',
2026 { plan => 'sqlradacct_hour' })
2029 my $pkgpart = $part_pkg->pkgpart;
2031 foreach my $opt (qsearch('part_pkg_option',
2032 { 'optionname' => { op => 'LIKE',
2033 value => 'recur_included_%',
2035 pkgpart => $pkgpart,
2038 next if $opt->optionname eq 'recur_included_hours'; # unfortunately named field
2039 next if $opt->optionvalue == 0;
2041 $opt->optionvalue($opt->optionvalue / 1024);
2043 my $error = $opt->replace;
2044 die $error if $error;
2047 foreach my $opt (qsearch('part_pkg_option',
2048 { 'optionname' => { op => 'LIKE',
2049 value => 'recur_%_charge',
2051 pkgpart => $pkgpart,
2053 $opt->optionvalue($opt->optionvalue * 1024);
2055 my $error = $opt->replace;
2056 die $error if $error;
2060 FS::upgrade_journal->set_done($upgrade);
2063 # the rest can be done asynchronously
2066 sub queueable_upgrade {
2067 # now upgrade to the explicit custom flag
2069 my $search = FS::Cursor->new({
2070 'table' => 'part_pkg',
2071 'hashref' => { disabled => 'Y', custom => '' },
2072 'extra_sql' => "AND comment LIKE '(CUSTOM) %'",
2076 while (my $part_pkg = $search->fetch) {
2077 my $new = new FS::part_pkg { $part_pkg->hash };
2079 my $comment = $part_pkg->comment;
2080 $comment =~ s/^\(CUSTOM\) //;
2081 $comment = '(none)' unless $comment =~ /\S/;
2082 $new->comment($comment);
2084 my $pkg_svc = { map { $_->svcpart => $_->quantity } $part_pkg->pkg_svc };
2085 my $primary = $part_pkg->svcpart;
2086 my $options = { $part_pkg->options };
2088 my $error = $new->replace( $part_pkg,
2089 'pkg_svc' => $pkg_svc,
2090 'primary_svc' => $primary,
2091 'options' => $options,
2094 warn "pkgpart#".$part_pkg->pkgpart.": $error\n";
2101 # set family_pkgpart on any packages that don't have it
2102 $search = FS::Cursor->new('part_pkg', { 'family_pkgpart' => '' });
2103 while (my $part_pkg = $search->fetch) {
2104 $part_pkg->set('family_pkgpart' => $part_pkg->pkgpart);
2105 my $error = $part_pkg->SUPER::replace;
2107 warn "pkgpart#".$part_pkg->pkgpart.": $error\n";
2114 my @part_pkg_option = qsearch('part_pkg_option',
2115 { 'optionname' => 'unused_credit',
2118 foreach my $old_opt (@part_pkg_option) {
2119 my $pkgpart = $old_opt->pkgpart;
2120 my $error = $old_opt->delete;
2121 die $error if $error;
2123 foreach (qw(unused_credit_cancel unused_credit_change)) {
2124 my $new_opt = new FS::part_pkg_option {
2125 'pkgpart' => $pkgpart,
2129 $error = $new_opt->insert;
2130 die $error if $error;
2134 # migrate use_disposition_taqua and use_disposition to disposition_in
2135 @part_pkg_option = qsearch('part_pkg_option',
2136 { 'optionname' => { op => 'LIKE',
2137 value => 'use_disposition%',
2141 my %newopts = map { $_->pkgpart => $_ }
2142 qsearch('part_pkg_option', { 'optionname' => 'disposition_in', } );
2143 foreach my $old_opt (@part_pkg_option) {
2144 my $pkgpart = $old_opt->pkgpart;
2145 my $newval = $old_opt->optionname eq 'use_disposition_taqua' ? '100'
2147 my $error = $old_opt->delete;
2148 die $error if $error;
2150 if ( exists($newopts{$pkgpart}) ) {
2151 my $opt = $newopts{$pkgpart};
2152 $opt->optionvalue($opt->optionvalue.",$newval");
2153 $error = $opt->replace;
2154 die $error if $error;
2156 my $new_opt = new FS::part_pkg_option {
2157 'pkgpart' => $pkgpart,
2158 'optionname' => 'disposition_in',
2159 'optionvalue' => $newval,
2161 $error = $new_opt->insert;
2162 die $error if $error;
2163 $newopts{$pkgpart} = $new_opt;
2167 # set any package with FCC voice lines to the "VoIP with broadband" category
2168 # for backward compatibility
2170 # recover from a bad upgrade bug
2171 my $upgrade = 'part_pkg_fcc_voip_class_FIX';
2172 if (!FS::upgrade_journal->is_done($upgrade)) {
2173 my $bad_upgrade = qsearchs('upgrade_journal',
2174 { upgrade => 'part_pkg_fcc_voip_class' }
2176 if ( $bad_upgrade ) {
2177 my $where = 'WHERE history_date <= '.$bad_upgrade->_date.
2178 ' AND history_date > '.($bad_upgrade->_date - 3600);
2179 my @h_part_pkg_option = map { FS::part_pkg_option->new($_->hashref) }
2182 'table' => 'h_part_pkg_option',
2184 'extra_sql' => "$where AND history_action = 'delete'",
2185 'order_by' => 'ORDER BY history_date ASC',
2187 my @h_pkg_svc = map { FS::pkg_svc->new($_->hashref) }
2190 'table' => 'h_pkg_svc',
2192 'extra_sql' => "$where AND history_action = 'replace_old'",
2193 'order_by' => 'ORDER BY history_date ASC',
2196 foreach my $deleted (@h_part_pkg_option, @h_pkg_svc) {
2197 my $pkgpart ||= $deleted->pkgpart;
2198 $opt{$pkgpart} ||= {
2204 if ( $deleted->isa('FS::part_pkg_option') ) {
2205 $opt{$pkgpart}{options}{ $deleted->optionname } = $deleted->optionvalue;
2207 my $svcpart = $deleted->svcpart;
2208 $opt{$pkgpart}{pkg_svc}{$svcpart} = $deleted->quantity;
2209 $opt{$pkgpart}{hidden_svc}{$svcpart} ||= $deleted->hidden;
2210 $opt{$pkgpart}{primary_svc} = $svcpart if $deleted->primary_svc;
2213 foreach my $pkgpart (keys %opt) {
2214 my $part_pkg = FS::part_pkg->by_key($pkgpart);
2215 my $error = $part_pkg->replace( $part_pkg->replace_old, $opt{$pkgpart} );
2217 die "error recovering damaged pkgpart $pkgpart:\n$error\n";
2220 } # $bad_upgrade exists
2221 else { # do the original upgrade, but correctly this time
2222 my @part_pkg = qsearch('part_pkg', {
2223 fcc_ds0s => { op => '>', value => 0 },
2224 fcc_voip_class => ''
2226 foreach my $part_pkg (@part_pkg) {
2227 $part_pkg->set(fcc_voip_class => 2);
2228 my @pkg_svc = $part_pkg->pkg_svc;
2229 my %quantity = map {$_->svcpart, $_->quantity} @pkg_svc;
2230 my %hidden = map {$_->svcpart, $_->hidden } @pkg_svc;
2231 my $error = $part_pkg->replace(
2232 $part_pkg->replace_old,
2233 options => { $part_pkg->options },
2234 pkg_svc => \%quantity,
2235 hidden_svc => \%hidden,
2236 primary_svc => ($part_pkg->svcpart || ''),
2238 die $error if $error;
2241 FS::upgrade_journal->set_done($upgrade);
2244 # migrate adjourn_months, expire_months, and contract_end_months to
2246 foreach my $field (qw(adjourn_months expire_months contract_end_months)) {
2247 foreach my $option (qsearch('part_pkg_option', { optionname => $field })) {
2248 my $part_pkg = $option->part_pkg;
2249 my $error = $option->delete;
2250 if ( $option->optionvalue and $part_pkg->get($field) eq '' ) {
2251 $part_pkg->set($field, $option->optionvalue);
2252 $error ||= $part_pkg->replace;
2254 die $error if $error;
2259 =item curuser_pkgs_sql
2261 Returns an SQL fragment for searching for packages the current user can
2262 use, either via part_pkg.agentnum directly, or via agent type (see
2267 sub curuser_pkgs_sql {
2270 $class->_pkgs_sql( $FS::CurrentUser::CurrentUser->agentnums );
2274 =item agent_pkgs_sql AGENT | AGENTNUM, ...
2276 Returns an SQL fragment for searching for packages the provided agent or agents
2277 can use, either via part_pkg.agentnum directly, or via agent type (see
2282 sub agent_pkgs_sql {
2283 my $class = shift; #i'm a class method, not a sub (the question is... why??)
2284 my @agentnums = map { ref($_) ? $_->agentnum : $_ } @_;
2286 $class->_pkgs_sql(@agentnums); #is this why
2291 my( $class, @agentnums ) = @_;
2292 my $agentnums = join(',', @agentnums);
2296 ( agentnum IS NOT NULL AND agentnum IN ($agentnums) )
2297 OR ( agentnum IS NULL
2298 AND EXISTS ( SELECT 1
2300 LEFT JOIN agent_type USING ( typenum )
2301 LEFT JOIN agent AS typeagent USING ( typenum )
2302 WHERE type_pkgs.pkgpart = part_pkg.pkgpart
2303 AND typeagent.agentnum IN ($agentnums)
2321 #false laziness w/part_export & cdr
2323 foreach my $INC ( @INC ) {
2324 warn "globbing $INC/FS/part_pkg/[a-z]*.pm\n" if $DEBUG;
2325 foreach my $file ( glob("$INC/FS/part_pkg/[a-z]*.pm") ) {
2326 warn "attempting to load plan info from $file\n" if $DEBUG;
2327 $file =~ /\/(\w+)\.pm$/ or do {
2328 warn "unrecognized file in $INC/FS/part_pkg/: $file\n";
2332 my $info = eval "use FS::part_pkg::$mod; ".
2333 "\\%FS::part_pkg::$mod\::info;";
2335 die "error using FS::part_pkg::$mod (skipping): $@\n" if $@;
2338 unless ( keys %$info ) {
2339 warn "no %info hash found in FS::part_pkg::$mod, skipping\n";
2342 warn "got plan info from FS::part_pkg::$mod: $info\n" if $DEBUG;
2343 #if ( exists($info->{'disabled'}) && $info->{'disabled'} ) {
2344 # warn "skipping disabled plan FS::part_pkg::$mod" if $DEBUG;
2347 $info{$mod} = $info;
2348 $info->{'weight'} ||= 0; # quiet warnings
2352 # copy one level deep to allow replacement of fields and fieldorder
2353 tie %plans, 'Tie::IxHash',
2354 map { my %infohash = %{ $info{$_} };
2356 sort { $info{$a}->{'weight'} <=> $info{$b}->{'weight'} }
2359 # inheritance of plan options
2360 foreach my $name (keys(%info)) {
2361 if (exists($info{$name}->{'disabled'}) and $info{$name}->{'disabled'}) {
2362 warn "skipping disabled plan FS::part_pkg::$name" if $DEBUG;
2363 delete $plans{$name};
2366 my $parents = $info{$name}->{'inherit_fields'} || [];
2367 my (%fields, %field_exists, @fieldorder);
2368 foreach my $parent ($name, @$parents) {
2369 if ( !exists($info{$parent}) ) {
2370 warn "$name tried to inherit from nonexistent '$parent'\n";
2373 %fields = ( # avoid replacing existing fields
2374 %{ $info{$parent}->{'fields'} || {} },
2377 foreach (@{ $info{$parent}->{'fieldorder'} || [] }) {
2379 next if $field_exists{$_};
2380 $field_exists{$_} = 1;
2381 # allow inheritors to remove inherited fields from the fieldorder
2382 push @fieldorder, $_ if !exists($fields{$_}) or
2383 !exists($fields{$_}->{'disabled'});
2386 $plans{$name}->{'fields'} = \%fields;
2387 $plans{$name}->{'fieldorder'} = \@fieldorder;
2397 =head1 NEW PLAN CLASSES
2399 A module should be added in FS/FS/part_pkg/ Eventually, an example may be
2400 found in eg/plan_template.pm. Until then, it is suggested that you use the
2401 other modules in FS/FS/part_pkg/ as a guide.
2405 The delete method is unimplemented.
2407 setup and recur semantics are not yet defined (and are implemented in
2408 FS::cust_bill. hmm.). now they're deprecated and need to go.
2412 part_pkg_taxrate is Pg specific
2414 replace should be smarter about managing the related tables (options, pkg_svc)
2418 L<FS::Record>, L<FS::cust_pkg>, L<FS::type_pkgs>, L<FS::pkg_svc>, L<Safe>.
2419 schema.html from the base documentation.