4 use vars qw(@ISA $disable_agentcheck $DEBUG);
5 use Scalar::Util qw( blessed );
6 use List::Util qw(max);
8 use FS::UID qw( getotaker dbh );
9 use FS::Misc qw( send_email );
10 use FS::Record qw( qsearch qsearchs );
12 use FS::cust_main_Mixin;
18 use FS::cust_bill_pkg;
23 use FS::cust_pkg_reason;
27 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
29 # because they load configuration by setting FS::UID::callback (see TODO)
35 # for sending cancel emails in sub cancel
38 @ISA = qw( FS::m2m_Common FS::cust_main_Mixin FS::option_Common FS::Record );
42 $disable_agentcheck = 0;
46 my ( $hashref, $cache ) = @_;
47 #if ( $hashref->{'pkgpart'} ) {
48 if ( $hashref->{'pkg'} ) {
49 # #@{ $self->{'_pkgnum'} } = ();
50 # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
51 # $self->{'_pkgpart'} = $subcache;
52 # #push @{ $self->{'_pkgnum'} },
53 # FS::part_pkg->new_or_cached($hashref, $subcache);
54 $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
56 if ( exists $hashref->{'svcnum'} ) {
57 #@{ $self->{'_pkgnum'} } = ();
58 my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
59 $self->{'_svcnum'} = $subcache;
60 #push @{ $self->{'_pkgnum'} },
61 FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
67 FS::cust_pkg - Object methods for cust_pkg objects
73 $record = new FS::cust_pkg \%hash;
74 $record = new FS::cust_pkg { 'column' => 'value' };
76 $error = $record->insert;
78 $error = $new_record->replace($old_record);
80 $error = $record->delete;
82 $error = $record->check;
84 $error = $record->cancel;
86 $error = $record->suspend;
88 $error = $record->unsuspend;
90 $part_pkg = $record->part_pkg;
92 @labels = $record->labels;
94 $seconds = $record->seconds_since($timestamp);
96 $error = FS::cust_pkg::order( $custnum, \@pkgparts );
97 $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
101 An FS::cust_pkg object represents a customer billing item. FS::cust_pkg
102 inherits from FS::Record. The following fields are currently supported:
106 =item pkgnum - primary key (assigned automatically for new billing items)
108 =item custnum - Customer (see L<FS::cust_main>)
110 =item pkgpart - Billing item definition (see L<FS::part_pkg>)
114 =item bill - date (next bill date)
116 =item last_bill - last bill date
126 =item otaker - order taker (assigned automatically if null, see L<FS::UID>)
128 =item manual_flag - If this field is set to 1, disables the automatic
129 unsuspension of this package when using the B<unsuspendauto> config file.
131 =item quantity - If not set, defaults to 1
135 Note: setup, bill, adjourn, susp, expire and cancel are specified as UNIX timestamps;
136 see L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for
137 conversion functions.
145 Create a new billing item. To add the item to the database, see L<"insert">.
149 sub table { 'cust_pkg'; }
150 sub cust_linked { $_[0]->cust_main_custnum; }
151 sub cust_unlinked_msg {
153 "WARNING: can't find cust_main.custnum ". $self->custnum.
154 ' (cust_pkg.pkgnum '. $self->pkgnum. ')';
157 =item insert [ OPTION => VALUE ... ]
159 Adds this billing item to the database ("Orders" the item). If there is an
160 error, returns the error, otherwise returns false.
162 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
163 will be used to look up the package definition and agent restrictions will be
166 If the additional field I<refnum> is defined, an FS::pkg_referral record will
167 be created and inserted. Multiple FS::pkg_referral records can be created by
168 setting I<refnum> to an array reference of refnums or a hash reference with
169 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
170 record will be created corresponding to cust_main.refnum.
172 The following options are available: I<change>
174 I<change>, if set true, supresses any referral credit to a referring customer.
179 my( $self, %options ) = @_;
181 local $SIG{HUP} = 'IGNORE';
182 local $SIG{INT} = 'IGNORE';
183 local $SIG{QUIT} = 'IGNORE';
184 local $SIG{TERM} = 'IGNORE';
185 local $SIG{TSTP} = 'IGNORE';
186 local $SIG{PIPE} = 'IGNORE';
188 my $oldAutoCommit = $FS::UID::AutoCommit;
189 local $FS::UID::AutoCommit = 0;
192 my $error = $self->SUPER::insert($options{options} ? %{$options{options}} : ());
194 $dbh->rollback if $oldAutoCommit;
198 $self->refnum($self->cust_main->refnum) unless $self->refnum;
199 $self->refnum( [ $self->refnum ] ) unless ref($self->refnum);
200 $self->process_m2m( 'link_table' => 'pkg_referral',
201 'target_table' => 'part_referral',
202 'params' => $self->refnum,
205 #if ( $self->reg_code ) {
206 # my $reg_code = qsearchs('reg_code', { 'code' => $self->reg_code } );
207 # $error = $reg_code->delete;
209 # $dbh->rollback if $oldAutoCommit;
214 my $conf = new FS::Conf;
215 my $cust_main = $self->cust_main;
216 my $part_pkg = $self->part_pkg;
217 if ( $conf->exists('referral_credit')
218 && $cust_main->referral_custnum
219 && ! $options{'change'}
220 && $part_pkg->freq !~ /^0\D?$/
223 my $referring_cust_main = $cust_main->referring_cust_main;
224 if ( $referring_cust_main->status ne 'cancelled' ) {
226 if ( $part_pkg->freq !~ /^\d+$/ ) {
227 warn 'WARNING: Not crediting customer '. $cust_main->referral_custnum.
228 ' for package '. $self->pkgnum.
229 ' ( customer '. $self->custnum. ')'.
230 ' - One-time referral credits not (yet) available for '.
231 ' packages with '. $part_pkg->freq_pretty. ' frequency';
234 my $amount = sprintf( "%.2f", $part_pkg->base_recur / $part_pkg->freq );
236 $referring_cust_main->
238 'Referral credit for '.$cust_main->name,
239 'reason_type' => $conf->config('referral_credit_type')
242 $dbh->rollback if $oldAutoCommit;
243 return "Error crediting customer ". $cust_main->referral_custnum.
244 " for referral: $error";
252 if ($conf->config('welcome_letter') && $self->cust_main->num_pkgs == 1) {
253 my $queue = new FS::queue {
254 'job' => 'FS::cust_main::queueable_print',
256 $error = $queue->insert(
257 'custnum' => $self->custnum,
258 'template' => 'welcome_letter',
262 warn "can't send welcome letter: $error";
267 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
274 This method now works but you probably shouldn't use it.
276 You don't want to delete billing items, because there would then be no record
277 the customer ever purchased the item. Instead, see the cancel method.
282 # return "Can't delete cust_pkg records!";
285 =item replace OLD_RECORD
287 Replaces the OLD_RECORD with this one in the database. If there is an error,
288 returns the error, otherwise returns false.
290 Currently, custnum, setup, bill, adjourn, susp, expire, and cancel may be changed.
292 Changing pkgpart may have disasterous effects. See the order subroutine.
294 setup and bill are normally updated by calling the bill method of a customer
295 object (see L<FS::cust_main>).
297 suspend is normally updated by the suspend and unsuspend methods.
299 cancel is normally updated by the cancel method (and also the order subroutine
309 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
314 ( ref($_[0]) eq 'HASH' )
318 #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
319 return "Can't change otaker!" if $old->otaker ne $new->otaker;
322 #return "Can't change setup once it exists!"
323 # if $old->getfield('setup') &&
324 # $old->getfield('setup') != $new->getfield('setup');
326 #some logic for bill, susp, cancel?
328 local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
330 local $SIG{HUP} = 'IGNORE';
331 local $SIG{INT} = 'IGNORE';
332 local $SIG{QUIT} = 'IGNORE';
333 local $SIG{TERM} = 'IGNORE';
334 local $SIG{TSTP} = 'IGNORE';
335 local $SIG{PIPE} = 'IGNORE';
337 my $oldAutoCommit = $FS::UID::AutoCommit;
338 local $FS::UID::AutoCommit = 0;
341 foreach my $method ( qw(adjourn expire) ) { # How many reasons?
342 if ($options->{'reason'} && $new->$method && $old->$method ne $new->$method) {
343 my $error = $new->insert_reason( 'reason' => $options->{'reason'},
344 'date' => $new->$method,
346 'reason_otaker' => $options{'reason_otaker'},
349 dbh->rollback if $oldAutoCommit;
350 return "Error inserting cust_pkg_reason: $error";
355 #save off and freeze RADIUS attributes for any associated svc_acct records
357 if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
359 #also check for specific exports?
360 # to avoid spurious modify export events
361 @svc_acct = map { $_->svc_x }
362 grep { $_->part_svc->svcdb eq 'svc_acct' }
365 $_->snapshot foreach @svc_acct;
369 my $error = $new->SUPER::replace($old,
370 $options->{options} ? $options->{options} : ()
373 $dbh->rollback if $oldAutoCommit;
377 #for prepaid packages,
378 #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
379 foreach my $old_svc_acct ( @svc_acct ) {
380 my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
381 my $s_error = $new_svc_acct->replace($old_svc_acct);
383 $dbh->rollback if $oldAutoCommit;
388 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
395 Checks all fields to make sure this is a valid billing item. If there is an
396 error, returns the error, otherwise returns false. Called by the insert and
405 $self->ut_numbern('pkgnum')
406 || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
407 || $self->ut_numbern('pkgpart')
408 || $self->ut_numbern('setup')
409 || $self->ut_numbern('bill')
410 || $self->ut_numbern('susp')
411 || $self->ut_numbern('cancel')
412 || $self->ut_numbern('adjourn')
413 || $self->ut_numbern('expire')
415 return $error if $error;
417 if ( $self->reg_code ) {
419 unless ( grep { $self->pkgpart == $_->pkgpart }
420 map { $_->reg_code_pkg }
421 qsearchs( 'reg_code', { 'code' => $self->reg_code,
422 'agentnum' => $self->cust_main->agentnum })
424 return "Unknown registration code";
427 } elsif ( $self->promo_code ) {
430 qsearchs('part_pkg', {
431 'pkgpart' => $self->pkgpart,
432 'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
434 return 'Unknown promotional code' unless $promo_part_pkg;
438 unless ( $disable_agentcheck ) {
440 qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
441 my $pkgpart_href = $agent->pkgpart_hashref;
442 return "agent ". $agent->agentnum.
443 " can't purchase pkgpart ". $self->pkgpart
444 unless $pkgpart_href->{ $self->pkgpart };
447 $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
448 return $error if $error;
452 $self->otaker(getotaker) unless $self->otaker;
453 $self->otaker =~ /^(\w{1,32})$/ or return "Illegal otaker";
456 if ( $self->dbdef_table->column('manual_flag') ) {
457 $self->manual_flag('') if $self->manual_flag eq ' ';
458 $self->manual_flag =~ /^([01]?)$/
459 or return "Illegal manual_flag ". $self->manual_flag;
460 $self->manual_flag($1);
466 =item cancel [ OPTION => VALUE ... ]
468 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
469 in this package, then cancels the package itself (sets the cancel field to
472 Available options are:
476 =item quiet - can be set true to supress email cancellation notices.
478 =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.
480 =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.
482 =item date - can be set to a unix style timestamp to specify when to cancel (expire)
486 If there is an error, returns the error, otherwise returns false.
491 my( $self, %options ) = @_;
494 warn "cust_pkg::cancel called with options".
495 join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
498 local $SIG{HUP} = 'IGNORE';
499 local $SIG{INT} = 'IGNORE';
500 local $SIG{QUIT} = 'IGNORE';
501 local $SIG{TERM} = 'IGNORE';
502 local $SIG{TSTP} = 'IGNORE';
503 local $SIG{PIPE} = 'IGNORE';
505 my $oldAutoCommit = $FS::UID::AutoCommit;
506 local $FS::UID::AutoCommit = 0;
509 my $old = $self->select_for_update;
511 if ( $old->get('cancel') || $self->get('cancel') ) {
512 dbh->rollback if $oldAutoCommit;
513 return ""; # no error
516 my $date = $options{date} if $options{date}; # expire/cancel later
517 $date = '' if ($date && $date <= time); # complain instead?
519 my $cancel_time = $options{'time'} || time;
521 if ( $options{'reason'} ) {
522 $error = $self->insert_reason( 'reason' => $options{'reason'},
523 'action' => $date ? 'expire' : 'cancel',
524 'reason_otaker' => $options{'reason_otaker'},
527 dbh->rollback if $oldAutoCommit;
528 return "Error inserting cust_pkg_reason: $error";
534 foreach my $cust_svc (
537 sort { $a->[1] <=> $b->[1] }
538 map { [ $_, $_->svc_x->table_info->{'cancel_weight'} ]; }
539 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
542 my $error = $cust_svc->cancel;
545 $dbh->rollback if $oldAutoCommit;
546 return "Error cancelling cust_svc: $error";
550 # Add a credit for remaining service
551 my $remaining_value = $self->calc_remain(time=>$cancel_time);
552 if ( $remaining_value > 0 && !$options{'no_credit'} ) {
553 my $conf = new FS::Conf;
554 my $error = $self->cust_main->credit(
556 'Credit for unused time on '. $self->part_pkg->pkg,
557 'reason_type' => $conf->config('cancel_credit_type'),
560 $dbh->rollback if $oldAutoCommit;
561 return "Error crediting customer \$$remaining_value for unused time on".
562 $self->part_pkg->pkg. ": $error";
567 my %hash = $self->hash;
568 $date ? ($hash{'expire'} = $date) : ($hash{'cancel'} = $cancel_time);
569 my $new = new FS::cust_pkg ( \%hash );
570 $error = $new->replace( $self, options => { $self->options } );
572 $dbh->rollback if $oldAutoCommit;
576 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
577 return '' if $date; #no errors
579 my $conf = new FS::Conf;
580 my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
581 if ( !$options{'quiet'} && $conf->exists('emailcancel') && @invoicing_list ) {
582 my $conf = new FS::Conf;
583 my $error = send_email(
584 'from' => $conf->config('invoice_from'),
585 'to' => \@invoicing_list,
586 'subject' => ( $conf->config('cancelsubject') || 'Cancellation Notice' ),
587 'body' => [ map "$_\n", $conf->config('cancelmessage') ],
589 #should this do something on errors?
596 =item cancel_if_expired [ NOW_TIMESTAMP ]
598 Cancels this package if its expire date has been reached.
602 sub cancel_if_expired {
604 my $time = shift || time;
605 return '' unless $self->expire && $self->expire <= $time;
606 my $error = $self->cancel;
608 return "Error cancelling expired pkg ". $self->pkgnum. " for custnum ".
609 $self->custnum. ": $error";
616 Cancels any pending expiration (sets the expire field to null).
618 If there is an error, returns the error, otherwise returns false.
623 my( $self, %options ) = @_;
626 local $SIG{HUP} = 'IGNORE';
627 local $SIG{INT} = 'IGNORE';
628 local $SIG{QUIT} = 'IGNORE';
629 local $SIG{TERM} = 'IGNORE';
630 local $SIG{TSTP} = 'IGNORE';
631 local $SIG{PIPE} = 'IGNORE';
633 my $oldAutoCommit = $FS::UID::AutoCommit;
634 local $FS::UID::AutoCommit = 0;
637 my $old = $self->select_for_update;
639 my $pkgnum = $old->pkgnum;
640 if ( $old->get('cancel') || $self->get('cancel') ) {
641 dbh->rollback if $oldAutoCommit;
642 return "Can't unexpire cancelled package $pkgnum";
643 # or at least it's pointless
646 unless ( $old->get('expire') && $self->get('expire') ) {
647 dbh->rollback if $oldAutoCommit;
648 return ""; # no error
651 my %hash = $self->hash;
652 $hash{'expire'} = '';
653 my $new = new FS::cust_pkg ( \%hash );
654 $error = $new->replace( $self, options => { $self->options } );
656 $dbh->rollback if $oldAutoCommit;
660 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
666 =item suspend [ OPTION => VALUE ... ]
668 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
669 package, then suspends the package itself (sets the susp field to now).
671 Available options are:
675 =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.
677 =item date - can be set to a unix style timestamp to specify when to suspend (adjourn)
681 If there is an error, returns the error, otherwise returns false.
686 my( $self, %options ) = @_;
689 local $SIG{HUP} = 'IGNORE';
690 local $SIG{INT} = 'IGNORE';
691 local $SIG{QUIT} = 'IGNORE';
692 local $SIG{TERM} = 'IGNORE';
693 local $SIG{TSTP} = 'IGNORE';
694 local $SIG{PIPE} = 'IGNORE';
696 my $oldAutoCommit = $FS::UID::AutoCommit;
697 local $FS::UID::AutoCommit = 0;
700 my $old = $self->select_for_update;
702 my $pkgnum = $old->pkgnum;
703 if ( $old->get('cancel') || $self->get('cancel') ) {
704 dbh->rollback if $oldAutoCommit;
705 return "Can't suspend cancelled package $pkgnum";
708 if ( $old->get('susp') || $self->get('susp') ) {
709 dbh->rollback if $oldAutoCommit;
710 return ""; # no error # complain on adjourn?
713 my $date = $options{date} if $options{date}; # adjourn/suspend later
714 $date = '' if ($date && $date <= time); # complain instead?
716 if ( $date && $old->get('expire') && $old->get('expire') < $date ) {
717 dbh->rollback if $oldAutoCommit;
718 return "Package $pkgnum expires before it would be suspended.";
721 if ( $options{'reason'} ) {
722 $error = $self->insert_reason( 'reason' => $options{'reason'},
723 'action' => $date ? 'adjourn' : 'suspend',
724 'reason_otaker' => $options{'reason_otaker'},
727 dbh->rollback if $oldAutoCommit;
728 return "Error inserting cust_pkg_reason: $error";
733 foreach my $cust_svc (
734 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
736 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
738 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
739 $dbh->rollback if $oldAutoCommit;
740 return "Illegal svcdb value in part_svc!";
743 require "FS/$svcdb.pm";
745 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
747 $error = $svc->suspend;
749 $dbh->rollback if $oldAutoCommit;
756 my %hash = $self->hash;
757 $date ? ($hash{'adjourn'} = $date) : ($hash{'susp'} = time);
758 my $new = new FS::cust_pkg ( \%hash );
759 $error = $new->replace( $self, options => { $self->options } );
761 $dbh->rollback if $oldAutoCommit;
765 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
770 =item unsuspend [ OPTION => VALUE ... ]
772 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
773 package, then unsuspends the package itself (clears the susp field and the
774 adjourn field if it is in the past).
776 Available options are: I<adjust_next_bill>.
778 I<adjust_next_bill> can be set true to adjust the next bill date forward by
779 the amount of time the account was inactive. This was set true by default
780 since 1.4.2 and 1.5.0pre6; however, starting with 1.7.0 this needs to be
781 explicitly requested. Price plans for which this makes sense (anniversary-date
782 based than prorate or subscription) could have an option to enable this
785 If there is an error, returns the error, otherwise returns false.
790 my( $self, %opt ) = @_;
793 local $SIG{HUP} = 'IGNORE';
794 local $SIG{INT} = 'IGNORE';
795 local $SIG{QUIT} = 'IGNORE';
796 local $SIG{TERM} = 'IGNORE';
797 local $SIG{TSTP} = 'IGNORE';
798 local $SIG{PIPE} = 'IGNORE';
800 my $oldAutoCommit = $FS::UID::AutoCommit;
801 local $FS::UID::AutoCommit = 0;
804 my $old = $self->select_for_update;
806 my $pkgnum = $old->pkgnum;
807 if ( $old->get('cancel') || $self->get('cancel') ) {
808 dbh->rollback if $oldAutoCommit;
809 return "Can't unsuspend cancelled package $pkgnum";
812 unless ( $old->get('susp') && $self->get('susp') ) {
813 dbh->rollback if $oldAutoCommit;
814 return ""; # no error # complain instead?
817 foreach my $cust_svc (
818 qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
820 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
822 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
823 $dbh->rollback if $oldAutoCommit;
824 return "Illegal svcdb value in part_svc!";
827 require "FS/$svcdb.pm";
829 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
831 $error = $svc->unsuspend;
833 $dbh->rollback if $oldAutoCommit;
840 my %hash = $self->hash;
841 my $inactive = time - $hash{'susp'};
843 my $conf = new FS::Conf;
845 $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive
846 if ( $opt{'adjust_next_bill'}
847 || $conf->config('unsuspend-always_adjust_next_bill_date') )
848 && $inactive > 0 && ( $hash{'bill'} || $hash{'setup'} );
851 $hash{'adjourn'} = '' if $hash{'adjourn'} < time;
852 my $new = new FS::cust_pkg ( \%hash );
853 $error = $new->replace( $self, options => { $self->options } );
855 $dbh->rollback if $oldAutoCommit;
859 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
866 Cancels any pending suspension (sets the adjourn field to null).
868 If there is an error, returns the error, otherwise returns false.
873 my( $self, %options ) = @_;
876 local $SIG{HUP} = 'IGNORE';
877 local $SIG{INT} = 'IGNORE';
878 local $SIG{QUIT} = 'IGNORE';
879 local $SIG{TERM} = 'IGNORE';
880 local $SIG{TSTP} = 'IGNORE';
881 local $SIG{PIPE} = 'IGNORE';
883 my $oldAutoCommit = $FS::UID::AutoCommit;
884 local $FS::UID::AutoCommit = 0;
887 my $old = $self->select_for_update;
889 my $pkgnum = $old->pkgnum;
890 if ( $old->get('cancel') || $self->get('cancel') ) {
891 dbh->rollback if $oldAutoCommit;
892 return "Can't unadjourn cancelled package $pkgnum";
893 # or at least it's pointless
896 if ( $old->get('susp') || $self->get('susp') ) {
897 dbh->rollback if $oldAutoCommit;
898 return "Can't unadjourn suspended package $pkgnum";
899 # perhaps this is arbitrary
902 unless ( $old->get('adjourn') && $self->get('adjourn') ) {
903 dbh->rollback if $oldAutoCommit;
904 return ""; # no error
907 my %hash = $self->hash;
908 $hash{'adjourn'} = '';
909 my $new = new FS::cust_pkg ( \%hash );
910 $error = $new->replace( $self, options => { $self->options } );
912 $dbh->rollback if $oldAutoCommit;
916 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
924 Returns the last bill date, or if there is no last bill date, the setup date.
925 Useful for billing metered services.
931 return $self->setfield('last_bill', $_[0]) if @_;
932 return $self->getfield('last_bill') if $self->getfield('last_bill');
933 my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
934 'edate' => $self->bill, } );
935 $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
938 =item last_cust_pkg_reason ACTION
940 Returns the most recent ACTION FS::cust_pkg_reason associated with the package.
941 Returns false if there is no reason or the package is not currenly ACTION'd
942 ACTION is one of adjourn, susp, cancel, or expire.
946 sub last_cust_pkg_reason {
947 my ( $self, $action ) = ( shift, shift );
948 my $date = $self->get($action);
950 'table' => 'cust_pkg_reason',
951 'hashref' => { 'pkgnum' => $self->pkgnum,
952 'action' => substr(uc($action), 0, 1),
955 'order_by' => 'ORDER BY num DESC LIMIT 1',
959 =item last_reason ACTION
961 Returns the most recent ACTION FS::reason associated with the package.
962 Returns false if there is no reason or the package is not currenly ACTION'd
963 ACTION is one of adjourn, susp, cancel, or expire.
968 my $cust_pkg_reason = shift->last_cust_pkg_reason(@_);
969 $cust_pkg_reason->reason
975 Returns the definition for this billing item, as an FS::part_pkg object (see
982 #exists( $self->{'_pkgpart'} )
984 ? $self->{'_pkgpart'}
985 : qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
990 Returns the cancelled package this package was changed from, if any.
996 return '' unless $self->change_pkgnum;
997 qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
1002 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
1009 $self->part_pkg->calc_setup($self, @_);
1014 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
1021 $self->part_pkg->calc_recur($self, @_);
1026 Calls the I<calc_remain> of the FS::part_pkg object associated with this
1033 $self->part_pkg->calc_remain($self, @_);
1038 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
1045 $self->part_pkg->calc_cancel($self, @_);
1050 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
1056 qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
1061 Returns the new-style customer billing events (see L<FS::cust_event>) for this invoice.
1065 #false laziness w/cust_bill.pm
1069 'table' => 'cust_event',
1070 'addl_from' => 'JOIN part_event USING ( eventpart )',
1071 'hashref' => { 'tablenum' => $self->pkgnum },
1072 'extra_sql' => " AND eventtable = 'cust_pkg' ",
1076 =item num_cust_event
1078 Returns the number of new-style customer billing events (see L<FS::cust_event>) for this invoice.
1082 #false laziness w/cust_bill.pm
1083 sub num_cust_event {
1086 "SELECT COUNT(*) FROM cust_event JOIN part_event USING ( eventpart ) ".
1087 " WHERE tablenum = ? AND eventtable = 'cust_pkg'";
1088 my $sth = dbh->prepare($sql) or die dbh->errstr. " preparing $sql";
1089 $sth->execute($self->pkgnum) or die $sth->errstr. " executing $sql";
1090 $sth->fetchrow_arrayref->[0];
1093 =item cust_svc [ SVCPART ]
1095 Returns the services for this package, as FS::cust_svc objects (see
1096 L<FS::cust_svc>). If a svcpart is specified, return only the matching
1105 return qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum,
1106 'svcpart' => shift, } );
1109 #if ( $self->{'_svcnum'} ) {
1110 # values %{ $self->{'_svcnum'}->cache };
1112 $self->_sort_cust_svc(
1113 [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
1119 =item overlimit [ SVCPART ]
1121 Returns the services for this package which have exceeded their
1122 usage limit as FS::cust_svc objects (see L<FS::cust_svc>). If a svcpart
1123 is specified, return only the matching services.
1129 grep { $_->overlimit } $self->cust_svc;
1132 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ]
1134 Returns historical services for this package created before END TIMESTAMP and
1135 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
1136 (see L<FS::h_cust_svc>).
1143 $self->_sort_cust_svc(
1144 [ qsearch( 'h_cust_svc',
1145 { 'pkgnum' => $self->pkgnum, },
1146 FS::h_cust_svc->sql_h_search(@_),
1152 sub _sort_cust_svc {
1153 my( $self, $arrayref ) = @_;
1156 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
1158 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
1159 'svcpart' => $_->svcpart } );
1161 $pkg_svc ? $pkg_svc->primary_svc : '',
1162 $pkg_svc ? $pkg_svc->quantity : 0,
1169 =item num_cust_svc [ SVCPART ]
1171 Returns the number of provisioned services for this package. If a svcpart is
1172 specified, counts only the matching services.
1178 my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
1179 $sql .= ' AND svcpart = ?' if @_;
1180 my $sth = dbh->prepare($sql) or die dbh->errstr;
1181 $sth->execute($self->pkgnum, @_) or die $sth->errstr;
1182 $sth->fetchrow_arrayref->[0];
1185 =item available_part_svc
1187 Returns a list of FS::part_svc objects representing services included in this
1188 package but not yet provisioned. Each FS::part_svc object also has an extra
1189 field, I<num_avail>, which specifies the number of available services.
1193 sub available_part_svc {
1195 grep { $_->num_avail > 0 }
1197 my $part_svc = $_->part_svc;
1198 $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
1199 $_->quantity - $self->num_cust_svc($_->svcpart);
1202 $self->part_pkg->pkg_svc;
1207 Returns a list of FS::part_svc objects representing provisioned and available
1208 services included in this package. Each FS::part_svc object also has the
1209 following extra fields:
1213 =item num_cust_svc (count)
1215 =item num_avail (quantity - count)
1217 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
1220 label -> ($cust_svc->label)[1]
1229 #XXX some sort of sort order besides numeric by svcpart...
1230 my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
1232 my $part_svc = $pkg_svc->part_svc;
1233 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1234 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
1235 $part_svc->{'Hash'}{'num_avail'} =
1236 max( 0, $pkg_svc->quantity - $num_cust_svc );
1237 $part_svc->{'Hash'}{'cust_pkg_svc'} = [ $self->cust_svc($part_svc->svcpart) ];
1239 } $self->part_pkg->pkg_svc;
1242 push @part_svc, map {
1244 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1245 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
1246 $part_svc->{'Hash'}{'num_avail'} = 0; #0-$num_cust_svc ?
1247 $part_svc->{'Hash'}{'cust_pkg_svc'} = [ $self->cust_svc($part_svc->svcpart) ];
1249 } $self->extra_part_svc;
1255 =item extra_part_svc
1257 Returns a list of FS::part_svc objects corresponding to services in this
1258 package which are still provisioned but not (any longer) available in the
1263 sub extra_part_svc {
1266 my $pkgnum = $self->pkgnum;
1267 my $pkgpart = $self->pkgpart;
1270 'table' => 'part_svc',
1272 'extra_sql' => "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
1273 WHERE pkg_svc.svcpart = part_svc.svcpart
1274 AND pkg_svc.pkgpart = $pkgpart
1277 AND 0 < ( SELECT count(*)
1279 LEFT JOIN cust_pkg using ( pkgnum )
1280 WHERE cust_svc.svcpart = part_svc.svcpart
1281 AND pkgnum = $pkgnum
1288 Returns a short status string for this package, currently:
1292 =item not yet billed
1294 =item one-time charge
1309 my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
1311 return 'cancelled' if $self->get('cancel');
1312 return 'suspended' if $self->susp;
1313 return 'not yet billed' unless $self->setup;
1314 return 'one-time charge' if $freq =~ /^(0|$)/;
1320 Class method that returns the list of possible status strings for packages
1321 (see L<the status method|/status>). For example:
1323 @statuses = FS::cust_pkg->statuses();
1327 tie my %statuscolor, 'Tie::IxHash',
1328 'not yet billed' => '000000',
1329 'one-time charge' => '000000',
1330 'active' => '00CC00',
1331 'suspended' => 'FF9900',
1332 'cancelled' => 'FF0000',
1336 my $self = shift; #could be class...
1337 grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
1338 # mayble split btw one-time vs. recur
1344 Returns a hex triplet color string for this package's status.
1350 $statuscolor{$self->status};
1355 Returns a list of lists, calling the label method for all services
1356 (see L<FS::cust_svc>) of this billing item.
1362 map { [ $_->label ] } $self->cust_svc;
1365 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
1367 Like the labels method, but returns historical information on services that
1368 were active as of END_TIMESTAMP and (optionally) not cancelled before
1371 Returns a list of lists, calling the label method for all (historical) services
1372 (see L<FS::h_cust_svc>) of this billing item.
1378 map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
1381 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
1383 Like h_labels, except returns a simple flat list, and shortens long
1384 (currently >5) lists of identical services to one line that lists the service
1385 label and the number of individual services rather than individual items.
1389 sub h_labels_short {
1393 #tie %labels, 'Tie::IxHash';
1394 push @{ $labels{$_->[0]} }, $_->[1]
1395 foreach $self->h_labels(@_);
1397 foreach my $label ( keys %labels ) {
1398 my @values = @{ $labels{$label} };
1399 my $num = scalar(@values);
1401 push @labels, "$label ($num)";
1403 push @labels, map { "$label: $_" } @values;
1413 Returns the parent customer object (see L<FS::cust_main>).
1419 qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
1422 =item seconds_since TIMESTAMP
1424 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
1425 package have been online since TIMESTAMP, according to the session monitor.
1427 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1428 L<Time::Local> and L<Date::Parse> for conversion functions.
1433 my($self, $since) = @_;
1436 foreach my $cust_svc (
1437 grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
1439 $seconds += $cust_svc->seconds_since($since);
1446 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1448 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
1449 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
1452 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1453 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1459 sub seconds_since_sqlradacct {
1460 my($self, $start, $end) = @_;
1464 foreach my $cust_svc (
1466 my $part_svc = $_->part_svc;
1467 $part_svc->svcdb eq 'svc_acct'
1468 && scalar($part_svc->part_export('sqlradius'));
1471 $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
1478 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1480 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1481 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1485 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1486 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1491 sub attribute_since_sqlradacct {
1492 my($self, $start, $end, $attrib) = @_;
1496 foreach my $cust_svc (
1498 my $part_svc = $_->part_svc;
1499 $part_svc->svcdb eq 'svc_acct'
1500 && scalar($part_svc->part_export('sqlradius'));
1503 $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
1515 my( $self, $value ) = @_;
1516 if ( defined($value) ) {
1517 $self->setfield('quantity', $value);
1519 $self->getfield('quantity') || 1;
1522 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
1524 Transfers as many services as possible from this package to another package.
1526 The destination package can be specified by pkgnum by passing an FS::cust_pkg
1527 object. The destination package must already exist.
1529 Services are moved only if the destination allows services with the correct
1530 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true. Use
1531 this option with caution! No provision is made for export differences
1532 between the old and new service definitions. Probably only should be used
1533 when your exports for all service definitions of a given svcdb are identical.
1534 (attempt a transfer without it first, to move all possible svcpart-matching
1537 Any services that can't be moved remain in the original package.
1539 Returns an error, if there is one; otherwise, returns the number of services
1540 that couldn't be moved.
1545 my ($self, $dest_pkgnum, %opt) = @_;
1551 if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
1552 $dest = $dest_pkgnum;
1553 $dest_pkgnum = $dest->pkgnum;
1555 $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
1558 return ('Package does not exist: '.$dest_pkgnum) unless $dest;
1560 foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
1561 $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
1564 foreach my $cust_svc ($dest->cust_svc) {
1565 $target{$cust_svc->svcpart}--;
1568 my %svcpart2svcparts = ();
1569 if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1570 warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
1571 foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
1572 next if exists $svcpart2svcparts{$svcpart};
1573 my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
1574 $svcpart2svcparts{$svcpart} = [
1576 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
1578 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
1579 'svcpart' => $_ } );
1581 $pkg_svc ? $pkg_svc->primary_svc : '',
1582 $pkg_svc ? $pkg_svc->quantity : 0,
1586 grep { $_ != $svcpart }
1588 qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
1590 warn "alternates for svcpart $svcpart: ".
1591 join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
1596 foreach my $cust_svc ($self->cust_svc) {
1597 if($target{$cust_svc->svcpart} > 0) {
1598 $target{$cust_svc->svcpart}--;
1599 my $new = new FS::cust_svc { $cust_svc->hash };
1600 $new->pkgnum($dest_pkgnum);
1601 my $error = $new->replace($cust_svc);
1602 return $error if $error;
1603 } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1605 warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
1606 warn "alternates to consider: ".
1607 join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
1609 my @alternate = grep {
1610 warn "considering alternate svcpart $_: ".
1611 "$target{$_} available in new package\n"
1614 } @{$svcpart2svcparts{$cust_svc->svcpart}};
1616 warn "alternate(s) found\n" if $DEBUG;
1617 my $change_svcpart = $alternate[0];
1618 $target{$change_svcpart}--;
1619 my $new = new FS::cust_svc { $cust_svc->hash };
1620 $new->svcpart($change_svcpart);
1621 $new->pkgnum($dest_pkgnum);
1622 my $error = $new->replace($cust_svc);
1623 return $error if $error;
1636 This method is deprecated. See the I<depend_jobnum> option to the insert and
1637 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
1644 local $SIG{HUP} = 'IGNORE';
1645 local $SIG{INT} = 'IGNORE';
1646 local $SIG{QUIT} = 'IGNORE';
1647 local $SIG{TERM} = 'IGNORE';
1648 local $SIG{TSTP} = 'IGNORE';
1649 local $SIG{PIPE} = 'IGNORE';
1651 my $oldAutoCommit = $FS::UID::AutoCommit;
1652 local $FS::UID::AutoCommit = 0;
1655 foreach my $cust_svc ( $self->cust_svc ) {
1656 #false laziness w/svc_Common::insert
1657 my $svc_x = $cust_svc->svc_x;
1658 foreach my $part_export ( $cust_svc->part_svc->part_export ) {
1659 my $error = $part_export->export_insert($svc_x);
1661 $dbh->rollback if $oldAutoCommit;
1667 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1674 =head1 CLASS METHODS
1680 Returns an SQL expression identifying recurring packages.
1684 sub recurring_sql { "
1685 '0' != ( select freq from part_pkg
1686 where cust_pkg.pkgpart = part_pkg.pkgpart )
1691 Returns an SQL expression identifying one-time packages.
1696 '0' = ( select freq from part_pkg
1697 where cust_pkg.pkgpart = part_pkg.pkgpart )
1702 Returns an SQL expression identifying active packages.
1707 ". $_[0]->recurring_sql(). "
1708 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1709 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
1714 Returns an SQL expression identifying inactive packages (one-time packages
1715 that are otherwise unsuspended/uncancelled).
1719 sub inactive_sql { "
1720 ". $_[0]->onetime_sql(). "
1721 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1722 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
1728 Returns an SQL expression identifying suspended packages.
1732 sub suspended_sql { susp_sql(@_); }
1734 #$_[0]->recurring_sql(). ' AND '.
1736 ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1737 AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0
1744 Returns an SQL exprression identifying cancelled packages.
1748 sub cancelled_sql { cancel_sql(@_); }
1750 #$_[0]->recurring_sql(). ' AND '.
1751 "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
1754 =item search_sql HASHREF
1758 Returns a qsearch hash expression to search for parameters specified in HASHREF.
1759 Valid parameters are
1767 active, inactive, suspended, cancel (or cancelled)
1771 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
1781 arrayref of beginning and ending epoch date
1785 arrayref of beginning and ending epoch date
1789 arrayref of beginning and ending epoch date
1793 arrayref of beginning and ending epoch date
1797 arrayref of beginning and ending epoch date
1801 arrayref of beginning and ending epoch date
1805 arrayref of beginning and ending epoch date
1809 pkgnum or APKG_pkgnum
1813 a value suited to passing to FS::UI::Web::cust_header
1817 specifies the user for agent virtualization
1824 my ($class, $params) = @_;
1831 if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
1833 "cust_main.agentnum = $1";
1840 if ( $params->{'magic'} eq 'active'
1841 || $params->{'status'} eq 'active' ) {
1843 push @where, FS::cust_pkg->active_sql();
1845 } elsif ( $params->{'magic'} eq 'inactive'
1846 || $params->{'status'} eq 'inactive' ) {
1848 push @where, FS::cust_pkg->inactive_sql();
1850 } elsif ( $params->{'magic'} eq 'suspended'
1851 || $params->{'status'} eq 'suspended' ) {
1853 push @where, FS::cust_pkg->suspended_sql();
1855 } elsif ( $params->{'magic'} =~ /^cancell?ed$/
1856 || $params->{'status'} =~ /^cancell?ed$/ ) {
1858 push @where, FS::cust_pkg->cancelled_sql();
1860 } elsif ( $params->{'status'} =~ /^(one-time charge|inactive)$/ ) {
1862 push @where, FS::cust_pkg->inactive_sql();
1867 # parse package class
1870 #false lazinessish w/graph/cust_bill_pkg.cgi
1873 if ( exists($params->{'classnum'})
1874 && $params->{'classnum'} =~ /^(\d*)$/
1878 if ( $classnum ) { #a specific class
1879 push @where, "classnum = $classnum";
1881 #@pkg_class = ( qsearchs('pkg_class', { 'classnum' => $classnum } ) );
1882 #die "classnum $classnum not found!" unless $pkg_class[0];
1883 #$title .= $pkg_class[0]->classname.' ';
1885 } elsif ( $classnum eq '' ) { #the empty class
1887 push @where, "classnum IS NULL";
1888 #$title .= 'Empty class ';
1889 #@pkg_class = ( '(empty class)' );
1890 } elsif ( $classnum eq '0' ) {
1891 #@pkg_class = qsearch('pkg_class', {} ); # { 'disabled' => '' } );
1892 #push @pkg_class, '(empty class)';
1894 die "illegal classnum";
1903 my $pkgpart = join (' OR pkgpart=',
1904 grep {$_} map { /^(\d+)$/; } ($params->{'pkgpart'}));
1905 push @where, '(pkgpart=' . $pkgpart . ')' if $pkgpart;
1913 #false laziness w/report_cust_pkg.html
1916 'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
1917 'active' => { 'susp'=>1, 'cancel'=>1 },
1918 'suspended' => { 'cancel' => 1 },
1923 foreach my $field (qw( setup last_bill bill adjourn susp expire cancel )) {
1925 next unless exists($params->{$field});
1927 my($beginning, $ending) = @{$params->{$field}};
1929 next if $beginning == 0 && $ending == 4294967295;
1932 "cust_pkg.$field IS NOT NULL",
1933 "cust_pkg.$field >= $beginning",
1934 "cust_pkg.$field <= $ending";
1936 $orderby ||= "ORDER BY cust_pkg.$field";
1940 $orderby ||= 'ORDER BY bill';
1943 # parse magic, legacy, etc.
1946 if ( $params->{'magic'} &&
1947 $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
1950 $orderby = 'ORDER BY pkgnum';
1952 if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
1953 push @where, "pkgpart = $1";
1956 } elsif ( $params->{'query'} eq 'pkgnum' ) {
1958 $orderby = 'ORDER BY pkgnum';
1960 } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
1962 $orderby = 'ORDER BY pkgnum';
1965 SELECT count(*) FROM pkg_svc
1966 WHERE pkg_svc.pkgpart = cust_pkg.pkgpart
1967 AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
1968 WHERE cust_svc.pkgnum = cust_pkg.pkgnum
1969 AND cust_svc.svcpart = pkg_svc.svcpart
1976 # setup queries, links, subs, etc. for the search
1979 # here is the agent virtualization
1980 if ($params->{CurrentUser}) {
1982 qsearchs('access_user', { username => $params->{CurrentUser} });
1985 push @where, $access_user->agentnums_sql('table'=>'cust_main');
1990 push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
1993 my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
1995 my $addl_from = 'LEFT JOIN cust_main USING ( custnum ) '.
1996 'LEFT JOIN part_pkg USING ( pkgpart ) '.
1997 'LEFT JOIN pkg_class USING ( classnum ) ';
1999 my $count_query = "SELECT COUNT(*) FROM cust_pkg $addl_from $extra_sql";
2002 'table' => 'cust_pkg',
2004 'select' => join(', ',
2006 ( map "part_pkg.$_", qw( pkg freq ) ),
2007 'pkg_class.classname',
2008 'cust_main.custnum as cust_main_custnum',
2009 FS::UI::Web::cust_sql_fields(
2010 $params->{'cust_fields'}
2013 'extra_sql' => "$extra_sql $orderby",
2014 'addl_from' => $addl_from,
2015 'count_query' => $count_query,
2024 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
2026 CUSTNUM is a customer (see L<FS::cust_main>)
2028 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
2029 L<FS::part_pkg>) to order for this customer. Duplicates are of course
2032 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
2033 remove for this customer. The services (see L<FS::cust_svc>) are moved to the
2034 new billing items. An error is returned if this is not possible (see
2035 L<FS::pkg_svc>). An empty arrayref is equivalent to not specifying this
2038 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
2039 newly-created cust_pkg objects.
2041 REFNUM, if specified, will specify the FS::pkg_referral record to be created
2042 and inserted. Multiple FS::pkg_referral records can be created by
2043 setting I<refnum> to an array reference of refnums or a hash reference with
2044 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
2045 record will be created corresponding to cust_main.refnum.
2050 my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
2052 my $conf = new FS::Conf;
2054 # Transactionize this whole mess
2055 local $SIG{HUP} = 'IGNORE';
2056 local $SIG{INT} = 'IGNORE';
2057 local $SIG{QUIT} = 'IGNORE';
2058 local $SIG{TERM} = 'IGNORE';
2059 local $SIG{TSTP} = 'IGNORE';
2060 local $SIG{PIPE} = 'IGNORE';
2062 my $oldAutoCommit = $FS::UID::AutoCommit;
2063 local $FS::UID::AutoCommit = 0;
2067 my $cust_main = qsearchs('cust_main', { custnum => $custnum });
2068 return "Customer not found: $custnum" unless $cust_main;
2070 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
2073 my $change = scalar(@old_cust_pkg) != 0;
2076 if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
2080 #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( last_bill bill );
2082 #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( setup );
2083 $hash{'setup'} = $time if $old_cust_pkg[0]->setup;
2085 $hash{'change_date'} = $time;
2086 $hash{"change_$_"} = $old_cust_pkg[0]->$_() foreach qw( pkgnum pkgpart );
2089 # Create the new packages.
2090 foreach my $pkgpart (@$pkgparts) {
2091 my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
2092 pkgpart => $pkgpart,
2096 $error = $cust_pkg->insert( 'change' => $change );
2098 $dbh->rollback if $oldAutoCommit;
2101 push @$return_cust_pkg, $cust_pkg;
2103 # $return_cust_pkg now contains refs to all of the newly
2106 # Transfer services and cancel old packages.
2107 foreach my $old_pkg (@old_cust_pkg) {
2109 foreach my $new_pkg (@$return_cust_pkg) {
2110 $error = $old_pkg->transfer($new_pkg);
2111 if ($error and $error == 0) {
2112 # $old_pkg->transfer failed.
2113 $dbh->rollback if $oldAutoCommit;
2118 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
2119 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
2120 foreach my $new_pkg (@$return_cust_pkg) {
2121 $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
2122 if ($error and $error == 0) {
2123 # $old_pkg->transfer failed.
2124 $dbh->rollback if $oldAutoCommit;
2131 # Transfers were successful, but we went through all of the
2132 # new packages and still had services left on the old package.
2133 # We can't cancel the package under the circumstances, so abort.
2134 $dbh->rollback if $oldAutoCommit;
2135 return "Unable to transfer all services from package ".$old_pkg->pkgnum;
2137 $error = $old_pkg->cancel( quiet=>1 );
2143 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2149 Associates this package with a (suspension or cancellation) reason (see
2150 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
2153 Available options are:
2157 =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.
2163 If there is an error, returns the error, otherwise returns false.
2167 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
2169 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
2170 L<FS::part_pkg>) to order for this customer. Duplicates are of course
2173 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
2174 replace. The services (see L<FS::cust_svc>) are moved to the
2175 new billing items. An error is returned if this is not possible (see
2178 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
2179 newly-created cust_pkg objects.
2184 my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
2186 # Transactionize this whole mess
2187 local $SIG{HUP} = 'IGNORE';
2188 local $SIG{INT} = 'IGNORE';
2189 local $SIG{QUIT} = 'IGNORE';
2190 local $SIG{TERM} = 'IGNORE';
2191 local $SIG{TSTP} = 'IGNORE';
2192 local $SIG{PIPE} = 'IGNORE';
2194 my $oldAutoCommit = $FS::UID::AutoCommit;
2195 local $FS::UID::AutoCommit = 0;
2199 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
2202 while(scalar(@old_cust_pkg)) {
2204 my $custnum = $old_cust_pkg[0]->custnum;
2205 my (@remove) = map { $_->pkgnum }
2206 grep { $_->custnum == $custnum } @old_cust_pkg;
2207 @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
2209 my $error = order $custnum, $pkgparts, \@remove, \@return;
2211 push @errors, $error
2213 push @$return_cust_pkg, @return;
2216 if (scalar(@errors)) {
2217 $dbh->rollback if $oldAutoCommit;
2218 return join(' / ', @errors);
2221 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2226 my ($self, %options) = @_;
2228 my $otaker = $options{reason_otaker} ||
2229 $FS::CurrentUser::CurrentUser->username;
2232 if ( $options{'reason'} =~ /^(\d+)$/ ) {
2236 } elsif ( ref($options{'reason'}) ) {
2238 return 'Enter a new reason (or select an existing one)'
2239 unless $options{'reason'}->{'reason'} !~ /^\s*$/;
2241 my $reason = new FS::reason({
2242 'reason_type' => $options{'reason'}->{'typenum'},
2243 'reason' => $options{'reason'}->{'reason'},
2245 my $error = $reason->insert;
2246 return $error if $error;
2248 $reasonnum = $reason->reasonnum;
2251 return "Unparsable reason: ". $options{'reason'};
2254 my $cust_pkg_reason =
2255 new FS::cust_pkg_reason({ 'pkgnum' => $self->pkgnum,
2256 'reasonnum' => $reasonnum,
2257 'otaker' => $otaker,
2258 'action' => substr(uc($options{'action'}),0,1),
2259 'date' => $options{'date'}
2264 $cust_pkg_reason->insert;
2267 =item set_usage USAGE_VALUE_HASHREF
2269 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2270 to which they should be set (see L<FS::svc_acct>). Currently seconds,
2271 upbytes, downbytes, and totalbytes are appropriate keys.
2273 All svc_accts which are part of this package have their values reset.
2278 my ($self, $valueref) = @_;
2280 foreach my $cust_svc ($self->cust_svc){
2281 my $svc_x = $cust_svc->svc_x;
2282 $svc_x->set_usage($valueref)
2283 if $svc_x->can("set_usage");
2287 =item recharge USAGE_VALUE_HASHREF
2289 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2290 to which they should be set (see L<FS::svc_acct>). Currently seconds,
2291 upbytes, downbytes, and totalbytes are appropriate keys.
2293 All svc_accts which are part of this package have their values incremented.
2298 my ($self, $valueref) = @_;
2300 foreach my $cust_svc ($self->cust_svc){
2301 my $svc_x = $cust_svc->svc_x;
2302 $svc_x->recharge($valueref)
2303 if $svc_x->can("recharge");
2311 sub order is not OO. Perhaps it should be moved to FS::cust_main and made so?
2313 In sub order, the @pkgparts array (passed by reference) is clobbered.
2315 Also in sub order, no money is adjusted. Once FS::part_pkg defines a standard
2316 method to pass dates to the recur_prog expression, it should do so.
2318 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
2319 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
2320 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
2321 configuration values. Probably need a subroutine which decides what to do
2322 based on whether or not we've fetched the user yet, rather than a hash. See
2323 FS::UID and the TODO.
2325 Now that things are transactional should the check in the insert method be
2330 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
2331 L<FS::pkg_svc>, schema.html from the base documentation