4 use vars qw(@ISA $disable_agentcheck $DEBUG);
5 use List::Util qw(max);
7 use FS::UID qw( getotaker dbh );
8 use FS::Misc qw( send_email );
9 use FS::Record qw( qsearch qsearchs );
11 use FS::cust_main_Mixin;
17 use FS::cust_bill_pkg;
22 use FS::cust_pkg_reason;
25 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
27 # because they load configuration by setting FS::UID::callback (see TODO)
33 # for sending cancel emails in sub cancel
36 @ISA = qw( FS::m2m_Common FS::cust_main_Mixin FS::option_Common FS::Record );
40 $disable_agentcheck = 0;
44 my ( $hashref, $cache ) = @_;
45 #if ( $hashref->{'pkgpart'} ) {
46 if ( $hashref->{'pkg'} ) {
47 # #@{ $self->{'_pkgnum'} } = ();
48 # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
49 # $self->{'_pkgpart'} = $subcache;
50 # #push @{ $self->{'_pkgnum'} },
51 # FS::part_pkg->new_or_cached($hashref, $subcache);
52 $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
54 if ( exists $hashref->{'svcnum'} ) {
55 #@{ $self->{'_pkgnum'} } = ();
56 my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
57 $self->{'_svcnum'} = $subcache;
58 #push @{ $self->{'_pkgnum'} },
59 FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
65 FS::cust_pkg - Object methods for cust_pkg objects
71 $record = new FS::cust_pkg \%hash;
72 $record = new FS::cust_pkg { 'column' => 'value' };
74 $error = $record->insert;
76 $error = $new_record->replace($old_record);
78 $error = $record->delete;
80 $error = $record->check;
82 $error = $record->cancel;
84 $error = $record->suspend;
86 $error = $record->unsuspend;
88 $part_pkg = $record->part_pkg;
90 @labels = $record->labels;
92 $seconds = $record->seconds_since($timestamp);
94 $error = FS::cust_pkg::order( $custnum, \@pkgparts );
95 $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
99 An FS::cust_pkg object represents a customer billing item. FS::cust_pkg
100 inherits from FS::Record. The following fields are currently supported:
104 =item pkgnum - primary key (assigned automatically for new billing items)
106 =item custnum - Customer (see L<FS::cust_main>)
108 =item pkgpart - Billing item definition (see L<FS::part_pkg>)
112 =item bill - date (next bill date)
114 =item last_bill - last bill date
124 =item otaker - order taker (assigned automatically if null, see L<FS::UID>)
126 =item manual_flag - If this field is set to 1, disables the automatic
127 unsuspension of this package when using the B<unsuspendauto> config file.
131 Note: setup, bill, adjourn, susp, expire and cancel are specified as UNIX timestamps;
132 see L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for
133 conversion functions.
141 Create a new billing item. To add the item to the database, see L<"insert">.
145 sub table { 'cust_pkg'; }
146 sub cust_linked { $_[0]->cust_main_custnum; }
147 sub cust_unlinked_msg {
149 "WARNING: can't find cust_main.custnum ". $self->custnum.
150 ' (cust_pkg.pkgnum '. $self->pkgnum. ')';
153 =item insert [ OPTION => VALUE ... ]
155 Adds this billing item to the database ("Orders" the item). If there is an
156 error, returns the error, otherwise returns false.
158 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
159 will be used to look up the package definition and agent restrictions will be
162 If the additional field I<refnum> is defined, an FS::pkg_referral record will
163 be created and inserted. Multiple FS::pkg_referral records can be created by
164 setting I<refnum> to an array reference of refnums or a hash reference with
165 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
166 record will be created corresponding to cust_main.refnum.
168 The following options are available: I<change>
170 I<change>, if set true, supresses any referral credit to a referring customer.
175 my( $self, %options ) = @_;
177 local $SIG{HUP} = 'IGNORE';
178 local $SIG{INT} = 'IGNORE';
179 local $SIG{QUIT} = 'IGNORE';
180 local $SIG{TERM} = 'IGNORE';
181 local $SIG{TSTP} = 'IGNORE';
182 local $SIG{PIPE} = 'IGNORE';
184 my $oldAutoCommit = $FS::UID::AutoCommit;
185 local $FS::UID::AutoCommit = 0;
188 my $error = $self->SUPER::insert($options{options} ? %{$options{options}} : ());
190 $dbh->rollback if $oldAutoCommit;
194 $self->refnum($self->cust_main->refnum) unless $self->refnum;
195 $self->refnum( [ $self->refnum ] ) unless ref($self->refnum);
196 $self->process_m2m( 'link_table' => 'pkg_referral',
197 'target_table' => 'part_referral',
198 'params' => $self->refnum,
201 #if ( $self->reg_code ) {
202 # my $reg_code = qsearchs('reg_code', { 'code' => $self->reg_code } );
203 # $error = $reg_code->delete;
205 # $dbh->rollback if $oldAutoCommit;
210 my $conf = new FS::Conf;
211 my $cust_main = $self->cust_main;
212 my $part_pkg = $self->part_pkg;
213 if ( $conf->exists('referral_credit')
214 && $cust_main->referral_custnum
215 && ! $options{'change'}
216 && $part_pkg->freq !~ /^0\D?$/
219 my $referring_cust_main = $cust_main->referring_cust_main;
220 if ( $referring_cust_main->status ne 'cancelled' ) {
222 if ( $part_pkg->freq !~ /^\d+$/ ) {
223 warn 'WARNING: Not crediting customer '. $cust_main->referral_custnum.
224 ' for package '. $self->pkgnum.
225 ' ( customer '. $self->custnum. ')'.
226 ' - One-time referral credits not (yet) available for '.
227 ' packages with '. $part_pkg->freq_pretty. ' frequency';
230 my $amount = sprintf( "%.2f", $part_pkg->base_recur / $part_pkg->freq );
232 $referring_cust_main->credit( $amount,
233 'Referral credit for '. $cust_main->name
236 $dbh->rollback if $oldAutoCommit;
237 return "Error crediting customer ". $cust_main->referral_custnum.
238 " for referral: $error";
246 if ($conf->config('welcome_letter') && $self->cust_main->num_pkgs == 1) {
247 my $queue = new FS::queue {
248 'job' => 'FS::cust_main::queueable_print',
250 $error = $queue->insert(
251 'custnum' => $self->custnum,
252 'template' => 'welcome_letter',
256 warn "can't send welcome letter: $error";
261 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
268 This method now works but you probably shouldn't use it.
270 You don't want to delete billing items, because there would then be no record
271 the customer ever purchased the item. Instead, see the cancel method.
276 # return "Can't delete cust_pkg records!";
279 =item replace OLD_RECORD
281 Replaces the OLD_RECORD with this one in the database. If there is an error,
282 returns the error, otherwise returns false.
284 Currently, custnum, setup, bill, adjourn, susp, expire, and cancel may be changed.
286 Changing pkgpart may have disasterous effects. See the order subroutine.
288 setup and bill are normally updated by calling the bill method of a customer
289 object (see L<FS::cust_main>).
291 suspend is normally updated by the suspend and unsuspend methods.
293 cancel is normally updated by the cancel method (and also the order subroutine
301 my( $new, $old, %options ) = @_;
303 # We absolutely have to have an old vs. new record to make this work.
304 if (!defined($old)) {
305 $old = qsearchs( 'cust_pkg', { 'pkgnum' => $new->pkgnum } );
307 #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
308 return "Can't change otaker!" if $old->otaker ne $new->otaker;
311 #return "Can't change setup once it exists!"
312 # if $old->getfield('setup') &&
313 # $old->getfield('setup') != $new->getfield('setup');
315 #some logic for bill, susp, cancel?
317 local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
319 local $SIG{HUP} = 'IGNORE';
320 local $SIG{INT} = 'IGNORE';
321 local $SIG{QUIT} = 'IGNORE';
322 local $SIG{TERM} = 'IGNORE';
323 local $SIG{TSTP} = 'IGNORE';
324 local $SIG{PIPE} = 'IGNORE';
326 my $oldAutoCommit = $FS::UID::AutoCommit;
327 local $FS::UID::AutoCommit = 0;
330 foreach my $method ( qw(adjourn expire) ) { # How many reasons?
331 if ($options{'reason'} && $new->$method && $old->$method ne $new->$method) {
332 my $error = $new->insert_reason( 'reason' => $options{'reason'},
333 'date' => $new->$method,
336 dbh->rollback if $oldAutoCommit;
337 return "Error inserting cust_pkg_reason: $error";
342 #save off and freeze RADIUS attributes for any associated svc_acct records
344 if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
346 #also check for specific exports?
347 # to avoid spurious modify export events
348 @svc_acct = map { $_->svc_x }
349 grep { $_->part_svc->svcdb eq 'svc_acct' }
352 $_->snapshot foreach @svc_acct;
356 my $error = $new->SUPER::replace($old,
357 $options{options} ? ${options{options}} : ()
360 $dbh->rollback if $oldAutoCommit;
364 #for prepaid packages,
365 #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
366 foreach my $old_svc_acct ( @svc_acct ) {
367 my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
368 my $s_error = $new_svc_acct->replace($old_svc_acct);
370 $dbh->rollback if $oldAutoCommit;
375 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
382 Checks all fields to make sure this is a valid billing item. If there is an
383 error, returns the error, otherwise returns false. Called by the insert and
392 $self->ut_numbern('pkgnum')
393 || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
394 || $self->ut_numbern('pkgpart')
395 || $self->ut_numbern('setup')
396 || $self->ut_numbern('bill')
397 || $self->ut_numbern('susp')
398 || $self->ut_numbern('cancel')
399 || $self->ut_numbern('adjourn')
400 || $self->ut_numbern('expire')
402 return $error if $error;
404 if ( $self->reg_code ) {
406 unless ( grep { $self->pkgpart == $_->pkgpart }
407 map { $_->reg_code_pkg }
408 qsearchs( 'reg_code', { 'code' => $self->reg_code,
409 'agentnum' => $self->cust_main->agentnum })
411 return "Unknown registration code";
414 } elsif ( $self->promo_code ) {
417 qsearchs('part_pkg', {
418 'pkgpart' => $self->pkgpart,
419 'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
421 return 'Unknown promotional code' unless $promo_part_pkg;
425 unless ( $disable_agentcheck ) {
427 qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
428 my $pkgpart_href = $agent->pkgpart_hashref;
429 return "agent ". $agent->agentnum.
430 " can't purchase pkgpart ". $self->pkgpart
431 unless $pkgpart_href->{ $self->pkgpart };
434 $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
435 return $error if $error;
439 $self->otaker(getotaker) unless $self->otaker;
440 $self->otaker =~ /^(\w{1,32})$/ or return "Illegal otaker";
443 if ( $self->dbdef_table->column('manual_flag') ) {
444 $self->manual_flag('') if $self->manual_flag eq ' ';
445 $self->manual_flag =~ /^([01]?)$/
446 or return "Illegal manual_flag ". $self->manual_flag;
447 $self->manual_flag($1);
453 =item cancel [ OPTION => VALUE ... ]
455 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
456 in this package, then cancels the package itself (sets the cancel field to
459 Available options are:
463 =item quiet - can be set true to supress email cancellation notices.
465 =item time - can be set to cancel the package based on a specific future or historical date. Using time ensures that the remaining amount is calculated correctly. Note however that this is an immediate cancel and just changes the date. You are PROBABLY looking to expire the account instead of using this.
467 =item reason - can be set to a cancellation reason (see L<FS:reason>), either a reasonnum of an existing reason, or passing a hashref will create a new reason. The hashref should have the following keys: typenum - Reason type (see L<FS::reason_type>, reason - Text of the new reason.
471 If there is an error, returns the error, otherwise returns false.
476 my( $self, %options ) = @_;
478 warn "cust_pkg::cancel called with options".
479 join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
482 local $SIG{HUP} = 'IGNORE';
483 local $SIG{INT} = 'IGNORE';
484 local $SIG{QUIT} = 'IGNORE';
485 local $SIG{TERM} = 'IGNORE';
486 local $SIG{TSTP} = 'IGNORE';
487 local $SIG{PIPE} = 'IGNORE';
489 my $oldAutoCommit = $FS::UID::AutoCommit;
490 local $FS::UID::AutoCommit = 0;
493 my $cancel_time = $options{'time'} || time;
497 if ( $options{'reason'} ) {
498 $error = $self->insert_reason( 'reason' => $options{'reason'} );
500 dbh->rollback if $oldAutoCommit;
501 return "Error inserting cust_pkg_reason: $error";
506 foreach my $cust_svc (
509 sort { $a->[1] <=> $b->[1] }
510 map { [ $_, $_->svc_x->table_info->{'cancel_weight'} ]; }
511 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
514 my $error = $cust_svc->cancel;
517 $dbh->rollback if $oldAutoCommit;
518 return "Error cancelling cust_svc: $error";
522 unless ( $self->getfield('cancel') ) {
523 # Add a credit for remaining service
524 my $remaining_value = $self->calc_remain(time=>$cancel_time);
525 if ( $remaining_value > 0 && !$options{'no_credit'} ) {
526 my $error = $self->cust_main->credit(
528 'Credit for unused time on '. $self->part_pkg->pkg,
531 $dbh->rollback if $oldAutoCommit;
532 return "Error crediting customer \$$remaining_value for unused time on".
533 $self->part_pkg->pkg. ": $error";
536 my %hash = $self->hash;
537 $hash{'cancel'} = $cancel_time;
538 my $new = new FS::cust_pkg ( \%hash );
539 $error = $new->replace( $self, options => { $self->options } );
541 $dbh->rollback if $oldAutoCommit;
546 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
548 my $conf = new FS::Conf;
549 my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
550 if ( !$options{'quiet'} && $conf->exists('emailcancel') && @invoicing_list ) {
551 my $conf = new FS::Conf;
552 my $error = send_email(
553 'from' => $conf->config('invoice_from'),
554 'to' => \@invoicing_list,
555 'subject' => ( $conf->config('cancelsubject') || 'Cancellation Notice' ),
556 'body' => [ map "$_\n", $conf->config('cancelmessage') ],
558 #should this do something on errors?
565 =item cancel_if_expired [ NOW_TIMESTAMP ]
567 Cancels this package if its expire date has been reached.
571 sub cancel_if_expired {
573 my $time = shift || time;
574 return '' unless $self->expire && $self->expire <= $time;
575 my $error = $self->cancel;
577 return "Error cancelling expired pkg ". $self->pkgnum. " for custnum ".
578 $self->custnum. ": $error";
583 =item suspend [ OPTION => VALUE ... ]
585 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
586 package, then suspends the package itself (sets the susp field to now).
588 Available options are:
592 =item reason - can be set to a cancellation reason (see L<FS:reason>), either a reasonnum of an existing reason, or passing a hashref will create a new reason. The hashref should have the following keys: typenum - Reason type (see L<FS::reason_type>, reason - Text of the new reason.
596 If there is an error, returns the error, otherwise returns false.
601 my( $self, %options ) = @_;
603 local $SIG{HUP} = 'IGNORE';
604 local $SIG{INT} = 'IGNORE';
605 local $SIG{QUIT} = 'IGNORE';
606 local $SIG{TERM} = 'IGNORE';
607 local $SIG{TSTP} = 'IGNORE';
608 local $SIG{PIPE} = 'IGNORE';
610 my $oldAutoCommit = $FS::UID::AutoCommit;
611 local $FS::UID::AutoCommit = 0;
616 if ( $options{'reason'} ) {
617 $error = $self->insert_reason( 'reason' => $options{'reason'} );
619 dbh->rollback if $oldAutoCommit;
620 return "Error inserting cust_pkg_reason: $error";
624 foreach my $cust_svc (
625 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
627 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
629 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
630 $dbh->rollback if $oldAutoCommit;
631 return "Illegal svcdb value in part_svc!";
634 require "FS/$svcdb.pm";
636 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
638 $error = $svc->suspend;
640 $dbh->rollback if $oldAutoCommit;
647 unless ( $self->getfield('susp') ) {
648 my %hash = $self->hash;
649 $hash{'susp'} = time;
650 my $new = new FS::cust_pkg ( \%hash );
651 $error = $new->replace( $self, options => { $self->options } );
653 $dbh->rollback if $oldAutoCommit;
658 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
663 =item unsuspend [ OPTION => VALUE ... ]
665 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
666 package, then unsuspends the package itself (clears the susp field and the
667 adjourn field if it is in the past).
669 Available options are: I<adjust_next_bill>.
671 I<adjust_next_bill> can be set true to adjust the next bill date forward by
672 the amount of time the account was inactive. This was set true by default
673 since 1.4.2 and 1.5.0pre6; however, starting with 1.7.0 this needs to be
674 explicitly requested. Price plans for which this makes sense (anniversary-date
675 based than prorate or subscription) could have an option to enable this
678 If there is an error, returns the error, otherwise returns false.
683 my( $self, %opt ) = @_;
686 local $SIG{HUP} = 'IGNORE';
687 local $SIG{INT} = 'IGNORE';
688 local $SIG{QUIT} = 'IGNORE';
689 local $SIG{TERM} = 'IGNORE';
690 local $SIG{TSTP} = 'IGNORE';
691 local $SIG{PIPE} = 'IGNORE';
693 my $oldAutoCommit = $FS::UID::AutoCommit;
694 local $FS::UID::AutoCommit = 0;
697 foreach my $cust_svc (
698 qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
700 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
702 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
703 $dbh->rollback if $oldAutoCommit;
704 return "Illegal svcdb value in part_svc!";
707 require "FS/$svcdb.pm";
709 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
711 $error = $svc->unsuspend;
713 $dbh->rollback if $oldAutoCommit;
720 unless ( ! $self->getfield('susp') ) {
721 my %hash = $self->hash;
722 my $inactive = time - $hash{'susp'};
724 my $conf = new FS::Conf;
726 $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive
727 if ( $opt{'adjust_next_bill'}
728 || $conf->config('unsuspend-always_adjust_next_bill_date') )
729 && $inactive > 0 && ( $hash{'bill'} || $hash{'setup'} );
732 $hash{'adjourn'} = '' if $hash{'adjourn'} < time;
733 my $new = new FS::cust_pkg ( \%hash );
734 $error = $new->replace( $self, options => { $self->options } );
736 $dbh->rollback if $oldAutoCommit;
741 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
748 Returns the last bill date, or if there is no last bill date, the setup date.
749 Useful for billing metered services.
755 if ( $self->dbdef_table->column('last_bill') ) {
756 return $self->setfield('last_bill', $_[0]) if @_;
757 return $self->getfield('last_bill') if $self->getfield('last_bill');
759 my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
760 'edate' => $self->bill, } );
761 $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
766 Returns the most recent FS::reason associated with the package.
772 my $cust_pkg_reason = qsearchs( {
773 'table' => 'cust_pkg_reason',
774 'hashref' => { 'pkgnum' => $self->pkgnum, },
775 'extra_sql'=> 'ORDER BY date DESC LIMIT 1',
777 qsearchs ( 'reason', { 'reasonnum' => $cust_pkg_reason->reasonnum } )
783 Returns the definition for this billing item, as an FS::part_pkg object (see
790 #exists( $self->{'_pkgpart'} )
792 ? $self->{'_pkgpart'}
793 : qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
798 Returns the cancelled package this package was changed from, if any.
804 return '' unless $self->change_pkgnum;
805 qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
810 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
817 $self->part_pkg->calc_setup($self, @_);
822 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
829 $self->part_pkg->calc_recur($self, @_);
834 Calls the I<calc_remain> of the FS::part_pkg object associated with this
841 $self->part_pkg->calc_remain($self, @_);
846 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
853 $self->part_pkg->calc_cancel($self, @_);
858 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
864 qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
869 Returns the new-style customer billing events (see L<FS::cust_event>) for this invoice.
873 #false laziness w/cust_bill.pm
877 'table' => 'cust_event',
878 'addl_from' => 'JOIN part_event USING ( eventpart )',
879 'hashref' => { 'tablenum' => $self->pkgnum },
880 'extra_sql' => " AND eventtable = 'cust_pkg' ",
886 Returns the number of new-style customer billing events (see L<FS::cust_event>) for this invoice.
890 #false laziness w/cust_bill.pm
894 "SELECT COUNT(*) FROM cust_event JOIN part_event USING ( eventpart ) ".
895 " WHERE tablenum = ? AND eventtable = 'cust_pkg'";
896 my $sth = dbh->prepare($sql) or die dbh->errstr. " preparing $sql";
897 $sth->execute($self->pkgnum) or die $sth->errstr. " executing $sql";
898 $sth->fetchrow_arrayref->[0];
901 =item cust_svc [ SVCPART ]
903 Returns the services for this package, as FS::cust_svc objects (see
904 L<FS::cust_svc>). If a svcpart is specified, return only the matching
913 return qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum,
914 'svcpart' => shift, } );
917 #if ( $self->{'_svcnum'} ) {
918 # values %{ $self->{'_svcnum'}->cache };
920 $self->_sort_cust_svc(
921 [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
927 =item overlimit [ SVCPART ]
929 Returns the services for this package which have exceeded their
930 usage limit as FS::cust_svc objects (see L<FS::cust_svc>). If a svcpart
931 is specified, return only the matching services.
937 grep { $_->overlimit } $self->cust_svc;
940 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ]
942 Returns historical services for this package created before END TIMESTAMP and
943 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
944 (see L<FS::h_cust_svc>).
951 $self->_sort_cust_svc(
952 [ qsearch( 'h_cust_svc',
953 { 'pkgnum' => $self->pkgnum, },
954 FS::h_cust_svc->sql_h_search(@_),
961 my( $self, $arrayref ) = @_;
964 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
966 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
967 'svcpart' => $_->svcpart } );
969 $pkg_svc ? $pkg_svc->primary_svc : '',
970 $pkg_svc ? $pkg_svc->quantity : 0,
977 =item num_cust_svc [ SVCPART ]
979 Returns the number of provisioned services for this package. If a svcpart is
980 specified, counts only the matching services.
986 my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
987 $sql .= ' AND svcpart = ?' if @_;
988 my $sth = dbh->prepare($sql) or die dbh->errstr;
989 $sth->execute($self->pkgnum, @_) or die $sth->errstr;
990 $sth->fetchrow_arrayref->[0];
993 =item available_part_svc
995 Returns a list of FS::part_svc objects representing services included in this
996 package but not yet provisioned. Each FS::part_svc object also has an extra
997 field, I<num_avail>, which specifies the number of available services.
1001 sub available_part_svc {
1003 grep { $_->num_avail > 0 }
1005 my $part_svc = $_->part_svc;
1006 $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
1007 $_->quantity - $self->num_cust_svc($_->svcpart);
1010 $self->part_pkg->pkg_svc;
1015 Returns a list of FS::part_svc objects representing provisioned and available
1016 services included in this package. Each FS::part_svc object also has the
1017 following extra fields:
1021 =item num_cust_svc (count)
1023 =item num_avail (quantity - count)
1025 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
1028 label -> ($cust_svc->label)[1]
1037 #XXX some sort of sort order besides numeric by svcpart...
1038 my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
1040 my $part_svc = $pkg_svc->part_svc;
1041 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1042 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
1043 $part_svc->{'Hash'}{'num_avail'} =
1044 max( 0, $pkg_svc->quantity - $num_cust_svc );
1045 $part_svc->{'Hash'}{'cust_pkg_svc'} = [ $self->cust_svc($part_svc->svcpart) ];
1047 } $self->part_pkg->pkg_svc;
1050 push @part_svc, map {
1052 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1053 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
1054 $part_svc->{'Hash'}{'num_avail'} = 0; #0-$num_cust_svc ?
1055 $part_svc->{'Hash'}{'cust_pkg_svc'} = [ $self->cust_svc($part_svc->svcpart) ];
1057 } $self->extra_part_svc;
1063 =item extra_part_svc
1065 Returns a list of FS::part_svc objects corresponding to services in this
1066 package which are still provisioned but not (any longer) available in the
1071 sub extra_part_svc {
1074 my $pkgnum = $self->pkgnum;
1075 my $pkgpart = $self->pkgpart;
1078 'table' => 'part_svc',
1080 'extra_sql' => "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
1081 WHERE pkg_svc.svcpart = part_svc.svcpart
1082 AND pkg_svc.pkgpart = $pkgpart
1085 AND 0 < ( SELECT count(*)
1087 LEFT JOIN cust_pkg using ( pkgnum )
1088 WHERE cust_svc.svcpart = part_svc.svcpart
1089 AND pkgnum = $pkgnum
1096 Returns a short status string for this package, currently:
1100 =item not yet billed
1102 =item one-time charge
1117 my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
1119 return 'cancelled' if $self->get('cancel');
1120 return 'suspended' if $self->susp;
1121 return 'not yet billed' unless $self->setup;
1122 return 'one-time charge' if $freq =~ /^(0|$)/;
1128 Class method that returns the list of possible status strings for packages
1129 (see L<the status method|/status>). For example:
1131 @statuses = FS::cust_pkg->statuses();
1135 tie my %statuscolor, 'Tie::IxHash',
1136 'not yet billed' => '000000',
1137 'one-time charge' => '000000',
1138 'active' => '00CC00',
1139 'suspended' => 'FF9900',
1140 'cancelled' => 'FF0000',
1144 my $self = shift; #could be class...
1145 grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
1146 # mayble split btw one-time vs. recur
1152 Returns a hex triplet color string for this package's status.
1158 $statuscolor{$self->status};
1163 Returns a list of lists, calling the label method for all services
1164 (see L<FS::cust_svc>) of this billing item.
1170 map { [ $_->label ] } $self->cust_svc;
1173 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
1175 Like the labels method, but returns historical information on services that
1176 were active as of END_TIMESTAMP and (optionally) not cancelled before
1179 Returns a list of lists, calling the label method for all (historical) services
1180 (see L<FS::h_cust_svc>) of this billing item.
1186 map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
1189 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
1191 Like h_labels, except returns a simple flat list, and shortens long
1192 (currently >5) lists of identical services to one line that lists the service
1193 label and the number of individual services rather than individual items.
1197 sub h_labels_short {
1201 #tie %labels, 'Tie::IxHash';
1202 push @{ $labels{$_->[0]} }, $_->[1]
1203 foreach $self->h_labels(@_);
1205 foreach my $label ( keys %labels ) {
1206 my @values = @{ $labels{$label} };
1207 my $num = scalar(@values);
1209 push @labels, "$label ($num)";
1211 push @labels, map { "$label: $_" } @values;
1221 Returns the parent customer object (see L<FS::cust_main>).
1227 qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
1230 =item seconds_since TIMESTAMP
1232 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
1233 package have been online since TIMESTAMP, according to the session monitor.
1235 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1236 L<Time::Local> and L<Date::Parse> for conversion functions.
1241 my($self, $since) = @_;
1244 foreach my $cust_svc (
1245 grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
1247 $seconds += $cust_svc->seconds_since($since);
1254 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1256 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
1257 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
1260 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1261 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1267 sub seconds_since_sqlradacct {
1268 my($self, $start, $end) = @_;
1272 foreach my $cust_svc (
1274 my $part_svc = $_->part_svc;
1275 $part_svc->svcdb eq 'svc_acct'
1276 && scalar($part_svc->part_export('sqlradius'));
1279 $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
1286 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1288 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1289 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1293 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1294 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1299 sub attribute_since_sqlradacct {
1300 my($self, $start, $end, $attrib) = @_;
1304 foreach my $cust_svc (
1306 my $part_svc = $_->part_svc;
1307 $part_svc->svcdb eq 'svc_acct'
1308 && scalar($part_svc->part_export('sqlradius'));
1311 $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
1318 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
1320 Transfers as many services as possible from this package to another package.
1322 The destination package can be specified by pkgnum by passing an FS::cust_pkg
1323 object. The destination package must already exist.
1325 Services are moved only if the destination allows services with the correct
1326 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true. Use
1327 this option with caution! No provision is made for export differences
1328 between the old and new service definitions. Probably only should be used
1329 when your exports for all service definitions of a given svcdb are identical.
1330 (attempt a transfer without it first, to move all possible svcpart-matching
1333 Any services that can't be moved remain in the original package.
1335 Returns an error, if there is one; otherwise, returns the number of services
1336 that couldn't be moved.
1341 my ($self, $dest_pkgnum, %opt) = @_;
1347 if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
1348 $dest = $dest_pkgnum;
1349 $dest_pkgnum = $dest->pkgnum;
1351 $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
1354 return ('Package does not exist: '.$dest_pkgnum) unless $dest;
1356 foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
1357 $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
1360 foreach my $cust_svc ($dest->cust_svc) {
1361 $target{$cust_svc->svcpart}--;
1364 my %svcpart2svcparts = ();
1365 if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1366 warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
1367 foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
1368 next if exists $svcpart2svcparts{$svcpart};
1369 my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
1370 $svcpart2svcparts{$svcpart} = [
1372 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
1374 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
1375 'svcpart' => $_ } );
1377 $pkg_svc ? $pkg_svc->primary_svc : '',
1378 $pkg_svc ? $pkg_svc->quantity : 0,
1382 grep { $_ != $svcpart }
1384 qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
1386 warn "alternates for svcpart $svcpart: ".
1387 join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
1392 foreach my $cust_svc ($self->cust_svc) {
1393 if($target{$cust_svc->svcpart} > 0) {
1394 $target{$cust_svc->svcpart}--;
1395 my $new = new FS::cust_svc { $cust_svc->hash };
1396 $new->pkgnum($dest_pkgnum);
1397 my $error = $new->replace($cust_svc);
1398 return $error if $error;
1399 } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1401 warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
1402 warn "alternates to consider: ".
1403 join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
1405 my @alternate = grep {
1406 warn "considering alternate svcpart $_: ".
1407 "$target{$_} available in new package\n"
1410 } @{$svcpart2svcparts{$cust_svc->svcpart}};
1412 warn "alternate(s) found\n" if $DEBUG;
1413 my $change_svcpart = $alternate[0];
1414 $target{$change_svcpart}--;
1415 my $new = new FS::cust_svc { $cust_svc->hash };
1416 $new->svcpart($change_svcpart);
1417 $new->pkgnum($dest_pkgnum);
1418 my $error = $new->replace($cust_svc);
1419 return $error if $error;
1432 This method is deprecated. See the I<depend_jobnum> option to the insert and
1433 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
1440 local $SIG{HUP} = 'IGNORE';
1441 local $SIG{INT} = 'IGNORE';
1442 local $SIG{QUIT} = 'IGNORE';
1443 local $SIG{TERM} = 'IGNORE';
1444 local $SIG{TSTP} = 'IGNORE';
1445 local $SIG{PIPE} = 'IGNORE';
1447 my $oldAutoCommit = $FS::UID::AutoCommit;
1448 local $FS::UID::AutoCommit = 0;
1451 foreach my $cust_svc ( $self->cust_svc ) {
1452 #false laziness w/svc_Common::insert
1453 my $svc_x = $cust_svc->svc_x;
1454 foreach my $part_export ( $cust_svc->part_svc->part_export ) {
1455 my $error = $part_export->export_insert($svc_x);
1457 $dbh->rollback if $oldAutoCommit;
1463 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1470 =head1 CLASS METHODS
1476 Returns an SQL expression identifying recurring packages.
1480 sub recurring_sql { "
1481 '0' != ( select freq from part_pkg
1482 where cust_pkg.pkgpart = part_pkg.pkgpart )
1487 Returns an SQL expression identifying one-time packages.
1492 '0' = ( select freq from part_pkg
1493 where cust_pkg.pkgpart = part_pkg.pkgpart )
1498 Returns an SQL expression identifying active packages.
1503 ". $_[0]->recurring_sql(). "
1504 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1505 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
1510 Returns an SQL expression identifying inactive packages (one-time packages
1511 that are otherwise unsuspended/uncancelled).
1515 sub inactive_sql { "
1516 ". $_[0]->onetime_sql(). "
1517 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1518 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
1524 Returns an SQL expression identifying suspended packages.
1528 sub suspended_sql { susp_sql(@_); }
1530 #$_[0]->recurring_sql(). ' AND '.
1532 ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1533 AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0
1540 Returns an SQL exprression identifying cancelled packages.
1544 sub cancelled_sql { cancel_sql(@_); }
1546 #$_[0]->recurring_sql(). ' AND '.
1547 "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
1554 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
1556 CUSTNUM is a customer (see L<FS::cust_main>)
1558 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
1559 L<FS::part_pkg>) to order for this customer. Duplicates are of course
1562 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
1563 remove for this customer. The services (see L<FS::cust_svc>) are moved to the
1564 new billing items. An error is returned if this is not possible (see
1565 L<FS::pkg_svc>). An empty arrayref is equivalent to not specifying this
1568 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
1569 newly-created cust_pkg objects.
1571 REFNUM, if specified, will specify the FS::pkg_referral record to be created
1572 and inserted. Multiple FS::pkg_referral records can be created by
1573 setting I<refnum> to an array reference of refnums or a hash reference with
1574 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
1575 record will be created corresponding to cust_main.refnum.
1580 my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
1582 my $conf = new FS::Conf;
1584 # Transactionize this whole mess
1585 local $SIG{HUP} = 'IGNORE';
1586 local $SIG{INT} = 'IGNORE';
1587 local $SIG{QUIT} = 'IGNORE';
1588 local $SIG{TERM} = 'IGNORE';
1589 local $SIG{TSTP} = 'IGNORE';
1590 local $SIG{PIPE} = 'IGNORE';
1592 my $oldAutoCommit = $FS::UID::AutoCommit;
1593 local $FS::UID::AutoCommit = 0;
1597 my $cust_main = qsearchs('cust_main', { custnum => $custnum });
1598 return "Customer not found: $custnum" unless $cust_main;
1600 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
1603 my $change = scalar(@old_cust_pkg) != 0;
1606 if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
1610 #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( last_bill bill );
1612 #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( setup );
1613 $hash{'setup'} = $time if $old_cust_pkg[0]->setup;
1615 $hash{'change_date'} = $time;
1616 $hash{"change_$_"} = $old_cust_pkg[0]->$_() foreach qw( pkgnum pkgpart );
1619 # Create the new packages.
1620 foreach my $pkgpart (@$pkgparts) {
1621 my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
1622 pkgpart => $pkgpart,
1626 $error = $cust_pkg->insert( 'change' => $change );
1628 $dbh->rollback if $oldAutoCommit;
1631 push @$return_cust_pkg, $cust_pkg;
1633 # $return_cust_pkg now contains refs to all of the newly
1636 # Transfer services and cancel old packages.
1637 foreach my $old_pkg (@old_cust_pkg) {
1639 foreach my $new_pkg (@$return_cust_pkg) {
1640 $error = $old_pkg->transfer($new_pkg);
1641 if ($error and $error == 0) {
1642 # $old_pkg->transfer failed.
1643 $dbh->rollback if $oldAutoCommit;
1648 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1649 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1650 foreach my $new_pkg (@$return_cust_pkg) {
1651 $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
1652 if ($error and $error == 0) {
1653 # $old_pkg->transfer failed.
1654 $dbh->rollback if $oldAutoCommit;
1661 # Transfers were successful, but we went through all of the
1662 # new packages and still had services left on the old package.
1663 # We can't cancel the package under the circumstances, so abort.
1664 $dbh->rollback if $oldAutoCommit;
1665 return "Unable to transfer all services from package ".$old_pkg->pkgnum;
1667 $error = $old_pkg->cancel( quiet=>1 );
1673 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1679 Associates this package with a (suspension or cancellation) reason (see
1680 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
1683 Available options are:
1687 =item reason - can be set to a cancellation reason (see L<FS:reason>), either a reasonnum of an existing reason, or passing a hashref will create a new reason. The hashref should have the following keys: typenum - Reason type (see L<FS::reason_type>, reason - Text of the new reason.
1693 If there is an error, returns the error, otherwise returns false.
1698 my ($self, %options) = @_;
1700 my $otaker = $FS::CurrentUser::CurrentUser->username;
1703 if ( $options{'reason'} =~ /^(\d+)$/ ) {
1707 } elsif ( ref($options{'reason'}) ) {
1709 return 'Enter a new reason (or select an existing one)'
1710 unless $options{'reason'}->{'reason'} !~ /^\s*$/;
1712 my $reason = new FS::reason({
1713 'reason_type' => $options{'reason'}->{'typenum'},
1714 'reason' => $options{'reason'}->{'reason'},
1716 my $error = $reason->insert;
1717 return $error if $error;
1719 $reasonnum = $reason->reasonnum;
1722 return "Unparsable reason: ". $options{'reason'};
1725 my $cust_pkg_reason =
1726 new FS::cust_pkg_reason({ 'pkgnum' => $self->pkgnum,
1727 'reasonnum' => $reasonnum,
1728 'otaker' => $otaker,
1729 'date' => $options{'date'}
1734 $cust_pkg_reason->insert;
1737 =item set_usage USAGE_VALUE_HASHREF
1739 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
1740 to which they should be set (see L<FS::svc_acct>). Currently seconds,
1741 upbytes, downbytes, and totalbytes are appropriate keys.
1743 All svc_accts which are part of this package have their values reset.
1748 my ($self, $valueref) = @_;
1750 foreach my $cust_svc ($self->cust_svc){
1751 my $svc_x = $cust_svc->svc_x;
1752 $svc_x->set_usage($valueref)
1753 if $svc_x->can("set_usage");
1757 =item recharge USAGE_VALUE_HASHREF
1759 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
1760 to which they should be set (see L<FS::svc_acct>). Currently seconds,
1761 upbytes, downbytes, and totalbytes are appropriate keys.
1763 All svc_accts which are part of this package have their values incremented.
1768 my ($self, $valueref) = @_;
1770 foreach my $cust_svc ($self->cust_svc){
1771 my $svc_x = $cust_svc->svc_x;
1772 $svc_x->recharge($valueref)
1773 if $svc_x->can("recharge");
1781 sub order is not OO. Perhaps it should be moved to FS::cust_main and made so?
1783 In sub order, the @pkgparts array (passed by reference) is clobbered.
1785 Also in sub order, no money is adjusted. Once FS::part_pkg defines a standard
1786 method to pass dates to the recur_prog expression, it should do so.
1788 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
1789 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
1790 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
1791 configuration values. Probably need a subroutine which decides what to do
1792 based on whether or not we've fetched the user yet, rather than a hash. See
1793 FS::UID and the TODO.
1795 Now that things are transactional should the check in the insert method be
1800 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
1801 L<FS::pkg_svc>, schema.html from the base documentation