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:
178 If set true, supresses any referral credit to a referring customer.
182 cust_pkg_option records will be created
189 my( $self, %options ) = @_;
191 local $SIG{HUP} = 'IGNORE';
192 local $SIG{INT} = 'IGNORE';
193 local $SIG{QUIT} = 'IGNORE';
194 local $SIG{TERM} = 'IGNORE';
195 local $SIG{TSTP} = 'IGNORE';
196 local $SIG{PIPE} = 'IGNORE';
198 my $oldAutoCommit = $FS::UID::AutoCommit;
199 local $FS::UID::AutoCommit = 0;
202 my $error = $self->SUPER::insert($options{options} ? %{$options{options}} : ());
204 $dbh->rollback if $oldAutoCommit;
208 $self->refnum($self->cust_main->refnum) unless $self->refnum;
209 $self->refnum( [ $self->refnum ] ) unless ref($self->refnum);
210 $self->process_m2m( 'link_table' => 'pkg_referral',
211 'target_table' => 'part_referral',
212 'params' => $self->refnum,
215 #if ( $self->reg_code ) {
216 # my $reg_code = qsearchs('reg_code', { 'code' => $self->reg_code } );
217 # $error = $reg_code->delete;
219 # $dbh->rollback if $oldAutoCommit;
224 my $conf = new FS::Conf;
225 my $cust_main = $self->cust_main;
226 my $part_pkg = $self->part_pkg;
227 if ( $conf->exists('referral_credit')
228 && $cust_main->referral_custnum
229 && ! $options{'change'}
230 && $part_pkg->freq !~ /^0\D?$/
233 my $referring_cust_main = $cust_main->referring_cust_main;
234 if ( $referring_cust_main->status ne 'cancelled' ) {
236 if ( $part_pkg->freq !~ /^\d+$/ ) {
237 warn 'WARNING: Not crediting customer '. $cust_main->referral_custnum.
238 ' for package '. $self->pkgnum.
239 ' ( customer '. $self->custnum. ')'.
240 ' - One-time referral credits not (yet) available for '.
241 ' packages with '. $part_pkg->freq_pretty. ' frequency';
244 my $amount = sprintf( "%.2f", $part_pkg->base_recur / $part_pkg->freq );
246 $referring_cust_main->
248 'Referral credit for '.$cust_main->name,
249 'reason_type' => $conf->config('referral_credit_type')
252 $dbh->rollback if $oldAutoCommit;
253 return "Error crediting customer ". $cust_main->referral_custnum.
254 " for referral: $error";
262 if ($conf->config('welcome_letter') && $self->cust_main->num_pkgs == 1) {
263 my $queue = new FS::queue {
264 'job' => 'FS::cust_main::queueable_print',
266 $error = $queue->insert(
267 'custnum' => $self->custnum,
268 'template' => 'welcome_letter',
272 warn "can't send welcome letter: $error";
277 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
284 This method now works but you probably shouldn't use it.
286 You don't want to delete billing items, because there would then be no record
287 the customer ever purchased the item. Instead, see the cancel method.
292 # return "Can't delete cust_pkg records!";
295 =item replace [ OLD_RECORD ] [ HASHREF | OPTION => VALUE ... ]
297 Replaces the OLD_RECORD with this one in the database. If there is an error,
298 returns the error, otherwise returns false.
300 Currently, custnum, setup, bill, adjourn, susp, expire, and cancel may be changed.
302 Changing pkgpart may have disasterous effects. See the order subroutine.
304 setup and bill are normally updated by calling the bill method of a customer
305 object (see L<FS::cust_main>).
307 suspend is normally updated by the suspend and unsuspend methods.
309 cancel is normally updated by the cancel method (and also the order subroutine
312 Available options are:
318 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.
322 the access_user (see L<FS::access_user>) providing the reason
326 hashref of keys and values - cust_pkg_option records will be created, updated or removed as appopriate
335 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
340 ( ref($_[0]) eq 'HASH' )
344 #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
345 return "Can't change otaker!" if $old->otaker ne $new->otaker;
348 #return "Can't change setup once it exists!"
349 # if $old->getfield('setup') &&
350 # $old->getfield('setup') != $new->getfield('setup');
352 #some logic for bill, susp, cancel?
354 local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
356 local $SIG{HUP} = 'IGNORE';
357 local $SIG{INT} = 'IGNORE';
358 local $SIG{QUIT} = 'IGNORE';
359 local $SIG{TERM} = 'IGNORE';
360 local $SIG{TSTP} = 'IGNORE';
361 local $SIG{PIPE} = 'IGNORE';
363 my $oldAutoCommit = $FS::UID::AutoCommit;
364 local $FS::UID::AutoCommit = 0;
367 foreach my $method ( qw(adjourn expire) ) { # How many reasons?
368 if ($options->{'reason'} && $new->$method && $old->$method ne $new->$method) {
369 my $error = $new->insert_reason(
370 'reason' => $options->{'reason'},
371 'date' => $new->$method,
373 'reason_otaker' => $options->{'reason_otaker'},
376 dbh->rollback if $oldAutoCommit;
377 return "Error inserting cust_pkg_reason: $error";
382 #save off and freeze RADIUS attributes for any associated svc_acct records
384 if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
386 #also check for specific exports?
387 # to avoid spurious modify export events
388 @svc_acct = map { $_->svc_x }
389 grep { $_->part_svc->svcdb eq 'svc_acct' }
392 $_->snapshot foreach @svc_acct;
396 my $error = $new->SUPER::replace($old,
397 $options->{options} ? $options->{options} : ()
400 $dbh->rollback if $oldAutoCommit;
404 #for prepaid packages,
405 #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
406 foreach my $old_svc_acct ( @svc_acct ) {
407 my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
408 my $s_error = $new_svc_acct->replace($old_svc_acct);
410 $dbh->rollback if $oldAutoCommit;
415 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
422 Checks all fields to make sure this is a valid billing item. If there is an
423 error, returns the error, otherwise returns false. Called by the insert and
432 $self->ut_numbern('pkgnum')
433 || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
434 || $self->ut_numbern('pkgpart')
435 || $self->ut_numbern('setup')
436 || $self->ut_numbern('bill')
437 || $self->ut_numbern('susp')
438 || $self->ut_numbern('cancel')
439 || $self->ut_numbern('adjourn')
440 || $self->ut_numbern('expire')
442 return $error if $error;
444 if ( $self->reg_code ) {
446 unless ( grep { $self->pkgpart == $_->pkgpart }
447 map { $_->reg_code_pkg }
448 qsearchs( 'reg_code', { 'code' => $self->reg_code,
449 'agentnum' => $self->cust_main->agentnum })
451 return "Unknown registration code";
454 } elsif ( $self->promo_code ) {
457 qsearchs('part_pkg', {
458 'pkgpart' => $self->pkgpart,
459 'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
461 return 'Unknown promotional code' unless $promo_part_pkg;
465 unless ( $disable_agentcheck ) {
467 qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
468 my $pkgpart_href = $agent->pkgpart_hashref;
469 return "agent ". $agent->agentnum.
470 " can't purchase pkgpart ". $self->pkgpart
471 unless $pkgpart_href->{ $self->pkgpart };
474 $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
475 return $error if $error;
479 $self->otaker(getotaker) unless $self->otaker;
480 $self->otaker =~ /^(\w{1,32})$/ or return "Illegal otaker";
483 if ( $self->dbdef_table->column('manual_flag') ) {
484 $self->manual_flag('') if $self->manual_flag eq ' ';
485 $self->manual_flag =~ /^([01]?)$/
486 or return "Illegal manual_flag ". $self->manual_flag;
487 $self->manual_flag($1);
493 =item cancel [ OPTION => VALUE ... ]
495 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
496 in this package, then cancels the package itself (sets the cancel field to
499 Available options are:
503 =item quiet - can be set true to supress email cancellation notices.
505 =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.
507 =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.
509 =item date - can be set to a unix style timestamp to specify when to cancel (expire)
513 If there is an error, returns the error, otherwise returns false.
518 my( $self, %options ) = @_;
521 warn "cust_pkg::cancel called with options".
522 join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
525 local $SIG{HUP} = 'IGNORE';
526 local $SIG{INT} = 'IGNORE';
527 local $SIG{QUIT} = 'IGNORE';
528 local $SIG{TERM} = 'IGNORE';
529 local $SIG{TSTP} = 'IGNORE';
530 local $SIG{PIPE} = 'IGNORE';
532 my $oldAutoCommit = $FS::UID::AutoCommit;
533 local $FS::UID::AutoCommit = 0;
536 my $old = $self->select_for_update;
538 if ( $old->get('cancel') || $self->get('cancel') ) {
539 dbh->rollback if $oldAutoCommit;
540 return ""; # no error
543 my $date = $options{date} if $options{date}; # expire/cancel later
544 $date = '' if ($date && $date <= time); # complain instead?
546 my $cancel_time = $options{'time'} || time;
548 if ( $options{'reason'} ) {
549 $error = $self->insert_reason( 'reason' => $options{'reason'},
550 'action' => $date ? 'expire' : 'cancel',
551 'reason_otaker' => $options{'reason_otaker'},
554 dbh->rollback if $oldAutoCommit;
555 return "Error inserting cust_pkg_reason: $error";
561 foreach my $cust_svc (
564 sort { $a->[1] <=> $b->[1] }
565 map { [ $_, $_->svc_x->table_info->{'cancel_weight'} ]; }
566 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
569 my $error = $cust_svc->cancel;
572 $dbh->rollback if $oldAutoCommit;
573 return "Error cancelling cust_svc: $error";
577 # Add a credit for remaining service
578 my $remaining_value = $self->calc_remain(time=>$cancel_time);
579 if ( $remaining_value > 0 && !$options{'no_credit'} ) {
580 my $conf = new FS::Conf;
581 my $error = $self->cust_main->credit(
583 'Credit for unused time on '. $self->part_pkg->pkg,
584 'reason_type' => $conf->config('cancel_credit_type'),
587 $dbh->rollback if $oldAutoCommit;
588 return "Error crediting customer \$$remaining_value for unused time on".
589 $self->part_pkg->pkg. ": $error";
594 my %hash = $self->hash;
595 $date ? ($hash{'expire'} = $date) : ($hash{'cancel'} = $cancel_time);
596 my $new = new FS::cust_pkg ( \%hash );
597 $error = $new->replace( $self, options => { $self->options } );
599 $dbh->rollback if $oldAutoCommit;
603 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
604 return '' if $date; #no errors
606 my $conf = new FS::Conf;
607 my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
608 if ( !$options{'quiet'} && $conf->exists('emailcancel') && @invoicing_list ) {
609 my $conf = new FS::Conf;
610 my $error = send_email(
611 'from' => $conf->config('invoice_from'),
612 'to' => \@invoicing_list,
613 'subject' => ( $conf->config('cancelsubject') || 'Cancellation Notice' ),
614 'body' => [ map "$_\n", $conf->config('cancelmessage') ],
616 #should this do something on errors?
623 =item cancel_if_expired [ NOW_TIMESTAMP ]
625 Cancels this package if its expire date has been reached.
629 sub cancel_if_expired {
631 my $time = shift || time;
632 return '' unless $self->expire && $self->expire <= $time;
633 my $error = $self->cancel;
635 return "Error cancelling expired pkg ". $self->pkgnum. " for custnum ".
636 $self->custnum. ": $error";
643 Cancels any pending expiration (sets the expire field to null).
645 If there is an error, returns the error, otherwise returns false.
650 my( $self, %options ) = @_;
653 local $SIG{HUP} = 'IGNORE';
654 local $SIG{INT} = 'IGNORE';
655 local $SIG{QUIT} = 'IGNORE';
656 local $SIG{TERM} = 'IGNORE';
657 local $SIG{TSTP} = 'IGNORE';
658 local $SIG{PIPE} = 'IGNORE';
660 my $oldAutoCommit = $FS::UID::AutoCommit;
661 local $FS::UID::AutoCommit = 0;
664 my $old = $self->select_for_update;
666 my $pkgnum = $old->pkgnum;
667 if ( $old->get('cancel') || $self->get('cancel') ) {
668 dbh->rollback if $oldAutoCommit;
669 return "Can't unexpire cancelled package $pkgnum";
670 # or at least it's pointless
673 unless ( $old->get('expire') && $self->get('expire') ) {
674 dbh->rollback if $oldAutoCommit;
675 return ""; # no error
678 my %hash = $self->hash;
679 $hash{'expire'} = '';
680 my $new = new FS::cust_pkg ( \%hash );
681 $error = $new->replace( $self, options => { $self->options } );
683 $dbh->rollback if $oldAutoCommit;
687 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
693 =item suspend [ OPTION => VALUE ... ]
695 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
696 package, then suspends the package itself (sets the susp field to now).
698 Available options are:
702 =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.
704 =item date - can be set to a unix style timestamp to specify when to suspend (adjourn)
708 If there is an error, returns the error, otherwise returns false.
713 my( $self, %options ) = @_;
716 local $SIG{HUP} = 'IGNORE';
717 local $SIG{INT} = 'IGNORE';
718 local $SIG{QUIT} = 'IGNORE';
719 local $SIG{TERM} = 'IGNORE';
720 local $SIG{TSTP} = 'IGNORE';
721 local $SIG{PIPE} = 'IGNORE';
723 my $oldAutoCommit = $FS::UID::AutoCommit;
724 local $FS::UID::AutoCommit = 0;
727 my $old = $self->select_for_update;
729 my $pkgnum = $old->pkgnum;
730 if ( $old->get('cancel') || $self->get('cancel') ) {
731 dbh->rollback if $oldAutoCommit;
732 return "Can't suspend cancelled package $pkgnum";
735 if ( $old->get('susp') || $self->get('susp') ) {
736 dbh->rollback if $oldAutoCommit;
737 return ""; # no error # complain on adjourn?
740 my $date = $options{date} if $options{date}; # adjourn/suspend later
741 $date = '' if ($date && $date <= time); # complain instead?
743 if ( $date && $old->get('expire') && $old->get('expire') < $date ) {
744 dbh->rollback if $oldAutoCommit;
745 return "Package $pkgnum expires before it would be suspended.";
748 if ( $options{'reason'} ) {
749 $error = $self->insert_reason( 'reason' => $options{'reason'},
750 'action' => $date ? 'adjourn' : 'suspend',
751 'reason_otaker' => $options{'reason_otaker'},
754 dbh->rollback if $oldAutoCommit;
755 return "Error inserting cust_pkg_reason: $error";
760 foreach my $cust_svc (
761 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
763 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
765 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
766 $dbh->rollback if $oldAutoCommit;
767 return "Illegal svcdb value in part_svc!";
770 require "FS/$svcdb.pm";
772 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
774 $error = $svc->suspend;
776 $dbh->rollback if $oldAutoCommit;
783 my %hash = $self->hash;
784 $date ? ($hash{'adjourn'} = $date) : ($hash{'susp'} = time);
785 my $new = new FS::cust_pkg ( \%hash );
786 $error = $new->replace( $self, options => { $self->options } );
788 $dbh->rollback if $oldAutoCommit;
792 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
797 =item unsuspend [ OPTION => VALUE ... ]
799 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
800 package, then unsuspends the package itself (clears the susp field and the
801 adjourn field if it is in the past).
803 Available options are:
807 =item adjust_next_bill
809 Can be set true to adjust the next bill date forward by
810 the amount of time the account was inactive. This was set true by default
811 since 1.4.2 and 1.5.0pre6; however, starting with 1.7.0 this needs to be
812 explicitly requested. Price plans for which this makes sense (anniversary-date
813 based than prorate or subscription) could have an option to enable this
818 If there is an error, returns the error, otherwise returns false.
823 my( $self, %opt ) = @_;
826 local $SIG{HUP} = 'IGNORE';
827 local $SIG{INT} = 'IGNORE';
828 local $SIG{QUIT} = 'IGNORE';
829 local $SIG{TERM} = 'IGNORE';
830 local $SIG{TSTP} = 'IGNORE';
831 local $SIG{PIPE} = 'IGNORE';
833 my $oldAutoCommit = $FS::UID::AutoCommit;
834 local $FS::UID::AutoCommit = 0;
837 my $old = $self->select_for_update;
839 my $pkgnum = $old->pkgnum;
840 if ( $old->get('cancel') || $self->get('cancel') ) {
841 dbh->rollback if $oldAutoCommit;
842 return "Can't unsuspend cancelled package $pkgnum";
845 unless ( $old->get('susp') && $self->get('susp') ) {
846 dbh->rollback if $oldAutoCommit;
847 return ""; # no error # complain instead?
850 foreach my $cust_svc (
851 qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
853 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
855 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
856 $dbh->rollback if $oldAutoCommit;
857 return "Illegal svcdb value in part_svc!";
860 require "FS/$svcdb.pm";
862 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
864 $error = $svc->unsuspend;
866 $dbh->rollback if $oldAutoCommit;
873 my %hash = $self->hash;
874 my $inactive = time - $hash{'susp'};
876 my $conf = new FS::Conf;
878 $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive
879 if ( $opt{'adjust_next_bill'}
880 || $conf->config('unsuspend-always_adjust_next_bill_date') )
881 && $inactive > 0 && ( $hash{'bill'} || $hash{'setup'} );
884 $hash{'adjourn'} = '' if $hash{'adjourn'} < time;
885 my $new = new FS::cust_pkg ( \%hash );
886 $error = $new->replace( $self, options => { $self->options } );
888 $dbh->rollback if $oldAutoCommit;
892 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
899 Cancels any pending suspension (sets the adjourn field to null).
901 If there is an error, returns the error, otherwise returns false.
906 my( $self, %options ) = @_;
909 local $SIG{HUP} = 'IGNORE';
910 local $SIG{INT} = 'IGNORE';
911 local $SIG{QUIT} = 'IGNORE';
912 local $SIG{TERM} = 'IGNORE';
913 local $SIG{TSTP} = 'IGNORE';
914 local $SIG{PIPE} = 'IGNORE';
916 my $oldAutoCommit = $FS::UID::AutoCommit;
917 local $FS::UID::AutoCommit = 0;
920 my $old = $self->select_for_update;
922 my $pkgnum = $old->pkgnum;
923 if ( $old->get('cancel') || $self->get('cancel') ) {
924 dbh->rollback if $oldAutoCommit;
925 return "Can't unadjourn cancelled package $pkgnum";
926 # or at least it's pointless
929 if ( $old->get('susp') || $self->get('susp') ) {
930 dbh->rollback if $oldAutoCommit;
931 return "Can't unadjourn suspended package $pkgnum";
932 # perhaps this is arbitrary
935 unless ( $old->get('adjourn') && $self->get('adjourn') ) {
936 dbh->rollback if $oldAutoCommit;
937 return ""; # no error
940 my %hash = $self->hash;
941 $hash{'adjourn'} = '';
942 my $new = new FS::cust_pkg ( \%hash );
943 $error = $new->replace( $self, options => { $self->options } );
945 $dbh->rollback if $oldAutoCommit;
949 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
957 Returns the last bill date, or if there is no last bill date, the setup date.
958 Useful for billing metered services.
964 return $self->setfield('last_bill', $_[0]) if @_;
965 return $self->getfield('last_bill') if $self->getfield('last_bill');
966 my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
967 'edate' => $self->bill, } );
968 $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
971 =item last_cust_pkg_reason ACTION
973 Returns the most recent ACTION FS::cust_pkg_reason associated with the package.
974 Returns false if there is no reason or the package is not currenly ACTION'd
975 ACTION is one of adjourn, susp, cancel, or expire.
979 sub last_cust_pkg_reason {
980 my ( $self, $action ) = ( shift, shift );
981 my $date = $self->get($action);
983 'table' => 'cust_pkg_reason',
984 'hashref' => { 'pkgnum' => $self->pkgnum,
985 'action' => substr(uc($action), 0, 1),
988 'order_by' => 'ORDER BY num DESC LIMIT 1',
992 =item last_reason ACTION
994 Returns the most recent ACTION FS::reason associated with the package.
995 Returns false if there is no reason or the package is not currenly ACTION'd
996 ACTION is one of adjourn, susp, cancel, or expire.
1001 my $cust_pkg_reason = shift->last_cust_pkg_reason(@_);
1002 $cust_pkg_reason->reason
1003 if $cust_pkg_reason;
1008 Returns the definition for this billing item, as an FS::part_pkg object (see
1015 #exists( $self->{'_pkgpart'} )
1017 ? $self->{'_pkgpart'}
1018 : qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
1023 Returns the cancelled package this package was changed from, if any.
1029 return '' unless $self->change_pkgnum;
1030 qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
1035 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
1042 $self->part_pkg->calc_setup($self, @_);
1047 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
1054 $self->part_pkg->calc_recur($self, @_);
1059 Calls the I<calc_remain> of the FS::part_pkg object associated with this
1066 $self->part_pkg->calc_remain($self, @_);
1071 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
1078 $self->part_pkg->calc_cancel($self, @_);
1083 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
1089 qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
1094 Returns the new-style customer billing events (see L<FS::cust_event>) for this invoice.
1098 #false laziness w/cust_bill.pm
1102 'table' => 'cust_event',
1103 'addl_from' => 'JOIN part_event USING ( eventpart )',
1104 'hashref' => { 'tablenum' => $self->pkgnum },
1105 'extra_sql' => " AND eventtable = 'cust_pkg' ",
1109 =item num_cust_event
1111 Returns the number of new-style customer billing events (see L<FS::cust_event>) for this invoice.
1115 #false laziness w/cust_bill.pm
1116 sub num_cust_event {
1119 "SELECT COUNT(*) FROM cust_event JOIN part_event USING ( eventpart ) ".
1120 " WHERE tablenum = ? AND eventtable = 'cust_pkg'";
1121 my $sth = dbh->prepare($sql) or die dbh->errstr. " preparing $sql";
1122 $sth->execute($self->pkgnum) or die $sth->errstr. " executing $sql";
1123 $sth->fetchrow_arrayref->[0];
1126 =item cust_svc [ SVCPART ]
1128 Returns the services for this package, as FS::cust_svc objects (see
1129 L<FS::cust_svc>). If a svcpart is specified, return only the matching
1138 return qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum,
1139 'svcpart' => shift, } );
1142 #if ( $self->{'_svcnum'} ) {
1143 # values %{ $self->{'_svcnum'}->cache };
1145 $self->_sort_cust_svc(
1146 [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
1152 =item overlimit [ SVCPART ]
1154 Returns the services for this package which have exceeded their
1155 usage limit as FS::cust_svc objects (see L<FS::cust_svc>). If a svcpart
1156 is specified, return only the matching services.
1162 grep { $_->overlimit } $self->cust_svc;
1165 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ]
1167 Returns historical services for this package created before END TIMESTAMP and
1168 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
1169 (see L<FS::h_cust_svc>).
1176 $self->_sort_cust_svc(
1177 [ qsearch( 'h_cust_svc',
1178 { 'pkgnum' => $self->pkgnum, },
1179 FS::h_cust_svc->sql_h_search(@_),
1185 sub _sort_cust_svc {
1186 my( $self, $arrayref ) = @_;
1189 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
1191 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
1192 'svcpart' => $_->svcpart } );
1194 $pkg_svc ? $pkg_svc->primary_svc : '',
1195 $pkg_svc ? $pkg_svc->quantity : 0,
1202 =item num_cust_svc [ SVCPART ]
1204 Returns the number of provisioned services for this package. If a svcpart is
1205 specified, counts only the matching services.
1211 my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
1212 $sql .= ' AND svcpart = ?' if @_;
1213 my $sth = dbh->prepare($sql) or die dbh->errstr;
1214 $sth->execute($self->pkgnum, @_) or die $sth->errstr;
1215 $sth->fetchrow_arrayref->[0];
1218 =item available_part_svc
1220 Returns a list of FS::part_svc objects representing services included in this
1221 package but not yet provisioned. Each FS::part_svc object also has an extra
1222 field, I<num_avail>, which specifies the number of available services.
1226 sub available_part_svc {
1228 grep { $_->num_avail > 0 }
1230 my $part_svc = $_->part_svc;
1231 $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
1232 $_->quantity - $self->num_cust_svc($_->svcpart);
1235 $self->part_pkg->pkg_svc;
1240 Returns a list of FS::part_svc objects representing provisioned and available
1241 services included in this package. Each FS::part_svc object also has the
1242 following extra fields:
1246 =item num_cust_svc (count)
1248 =item num_avail (quantity - count)
1250 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
1253 label -> ($cust_svc->label)[1]
1262 #XXX some sort of sort order besides numeric by svcpart...
1263 my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
1265 my $part_svc = $pkg_svc->part_svc;
1266 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1267 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
1268 $part_svc->{'Hash'}{'num_avail'} =
1269 max( 0, $pkg_svc->quantity - $num_cust_svc );
1270 $part_svc->{'Hash'}{'cust_pkg_svc'} = [ $self->cust_svc($part_svc->svcpart) ];
1272 } $self->part_pkg->pkg_svc;
1275 push @part_svc, map {
1277 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1278 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
1279 $part_svc->{'Hash'}{'num_avail'} = 0; #0-$num_cust_svc ?
1280 $part_svc->{'Hash'}{'cust_pkg_svc'} = [ $self->cust_svc($part_svc->svcpart) ];
1282 } $self->extra_part_svc;
1288 =item extra_part_svc
1290 Returns a list of FS::part_svc objects corresponding to services in this
1291 package which are still provisioned but not (any longer) available in the
1296 sub extra_part_svc {
1299 my $pkgnum = $self->pkgnum;
1300 my $pkgpart = $self->pkgpart;
1303 'table' => 'part_svc',
1305 'extra_sql' => "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
1306 WHERE pkg_svc.svcpart = part_svc.svcpart
1307 AND pkg_svc.pkgpart = $pkgpart
1310 AND 0 < ( SELECT count(*)
1312 LEFT JOIN cust_pkg using ( pkgnum )
1313 WHERE cust_svc.svcpart = part_svc.svcpart
1314 AND pkgnum = $pkgnum
1321 Returns a short status string for this package, currently:
1325 =item not yet billed
1327 =item one-time charge
1342 my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
1344 return 'cancelled' if $self->get('cancel');
1345 return 'suspended' if $self->susp;
1346 return 'not yet billed' unless $self->setup;
1347 return 'one-time charge' if $freq =~ /^(0|$)/;
1353 Class method that returns the list of possible status strings for packages
1354 (see L<the status method|/status>). For example:
1356 @statuses = FS::cust_pkg->statuses();
1360 tie my %statuscolor, 'Tie::IxHash',
1361 'not yet billed' => '000000',
1362 'one-time charge' => '000000',
1363 'active' => '00CC00',
1364 'suspended' => 'FF9900',
1365 'cancelled' => 'FF0000',
1369 my $self = shift; #could be class...
1370 grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
1371 # mayble split btw one-time vs. recur
1377 Returns a hex triplet color string for this package's status.
1383 $statuscolor{$self->status};
1388 Returns a list of lists, calling the label method for all services
1389 (see L<FS::cust_svc>) of this billing item.
1395 map { [ $_->label ] } $self->cust_svc;
1398 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
1400 Like the labels method, but returns historical information on services that
1401 were active as of END_TIMESTAMP and (optionally) not cancelled before
1404 Returns a list of lists, calling the label method for all (historical) services
1405 (see L<FS::h_cust_svc>) of this billing item.
1411 map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
1414 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
1416 Like h_labels, except returns a simple flat list, and shortens long
1417 (currently >5) lists of identical services to one line that lists the service
1418 label and the number of individual services rather than individual items.
1422 sub h_labels_short {
1426 #tie %labels, 'Tie::IxHash';
1427 push @{ $labels{$_->[0]} }, $_->[1]
1428 foreach $self->h_labels(@_);
1430 foreach my $label ( keys %labels ) {
1431 my @values = @{ $labels{$label} };
1432 my $num = scalar(@values);
1434 push @labels, "$label ($num)";
1436 push @labels, map { "$label: $_" } @values;
1446 Returns the parent customer object (see L<FS::cust_main>).
1452 qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
1455 =item seconds_since TIMESTAMP
1457 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
1458 package have been online since TIMESTAMP, according to the session monitor.
1460 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1461 L<Time::Local> and L<Date::Parse> for conversion functions.
1466 my($self, $since) = @_;
1469 foreach my $cust_svc (
1470 grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
1472 $seconds += $cust_svc->seconds_since($since);
1479 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1481 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
1482 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
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
1492 sub seconds_since_sqlradacct {
1493 my($self, $start, $end) = @_;
1497 foreach my $cust_svc (
1499 my $part_svc = $_->part_svc;
1500 $part_svc->svcdb eq 'svc_acct'
1501 && scalar($part_svc->part_export('sqlradius'));
1504 $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
1511 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1513 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1514 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1518 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1519 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1524 sub attribute_since_sqlradacct {
1525 my($self, $start, $end, $attrib) = @_;
1529 foreach my $cust_svc (
1531 my $part_svc = $_->part_svc;
1532 $part_svc->svcdb eq 'svc_acct'
1533 && scalar($part_svc->part_export('sqlradius'));
1536 $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
1548 my( $self, $value ) = @_;
1549 if ( defined($value) ) {
1550 $self->setfield('quantity', $value);
1552 $self->getfield('quantity') || 1;
1555 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
1557 Transfers as many services as possible from this package to another package.
1559 The destination package can be specified by pkgnum by passing an FS::cust_pkg
1560 object. The destination package must already exist.
1562 Services are moved only if the destination allows services with the correct
1563 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true. Use
1564 this option with caution! No provision is made for export differences
1565 between the old and new service definitions. Probably only should be used
1566 when your exports for all service definitions of a given svcdb are identical.
1567 (attempt a transfer without it first, to move all possible svcpart-matching
1570 Any services that can't be moved remain in the original package.
1572 Returns an error, if there is one; otherwise, returns the number of services
1573 that couldn't be moved.
1578 my ($self, $dest_pkgnum, %opt) = @_;
1584 if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
1585 $dest = $dest_pkgnum;
1586 $dest_pkgnum = $dest->pkgnum;
1588 $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
1591 return ('Package does not exist: '.$dest_pkgnum) unless $dest;
1593 foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
1594 $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
1597 foreach my $cust_svc ($dest->cust_svc) {
1598 $target{$cust_svc->svcpart}--;
1601 my %svcpart2svcparts = ();
1602 if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1603 warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
1604 foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
1605 next if exists $svcpart2svcparts{$svcpart};
1606 my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
1607 $svcpart2svcparts{$svcpart} = [
1609 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
1611 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
1612 'svcpart' => $_ } );
1614 $pkg_svc ? $pkg_svc->primary_svc : '',
1615 $pkg_svc ? $pkg_svc->quantity : 0,
1619 grep { $_ != $svcpart }
1621 qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
1623 warn "alternates for svcpart $svcpart: ".
1624 join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
1629 foreach my $cust_svc ($self->cust_svc) {
1630 if($target{$cust_svc->svcpart} > 0) {
1631 $target{$cust_svc->svcpart}--;
1632 my $new = new FS::cust_svc { $cust_svc->hash };
1633 $new->pkgnum($dest_pkgnum);
1634 my $error = $new->replace($cust_svc);
1635 return $error if $error;
1636 } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1638 warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
1639 warn "alternates to consider: ".
1640 join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
1642 my @alternate = grep {
1643 warn "considering alternate svcpart $_: ".
1644 "$target{$_} available in new package\n"
1647 } @{$svcpart2svcparts{$cust_svc->svcpart}};
1649 warn "alternate(s) found\n" if $DEBUG;
1650 my $change_svcpart = $alternate[0];
1651 $target{$change_svcpart}--;
1652 my $new = new FS::cust_svc { $cust_svc->hash };
1653 $new->svcpart($change_svcpart);
1654 $new->pkgnum($dest_pkgnum);
1655 my $error = $new->replace($cust_svc);
1656 return $error if $error;
1669 This method is deprecated. See the I<depend_jobnum> option to the insert and
1670 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
1677 local $SIG{HUP} = 'IGNORE';
1678 local $SIG{INT} = 'IGNORE';
1679 local $SIG{QUIT} = 'IGNORE';
1680 local $SIG{TERM} = 'IGNORE';
1681 local $SIG{TSTP} = 'IGNORE';
1682 local $SIG{PIPE} = 'IGNORE';
1684 my $oldAutoCommit = $FS::UID::AutoCommit;
1685 local $FS::UID::AutoCommit = 0;
1688 foreach my $cust_svc ( $self->cust_svc ) {
1689 #false laziness w/svc_Common::insert
1690 my $svc_x = $cust_svc->svc_x;
1691 foreach my $part_export ( $cust_svc->part_svc->part_export ) {
1692 my $error = $part_export->export_insert($svc_x);
1694 $dbh->rollback if $oldAutoCommit;
1700 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1707 =head1 CLASS METHODS
1713 Returns an SQL expression identifying recurring packages.
1717 sub recurring_sql { "
1718 '0' != ( select freq from part_pkg
1719 where cust_pkg.pkgpart = part_pkg.pkgpart )
1724 Returns an SQL expression identifying one-time packages.
1729 '0' = ( select freq from part_pkg
1730 where cust_pkg.pkgpart = part_pkg.pkgpart )
1735 Returns an SQL expression identifying active packages.
1740 ". $_[0]->recurring_sql(). "
1741 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1742 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
1747 Returns an SQL expression identifying inactive packages (one-time packages
1748 that are otherwise unsuspended/uncancelled).
1752 sub inactive_sql { "
1753 ". $_[0]->onetime_sql(). "
1754 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1755 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
1761 Returns an SQL expression identifying suspended packages.
1765 sub suspended_sql { susp_sql(@_); }
1767 #$_[0]->recurring_sql(). ' AND '.
1769 ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1770 AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0
1777 Returns an SQL exprression identifying cancelled packages.
1781 sub cancelled_sql { cancel_sql(@_); }
1783 #$_[0]->recurring_sql(). ' AND '.
1784 "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
1787 =item search_sql HASHREF
1791 Returns a qsearch hash expression to search for parameters specified in HASHREF.
1792 Valid parameters are
1800 active, inactive, suspended, cancel (or cancelled)
1804 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
1814 arrayref of beginning and ending epoch date
1818 arrayref of beginning and ending epoch date
1822 arrayref of beginning and ending epoch date
1826 arrayref of beginning and ending epoch date
1830 arrayref of beginning and ending epoch date
1834 arrayref of beginning and ending epoch date
1838 arrayref of beginning and ending epoch date
1842 pkgnum or APKG_pkgnum
1846 a value suited to passing to FS::UI::Web::cust_header
1850 specifies the user for agent virtualization
1857 my ($class, $params) = @_;
1864 if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
1866 "cust_main.agentnum = $1";
1873 if ( $params->{'magic'} eq 'active'
1874 || $params->{'status'} eq 'active' ) {
1876 push @where, FS::cust_pkg->active_sql();
1878 } elsif ( $params->{'magic'} eq 'inactive'
1879 || $params->{'status'} eq 'inactive' ) {
1881 push @where, FS::cust_pkg->inactive_sql();
1883 } elsif ( $params->{'magic'} eq 'suspended'
1884 || $params->{'status'} eq 'suspended' ) {
1886 push @where, FS::cust_pkg->suspended_sql();
1888 } elsif ( $params->{'magic'} =~ /^cancell?ed$/
1889 || $params->{'status'} =~ /^cancell?ed$/ ) {
1891 push @where, FS::cust_pkg->cancelled_sql();
1893 } elsif ( $params->{'status'} =~ /^(one-time charge|inactive)$/ ) {
1895 push @where, FS::cust_pkg->inactive_sql();
1900 # parse package class
1903 #false lazinessish w/graph/cust_bill_pkg.cgi
1906 if ( exists($params->{'classnum'})
1907 && $params->{'classnum'} =~ /^(\d*)$/
1911 if ( $classnum ) { #a specific class
1912 push @where, "classnum = $classnum";
1914 #@pkg_class = ( qsearchs('pkg_class', { 'classnum' => $classnum } ) );
1915 #die "classnum $classnum not found!" unless $pkg_class[0];
1916 #$title .= $pkg_class[0]->classname.' ';
1918 } elsif ( $classnum eq '' ) { #the empty class
1920 push @where, "classnum IS NULL";
1921 #$title .= 'Empty class ';
1922 #@pkg_class = ( '(empty class)' );
1923 } elsif ( $classnum eq '0' ) {
1924 #@pkg_class = qsearch('pkg_class', {} ); # { 'disabled' => '' } );
1925 #push @pkg_class, '(empty class)';
1927 die "illegal classnum";
1936 my $pkgpart = join (' OR pkgpart=',
1937 grep {$_} map { /^(\d+)$/; } ($params->{'pkgpart'}));
1938 push @where, '(pkgpart=' . $pkgpart . ')' if $pkgpart;
1946 #false laziness w/report_cust_pkg.html
1949 'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
1950 'active' => { 'susp'=>1, 'cancel'=>1 },
1951 'suspended' => { 'cancel' => 1 },
1956 foreach my $field (qw( setup last_bill bill adjourn susp expire cancel )) {
1958 next unless exists($params->{$field});
1960 my($beginning, $ending) = @{$params->{$field}};
1962 next if $beginning == 0 && $ending == 4294967295;
1965 "cust_pkg.$field IS NOT NULL",
1966 "cust_pkg.$field >= $beginning",
1967 "cust_pkg.$field <= $ending";
1969 $orderby ||= "ORDER BY cust_pkg.$field";
1973 $orderby ||= 'ORDER BY bill';
1976 # parse magic, legacy, etc.
1979 if ( $params->{'magic'} &&
1980 $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
1983 $orderby = 'ORDER BY pkgnum';
1985 if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
1986 push @where, "pkgpart = $1";
1989 } elsif ( $params->{'query'} eq 'pkgnum' ) {
1991 $orderby = 'ORDER BY pkgnum';
1993 } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
1995 $orderby = 'ORDER BY pkgnum';
1998 SELECT count(*) FROM pkg_svc
1999 WHERE pkg_svc.pkgpart = cust_pkg.pkgpart
2000 AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
2001 WHERE cust_svc.pkgnum = cust_pkg.pkgnum
2002 AND cust_svc.svcpart = pkg_svc.svcpart
2009 # setup queries, links, subs, etc. for the search
2012 # here is the agent virtualization
2013 if ($params->{CurrentUser}) {
2015 qsearchs('access_user', { username => $params->{CurrentUser} });
2018 push @where, $access_user->agentnums_sql('table'=>'cust_main');
2023 push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
2026 my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
2028 my $addl_from = 'LEFT JOIN cust_main USING ( custnum ) '.
2029 'LEFT JOIN part_pkg USING ( pkgpart ) '.
2030 'LEFT JOIN pkg_class USING ( classnum ) ';
2032 my $count_query = "SELECT COUNT(*) FROM cust_pkg $addl_from $extra_sql";
2035 'table' => 'cust_pkg',
2037 'select' => join(', ',
2039 ( map "part_pkg.$_", qw( pkg freq ) ),
2040 'pkg_class.classname',
2041 'cust_main.custnum as cust_main_custnum',
2042 FS::UI::Web::cust_sql_fields(
2043 $params->{'cust_fields'}
2046 'extra_sql' => "$extra_sql $orderby",
2047 'addl_from' => $addl_from,
2048 'count_query' => $count_query,
2057 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
2059 CUSTNUM is a customer (see L<FS::cust_main>)
2061 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
2062 L<FS::part_pkg>) to order for this customer. Duplicates are of course
2065 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
2066 remove for this customer. The services (see L<FS::cust_svc>) are moved to the
2067 new billing items. An error is returned if this is not possible (see
2068 L<FS::pkg_svc>). An empty arrayref is equivalent to not specifying this
2071 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
2072 newly-created cust_pkg objects.
2074 REFNUM, if specified, will specify the FS::pkg_referral record to be created
2075 and inserted. Multiple FS::pkg_referral records can be created by
2076 setting I<refnum> to an array reference of refnums or a hash reference with
2077 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
2078 record will be created corresponding to cust_main.refnum.
2083 my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
2085 my $conf = new FS::Conf;
2087 # Transactionize this whole mess
2088 local $SIG{HUP} = 'IGNORE';
2089 local $SIG{INT} = 'IGNORE';
2090 local $SIG{QUIT} = 'IGNORE';
2091 local $SIG{TERM} = 'IGNORE';
2092 local $SIG{TSTP} = 'IGNORE';
2093 local $SIG{PIPE} = 'IGNORE';
2095 my $oldAutoCommit = $FS::UID::AutoCommit;
2096 local $FS::UID::AutoCommit = 0;
2100 my $cust_main = qsearchs('cust_main', { custnum => $custnum });
2101 return "Customer not found: $custnum" unless $cust_main;
2103 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
2106 my $change = scalar(@old_cust_pkg) != 0;
2109 if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
2113 #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( last_bill bill );
2115 #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( setup );
2116 $hash{'setup'} = $time if $old_cust_pkg[0]->setup;
2118 $hash{'change_date'} = $time;
2119 $hash{"change_$_"} = $old_cust_pkg[0]->$_() foreach qw( pkgnum pkgpart );
2122 # Create the new packages.
2123 foreach my $pkgpart (@$pkgparts) {
2124 my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
2125 pkgpart => $pkgpart,
2129 $error = $cust_pkg->insert( 'change' => $change );
2131 $dbh->rollback if $oldAutoCommit;
2134 push @$return_cust_pkg, $cust_pkg;
2136 # $return_cust_pkg now contains refs to all of the newly
2139 # Transfer services and cancel old packages.
2140 foreach my $old_pkg (@old_cust_pkg) {
2142 foreach my $new_pkg (@$return_cust_pkg) {
2143 $error = $old_pkg->transfer($new_pkg);
2144 if ($error and $error == 0) {
2145 # $old_pkg->transfer failed.
2146 $dbh->rollback if $oldAutoCommit;
2151 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
2152 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
2153 foreach my $new_pkg (@$return_cust_pkg) {
2154 $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
2155 if ($error and $error == 0) {
2156 # $old_pkg->transfer failed.
2157 $dbh->rollback if $oldAutoCommit;
2164 # Transfers were successful, but we went through all of the
2165 # new packages and still had services left on the old package.
2166 # We can't cancel the package under the circumstances, so abort.
2167 $dbh->rollback if $oldAutoCommit;
2168 return "Unable to transfer all services from package ".$old_pkg->pkgnum;
2170 $error = $old_pkg->cancel( quiet=>1 );
2176 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2180 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
2182 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
2183 L<FS::part_pkg>) to order for this customer. Duplicates are of course
2186 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
2187 replace. The services (see L<FS::cust_svc>) are moved to the
2188 new billing items. An error is returned if this is not possible (see
2191 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
2192 newly-created cust_pkg objects.
2197 my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
2199 # Transactionize this whole mess
2200 local $SIG{HUP} = 'IGNORE';
2201 local $SIG{INT} = 'IGNORE';
2202 local $SIG{QUIT} = 'IGNORE';
2203 local $SIG{TERM} = 'IGNORE';
2204 local $SIG{TSTP} = 'IGNORE';
2205 local $SIG{PIPE} = 'IGNORE';
2207 my $oldAutoCommit = $FS::UID::AutoCommit;
2208 local $FS::UID::AutoCommit = 0;
2212 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
2215 while(scalar(@old_cust_pkg)) {
2217 my $custnum = $old_cust_pkg[0]->custnum;
2218 my (@remove) = map { $_->pkgnum }
2219 grep { $_->custnum == $custnum } @old_cust_pkg;
2220 @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
2222 my $error = order $custnum, $pkgparts, \@remove, \@return;
2224 push @errors, $error
2226 push @$return_cust_pkg, @return;
2229 if (scalar(@errors)) {
2230 $dbh->rollback if $oldAutoCommit;
2231 return join(' / ', @errors);
2234 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2240 Associates this package with a (suspension or cancellation) reason (see
2241 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
2244 Available options are:
2250 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.
2254 the access_user (see L<FS::access_user>) providing the reason
2262 the action (cancel, susp, adjourn, expire) associated with the reason
2266 If there is an error, returns the error, otherwise returns false.
2271 my ($self, %options) = @_;
2273 my $otaker = $options{reason_otaker} ||
2274 $FS::CurrentUser::CurrentUser->username;
2277 if ( $options{'reason'} =~ /^(\d+)$/ ) {
2281 } elsif ( ref($options{'reason'}) ) {
2283 return 'Enter a new reason (or select an existing one)'
2284 unless $options{'reason'}->{'reason'} !~ /^\s*$/;
2286 my $reason = new FS::reason({
2287 'reason_type' => $options{'reason'}->{'typenum'},
2288 'reason' => $options{'reason'}->{'reason'},
2290 my $error = $reason->insert;
2291 return $error if $error;
2293 $reasonnum = $reason->reasonnum;
2296 return "Unparsable reason: ". $options{'reason'};
2299 my $cust_pkg_reason =
2300 new FS::cust_pkg_reason({ 'pkgnum' => $self->pkgnum,
2301 'reasonnum' => $reasonnum,
2302 'otaker' => $otaker,
2303 'action' => substr(uc($options{'action'}),0,1),
2304 'date' => $options{'date'}
2309 $cust_pkg_reason->insert;
2312 =item set_usage USAGE_VALUE_HASHREF
2314 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2315 to which they should be set (see L<FS::svc_acct>). Currently seconds,
2316 upbytes, downbytes, and totalbytes are appropriate keys.
2318 All svc_accts which are part of this package have their values reset.
2323 my ($self, $valueref) = @_;
2325 foreach my $cust_svc ($self->cust_svc){
2326 my $svc_x = $cust_svc->svc_x;
2327 $svc_x->set_usage($valueref)
2328 if $svc_x->can("set_usage");
2332 =item recharge USAGE_VALUE_HASHREF
2334 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2335 to which they should be set (see L<FS::svc_acct>). Currently seconds,
2336 upbytes, downbytes, and totalbytes are appropriate keys.
2338 All svc_accts which are part of this package have their values incremented.
2343 my ($self, $valueref) = @_;
2345 foreach my $cust_svc ($self->cust_svc){
2346 my $svc_x = $cust_svc->svc_x;
2347 $svc_x->recharge($valueref)
2348 if $svc_x->can("recharge");
2356 sub order is not OO. Perhaps it should be moved to FS::cust_main and made so?
2358 In sub order, the @pkgparts array (passed by reference) is clobbered.
2360 Also in sub order, no money is adjusted. Once FS::part_pkg defines a standard
2361 method to pass dates to the recur_prog expression, it should do so.
2363 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
2364 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
2365 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
2366 configuration values. Probably need a subroutine which decides what to do
2367 based on whether or not we've fetched the user yet, rather than a hash. See
2368 FS::UID and the TODO.
2370 Now that things are transactional should the check in the insert method be
2375 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
2376 L<FS::pkg_svc>, schema.html from the base documentation