4 use base qw( FS::otaker_Mixin FS::cust_main_Mixin FS::location_Mixin
5 FS::m2m_Common FS::option_Common );
6 use vars qw($disable_agentcheck $DEBUG $me);
8 use Scalar::Util qw( blessed );
9 use List::Util qw(min max);
11 use Time::Local qw( timelocal timelocal_nocheck );
13 use FS::UID qw( getotaker dbh driver_name );
14 use FS::Misc qw( send_email );
15 use FS::Record qw( qsearch qsearchs fields );
20 use FS::cust_location;
22 use FS::cust_bill_pkg;
23 use FS::cust_pkg_detail;
24 use FS::cust_pkg_usage;
25 use FS::cdr_cust_pkg_usage;
30 use FS::cust_pkg_reason;
32 use FS::cust_pkg_discount;
37 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
39 # because they load configuration by setting FS::UID::callback (see TODO)
45 # for sending cancel emails in sub cancel
49 $me = '[FS::cust_pkg]';
51 $disable_agentcheck = 0;
55 my ( $hashref, $cache ) = @_;
56 #if ( $hashref->{'pkgpart'} ) {
57 if ( $hashref->{'pkg'} ) {
58 # #@{ $self->{'_pkgnum'} } = ();
59 # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
60 # $self->{'_pkgpart'} = $subcache;
61 # #push @{ $self->{'_pkgnum'} },
62 # FS::part_pkg->new_or_cached($hashref, $subcache);
63 $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
65 if ( exists $hashref->{'svcnum'} ) {
66 #@{ $self->{'_pkgnum'} } = ();
67 my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
68 $self->{'_svcnum'} = $subcache;
69 #push @{ $self->{'_pkgnum'} },
70 FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
76 FS::cust_pkg - Object methods for cust_pkg objects
82 $record = new FS::cust_pkg \%hash;
83 $record = new FS::cust_pkg { 'column' => 'value' };
85 $error = $record->insert;
87 $error = $new_record->replace($old_record);
89 $error = $record->delete;
91 $error = $record->check;
93 $error = $record->cancel;
95 $error = $record->suspend;
97 $error = $record->unsuspend;
99 $part_pkg = $record->part_pkg;
101 @labels = $record->labels;
103 $seconds = $record->seconds_since($timestamp);
105 $error = FS::cust_pkg::order( $custnum, \@pkgparts );
106 $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
110 An FS::cust_pkg object represents a customer billing item. FS::cust_pkg
111 inherits from FS::Record. The following fields are currently supported:
117 Primary key (assigned automatically for new billing items)
121 Customer (see L<FS::cust_main>)
125 Billing item definition (see L<FS::part_pkg>)
129 Optional link to package location (see L<FS::location>)
133 date package was ordered (also remains same on changes)
145 date (next bill date)
173 order taker (see L<FS::access_user>)
177 If this field is set to 1, disables the automatic
178 unsuspension of this package when using the B<unsuspendauto> config option.
182 If not set, defaults to 1
186 Date of change from previous package
196 =item change_locationnum
204 The pkgnum of the package that this package is supplemental to, if any.
208 The package link (L<FS::part_pkg_link>) that defines this supplemental
209 package, if it is one.
213 Note: setup, last_bill, bill, adjourn, susp, expire, cancel and change_date
214 are specified as UNIX timestamps; see L<perlfunc/"time">. Also see
215 L<Time::Local> and L<Date::Parse> for conversion functions.
223 Create a new billing item. To add the item to the database, see L<"insert">.
227 sub table { 'cust_pkg'; }
228 sub cust_linked { $_[0]->cust_main_custnum; }
229 sub cust_unlinked_msg {
231 "WARNING: can't find cust_main.custnum ". $self->custnum.
232 ' (cust_pkg.pkgnum '. $self->pkgnum. ')';
235 =item insert [ OPTION => VALUE ... ]
237 Adds this billing item to the database ("Orders" the item). If there is an
238 error, returns the error, otherwise returns false.
240 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
241 will be used to look up the package definition and agent restrictions will be
244 If the additional field I<refnum> is defined, an FS::pkg_referral record will
245 be created and inserted. Multiple FS::pkg_referral records can be created by
246 setting I<refnum> to an array reference of refnums or a hash reference with
247 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
248 record will be created corresponding to cust_main.refnum.
250 The following options are available:
256 If set true, supresses any referral credit to a referring customer.
260 cust_pkg_option records will be created
264 a ticket will be added to this customer with this subject
268 an optional queue name for ticket additions
272 Don't check the legality of the package definition. This should be used
273 when performing a package change that doesn't change the pkgpart (i.e.
281 my( $self, %options ) = @_;
284 $error = $self->check_pkgpart unless $options{'allow_pkgpart'};
285 return $error if $error;
287 my $part_pkg = $self->part_pkg;
289 if ( $part_pkg->option('start_1st', 1) && !$self->start_date ) {
290 my ($sec,$min,$hour,$mday,$mon,$year) = (localtime(time) )[0,1,2,3,4,5];
291 $mon += 1 unless $mday == 1;
292 until ( $mon < 12 ) { $mon -= 12; $year++; }
293 $self->start_date( timelocal_nocheck(0,0,0,1,$mon,$year) );
296 foreach my $action ( qw(expire adjourn contract_end) ) {
297 my $months = $part_pkg->option("${action}_months",1);
298 if($months and !$self->$action) {
299 my $start = $self->start_date || $self->setup || time;
300 $self->$action( $part_pkg->add_freq($start, $months) );
304 my $free_days = $part_pkg->option('free_days',1);
305 if ( $free_days && $part_pkg->option('delay_setup',1) ) { #&& !$self->start_date
306 my ($mday,$mon,$year) = (localtime(time) )[3,4,5];
307 #my $start_date = ($self->start_date || timelocal(0,0,0,$mday,$mon,$year)) + 86400 * $free_days;
308 my $start_date = timelocal(0,0,0,$mday,$mon,$year) + 86400 * $free_days;
309 $self->start_date($start_date);
312 $self->order_date(time);
314 local $SIG{HUP} = 'IGNORE';
315 local $SIG{INT} = 'IGNORE';
316 local $SIG{QUIT} = 'IGNORE';
317 local $SIG{TERM} = 'IGNORE';
318 local $SIG{TSTP} = 'IGNORE';
319 local $SIG{PIPE} = 'IGNORE';
321 my $oldAutoCommit = $FS::UID::AutoCommit;
322 local $FS::UID::AutoCommit = 0;
325 $error = $self->SUPER::insert($options{options} ? %{$options{options}} : ());
327 $dbh->rollback if $oldAutoCommit;
331 $self->refnum($self->cust_main->refnum) unless $self->refnum;
332 $self->refnum( [ $self->refnum ] ) unless ref($self->refnum);
333 $self->process_m2m( 'link_table' => 'pkg_referral',
334 'target_table' => 'part_referral',
335 'params' => $self->refnum,
338 if ( $self->discountnum ) {
339 my $error = $self->insert_discount();
341 $dbh->rollback if $oldAutoCommit;
346 #if ( $self->reg_code ) {
347 # my $reg_code = qsearchs('reg_code', { 'code' => $self->reg_code } );
348 # $error = $reg_code->delete;
350 # $dbh->rollback if $oldAutoCommit;
355 my $conf = new FS::Conf;
357 if ( $conf->config('ticket_system') && $options{ticket_subject} ) {
359 #this init stuff is still inefficient, but at least its limited to
360 # the small number (any?) folks using ticket emailing on pkg order
363 # use lib ( "/opt/rt3/local/lib", "/opt/rt3/lib" );
370 use FS::TicketSystem;
371 FS::TicketSystem->init();
373 my $q = new RT::Queue($RT::SystemUser);
374 $q->Load($options{ticket_queue}) if $options{ticket_queue};
375 my $t = new RT::Ticket($RT::SystemUser);
376 my $mime = new MIME::Entity;
377 $mime->build( Type => 'text/plain', Data => $options{ticket_subject} );
378 $t->Create( $options{ticket_queue} ? (Queue => $q) : (),
379 Subject => $options{ticket_subject},
382 $t->AddLink( Type => 'MemberOf',
383 Target => 'freeside://freeside/cust_main/'. $self->custnum,
387 if ($conf->config('welcome_letter') && $self->cust_main->num_pkgs == 1) {
388 my $queue = new FS::queue {
389 'job' => 'FS::cust_main::queueable_print',
391 $error = $queue->insert(
392 'custnum' => $self->custnum,
393 'template' => 'welcome_letter',
397 warn "can't send welcome letter: $error";
402 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
409 This method now works but you probably shouldn't use it.
411 You don't want to delete packages, because there would then be no record
412 the customer ever purchased the package. Instead, see the cancel method and
413 hide cancelled packages.
420 local $SIG{HUP} = 'IGNORE';
421 local $SIG{INT} = 'IGNORE';
422 local $SIG{QUIT} = 'IGNORE';
423 local $SIG{TERM} = 'IGNORE';
424 local $SIG{TSTP} = 'IGNORE';
425 local $SIG{PIPE} = 'IGNORE';
427 my $oldAutoCommit = $FS::UID::AutoCommit;
428 local $FS::UID::AutoCommit = 0;
431 foreach my $cust_pkg_discount ($self->cust_pkg_discount) {
432 my $error = $cust_pkg_discount->delete;
434 $dbh->rollback if $oldAutoCommit;
438 #cust_bill_pkg_discount?
440 foreach my $cust_pkg_detail ($self->cust_pkg_detail) {
441 my $error = $cust_pkg_detail->delete;
443 $dbh->rollback if $oldAutoCommit;
448 foreach my $cust_pkg_reason (
450 'table' => 'cust_pkg_reason',
451 'hashref' => { 'pkgnum' => $self->pkgnum },
455 my $error = $cust_pkg_reason->delete;
457 $dbh->rollback if $oldAutoCommit;
464 my $error = $self->SUPER::delete(@_);
466 $dbh->rollback if $oldAutoCommit;
470 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
476 =item replace [ OLD_RECORD ] [ HASHREF | OPTION => VALUE ... ]
478 Replaces the OLD_RECORD with this one in the database. If there is an error,
479 returns the error, otherwise returns false.
481 Currently, custnum, setup, bill, adjourn, susp, expire, and cancel may be changed.
483 Changing pkgpart may have disasterous effects. See the order subroutine.
485 setup and bill are normally updated by calling the bill method of a customer
486 object (see L<FS::cust_main>).
488 suspend is normally updated by the suspend and unsuspend methods.
490 cancel is normally updated by the cancel method (and also the order subroutine
493 Available options are:
499 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.
503 the access_user (see L<FS::access_user>) providing the reason
507 hashref of keys and values - cust_pkg_option records will be created, updated or removed as appopriate
516 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
521 ( ref($_[0]) eq 'HASH' )
525 #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
526 #return "Can't change otaker!" if $old->otaker ne $new->otaker;
529 #return "Can't change setup once it exists!"
530 # if $old->getfield('setup') &&
531 # $old->getfield('setup') != $new->getfield('setup');
533 #some logic for bill, susp, cancel?
535 local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
537 local $SIG{HUP} = 'IGNORE';
538 local $SIG{INT} = 'IGNORE';
539 local $SIG{QUIT} = 'IGNORE';
540 local $SIG{TERM} = 'IGNORE';
541 local $SIG{TSTP} = 'IGNORE';
542 local $SIG{PIPE} = 'IGNORE';
544 my $oldAutoCommit = $FS::UID::AutoCommit;
545 local $FS::UID::AutoCommit = 0;
548 foreach my $method ( qw(adjourn expire) ) { # How many reasons?
549 if ($options->{'reason'} && $new->$method && $old->$method ne $new->$method) {
550 my $error = $new->insert_reason(
551 'reason' => $options->{'reason'},
552 'date' => $new->$method,
554 'reason_otaker' => $options->{'reason_otaker'},
557 dbh->rollback if $oldAutoCommit;
558 return "Error inserting cust_pkg_reason: $error";
563 #save off and freeze RADIUS attributes for any associated svc_acct records
565 if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
567 #also check for specific exports?
568 # to avoid spurious modify export events
569 @svc_acct = map { $_->svc_x }
570 grep { $_->part_svc->svcdb eq 'svc_acct' }
573 $_->snapshot foreach @svc_acct;
577 my $error = $new->SUPER::replace($old,
578 $options->{options} ? $options->{options} : ()
581 $dbh->rollback if $oldAutoCommit;
585 #for prepaid packages,
586 #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
587 foreach my $old_svc_acct ( @svc_acct ) {
588 my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
590 $new_svc_acct->replace( $old_svc_acct,
591 'depend_jobnum' => $options->{depend_jobnum},
594 $dbh->rollback if $oldAutoCommit;
599 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
606 Checks all fields to make sure this is a valid billing item. If there is an
607 error, returns the error, otherwise returns false. Called by the insert and
615 if ( !$self->locationnum or $self->locationnum == -1 ) {
616 $self->set('locationnum', $self->cust_main->ship_locationnum);
620 $self->ut_numbern('pkgnum')
621 || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
622 || $self->ut_numbern('pkgpart')
623 || $self->ut_foreign_keyn('locationnum', 'cust_location', 'locationnum')
624 || $self->ut_numbern('start_date')
625 || $self->ut_numbern('setup')
626 || $self->ut_numbern('bill')
627 || $self->ut_numbern('susp')
628 || $self->ut_numbern('cancel')
629 || $self->ut_numbern('adjourn')
630 || $self->ut_numbern('resume')
631 || $self->ut_numbern('expire')
632 || $self->ut_numbern('dundate')
633 || $self->ut_enum('no_auto', [ '', 'Y' ])
634 || $self->ut_enum('waive_setup', [ '', 'Y' ])
635 || $self->ut_numbern('agent_pkgid')
636 || $self->ut_enum('recur_show_zero', [ '', 'Y', 'N', ])
637 || $self->ut_enum('setup_show_zero', [ '', 'Y', 'N', ])
638 || $self->ut_foreign_keyn('main_pkgnum', 'cust_pkg', 'pkgnum')
639 || $self->ut_foreign_keyn('pkglinknum', 'part_pkg_link', 'pkglinknum')
641 return $error if $error;
643 return "A package with both start date (future start) and setup date (already started) will never bill"
644 if $self->start_date && $self->setup;
646 return "A future unsuspend date can only be set for a package with a suspend date"
647 if $self->resume and !$self->susp and !$self->adjourn;
649 $self->usernum($FS::CurrentUser::CurrentUser->usernum) unless $self->usernum;
651 if ( $self->dbdef_table->column('manual_flag') ) {
652 $self->manual_flag('') if $self->manual_flag eq ' ';
653 $self->manual_flag =~ /^([01]?)$/
654 or return "Illegal manual_flag ". $self->manual_flag;
655 $self->manual_flag($1);
663 Check the pkgpart to make sure it's allowed with the reg_code and/or
664 promo_code of the package (if present) and with the customer's agent.
665 Called from C<insert>, unless we are doing a package change that doesn't
673 # my $error = $self->ut_numbern('pkgpart'); # already done
676 if ( $self->reg_code ) {
678 unless ( grep { $self->pkgpart == $_->pkgpart }
679 map { $_->reg_code_pkg }
680 qsearchs( 'reg_code', { 'code' => $self->reg_code,
681 'agentnum' => $self->cust_main->agentnum })
683 return "Unknown registration code";
686 } elsif ( $self->promo_code ) {
689 qsearchs('part_pkg', {
690 'pkgpart' => $self->pkgpart,
691 'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
693 return 'Unknown promotional code' unless $promo_part_pkg;
697 unless ( $disable_agentcheck ) {
699 qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
700 return "agent ". $agent->agentnum. ':'. $agent->agent.
701 " can't purchase pkgpart ". $self->pkgpart
702 unless $agent->pkgpart_hashref->{ $self->pkgpart }
703 || $agent->agentnum == $self->part_pkg->agentnum;
706 $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
707 return $error if $error;
715 =item cancel [ OPTION => VALUE ... ]
717 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
718 in this package, then cancels the package itself (sets the cancel field to
721 Available options are:
725 =item quiet - can be set true to supress email cancellation notices.
727 =item time - can be set to cancel the package based on a specific future or
728 historical date. Using time ensures that the remaining amount is calculated
729 correctly. Note however that this is an immediate cancel and just changes
730 the date. You are PROBABLY looking to expire the account instead of using
733 =item reason - can be set to a cancellation reason (see L<FS:reason>),
734 either a reasonnum of an existing reason, or passing a hashref will create
735 a new reason. The hashref should have the following keys: typenum - Reason
736 type (see L<FS::reason_type>, reason - Text of the new reason.
738 =item date - can be set to a unix style timestamp to specify when to
741 =item nobill - can be set true to skip billing if it might otherwise be done.
743 =item unused_credit - can be set to 1 to credit the remaining time, or 0 to
744 not credit it. This must be set (by change()) when changing the package
745 to a different pkgpart or location, and probably shouldn't be in any other
746 case. If it's not set, the 'unused_credit_cancel' part_pkg option will
751 If there is an error, returns the error, otherwise returns false.
756 my( $self, %options ) = @_;
759 # pass all suspend/cancel actions to the main package
760 if ( $self->main_pkgnum and !$options{'from_main'} ) {
761 return $self->main_pkg->cancel(%options);
764 my $conf = new FS::Conf;
766 warn "cust_pkg::cancel called with options".
767 join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
770 local $SIG{HUP} = 'IGNORE';
771 local $SIG{INT} = 'IGNORE';
772 local $SIG{QUIT} = 'IGNORE';
773 local $SIG{TERM} = 'IGNORE';
774 local $SIG{TSTP} = 'IGNORE';
775 local $SIG{PIPE} = 'IGNORE';
777 my $oldAutoCommit = $FS::UID::AutoCommit;
778 local $FS::UID::AutoCommit = 0;
781 my $old = $self->select_for_update;
783 if ( $old->get('cancel') || $self->get('cancel') ) {
784 dbh->rollback if $oldAutoCommit;
785 return ""; # no error
788 # XXX possibly set cancel_time to the expire date?
789 my $cancel_time = $options{'time'} || time;
790 my $date = $options{'date'} if $options{'date'}; # expire/cancel later
791 $date = '' if ($date && $date <= $cancel_time); # complain instead?
793 #race condition: usage could be ongoing until unprovisioned
794 #resolved by performing a change package instead (which unprovisions) and
796 if ( !$options{nobill} && !$date ) {
797 # && $conf->exists('bill_usage_on_cancel') ) { #calc_cancel checks this
798 my $copy = $self->new({$self->hash});
800 $copy->cust_main->bill( 'pkg_list' => [ $copy ],
802 'time' => $cancel_time );
803 warn "Error billing during cancel, custnum ".
804 #$self->cust_main->custnum. ": $error"
809 if ( $options{'reason'} ) {
810 $error = $self->insert_reason( 'reason' => $options{'reason'},
811 'action' => $date ? 'expire' : 'cancel',
812 'date' => $date ? $date : $cancel_time,
813 'reason_otaker' => $options{'reason_otaker'},
816 dbh->rollback if $oldAutoCommit;
817 return "Error inserting cust_pkg_reason: $error";
821 my %svc_cancel_opt = ();
822 $svc_cancel_opt{'date'} = $date if $date;
823 foreach my $cust_svc (
826 sort { $a->[1] <=> $b->[1] }
827 map { [ $_, $_->svc_x ? $_->svc_x->table_info->{'cancel_weight'} : -1 ]; }
828 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
830 my $part_svc = $cust_svc->part_svc;
831 next if ( defined($part_svc) and $part_svc->preserve );
832 my $error = $cust_svc->cancel( %svc_cancel_opt );
835 $dbh->rollback if $oldAutoCommit;
836 return 'Error '. ($svc_cancel_opt{'date'} ? 'expiring' : 'canceling' ).
842 # credit remaining time if appropriate
844 if ( exists($options{'unused_credit'}) ) {
845 $do_credit = $options{'unused_credit'};
848 $do_credit = $self->part_pkg->option('unused_credit_cancel', 1);
851 my $error = $self->credit_remaining('cancel', $cancel_time);
853 $dbh->rollback if $oldAutoCommit;
860 my %hash = $self->hash;
861 $date ? ($hash{'expire'} = $date) : ($hash{'cancel'} = $cancel_time);
862 my $new = new FS::cust_pkg ( \%hash );
863 $error = $new->replace( $self, options => { $self->options } );
865 $dbh->rollback if $oldAutoCommit;
869 foreach my $supp_pkg ( $self->supplemental_pkgs ) {
870 $error = $supp_pkg->cancel(%options, 'from_main' => 1);
872 $dbh->rollback if $oldAutoCommit;
873 return "canceling supplemental pkg#".$supp_pkg->pkgnum.": $error";
877 foreach my $usage ( $self->cust_pkg_usage ) {
878 $error = $usage->delete;
880 $dbh->rollback if $oldAutoCommit;
881 return "deleting usage pools: $error";
885 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
886 return '' if $date; #no errors
888 my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
889 if ( !$options{'quiet'} &&
890 $conf->exists('emailcancel', $self->cust_main->agentnum) &&
892 my $msgnum = $conf->config('cancel_msgnum', $self->cust_main->agentnum);
895 my $msg_template = qsearchs('msg_template', { msgnum => $msgnum });
896 $error = $msg_template->send( 'cust_main' => $self->cust_main,
901 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
902 'to' => \@invoicing_list,
903 'subject' => ( $conf->config('cancelsubject') || 'Cancellation Notice' ),
904 'body' => [ map "$_\n", $conf->config('cancelmessage') ],
907 #should this do something on errors?
914 =item cancel_if_expired [ NOW_TIMESTAMP ]
916 Cancels this package if its expire date has been reached.
920 sub cancel_if_expired {
922 my $time = shift || time;
923 return '' unless $self->expire && $self->expire <= $time;
924 my $error = $self->cancel;
926 return "Error cancelling expired pkg ". $self->pkgnum. " for custnum ".
927 $self->custnum. ": $error";
934 "Un-cancels" this package: Orders a new package with the same custnum, pkgpart,
935 locationnum, (other fields?). Attempts to re-provision cancelled services
936 using history information (errors at this stage are not fatal).
938 cust_pkg: pass a scalar reference, will be filled in with the new cust_pkg object
940 svc_fatal: service provisioning errors are fatal
942 svc_errors: pass an array reference, will be filled in with any provisioning errors
944 main_pkgnum: link the package as a supplemental package of this one. For
950 my( $self, %options ) = @_;
952 #in case you try do do $uncancel-date = $cust_pkg->uncacel
953 return '' unless $self->get('cancel');
955 if ( $self->main_pkgnum and !$options{'main_pkgnum'} ) {
956 return $self->main_pkg->uncancel(%options);
963 local $SIG{HUP} = 'IGNORE';
964 local $SIG{INT} = 'IGNORE';
965 local $SIG{QUIT} = 'IGNORE';
966 local $SIG{TERM} = 'IGNORE';
967 local $SIG{TSTP} = 'IGNORE';
968 local $SIG{PIPE} = 'IGNORE';
970 my $oldAutoCommit = $FS::UID::AutoCommit;
971 local $FS::UID::AutoCommit = 0;
975 # insert the new package
978 my $cust_pkg = new FS::cust_pkg {
979 last_bill => ( $options{'last_bill'} || $self->get('last_bill') ),
980 bill => ( $options{'bill'} || $self->get('bill') ),
982 uncancel_pkgnum => $self->pkgnum,
983 main_pkgnum => ($options{'main_pkgnum'} || ''),
984 map { $_ => $self->get($_) } qw(
985 custnum pkgpart locationnum
987 susp adjourn resume expire start_date contract_end dundate
988 change_date change_pkgpart change_locationnum
989 manual_flag no_auto quantity agent_pkgid recur_show_zero setup_show_zero
993 my $error = $cust_pkg->insert(
994 'change' => 1, #supresses any referral credit to a referring customer
995 'allow_pkgpart' => 1, # allow this even if the package def is disabled
998 $dbh->rollback if $oldAutoCommit;
1006 #find historical services within this timeframe before the package cancel
1007 # (incompatible with "time" option to cust_pkg->cancel?)
1008 my $fuzz = 2 * 60; #2 minutes? too much? (might catch separate unprovision)
1009 # too little? (unprovisioing export delay?)
1010 my($end, $start) = ( $self->get('cancel'), $self->get('cancel') - $fuzz );
1011 my @h_cust_svc = $self->h_cust_svc( $end, $start );
1014 foreach my $h_cust_svc (@h_cust_svc) {
1015 my $h_svc_x = $h_cust_svc->h_svc_x( $end, $start );
1016 #next unless $h_svc_x; #should this happen?
1017 (my $table = $h_svc_x->table) =~ s/^h_//;
1018 require "FS/$table.pm";
1019 my $class = "FS::$table";
1020 my $svc_x = $class->new( {
1021 'pkgnum' => $cust_pkg->pkgnum,
1022 'svcpart' => $h_cust_svc->svcpart,
1023 map { $_ => $h_svc_x->get($_) } fields($table)
1027 if ( $h_svc_x->isa('FS::h_svc_Radius_Mixin') ) {
1028 $svc_x->usergroup( [ $h_svc_x->h_usergroup($end, $start) ] );
1031 my $svc_error = $svc_x->insert;
1033 if ( $options{svc_fatal} ) {
1034 $dbh->rollback if $oldAutoCommit;
1037 push @svc_errors, $svc_error;
1038 # is this necessary? svc_Common::insert already deletes the
1039 # cust_svc if inserting svc_x fails.
1040 my $cust_svc = qsearchs('cust_svc', { 'svcnum' => $svc_x->svcnum });
1042 my $cs_error = $cust_svc->delete;
1044 $dbh->rollback if $oldAutoCommit;
1050 } #foreach $h_cust_svc
1052 #these are pretty rare, but should handle them
1053 # - dsl_device (mac addresses)
1054 # - phone_device (mac addresses)
1055 # - dsl_note (ikano notes)
1056 # - domain_record (i.e. restore DNS information w/domains)
1057 # - inventory_item(?) (inventory w/un-cancelling service?)
1058 # - nas (svc_broaband nas stuff)
1059 #this stuff is unused in the wild afaik
1060 # - mailinglistmember
1062 # - svc_domain.parent_svcnum?
1063 # - acct_snarf (ancient mail fetching config)
1064 # - cgp_rule (communigate)
1065 # - cust_svc_option (used by our Tron stuff)
1066 # - acct_rt_transaction (used by our time worked stuff)
1069 # also move over any services that didn't unprovision at cancellation
1072 foreach my $cust_svc ( qsearch('cust_svc', { pkgnum => $self->pkgnum } ) ) {
1073 $cust_svc->pkgnum( $cust_pkg->pkgnum );
1074 my $error = $cust_svc->replace;
1076 $dbh->rollback if $oldAutoCommit;
1082 # Uncancel any supplemental packages, and make them supplemental to the
1086 foreach my $supp_pkg ( $self->supplemental_pkgs ) {
1088 $error = $supp_pkg->uncancel(%options, 'main_pkgnum' => $cust_pkg->pkgnum);
1090 $dbh->rollback if $oldAutoCommit;
1091 return "canceling supplemental pkg#".$supp_pkg->pkgnum.": $error";
1099 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1101 ${ $options{cust_pkg} } = $cust_pkg if ref($options{cust_pkg});
1102 @{ $options{svc_errors} } = @svc_errors if ref($options{svc_errors});
1109 Cancels any pending expiration (sets the expire field to null).
1111 If there is an error, returns the error, otherwise returns false.
1116 my( $self, %options ) = @_;
1119 local $SIG{HUP} = 'IGNORE';
1120 local $SIG{INT} = 'IGNORE';
1121 local $SIG{QUIT} = 'IGNORE';
1122 local $SIG{TERM} = 'IGNORE';
1123 local $SIG{TSTP} = 'IGNORE';
1124 local $SIG{PIPE} = 'IGNORE';
1126 my $oldAutoCommit = $FS::UID::AutoCommit;
1127 local $FS::UID::AutoCommit = 0;
1130 my $old = $self->select_for_update;
1132 my $pkgnum = $old->pkgnum;
1133 if ( $old->get('cancel') || $self->get('cancel') ) {
1134 dbh->rollback if $oldAutoCommit;
1135 return "Can't unexpire cancelled package $pkgnum";
1136 # or at least it's pointless
1139 unless ( $old->get('expire') && $self->get('expire') ) {
1140 dbh->rollback if $oldAutoCommit;
1141 return ""; # no error
1144 my %hash = $self->hash;
1145 $hash{'expire'} = '';
1146 my $new = new FS::cust_pkg ( \%hash );
1147 $error = $new->replace( $self, options => { $self->options } );
1149 $dbh->rollback if $oldAutoCommit;
1153 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1159 =item suspend [ OPTION => VALUE ... ]
1161 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
1162 package, then suspends the package itself (sets the susp field to now).
1164 Available options are:
1168 =item reason - can be set to a cancellation reason (see L<FS:reason>),
1169 either a reasonnum of an existing reason, or passing a hashref will create
1170 a new reason. The hashref should have the following keys:
1171 - typenum - Reason type (see L<FS::reason_type>
1172 - reason - Text of the new reason.
1174 =item date - can be set to a unix style timestamp to specify when to
1177 =item time - can be set to override the current time, for calculation
1178 of final invoices or unused-time credits
1180 =item resume_date - can be set to a time when the package should be
1181 unsuspended. This may be more convenient than calling C<unsuspend()>
1184 =item from_main - allows a supplemental package to be suspended, rather
1185 than redirecting the method call to its main package. For internal use.
1189 If there is an error, returns the error, otherwise returns false.
1194 my( $self, %options ) = @_;
1197 # pass all suspend/cancel actions to the main package
1198 if ( $self->main_pkgnum and !$options{'from_main'} ) {
1199 return $self->main_pkg->suspend(%options);
1202 local $SIG{HUP} = 'IGNORE';
1203 local $SIG{INT} = 'IGNORE';
1204 local $SIG{QUIT} = 'IGNORE';
1205 local $SIG{TERM} = 'IGNORE';
1206 local $SIG{TSTP} = 'IGNORE';
1207 local $SIG{PIPE} = 'IGNORE';
1209 my $oldAutoCommit = $FS::UID::AutoCommit;
1210 local $FS::UID::AutoCommit = 0;
1213 my $old = $self->select_for_update;
1215 my $pkgnum = $old->pkgnum;
1216 if ( $old->get('cancel') || $self->get('cancel') ) {
1217 dbh->rollback if $oldAutoCommit;
1218 return "Can't suspend cancelled package $pkgnum";
1221 if ( $old->get('susp') || $self->get('susp') ) {
1222 dbh->rollback if $oldAutoCommit;
1223 return ""; # no error # complain on adjourn?
1226 my $suspend_time = $options{'time'} || time;
1227 my $date = $options{date} if $options{date}; # adjourn/suspend later
1228 $date = '' if ($date && $date <= $suspend_time); # complain instead?
1230 if ( $date && $old->get('expire') && $old->get('expire') < $date ) {
1231 dbh->rollback if $oldAutoCommit;
1232 return "Package $pkgnum expires before it would be suspended.";
1235 # some false laziness with sub cancel
1236 if ( !$options{nobill} && !$date &&
1237 $self->part_pkg->option('bill_suspend_as_cancel',1) ) {
1238 # kind of a kludge--'bill_suspend_as_cancel' to avoid having to
1239 # make the entire cust_main->bill path recognize 'suspend' and
1240 # 'cancel' separately.
1241 warn "Billing $pkgnum on suspension (at $suspend_time)\n" if $DEBUG;
1242 my $copy = $self->new({$self->hash});
1244 $copy->cust_main->bill( 'pkg_list' => [ $copy ],
1246 'time' => $suspend_time );
1247 warn "Error billing during suspend, custnum ".
1248 #$self->cust_main->custnum. ": $error"
1253 if ( $options{'reason'} ) {
1254 $error = $self->insert_reason( 'reason' => $options{'reason'},
1255 'action' => $date ? 'adjourn' : 'suspend',
1256 'date' => $date ? $date : $suspend_time,
1257 'reason_otaker' => $options{'reason_otaker'},
1260 dbh->rollback if $oldAutoCommit;
1261 return "Error inserting cust_pkg_reason: $error";
1265 my %hash = $self->hash;
1267 $hash{'adjourn'} = $date;
1269 $hash{'susp'} = $suspend_time;
1272 my $resume_date = $options{'resume_date'} || 0;
1273 if ( $resume_date > ($date || $suspend_time) ) {
1274 $hash{'resume'} = $resume_date;
1277 $options{options} ||= {};
1279 my $new = new FS::cust_pkg ( \%hash );
1280 $error = $new->replace( $self, options => { $self->options,
1281 %{ $options{options} },
1285 $dbh->rollback if $oldAutoCommit;
1290 # credit remaining time if appropriate
1291 if ( $self->part_pkg->option('unused_credit_suspend', 1) ) {
1292 my $error = $self->credit_remaining('suspend', $suspend_time);
1294 $dbh->rollback if $oldAutoCommit;
1301 foreach my $cust_svc (
1302 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
1304 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
1306 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
1307 $dbh->rollback if $oldAutoCommit;
1308 return "Illegal svcdb value in part_svc!";
1311 require "FS/$svcdb.pm";
1313 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
1315 $error = $svc->suspend;
1317 $dbh->rollback if $oldAutoCommit;
1320 my( $label, $value ) = $cust_svc->label;
1321 push @labels, "$label: $value";
1325 my $conf = new FS::Conf;
1326 if ( $conf->config('suspend_email_admin') ) {
1328 my $error = send_email(
1329 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
1330 #invoice_from ??? well as good as any
1331 'to' => $conf->config('suspend_email_admin'),
1332 'subject' => 'FREESIDE NOTIFICATION: Customer package suspended',
1334 "This is an automatic message from your Freeside installation\n",
1335 "informing you that the following customer package has been suspended:\n",
1337 'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
1338 'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
1339 ( map { "Service : $_\n" } @labels ),
1344 warn "WARNING: can't send suspension admin email (suspending anyway): ".
1352 foreach my $supp_pkg ( $self->supplemental_pkgs ) {
1353 $error = $supp_pkg->suspend(%options, 'from_main' => 1);
1355 $dbh->rollback if $oldAutoCommit;
1356 return "suspending supplemental pkg#".$supp_pkg->pkgnum.": $error";
1360 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1365 =item credit_remaining MODE TIME
1367 Generate a credit for this package for the time remaining in the current
1368 billing period. MODE is either "suspend" or "cancel" (determines the
1369 credit type). TIME is the time of suspension/cancellation. Both arguments
1374 sub credit_remaining {
1375 # Add a credit for remaining service
1376 my ($self, $mode, $time) = @_;
1377 die 'credit_remaining requires suspend or cancel'
1378 unless $mode eq 'suspend' or $mode eq 'cancel';
1379 die 'no suspend/cancel time' unless $time > 0;
1381 my $conf = FS::Conf->new;
1382 my $reason_type = $conf->config($mode.'_credit_type');
1384 my $last_bill = $self->getfield('last_bill') || 0;
1385 my $next_bill = $self->getfield('bill') || 0;
1386 if ( $last_bill > 0 # the package has been billed
1387 and $next_bill > 0 # the package has a next bill date
1388 and $next_bill >= $time # which is in the future
1390 my $remaining_value = $self->calc_remain('time' => $time);
1391 if ( $remaining_value > 0 ) {
1392 warn "Crediting for $remaining_value on package ".$self->pkgnum."\n"
1394 my $error = $self->cust_main->credit(
1396 'Credit for unused time on '. $self->part_pkg->pkg,
1397 'reason_type' => $reason_type,
1399 return "Error crediting customer \$$remaining_value for unused time".
1400 " on ". $self->part_pkg->pkg. ": $error"
1402 } #if $remaining_value
1403 } #if $last_bill, etc.
1407 =item unsuspend [ OPTION => VALUE ... ]
1409 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
1410 package, then unsuspends the package itself (clears the susp field and the
1411 adjourn field if it is in the past). If the suspend reason includes an
1412 unsuspension package, that package will be ordered.
1414 Available options are:
1420 Can be set to a date to unsuspend the package in the future (the 'resume'
1423 =item adjust_next_bill
1425 Can be set true to adjust the next bill date forward by
1426 the amount of time the account was inactive. This was set true by default
1427 since 1.4.2 and 1.5.0pre6; however, starting with 1.7.0 this needs to be
1428 explicitly requested. Price plans for which this makes sense (anniversary-date
1429 based than prorate or subscription) could have an option to enable this
1434 If there is an error, returns the error, otherwise returns false.
1439 my( $self, %opt ) = @_;
1442 # pass all suspend/cancel actions to the main package
1443 if ( $self->main_pkgnum and !$opt{'from_main'} ) {
1444 return $self->main_pkg->unsuspend(%opt);
1447 local $SIG{HUP} = 'IGNORE';
1448 local $SIG{INT} = 'IGNORE';
1449 local $SIG{QUIT} = 'IGNORE';
1450 local $SIG{TERM} = 'IGNORE';
1451 local $SIG{TSTP} = 'IGNORE';
1452 local $SIG{PIPE} = 'IGNORE';
1454 my $oldAutoCommit = $FS::UID::AutoCommit;
1455 local $FS::UID::AutoCommit = 0;
1458 my $old = $self->select_for_update;
1460 my $pkgnum = $old->pkgnum;
1461 if ( $old->get('cancel') || $self->get('cancel') ) {
1462 $dbh->rollback if $oldAutoCommit;
1463 return "Can't unsuspend cancelled package $pkgnum";
1466 unless ( $old->get('susp') && $self->get('susp') ) {
1467 $dbh->rollback if $oldAutoCommit;
1468 return ""; # no error # complain instead?
1471 my $date = $opt{'date'};
1472 if ( $date and $date > time ) { # return an error if $date <= time?
1474 if ( $old->get('expire') && $old->get('expire') < $date ) {
1475 $dbh->rollback if $oldAutoCommit;
1476 return "Package $pkgnum expires before it would be unsuspended.";
1479 my $new = new FS::cust_pkg { $self->hash };
1480 $new->set('resume', $date);
1481 $error = $new->replace($self, options => $self->options);
1484 $dbh->rollback if $oldAutoCommit;
1488 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1496 foreach my $cust_svc (
1497 qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
1499 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
1501 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
1502 $dbh->rollback if $oldAutoCommit;
1503 return "Illegal svcdb value in part_svc!";
1506 require "FS/$svcdb.pm";
1508 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
1510 $error = $svc->unsuspend;
1512 $dbh->rollback if $oldAutoCommit;
1515 my( $label, $value ) = $cust_svc->label;
1516 push @labels, "$label: $value";
1521 my $cust_pkg_reason = $self->last_cust_pkg_reason('susp');
1522 my $reason = $cust_pkg_reason ? $cust_pkg_reason->reason : '';
1524 my %hash = $self->hash;
1525 my $inactive = time - $hash{'susp'};
1527 my $conf = new FS::Conf;
1529 if ( $inactive > 0 &&
1530 ( $hash{'bill'} || $hash{'setup'} ) &&
1531 ( $opt{'adjust_next_bill'} ||
1532 $conf->exists('unsuspend-always_adjust_next_bill_date') ||
1533 $self->part_pkg->option('unsuspend_adjust_bill', 1) )
1536 $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive;
1541 $hash{'adjourn'} = '' if $hash{'adjourn'} and $hash{'adjourn'} < time;
1542 $hash{'resume'} = '' if !$hash{'adjourn'};
1543 my $new = new FS::cust_pkg ( \%hash );
1544 $error = $new->replace( $self, options => { $self->options } );
1546 $dbh->rollback if $oldAutoCommit;
1552 if ( $reason && $reason->unsuspend_pkgpart ) {
1553 my $part_pkg = FS::part_pkg->by_key($reason->unsuspend_pkgpart)
1554 or $error = "Unsuspend package definition ".$reason->unsuspend_pkgpart.
1556 my $start_date = $self->cust_main->next_bill_date
1557 if $reason->unsuspend_hold;
1560 $unsusp_pkg = FS::cust_pkg->new({
1561 'custnum' => $self->custnum,
1562 'pkgpart' => $reason->unsuspend_pkgpart,
1563 'start_date' => $start_date,
1564 'locationnum' => $self->locationnum,
1565 # discount? probably not...
1568 $error ||= $self->cust_main->order_pkg( 'cust_pkg' => $unsusp_pkg );
1572 $dbh->rollback if $oldAutoCommit;
1577 if ( $conf->config('unsuspend_email_admin') ) {
1579 my $error = send_email(
1580 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
1581 #invoice_from ??? well as good as any
1582 'to' => $conf->config('unsuspend_email_admin'),
1583 'subject' => 'FREESIDE NOTIFICATION: Customer package unsuspended', 'body' => [
1584 "This is an automatic message from your Freeside installation\n",
1585 "informing you that the following customer package has been unsuspended:\n",
1587 'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
1588 'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
1589 ( map { "Service : $_\n" } @labels ),
1591 "An unsuspension fee was charged: ".
1592 $unsusp_pkg->part_pkg->pkg_comment."\n"
1599 warn "WARNING: can't send unsuspension admin email (unsuspending anyway): ".
1605 foreach my $supp_pkg ( $self->supplemental_pkgs ) {
1606 $error = $supp_pkg->unsuspend(%opt, 'from_main' => 1);
1608 $dbh->rollback if $oldAutoCommit;
1609 return "unsuspending supplemental pkg#".$supp_pkg->pkgnum.": $error";
1613 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1620 Cancels any pending suspension (sets the adjourn field to null).
1622 If there is an error, returns the error, otherwise returns false.
1627 my( $self, %options ) = @_;
1630 local $SIG{HUP} = 'IGNORE';
1631 local $SIG{INT} = 'IGNORE';
1632 local $SIG{QUIT} = 'IGNORE';
1633 local $SIG{TERM} = 'IGNORE';
1634 local $SIG{TSTP} = 'IGNORE';
1635 local $SIG{PIPE} = 'IGNORE';
1637 my $oldAutoCommit = $FS::UID::AutoCommit;
1638 local $FS::UID::AutoCommit = 0;
1641 my $old = $self->select_for_update;
1643 my $pkgnum = $old->pkgnum;
1644 if ( $old->get('cancel') || $self->get('cancel') ) {
1645 dbh->rollback if $oldAutoCommit;
1646 return "Can't unadjourn cancelled package $pkgnum";
1647 # or at least it's pointless
1650 if ( $old->get('susp') || $self->get('susp') ) {
1651 dbh->rollback if $oldAutoCommit;
1652 return "Can't unadjourn suspended package $pkgnum";
1653 # perhaps this is arbitrary
1656 unless ( $old->get('adjourn') && $self->get('adjourn') ) {
1657 dbh->rollback if $oldAutoCommit;
1658 return ""; # no error
1661 my %hash = $self->hash;
1662 $hash{'adjourn'} = '';
1663 $hash{'resume'} = '';
1664 my $new = new FS::cust_pkg ( \%hash );
1665 $error = $new->replace( $self, options => { $self->options } );
1667 $dbh->rollback if $oldAutoCommit;
1671 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1678 =item change HASHREF | OPTION => VALUE ...
1680 Changes this package: cancels it and creates a new one, with a different
1681 pkgpart or locationnum or both. All services are transferred to the new
1682 package (no change will be made if this is not possible).
1684 Options may be passed as a list of key/value pairs or as a hash reference.
1691 New locationnum, to change the location for this package.
1695 New FS::cust_location object, to create a new location and assign it
1700 New pkgpart (see L<FS::part_pkg>).
1704 New refnum (see L<FS::part_referral>).
1708 Set to true to transfer billing dates (start_date, setup, last_bill, bill,
1709 susp, adjourn, cancel, expire, and contract_end) to the new package.
1713 At least one of locationnum, cust_location, pkgpart, refnum must be specified
1714 (otherwise, what's the point?)
1716 Returns either the new FS::cust_pkg object or a scalar error.
1720 my $err_or_new_cust_pkg = $old_cust_pkg->change
1724 #some false laziness w/order
1727 my $opt = ref($_[0]) ? shift : { @_ };
1729 # my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
1732 my $conf = new FS::Conf;
1734 # Transactionize this whole mess
1735 local $SIG{HUP} = 'IGNORE';
1736 local $SIG{INT} = 'IGNORE';
1737 local $SIG{QUIT} = 'IGNORE';
1738 local $SIG{TERM} = 'IGNORE';
1739 local $SIG{TSTP} = 'IGNORE';
1740 local $SIG{PIPE} = 'IGNORE';
1742 my $oldAutoCommit = $FS::UID::AutoCommit;
1743 local $FS::UID::AutoCommit = 0;
1752 #$hash{$_} = $self->$_() foreach qw( last_bill bill );
1754 #$hash{$_} = $self->$_() foreach qw( setup );
1756 $hash{'setup'} = $time if $self->setup;
1758 $hash{'change_date'} = $time;
1759 $hash{"change_$_"} = $self->$_()
1760 foreach qw( pkgnum pkgpart locationnum );
1762 if ( $opt->{'cust_location'} &&
1763 ( ! $opt->{'locationnum'} || $opt->{'locationnum'} == -1 ) ) {
1765 if ( ! $opt->{'cust_location'}->locationnum ) {
1767 $error = $opt->{'cust_location'}->insert;
1769 $dbh->rollback if $oldAutoCommit;
1770 return "inserting cust_location (transaction rolled back): $error";
1773 $opt->{'locationnum'} = $opt->{'cust_location'}->locationnum;
1777 # whether to override pkgpart checking on the new package
1778 my $same_pkgpart = 1;
1779 if ( $opt->{'pkgpart'} and ( $opt->{'pkgpart'} != $self->pkgpart ) ) {
1783 my $unused_credit = 0;
1784 my $keep_dates = $opt->{'keep_dates'};
1785 # Special case. If the pkgpart is changing, and the customer is
1786 # going to be credited for remaining time, don't keep setup, bill,
1787 # or last_bill dates, and DO pass the flag to cancel() to credit
1789 if ( $opt->{'pkgpart'}
1790 and $opt->{'pkgpart'} != $self->pkgpart
1791 and $self->part_pkg->option('unused_credit_change', 1) ) {
1794 $hash{$_} = '' foreach qw(setup bill last_bill);
1797 if ( $keep_dates ) {
1798 foreach my $date ( qw(setup bill last_bill susp adjourn cancel expire
1799 resume start_date contract_end ) ) {
1800 $hash{$date} = $self->getfield($date);
1803 # allow $opt->{'locationnum'} = '' to specifically set it to null
1804 # (i.e. customer default location)
1805 $opt->{'locationnum'} = $self->locationnum if !exists($opt->{'locationnum'});
1807 # usually this doesn't matter. the two cases where it does are:
1808 # 1. unused_credit_change + pkgpart change + setup fee on the new package
1810 # 2. (more importantly) changing a package before it's billed
1811 $hash{'waive_setup'} = $self->waive_setup;
1813 # Create the new package.
1814 my $cust_pkg = new FS::cust_pkg {
1815 custnum => $self->custnum,
1816 pkgpart => ( $opt->{'pkgpart'} || $self->pkgpart ),
1817 refnum => ( $opt->{'refnum'} || $self->refnum ),
1818 locationnum => ( $opt->{'locationnum'} ),
1821 $error = $cust_pkg->insert( 'change' => 1,
1822 'allow_pkgpart' => $same_pkgpart );
1824 $dbh->rollback if $oldAutoCommit;
1828 # Transfer services and cancel old package.
1830 $error = $self->transfer($cust_pkg);
1831 if ($error and $error == 0) {
1832 # $old_pkg->transfer failed.
1833 $dbh->rollback if $oldAutoCommit;
1837 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1838 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1839 $error = $self->transfer($cust_pkg, 'change_svcpart'=>1 );
1840 if ($error and $error == 0) {
1841 # $old_pkg->transfer failed.
1842 $dbh->rollback if $oldAutoCommit;
1848 # Transfers were successful, but we still had services left on the old
1849 # package. We can't change the package under this circumstances, so abort.
1850 $dbh->rollback if $oldAutoCommit;
1851 return "Unable to transfer all services from package ". $self->pkgnum;
1854 #reset usage if changing pkgpart
1855 # AND usage rollover is off (otherwise adds twice, now and at package bill)
1856 if ($self->pkgpart != $cust_pkg->pkgpart) {
1857 my $part_pkg = $cust_pkg->part_pkg;
1858 $error = $part_pkg->reset_usage($cust_pkg, $part_pkg->is_prepaid
1862 if $part_pkg->can('reset_usage') && ! $part_pkg->option('usage_rollover',1);
1865 $dbh->rollback if $oldAutoCommit;
1866 return "Error setting usage values: $error";
1869 # if NOT changing pkgpart, transfer any usage pools over
1870 foreach my $usage ($self->cust_pkg_usage) {
1871 $usage->set('pkgnum', $cust_pkg->pkgnum);
1872 $error = $usage->replace;
1874 $dbh->rollback if $oldAutoCommit;
1875 return "Error transferring usage pools: $error";
1880 # transfer discounts, if we're not changing pkgpart
1881 if ( $same_pkgpart ) {
1882 foreach my $old_discount ($self->cust_pkg_discount_active) {
1883 # don't remove the old discount, we may still need to bill that package.
1884 my $new_discount = new FS::cust_pkg_discount {
1885 'pkgnum' => $cust_pkg->pkgnum,
1886 'discountnum' => $old_discount->discountnum,
1887 'months_used' => $old_discount->months_used,
1889 $error = $new_discount->insert;
1891 $dbh->rollback if $oldAutoCommit;
1892 return "Error transferring discounts: $error";
1897 # Order any supplemental packages.
1898 my $part_pkg = $cust_pkg->part_pkg;
1899 my @old_supp_pkgs = $self->supplemental_pkgs;
1901 foreach my $link ($part_pkg->supp_part_pkg_link) {
1903 foreach (@old_supp_pkgs) {
1904 if ($_->pkgpart == $link->dst_pkgpart) {
1906 $_->pkgpart(0); # so that it can't match more than once
1910 # false laziness with FS::cust_main::Packages::order_pkg
1911 my $new = FS::cust_pkg->new({
1912 pkgpart => $link->dst_pkgpart,
1913 pkglinknum => $link->pkglinknum,
1914 custnum => $self->custnum,
1915 main_pkgnum => $cust_pkg->pkgnum,
1916 locationnum => $cust_pkg->locationnum,
1917 start_date => $cust_pkg->start_date,
1918 order_date => $cust_pkg->order_date,
1919 expire => $cust_pkg->expire,
1920 adjourn => $cust_pkg->adjourn,
1921 contract_end => $cust_pkg->contract_end,
1922 refnum => $cust_pkg->refnum,
1923 discountnum => $cust_pkg->discountnum,
1924 waive_setup => $cust_pkg->waive_setup,
1926 if ( $old and $opt->{'keep_dates'} ) {
1927 foreach (qw(setup bill last_bill)) {
1928 $new->set($_, $old->get($_));
1931 $error = $new->insert( allow_pkgpart => $same_pkgpart );
1934 $error ||= $old->transfer($new);
1936 if ( $error and $error > 0 ) {
1937 # no reason why this should ever fail, but still...
1938 $error = "Unable to transfer all services from supplemental package ".
1942 $dbh->rollback if $oldAutoCommit;
1945 push @new_supp_pkgs, $new;
1948 #Good to go, cancel old package. Notify 'cancel' of whether to credit
1950 #Don't allow billing the package (preceding period packages and/or
1951 #outstanding usage) if we are keeping dates (i.e. location changing),
1952 #because the new package will be billed for the same date range.
1953 #Supplemental packages are also canceled here.
1954 $error = $self->cancel(
1956 unused_credit => $unused_credit,
1957 nobill => $keep_dates
1960 $dbh->rollback if $oldAutoCommit;
1964 if ( $conf->exists('cust_pkg-change_pkgpart-bill_now') ) {
1966 my $error = $cust_pkg->cust_main->bill(
1967 'pkg_list' => [ $cust_pkg, @new_supp_pkgs ]
1970 $dbh->rollback if $oldAutoCommit;
1975 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1981 =item set_quantity QUANTITY
1983 Change the package's quantity field. This is the one package property
1984 that can safely be changed without canceling and reordering the package
1985 (because it doesn't affect tax eligibility). Returns an error or an
1992 $self = $self->replace_old; # just to make sure
1994 ($qty =~ /^\d+$/ and $qty > 0) or return "bad package quantity $qty";
1995 $self->set('quantity' => $qty);
1999 use Storable 'thaw';
2001 sub process_bulk_cust_pkg {
2003 my $param = thaw(decode_base64(shift));
2004 warn Dumper($param) if $DEBUG;
2006 my $old_part_pkg = qsearchs('part_pkg',
2007 { pkgpart => $param->{'old_pkgpart'} });
2008 my $new_part_pkg = qsearchs('part_pkg',
2009 { pkgpart => $param->{'new_pkgpart'} });
2010 die "Must select a new package type\n" unless $new_part_pkg;
2011 #my $keep_dates = $param->{'keep_dates'} || 0;
2012 my $keep_dates = 1; # there is no good reason to turn this off
2014 local $SIG{HUP} = 'IGNORE';
2015 local $SIG{INT} = 'IGNORE';
2016 local $SIG{QUIT} = 'IGNORE';
2017 local $SIG{TERM} = 'IGNORE';
2018 local $SIG{TSTP} = 'IGNORE';
2019 local $SIG{PIPE} = 'IGNORE';
2021 my $oldAutoCommit = $FS::UID::AutoCommit;
2022 local $FS::UID::AutoCommit = 0;
2025 my @cust_pkgs = qsearch('cust_pkg', { 'pkgpart' => $param->{'old_pkgpart'} } );
2028 foreach my $old_cust_pkg ( @cust_pkgs ) {
2030 $job->update_statustext(int(100*$i/(scalar @cust_pkgs)));
2031 if ( $old_cust_pkg->getfield('cancel') ) {
2032 warn '[process_bulk_cust_pkg ] skipping canceled pkgnum '.
2033 $old_cust_pkg->pkgnum."\n"
2037 warn '[process_bulk_cust_pkg] changing pkgnum '.$old_cust_pkg->pkgnum."\n"
2039 my $error = $old_cust_pkg->change(
2040 'pkgpart' => $param->{'new_pkgpart'},
2041 'keep_dates' => $keep_dates
2043 if ( !ref($error) ) { # change returns the cust_pkg on success
2045 die "Error changing pkgnum ".$old_cust_pkg->pkgnum.": '$error'\n";
2048 $dbh->commit if $oldAutoCommit;
2054 Returns the last bill date, or if there is no last bill date, the setup date.
2055 Useful for billing metered services.
2061 return $self->setfield('last_bill', $_[0]) if @_;
2062 return $self->getfield('last_bill') if $self->getfield('last_bill');
2063 my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
2064 'edate' => $self->bill, } );
2065 $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
2068 =item last_cust_pkg_reason ACTION
2070 Returns the most recent ACTION FS::cust_pkg_reason associated with the package.
2071 Returns false if there is no reason or the package is not currenly ACTION'd
2072 ACTION is one of adjourn, susp, cancel, or expire.
2076 sub last_cust_pkg_reason {
2077 my ( $self, $action ) = ( shift, shift );
2078 my $date = $self->get($action);
2080 'table' => 'cust_pkg_reason',
2081 'hashref' => { 'pkgnum' => $self->pkgnum,
2082 'action' => substr(uc($action), 0, 1),
2085 'order_by' => 'ORDER BY num DESC LIMIT 1',
2089 =item last_reason ACTION
2091 Returns the most recent ACTION FS::reason associated with the package.
2092 Returns false if there is no reason or the package is not currenly ACTION'd
2093 ACTION is one of adjourn, susp, cancel, or expire.
2098 my $cust_pkg_reason = shift->last_cust_pkg_reason(@_);
2099 $cust_pkg_reason->reason
2100 if $cust_pkg_reason;
2105 Returns the definition for this billing item, as an FS::part_pkg object (see
2112 return $self->{'_pkgpart'} if $self->{'_pkgpart'};
2113 cluck "cust_pkg->part_pkg called" if $DEBUG > 1;
2114 qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
2119 Returns the cancelled package this package was changed from, if any.
2125 return '' unless $self->change_pkgnum;
2126 qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
2131 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
2138 $self->part_pkg->calc_setup($self, @_);
2143 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
2150 $self->part_pkg->calc_recur($self, @_);
2155 Calls the I<base_recur> of the FS::part_pkg object associated with this billing
2162 $self->part_pkg->base_recur($self, @_);
2167 Calls the I<calc_remain> of the FS::part_pkg object associated with this
2174 $self->part_pkg->calc_remain($self, @_);
2179 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
2186 $self->part_pkg->calc_cancel($self, @_);
2191 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
2197 qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
2200 =item cust_pkg_detail [ DETAILTYPE ]
2202 Returns any customer package details for this package (see
2203 L<FS::cust_pkg_detail>).
2205 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
2209 sub cust_pkg_detail {
2211 my %hash = ( 'pkgnum' => $self->pkgnum );
2212 $hash{detailtype} = shift if @_;
2214 'table' => 'cust_pkg_detail',
2215 'hashref' => \%hash,
2216 'order_by' => 'ORDER BY weight, pkgdetailnum',
2220 =item set_cust_pkg_detail DETAILTYPE [ DETAIL, DETAIL, ... ]
2222 Sets customer package details for this package (see L<FS::cust_pkg_detail>).
2224 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
2226 If there is an error, returns the error, otherwise returns false.
2230 sub set_cust_pkg_detail {
2231 my( $self, $detailtype, @details ) = @_;
2233 local $SIG{HUP} = 'IGNORE';
2234 local $SIG{INT} = 'IGNORE';
2235 local $SIG{QUIT} = 'IGNORE';
2236 local $SIG{TERM} = 'IGNORE';
2237 local $SIG{TSTP} = 'IGNORE';
2238 local $SIG{PIPE} = 'IGNORE';
2240 my $oldAutoCommit = $FS::UID::AutoCommit;
2241 local $FS::UID::AutoCommit = 0;
2244 foreach my $current ( $self->cust_pkg_detail($detailtype) ) {
2245 my $error = $current->delete;
2247 $dbh->rollback if $oldAutoCommit;
2248 return "error removing old detail: $error";
2252 foreach my $detail ( @details ) {
2253 my $cust_pkg_detail = new FS::cust_pkg_detail {
2254 'pkgnum' => $self->pkgnum,
2255 'detailtype' => $detailtype,
2256 'detail' => $detail,
2258 my $error = $cust_pkg_detail->insert;
2260 $dbh->rollback if $oldAutoCommit;
2261 return "error adding new detail: $error";
2266 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2273 Returns the new-style customer billing events (see L<FS::cust_event>) for this invoice.
2277 #false laziness w/cust_bill.pm
2281 'table' => 'cust_event',
2282 'addl_from' => 'JOIN part_event USING ( eventpart )',
2283 'hashref' => { 'tablenum' => $self->pkgnum },
2284 'extra_sql' => " AND eventtable = 'cust_pkg' ",
2288 =item num_cust_event
2290 Returns the number of new-style customer billing events (see L<FS::cust_event>) for this invoice.
2294 #false laziness w/cust_bill.pm
2295 sub num_cust_event {
2298 "SELECT COUNT(*) FROM cust_event JOIN part_event USING ( eventpart ) ".
2299 " WHERE tablenum = ? AND eventtable = 'cust_pkg'";
2300 my $sth = dbh->prepare($sql) or die dbh->errstr. " preparing $sql";
2301 $sth->execute($self->pkgnum) or die $sth->errstr. " executing $sql";
2302 $sth->fetchrow_arrayref->[0];
2305 =item cust_svc [ SVCPART ] (old, deprecated usage)
2307 =item cust_svc [ OPTION => VALUE ... ] (current usage)
2309 Returns the services for this package, as FS::cust_svc objects (see
2310 L<FS::cust_svc>). Available options are svcpart and svcdb. If either is
2311 spcififed, returns only the matching services.
2318 return () unless $self->num_cust_svc(@_);
2321 if ( @_ && $_[0] =~ /^\d+/ ) {
2322 $opt{svcpart} = shift;
2323 } elsif ( @_ && ref($_[0]) eq 'HASH' ) {
2330 'table' => 'cust_svc',
2331 'hashref' => { 'pkgnum' => $self->pkgnum },
2333 if ( $opt{svcpart} ) {
2334 $search{hashref}->{svcpart} = $opt{'svcpart'};
2336 if ( $opt{'svcdb'} ) {
2337 $search{addl_from} = ' LEFT JOIN part_svc USING ( svcpart ) ';
2338 $search{extra_sql} = ' AND svcdb = '. dbh->quote( $opt{'svcdb'} );
2341 cluck "cust_pkg->cust_svc called" if $DEBUG > 2;
2343 #if ( $self->{'_svcnum'} ) {
2344 # values %{ $self->{'_svcnum'}->cache };
2346 $self->_sort_cust_svc( [ qsearch(\%search) ] );
2351 =item overlimit [ SVCPART ]
2353 Returns the services for this package which have exceeded their
2354 usage limit as FS::cust_svc objects (see L<FS::cust_svc>). If a svcpart
2355 is specified, return only the matching services.
2361 return () unless $self->num_cust_svc(@_);
2362 grep { $_->overlimit } $self->cust_svc(@_);
2365 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
2367 Returns historical services for this package created before END TIMESTAMP and
2368 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
2369 (see L<FS::h_cust_svc>). If MODE is 'I' (for 'invoice'), services with the
2370 I<pkg_svc.hidden> flag will be omitted.
2376 warn "$me _h_cust_svc called on $self\n"
2379 my ($end, $start, $mode) = @_;
2380 my @cust_svc = $self->_sort_cust_svc(
2381 [ qsearch( 'h_cust_svc',
2382 { 'pkgnum' => $self->pkgnum, },
2383 FS::h_cust_svc->sql_h_search(@_),
2386 if ( defined($mode) && $mode eq 'I' ) {
2387 my %hidden_svcpart = map { $_->svcpart => $_->hidden } $self->part_svc;
2388 return grep { !$hidden_svcpart{$_->svcpart} } @cust_svc;
2394 sub _sort_cust_svc {
2395 my( $self, $arrayref ) = @_;
2398 sub ($$) { my ($a, $b) = @_; $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] };
2403 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
2404 'svcpart' => $_->svcpart } );
2406 $pkg_svc ? $pkg_svc->primary_svc : '',
2407 $pkg_svc ? $pkg_svc->quantity : 0,
2414 =item num_cust_svc [ SVCPART ] (old, deprecated usage)
2416 =item num_cust_svc [ OPTION => VALUE ... ] (current usage)
2418 Returns the number of services for this package. Available options are svcpart
2419 and svcdb. If either is spcififed, returns only the matching services.
2426 return $self->{'_num_cust_svc'}
2428 && exists($self->{'_num_cust_svc'})
2429 && $self->{'_num_cust_svc'} =~ /\d/;
2431 cluck "cust_pkg->num_cust_svc called, _num_cust_svc:".$self->{'_num_cust_svc'}
2435 if ( @_ && $_[0] =~ /^\d+/ ) {
2436 $opt{svcpart} = shift;
2437 } elsif ( @_ && ref($_[0]) eq 'HASH' ) {
2443 my $select = 'SELECT COUNT(*) FROM cust_svc ';
2444 my $where = ' WHERE pkgnum = ? ';
2445 my @param = ($self->pkgnum);
2447 if ( $opt{'svcpart'} ) {
2448 $where .= ' AND svcpart = ? ';
2449 push @param, $opt{'svcpart'};
2451 if ( $opt{'svcdb'} ) {
2452 $select .= ' LEFT JOIN part_svc USING ( svcpart ) ';
2453 $where .= ' AND svcdb = ? ';
2454 push @param, $opt{'svcdb'};
2457 my $sth = dbh->prepare("$select $where") or die dbh->errstr;
2458 $sth->execute(@param) or die $sth->errstr;
2459 $sth->fetchrow_arrayref->[0];
2462 =item available_part_svc
2464 Returns a list of FS::part_svc objects representing services included in this
2465 package but not yet provisioned. Each FS::part_svc object also has an extra
2466 field, I<num_avail>, which specifies the number of available services.
2470 sub available_part_svc {
2473 my $pkg_quantity = $self->quantity || 1;
2475 grep { $_->num_avail > 0 }
2477 my $part_svc = $_->part_svc;
2478 $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
2479 $pkg_quantity * $_->quantity - $self->num_cust_svc($_->svcpart);
2481 # more evil encapsulation breakage
2482 if($part_svc->{'Hash'}{'num_avail'} > 0) {
2483 my @exports = $part_svc->part_export_did;
2484 $part_svc->{'Hash'}{'can_get_dids'} = scalar(@exports);
2489 $self->part_pkg->pkg_svc;
2492 =item part_svc [ OPTION => VALUE ... ]
2494 Returns a list of FS::part_svc objects representing provisioned and available
2495 services included in this package. Each FS::part_svc object also has the
2496 following extra fields:
2500 =item num_cust_svc (count)
2502 =item num_avail (quantity - count)
2504 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
2508 Accepts one option: summarize_size. If specified and non-zero, will omit the
2509 extra cust_pkg_svc option for objects where num_cust_svc is this size or
2515 #label -> ($cust_svc->label)[1]
2521 my $pkg_quantity = $self->quantity || 1;
2523 #XXX some sort of sort order besides numeric by svcpart...
2524 my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
2526 my $part_svc = $pkg_svc->part_svc;
2527 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
2528 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
2529 $part_svc->{'Hash'}{'num_avail'} =
2530 max( 0, $pkg_quantity * $pkg_svc->quantity - $num_cust_svc );
2531 $part_svc->{'Hash'}{'cust_pkg_svc'} =
2532 $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : []
2533 unless exists($opt{summarize_size}) && $opt{summarize_size} > 0
2534 && $num_cust_svc >= $opt{summarize_size};
2535 $part_svc->{'Hash'}{'hidden'} = $pkg_svc->hidden;
2537 } $self->part_pkg->pkg_svc;
2540 push @part_svc, map {
2542 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
2543 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
2544 $part_svc->{'Hash'}{'num_avail'} = 0; #0-$num_cust_svc ?
2545 $part_svc->{'Hash'}{'cust_pkg_svc'} =
2546 $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
2548 } $self->extra_part_svc;
2554 =item extra_part_svc
2556 Returns a list of FS::part_svc objects corresponding to services in this
2557 package which are still provisioned but not (any longer) available in the
2562 sub extra_part_svc {
2565 my $pkgnum = $self->pkgnum;
2566 #my $pkgpart = $self->pkgpart;
2569 # 'table' => 'part_svc',
2572 # "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
2573 # WHERE pkg_svc.svcpart = part_svc.svcpart
2574 # AND pkg_svc.pkgpart = ?
2577 # AND 0 < ( SELECT COUNT(*) FROM cust_svc
2578 # LEFT JOIN cust_pkg USING ( pkgnum )
2579 # WHERE cust_svc.svcpart = part_svc.svcpart
2582 # 'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
2585 #seems to benchmark slightly faster... (or did?)
2587 my @pkgparts = map $_->pkgpart, $self->part_pkg->self_and_svc_linked;
2588 my $pkgparts = join(',', @pkgparts);
2591 #'select' => 'DISTINCT ON (svcpart) part_svc.*',
2592 #MySQL doesn't grok DISINCT ON
2593 'select' => 'DISTINCT part_svc.*',
2594 'table' => 'part_svc',
2596 "LEFT JOIN pkg_svc ON ( pkg_svc.svcpart = part_svc.svcpart
2597 AND pkg_svc.pkgpart IN ($pkgparts)
2600 LEFT JOIN cust_svc ON ( cust_svc.svcpart = part_svc.svcpart )
2601 LEFT JOIN cust_pkg USING ( pkgnum )
2604 'extra_sql' => "WHERE pkgsvcnum IS NULL AND cust_pkg.pkgnum = ? ",
2605 'extra_param' => [ [$self->pkgnum=>'int'] ],
2611 Returns a short status string for this package, currently:
2615 =item not yet billed
2617 =item one-time charge
2632 my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
2634 return 'cancelled' if $self->get('cancel');
2635 return 'suspended' if $self->susp;
2636 return 'not yet billed' unless $self->setup;
2637 return 'one-time charge' if $freq =~ /^(0|$)/;
2641 =item ucfirst_status
2643 Returns the status with the first character capitalized.
2647 sub ucfirst_status {
2648 ucfirst(shift->status);
2653 Class method that returns the list of possible status strings for packages
2654 (see L<the status method|/status>). For example:
2656 @statuses = FS::cust_pkg->statuses();
2660 tie my %statuscolor, 'Tie::IxHash',
2661 'not yet billed' => '009999', #teal? cyan?
2662 'one-time charge' => '000000',
2663 'active' => '00CC00',
2664 'suspended' => 'FF9900',
2665 'cancelled' => 'FF0000',
2669 my $self = shift; #could be class...
2670 #grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
2671 # # mayble split btw one-time vs. recur
2677 Returns a hex triplet color string for this package's status.
2683 $statuscolor{$self->status};
2688 Returns a label for this package. (Currently "pkgnum: pkg - comment" or
2689 "pkg - comment" depending on user preference).
2695 my $label = $self->part_pkg->pkg_comment( 'nopkgpart' => 1 );
2696 $label = $self->pkgnum. ": $label"
2697 if $FS::CurrentUser::CurrentUser->option('show_pkgnum');
2701 =item pkg_label_long
2703 Returns a long label for this package, adding the primary service's label to
2708 sub pkg_label_long {
2710 my $label = $self->pkg_label;
2711 my $cust_svc = $self->primary_cust_svc;
2712 $label .= ' ('. ($cust_svc->label)[1]. ')' if $cust_svc;
2718 Returns a customer-localized label for this package.
2724 $self->part_pkg->pkg_locale( $self->cust_main->locale );
2727 =item primary_cust_svc
2729 Returns a primary service (as FS::cust_svc object) if one can be identified.
2733 #for labeling purposes - might not 100% match up with part_pkg->svcpart's idea
2735 sub primary_cust_svc {
2738 my @cust_svc = $self->cust_svc;
2740 return '' unless @cust_svc; #no serivces - irrelevant then
2742 return $cust_svc[0] if scalar(@cust_svc) == 1; #always return a single service
2744 # primary service as specified in the package definition
2745 # or exactly one service definition with quantity one
2746 my $svcpart = $self->part_pkg->svcpart;
2747 @cust_svc = grep { $_->svcpart == $svcpart } @cust_svc;
2748 return $cust_svc[0] if scalar(@cust_svc) == 1;
2750 #couldn't identify one thing..
2756 Returns a list of lists, calling the label method for all services
2757 (see L<FS::cust_svc>) of this billing item.
2763 map { [ $_->label ] } $self->cust_svc;
2766 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
2768 Like the labels method, but returns historical information on services that
2769 were active as of END_TIMESTAMP and (optionally) not cancelled before
2770 START_TIMESTAMP. If MODE is 'I' (for 'invoice'), services with the
2771 I<pkg_svc.hidden> flag will be omitted.
2773 Returns a list of lists, calling the label method for all (historical) services
2774 (see L<FS::h_cust_svc>) of this billing item.
2780 warn "$me _h_labels called on $self\n"
2782 map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
2787 Like labels, except returns a simple flat list, and shortens long
2788 (currently >5 or the cust_bill-max_same_services configuration value) lists of
2789 identical services to one line that lists the service label and the number of
2790 individual services rather than individual items.
2795 shift->_labels_short( 'labels', @_ );
2798 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
2800 Like h_labels, except returns a simple flat list, and shortens long
2801 (currently >5 or the cust_bill-max_same_services configuration value) lists of
2802 identical services to one line that lists the service label and the number of
2803 individual services rather than individual items.
2807 sub h_labels_short {
2808 shift->_labels_short( 'h_labels', @_ );
2812 my( $self, $method ) = ( shift, shift );
2814 warn "$me _labels_short called on $self with $method method\n"
2817 my $conf = new FS::Conf;
2818 my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
2820 warn "$me _labels_short populating \%labels\n"
2824 #tie %labels, 'Tie::IxHash';
2825 push @{ $labels{$_->[0]} }, $_->[1]
2826 foreach $self->$method(@_);
2828 warn "$me _labels_short populating \@labels\n"
2832 foreach my $label ( keys %labels ) {
2834 my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
2835 my $num = scalar(@values);
2836 warn "$me _labels_short $num items for $label\n"
2839 if ( $num > $max_same_services ) {
2840 warn "$me _labels_short more than $max_same_services, so summarizing\n"
2842 push @labels, "$label ($num)";
2844 if ( $conf->exists('cust_bill-consolidate_services') ) {
2845 warn "$me _labels_short consolidating services\n"
2847 # push @labels, "$label: ". join(', ', @values);
2849 my $detail = "$label: ";
2850 $detail .= shift(@values). ', '
2852 && ( length($detail.$values[0]) < 78 || $detail eq "$label: " );
2854 push @labels, $detail;
2856 warn "$me _labels_short done consolidating services\n"
2859 warn "$me _labels_short adding service data\n"
2861 push @labels, map { "$label: $_" } @values;
2872 Returns the parent customer object (see L<FS::cust_main>).
2878 qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
2883 Returns the balance for this specific package, when using
2884 experimental package balance.
2890 $self->cust_main->balance_pkgnum( $self->pkgnum );
2893 #these subs are in location_Mixin.pm now... unfortunately the POD doesn't mixin
2897 Returns the location object, if any (see L<FS::cust_location>).
2899 =item cust_location_or_main
2901 If this package is associated with a location, returns the locaiton (see
2902 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
2904 =item location_label [ OPTION => VALUE ... ]
2906 Returns the label of the location object (see L<FS::cust_location>).
2910 #end of subs in location_Mixin.pm now... unfortunately the POD doesn't mixin
2912 =item tax_locationnum
2914 Returns the foreign key to a L<FS::cust_location> object for calculating
2915 tax on this package, as determined by the C<tax-pkg_address> and
2916 C<tax-ship_address> configuration flags.
2920 sub tax_locationnum {
2922 my $conf = FS::Conf->new;
2923 if ( $conf->exists('tax-pkg_address') ) {
2924 return $self->locationnum;
2926 elsif ( $conf->exists('tax-ship_address') ) {
2927 return $self->cust_main->ship_locationnum;
2930 return $self->cust_main->bill_locationnum;
2936 Returns the L<FS::cust_location> object for tax_locationnum.
2942 FS::cust_location->by_key( $self->tax_locationnum )
2945 =item seconds_since TIMESTAMP
2947 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
2948 package have been online since TIMESTAMP, according to the session monitor.
2950 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
2951 L<Time::Local> and L<Date::Parse> for conversion functions.
2956 my($self, $since) = @_;
2959 foreach my $cust_svc (
2960 grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
2962 $seconds += $cust_svc->seconds_since($since);
2969 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2971 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
2972 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
2975 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2976 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2982 sub seconds_since_sqlradacct {
2983 my($self, $start, $end) = @_;
2987 foreach my $cust_svc (
2989 my $part_svc = $_->part_svc;
2990 $part_svc->svcdb eq 'svc_acct'
2991 && scalar($part_svc->part_export_usage);
2994 $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
3001 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
3003 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
3004 in this package for sessions ending between TIMESTAMP_START (inclusive) and
3008 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
3009 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
3014 sub attribute_since_sqlradacct {
3015 my($self, $start, $end, $attrib) = @_;
3019 foreach my $cust_svc (
3021 my $part_svc = $_->part_svc;
3022 $part_svc->svcdb eq 'svc_acct'
3023 && scalar($part_svc->part_export_usage);
3026 $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
3038 my( $self, $value ) = @_;
3039 if ( defined($value) ) {
3040 $self->setfield('quantity', $value);
3042 $self->getfield('quantity') || 1;
3045 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
3047 Transfers as many services as possible from this package to another package.
3049 The destination package can be specified by pkgnum by passing an FS::cust_pkg
3050 object. The destination package must already exist.
3052 Services are moved only if the destination allows services with the correct
3053 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true. Use
3054 this option with caution! No provision is made for export differences
3055 between the old and new service definitions. Probably only should be used
3056 when your exports for all service definitions of a given svcdb are identical.
3057 (attempt a transfer without it first, to move all possible svcpart-matching
3060 Any services that can't be moved remain in the original package.
3062 Returns an error, if there is one; otherwise, returns the number of services
3063 that couldn't be moved.
3068 my ($self, $dest_pkgnum, %opt) = @_;
3074 if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
3075 $dest = $dest_pkgnum;
3076 $dest_pkgnum = $dest->pkgnum;
3078 $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
3081 return ('Package does not exist: '.$dest_pkgnum) unless $dest;
3083 foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
3084 $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
3087 foreach my $cust_svc ($dest->cust_svc) {
3088 $target{$cust_svc->svcpart}--;
3091 my %svcpart2svcparts = ();
3092 if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
3093 warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
3094 foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
3095 next if exists $svcpart2svcparts{$svcpart};
3096 my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
3097 $svcpart2svcparts{$svcpart} = [
3099 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
3101 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
3102 'svcpart' => $_ } );
3104 $pkg_svc ? $pkg_svc->primary_svc : '',
3105 $pkg_svc ? $pkg_svc->quantity : 0,
3109 grep { $_ != $svcpart }
3111 qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
3113 warn "alternates for svcpart $svcpart: ".
3114 join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
3119 foreach my $cust_svc ($self->cust_svc) {
3120 if($target{$cust_svc->svcpart} > 0
3121 or $FS::cust_svc::ignore_quantity) { # maybe should be a 'force' option
3122 $target{$cust_svc->svcpart}--;
3123 my $new = new FS::cust_svc { $cust_svc->hash };
3124 $new->pkgnum($dest_pkgnum);
3125 my $error = $new->replace($cust_svc);
3126 return $error if $error;
3127 } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
3129 warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
3130 warn "alternates to consider: ".
3131 join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
3133 my @alternate = grep {
3134 warn "considering alternate svcpart $_: ".
3135 "$target{$_} available in new package\n"
3138 } @{$svcpart2svcparts{$cust_svc->svcpart}};
3140 warn "alternate(s) found\n" if $DEBUG;
3141 my $change_svcpart = $alternate[0];
3142 $target{$change_svcpart}--;
3143 my $new = new FS::cust_svc { $cust_svc->hash };
3144 $new->svcpart($change_svcpart);
3145 $new->pkgnum($dest_pkgnum);
3146 my $error = $new->replace($cust_svc);
3147 return $error if $error;
3160 This method is deprecated. See the I<depend_jobnum> option to the insert and
3161 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
3168 local $SIG{HUP} = 'IGNORE';
3169 local $SIG{INT} = 'IGNORE';
3170 local $SIG{QUIT} = 'IGNORE';
3171 local $SIG{TERM} = 'IGNORE';
3172 local $SIG{TSTP} = 'IGNORE';
3173 local $SIG{PIPE} = 'IGNORE';
3175 my $oldAutoCommit = $FS::UID::AutoCommit;
3176 local $FS::UID::AutoCommit = 0;
3179 foreach my $cust_svc ( $self->cust_svc ) {
3180 #false laziness w/svc_Common::insert
3181 my $svc_x = $cust_svc->svc_x;
3182 foreach my $part_export ( $cust_svc->part_svc->part_export ) {
3183 my $error = $part_export->export_insert($svc_x);
3185 $dbh->rollback if $oldAutoCommit;
3191 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3198 Associates this package with a (suspension or cancellation) reason (see
3199 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
3202 Available options are:
3208 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.
3212 the access_user (see L<FS::access_user>) providing the reason
3220 the action (cancel, susp, adjourn, expire) associated with the reason
3224 If there is an error, returns the error, otherwise returns false.
3229 my ($self, %options) = @_;
3231 my $otaker = $options{reason_otaker} ||
3232 $FS::CurrentUser::CurrentUser->username;
3235 if ( $options{'reason'} =~ /^(\d+)$/ ) {
3239 } elsif ( ref($options{'reason'}) ) {
3241 return 'Enter a new reason (or select an existing one)'
3242 unless $options{'reason'}->{'reason'} !~ /^\s*$/;
3244 my $reason = new FS::reason({
3245 'reason_type' => $options{'reason'}->{'typenum'},
3246 'reason' => $options{'reason'}->{'reason'},
3248 my $error = $reason->insert;
3249 return $error if $error;
3251 $reasonnum = $reason->reasonnum;
3254 return "Unparsable reason: ". $options{'reason'};
3257 my $cust_pkg_reason =
3258 new FS::cust_pkg_reason({ 'pkgnum' => $self->pkgnum,
3259 'reasonnum' => $reasonnum,
3260 'otaker' => $otaker,
3261 'action' => substr(uc($options{'action'}),0,1),
3262 'date' => $options{'date'}
3267 $cust_pkg_reason->insert;
3270 =item insert_discount
3272 Associates this package with a discount (see L<FS::cust_pkg_discount>, possibly
3273 inserting a new discount on the fly (see L<FS::discount>).
3275 Available options are:
3283 If there is an error, returns the error, otherwise returns false.
3287 sub insert_discount {
3288 #my ($self, %options) = @_;
3291 my $cust_pkg_discount = new FS::cust_pkg_discount {
3292 'pkgnum' => $self->pkgnum,
3293 'discountnum' => $self->discountnum,
3295 'end_date' => '', #XXX
3296 #for the create a new discount case
3297 '_type' => $self->discountnum__type,
3298 'amount' => $self->discountnum_amount,
3299 'percent' => $self->discountnum_percent,
3300 'months' => $self->discountnum_months,
3301 'setup' => $self->discountnum_setup,
3302 #'disabled' => $self->discountnum_disabled,
3305 $cust_pkg_discount->insert;
3308 =item set_usage USAGE_VALUE_HASHREF
3310 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
3311 to which they should be set (see L<FS::svc_acct>). Currently seconds,
3312 upbytes, downbytes, and totalbytes are appropriate keys.
3314 All svc_accts which are part of this package have their values reset.
3319 my ($self, $valueref, %opt) = @_;
3321 #only svc_acct can set_usage for now
3322 foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
3323 my $svc_x = $cust_svc->svc_x;
3324 $svc_x->set_usage($valueref, %opt)
3325 if $svc_x->can("set_usage");
3329 =item recharge USAGE_VALUE_HASHREF
3331 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
3332 to which they should be set (see L<FS::svc_acct>). Currently seconds,
3333 upbytes, downbytes, and totalbytes are appropriate keys.
3335 All svc_accts which are part of this package have their values incremented.
3340 my ($self, $valueref) = @_;
3342 #only svc_acct can set_usage for now
3343 foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
3344 my $svc_x = $cust_svc->svc_x;
3345 $svc_x->recharge($valueref)
3346 if $svc_x->can("recharge");
3350 =item cust_pkg_discount
3354 sub cust_pkg_discount {
3356 qsearch('cust_pkg_discount', { 'pkgnum' => $self->pkgnum } );
3359 =item cust_pkg_discount_active
3363 sub cust_pkg_discount_active {
3365 grep { $_->status eq 'active' } $self->cust_pkg_discount;
3368 =item cust_pkg_usage
3370 Returns a list of all voice usage counters attached to this package.
3374 sub cust_pkg_usage {
3376 qsearch('cust_pkg_usage', { pkgnum => $self->pkgnum });
3379 =item apply_usage OPTIONS
3381 Takes the following options:
3382 - cdr: a call detail record (L<FS::cdr>)
3383 - rate_detail: the rate determined for this call (L<FS::rate_detail>)
3384 - minutes: the maximum number of minutes to be charged
3386 Finds available usage minutes for a call of this class, and subtracts
3387 up to that many minutes from the usage pool. If the usage pool is empty,
3388 and the C<cdr-minutes_priority> global config option is set, minutes may
3389 be taken from other calls as well. Either way, an allocation record will
3390 be created (L<FS::cdr_cust_pkg_usage>) and this method will return the
3391 number of minutes of usage applied to the call.
3396 my ($self, %opt) = @_;
3397 my $cdr = $opt{cdr};
3398 my $rate_detail = $opt{rate_detail};
3399 my $minutes = $opt{minutes};
3400 my $classnum = $rate_detail->classnum;
3401 my $pkgnum = $self->pkgnum;
3402 my $custnum = $self->custnum;
3404 local $SIG{HUP} = 'IGNORE';
3405 local $SIG{INT} = 'IGNORE';
3406 local $SIG{QUIT} = 'IGNORE';
3407 local $SIG{TERM} = 'IGNORE';
3408 local $SIG{TSTP} = 'IGNORE';
3409 local $SIG{PIPE} = 'IGNORE';
3411 my $oldAutoCommit = $FS::UID::AutoCommit;
3412 local $FS::UID::AutoCommit = 0;
3414 my $order = FS::Conf->new->config('cdr-minutes_priority');
3418 $is_classnum = ' part_pkg_usage_class.classnum = '.$classnum;
3420 $is_classnum = ' part_pkg_usage_class.classnum IS NULL';
3422 my @usage_recs = qsearch({
3423 'table' => 'cust_pkg_usage',
3424 'addl_from' => ' JOIN part_pkg_usage USING (pkgusagepart)'.
3425 ' JOIN cust_pkg USING (pkgnum)'.
3426 ' JOIN part_pkg_usage_class USING (pkgusagepart)',
3427 'select' => 'cust_pkg_usage.*',
3428 'extra_sql' => " WHERE ( cust_pkg.pkgnum = $pkgnum OR ".
3429 " ( cust_pkg.custnum = $custnum AND ".
3430 " part_pkg_usage.shared IS NOT NULL ) ) AND ".
3431 $is_classnum . ' AND '.
3432 " cust_pkg_usage.minutes > 0",
3433 'order_by' => " ORDER BY priority ASC",
3436 my $orig_minutes = $minutes;
3438 while (!$error and $minutes > 0 and @usage_recs) {
3439 my $cust_pkg_usage = shift @usage_recs;
3440 $cust_pkg_usage->select_for_update;
3441 my $cdr_cust_pkg_usage = FS::cdr_cust_pkg_usage->new({
3442 pkgusagenum => $cust_pkg_usage->pkgusagenum,
3443 acctid => $cdr->acctid,
3444 minutes => min($cust_pkg_usage->minutes, $minutes),
3446 $cust_pkg_usage->set('minutes',
3447 sprintf('%.0f', $cust_pkg_usage->minutes - $cdr_cust_pkg_usage->minutes)
3449 $error = $cust_pkg_usage->replace || $cdr_cust_pkg_usage->insert;
3450 $minutes -= $cdr_cust_pkg_usage->minutes;
3452 if ( $order and $minutes > 0 and !$error ) {
3453 # then try to steal minutes from another call
3455 'table' => 'cdr_cust_pkg_usage',
3456 'addl_from' => ' JOIN cust_pkg_usage USING (pkgusagenum)'.
3457 ' JOIN part_pkg_usage USING (pkgusagepart)'.
3458 ' JOIN cust_pkg USING (pkgnum)'.
3459 ' JOIN part_pkg_usage_class USING (pkgusagepart)'.
3460 ' JOIN cdr USING (acctid)',
3461 'select' => 'cdr_cust_pkg_usage.*',
3462 'extra_sql' => " WHERE cdr.freesidestatus = 'rated' AND ".
3463 " ( cust_pkg.pkgnum = $pkgnum OR ".
3464 " ( cust_pkg.custnum = $custnum AND ".
3465 " part_pkg_usage.shared IS NOT NULL ) ) AND ".
3466 " part_pkg_usage_class.classnum = $classnum",
3467 'order_by' => ' ORDER BY part_pkg_usage.priority ASC',
3469 if ( $order eq 'time' ) {
3470 # find CDRs that are using minutes, but have a later startdate
3472 my $startdate = $cdr->startdate;
3473 if ($startdate !~ /^\d+$/) {
3474 die "bad cdr startdate '$startdate'";
3476 $search{'extra_sql'} .= " AND cdr.startdate > $startdate";
3477 # minimize needless reshuffling
3478 $search{'order_by'} .= ', cdr.startdate DESC';
3480 # XXX may not work correctly with rate_time schedules. Could
3481 # fix this by storing ratedetailnum in cdr_cust_pkg_usage, I
3483 $search{'addl_from'} .=
3484 ' JOIN rate_detail'.
3485 ' ON (cdr.rated_ratedetailnum = rate_detail.ratedetailnum)';
3486 if ( $order eq 'rate_high' ) {
3487 $search{'extra_sql'} .= ' AND rate_detail.min_charge < '.
3488 $rate_detail->min_charge;
3489 $search{'order_by'} .= ', rate_detail.min_charge ASC';
3490 } elsif ( $order eq 'rate_low' ) {
3491 $search{'extra_sql'} .= ' AND rate_detail.min_charge > '.
3492 $rate_detail->min_charge;
3493 $search{'order_by'} .= ', rate_detail.min_charge DESC';
3495 # this should really never happen
3496 die "invalid cdr-minutes_priority value '$order'\n";
3499 my @cdr_usage_recs = qsearch(\%search);
3501 while (!$error and @cdr_usage_recs and $minutes > 0) {
3502 my $cdr_cust_pkg_usage = shift @cdr_usage_recs;
3503 my $cust_pkg_usage = $cdr_cust_pkg_usage->cust_pkg_usage;
3504 my $old_cdr = $cdr_cust_pkg_usage->cdr;
3505 $reproc_cdrs{$old_cdr->acctid} = $old_cdr;
3506 $cdr_cust_pkg_usage->select_for_update;
3507 $old_cdr->select_for_update;
3508 $cust_pkg_usage->select_for_update;
3509 # in case someone else stole the usage from this CDR
3510 # while waiting for the lock...
3511 next if $old_cdr->acctid != $cdr_cust_pkg_usage->acctid;
3512 # steal the usage allocation and flag the old CDR for reprocessing
3513 $cdr_cust_pkg_usage->set('acctid', $cdr->acctid);
3514 # if the allocation is more minutes than we need, adjust it...
3515 my $delta = $cdr_cust_pkg_usage->minutes - $minutes;
3517 $cdr_cust_pkg_usage->set('minutes', $minutes);
3518 $cust_pkg_usage->set('minutes', $cust_pkg_usage->minutes + $delta);
3519 $error = $cust_pkg_usage->replace;
3521 #warn 'CDR '.$cdr->acctid . ' stealing allocation '.$cdr_cust_pkg_usage->cdrusagenum.' from CDR '.$old_cdr->acctid."\n";
3522 $error ||= $cdr_cust_pkg_usage->replace;
3523 # deduct the stolen minutes
3524 $minutes -= $cdr_cust_pkg_usage->minutes;
3526 # after all minute-stealing is done, reset the affected CDRs
3527 foreach (values %reproc_cdrs) {
3528 $error ||= $_->set_status('');
3529 # XXX or should we just call $cdr->rate right here?
3530 # it's not like we can create a loop this way, since the min_charge
3531 # or call time has to go monotonically in one direction.
3532 # we COULD get some very deep recursions going, though...
3534 } # if $order and $minutes
3537 die "error applying included minutes\npkgnum ".$self->pkgnum.", class $classnum, acctid ".$cdr->acctid."\n$error\n"
3539 $dbh->commit if $oldAutoCommit;
3540 return $orig_minutes - $minutes;
3544 =item supplemental_pkgs
3546 Returns a list of all packages supplemental to this one.
3550 sub supplemental_pkgs {
3552 qsearch('cust_pkg', { 'main_pkgnum' => $self->pkgnum });
3557 Returns the package that this one is supplemental to, if any.
3563 if ( $self->main_pkgnum ) {
3564 return FS::cust_pkg->by_key($self->main_pkgnum);
3571 =head1 CLASS METHODS
3577 Returns an SQL expression identifying recurring packages.
3581 sub recurring_sql { "
3582 '0' != ( select freq from part_pkg
3583 where cust_pkg.pkgpart = part_pkg.pkgpart )
3588 Returns an SQL expression identifying one-time packages.
3593 '0' = ( select freq from part_pkg
3594 where cust_pkg.pkgpart = part_pkg.pkgpart )
3599 Returns an SQL expression identifying ordered packages (recurring packages not
3605 $_[0]->recurring_sql. " AND ". $_[0]->not_yet_billed_sql;
3610 Returns an SQL expression identifying active packages.
3615 $_[0]->recurring_sql. "
3616 AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
3617 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
3618 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
3621 =item not_yet_billed_sql
3623 Returns an SQL expression identifying packages which have not yet been billed.
3627 sub not_yet_billed_sql { "
3628 ( cust_pkg.setup IS NULL OR cust_pkg.setup = 0 )
3629 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
3630 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
3635 Returns an SQL expression identifying inactive packages (one-time packages
3636 that are otherwise unsuspended/uncancelled).
3640 sub inactive_sql { "
3641 ". $_[0]->onetime_sql(). "
3642 AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
3643 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
3644 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
3650 Returns an SQL expression identifying suspended packages.
3654 sub suspended_sql { susp_sql(@_); }
3656 #$_[0]->recurring_sql(). ' AND '.
3658 ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
3659 AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0
3666 Returns an SQL exprression identifying cancelled packages.
3670 sub cancelled_sql { cancel_sql(@_); }
3672 #$_[0]->recurring_sql(). ' AND '.
3673 "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
3678 Returns an SQL expression to give the package status as a string.
3684 WHEN cust_pkg.cancel IS NOT NULL THEN 'cancelled'
3685 WHEN cust_pkg.susp IS NOT NULL THEN 'suspended'
3686 WHEN cust_pkg.setup IS NULL THEN 'not yet billed'
3687 WHEN ".onetime_sql()." THEN 'one-time charge'
3692 =item search HASHREF
3696 Returns a qsearch hash expression to search for parameters specified in HASHREF.
3697 Valid parameters are
3705 active, inactive, suspended, cancel (or cancelled)
3709 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
3713 boolean selects custom packages
3719 pkgpart or arrayref or hashref of pkgparts
3723 arrayref of beginning and ending epoch date
3727 arrayref of beginning and ending epoch date
3731 arrayref of beginning and ending epoch date
3735 arrayref of beginning and ending epoch date
3739 arrayref of beginning and ending epoch date
3743 arrayref of beginning and ending epoch date
3747 arrayref of beginning and ending epoch date
3751 pkgnum or APKG_pkgnum
3755 a value suited to passing to FS::UI::Web::cust_header
3759 specifies the user for agent virtualization
3763 boolean; if true, returns only packages with more than 0 FCC phone lines.
3765 =item state, country
3767 Limit to packages with a service location in the specified state and country.
3768 For FCC 477 reporting, mostly.
3775 my ($class, $params) = @_;
3782 if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
3784 "cust_main.agentnum = $1";
3791 if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
3793 "cust_pkg.custnum = $1";
3800 if ( $params->{'pkgbatch'} =~ /^([\w\/\-\:\.]+)$/ and $1 ) {
3802 "cust_pkg.pkgbatch = '$1'";
3809 if ( $params->{'magic'} eq 'active'
3810 || $params->{'status'} eq 'active' ) {
3812 push @where, FS::cust_pkg->active_sql();
3814 } elsif ( $params->{'magic'} =~ /^not[ _]yet[ _]billed$/
3815 || $params->{'status'} =~ /^not[ _]yet[ _]billed$/ ) {
3817 push @where, FS::cust_pkg->not_yet_billed_sql();
3819 } elsif ( $params->{'magic'} =~ /^(one-time charge|inactive)/
3820 || $params->{'status'} =~ /^(one-time charge|inactive)/ ) {
3822 push @where, FS::cust_pkg->inactive_sql();
3824 } elsif ( $params->{'magic'} eq 'suspended'
3825 || $params->{'status'} eq 'suspended' ) {
3827 push @where, FS::cust_pkg->suspended_sql();
3829 } elsif ( $params->{'magic'} =~ /^cancell?ed$/
3830 || $params->{'status'} =~ /^cancell?ed$/ ) {
3832 push @where, FS::cust_pkg->cancelled_sql();
3837 # parse package class
3840 if ( exists($params->{'classnum'}) ) {
3843 if ( ref($params->{'classnum'}) ) {
3845 if ( ref($params->{'classnum'}) eq 'HASH' ) {
3846 @classnum = grep $params->{'classnum'}{$_}, keys %{ $params->{'classnum'} };
3847 } elsif ( ref($params->{'classnum'}) eq 'ARRAY' ) {
3848 @classnum = @{ $params->{'classnum'} };
3850 die 'unhandled classnum ref '. $params->{'classnum'};
3854 } elsif ( $params->{'classnum'} =~ /^(\d*)$/ && $1 ne '0' ) {
3861 my @nums = grep $_, @classnum;
3862 push @c_where, 'part_pkg.classnum IN ('. join(',',@nums). ')' if @nums;
3863 my $null = scalar( grep { $_ eq '' } @classnum );
3864 push @c_where, 'part_pkg.classnum IS NULL' if $null;
3866 if ( scalar(@c_where) == 1 ) {
3867 push @where, @c_where;
3868 } elsif ( @c_where ) {
3869 push @where, ' ( '. join(' OR ', @c_where). ' ) ';
3878 # parse package report options
3881 my @report_option = ();
3882 if ( exists($params->{'report_option'}) ) {
3883 if ( ref($params->{'report_option'}) eq 'ARRAY' ) {
3884 @report_option = @{ $params->{'report_option'} };
3885 } elsif ( $params->{'report_option'} =~ /^([,\d]*)$/ ) {
3886 @report_option = split(',', $1);
3891 if (@report_option) {
3892 # this will result in the empty set for the dangling comma case as it should
3894 map{ "0 < ( SELECT count(*) FROM part_pkg_option
3895 WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
3896 AND optionname = 'report_option_$_'
3897 AND optionvalue = '1' )"
3901 foreach my $any ( grep /^report_option_any/, keys %$params ) {
3903 my @report_option_any = ();
3904 if ( ref($params->{$any}) eq 'ARRAY' ) {
3905 @report_option_any = @{ $params->{$any} };
3906 } elsif ( $params->{$any} =~ /^([,\d]*)$/ ) {
3907 @report_option_any = split(',', $1);
3910 if (@report_option_any) {
3911 # this will result in the empty set for the dangling comma case as it should
3912 push @where, ' ( '. join(' OR ',
3913 map{ "0 < ( SELECT count(*) FROM part_pkg_option
3914 WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
3915 AND optionname = 'report_option_$_'
3916 AND optionvalue = '1' )"
3917 } @report_option_any
3927 push @where, "part_pkg.custom = 'Y'" if $params->{custom};
3933 push @where, "(part_pkg.fcc_ds0s > 0 OR pkg_class.fcc_ds0s > 0)"
3934 if $params->{fcc_line};
3940 if ( exists($params->{'censustract'}) ) {
3941 $params->{'censustract'} =~ /^([.\d]*)$/;
3942 my $censustract = "cust_location.censustract = '$1'";
3943 $censustract .= ' OR cust_location.censustract is NULL' unless $1;
3944 push @where, "( $censustract )";
3948 # parse censustract2
3950 if ( exists($params->{'censustract2'})
3951 && $params->{'censustract2'} =~ /^(\d*)$/
3955 push @where, "cust_location.censustract LIKE '$1%'";
3958 "( cust_location.censustract = '' OR cust_location.censustract IS NULL )";
3963 # parse country/state
3965 for (qw(state country)) { # parsing rules are the same for these
3966 if ( exists($params->{$_})
3967 && uc($params->{$_}) =~ /^([A-Z]{2})$/ )
3969 # XXX post-2.3 only--before that, state/country may be in cust_main
3970 push @where, "cust_location.$_ = '$1'";
3978 if ( ref($params->{'pkgpart'}) ) {
3981 if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
3982 @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
3983 } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
3984 @pkgpart = @{ $params->{'pkgpart'} };
3986 die 'unhandled pkgpart ref '. $params->{'pkgpart'};
3989 @pkgpart = grep /^(\d+)$/, @pkgpart;
3991 push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
3993 } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
3994 push @where, "pkgpart = $1";
4003 #false laziness w/report_cust_pkg.html
4006 'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
4007 'active' => { 'susp'=>1, 'cancel'=>1 },
4008 'suspended' => { 'cancel' => 1 },
4013 if( exists($params->{'active'} ) ) {
4014 # This overrides all the other date-related fields
4015 my($beginning, $ending) = @{$params->{'active'}};
4017 "cust_pkg.setup IS NOT NULL",
4018 "cust_pkg.setup <= $ending",
4019 "(cust_pkg.cancel IS NULL OR cust_pkg.cancel >= $beginning )",
4020 "NOT (".FS::cust_pkg->onetime_sql . ")";
4023 foreach my $field (qw( setup last_bill bill adjourn susp expire contract_end change_date cancel )) {
4025 next unless exists($params->{$field});
4027 my($beginning, $ending) = @{$params->{$field}};
4029 next if $beginning == 0 && $ending == 4294967295;
4032 "cust_pkg.$field IS NOT NULL",
4033 "cust_pkg.$field >= $beginning",
4034 "cust_pkg.$field <= $ending";
4036 $orderby ||= "ORDER BY cust_pkg.$field";
4041 $orderby ||= 'ORDER BY bill';
4044 # parse magic, legacy, etc.
4047 if ( $params->{'magic'} &&
4048 $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
4051 $orderby = 'ORDER BY pkgnum';
4053 if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
4054 push @where, "pkgpart = $1";
4057 } elsif ( $params->{'query'} eq 'pkgnum' ) {
4059 $orderby = 'ORDER BY pkgnum';
4061 } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
4063 $orderby = 'ORDER BY pkgnum';
4066 SELECT count(*) FROM pkg_svc
4067 WHERE pkg_svc.pkgpart = cust_pkg.pkgpart
4068 AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
4069 WHERE cust_svc.pkgnum = cust_pkg.pkgnum
4070 AND cust_svc.svcpart = pkg_svc.svcpart
4077 # setup queries, links, subs, etc. for the search
4080 # here is the agent virtualization
4081 if ($params->{CurrentUser}) {
4083 qsearchs('access_user', { username => $params->{CurrentUser} });
4086 push @where, $access_user->agentnums_sql('table'=>'cust_main');
4091 push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
4094 my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
4096 my $addl_from = 'LEFT JOIN part_pkg USING ( pkgpart ) '.
4097 'LEFT JOIN pkg_class ON ( part_pkg.classnum = pkg_class.classnum ) '.
4098 'LEFT JOIN cust_location USING ( locationnum ) '.
4099 FS::UI::Web::join_cust_main('cust_pkg', 'cust_pkg');
4103 if ( $params->{'select_zip5'} ) {
4104 my $zip = 'cust_location.zip';
4106 $select = "DISTINCT substr($zip,1,5) as zip";
4107 $orderby = "ORDER BY substr($zip,1,5)";
4108 $count_query = "SELECT COUNT( DISTINCT substr($zip,1,5) )";
4110 $select = join(', ',
4112 ( map "part_pkg.$_", qw( pkg freq ) ),
4113 'pkg_class.classname',
4114 'cust_main.custnum AS cust_main_custnum',
4115 FS::UI::Web::cust_sql_fields(
4116 $params->{'cust_fields'}
4119 $count_query = 'SELECT COUNT(*)';
4122 $count_query .= " FROM cust_pkg $addl_from $extra_sql";
4125 'table' => 'cust_pkg',
4127 'select' => $select,
4128 'extra_sql' => $extra_sql,
4129 'order_by' => $orderby,
4130 'addl_from' => $addl_from,
4131 'count_query' => $count_query,
4138 Returns a list of two package counts. The first is a count of packages
4139 based on the supplied criteria and the second is the count of residential
4140 packages with those same criteria. Criteria are specified as in the search
4146 my ($class, $params) = @_;
4148 my $sql_query = $class->search( $params );
4150 my $count_sql = delete($sql_query->{'count_query'});
4151 $count_sql =~ s/ FROM/,count(CASE WHEN cust_main.company IS NULL OR cust_main.company = '' THEN 1 END) FROM/
4152 or die "couldn't parse count_sql";
4154 my $count_sth = dbh->prepare($count_sql)
4155 or die "Error preparing $count_sql: ". dbh->errstr;
4157 or die "Error executing $count_sql: ". $count_sth->errstr;
4158 my $count_arrayref = $count_sth->fetchrow_arrayref;
4160 return ( @$count_arrayref );
4164 =item tax_locationnum_sql
4166 Returns an SQL expression for the tax location for a package, based
4167 on the settings of 'tax-pkg_address' and 'tax-ship_address'.
4171 sub tax_locationnum_sql {
4172 my $conf = FS::Conf->new;
4173 if ( $conf->exists('tax-pkg_address') ) {
4174 'cust_pkg.locationnum';
4176 elsif ( $conf->exists('tax-ship_address') ) {
4177 'cust_main.ship_locationnum';
4180 'cust_main.bill_locationnum';
4186 Returns a list: the first item is an SQL fragment identifying matching
4187 packages/customers via location (taking into account shipping and package
4188 address taxation, if enabled), and subsequent items are the parameters to
4189 substitute for the placeholders in that fragment.
4194 my($class, %opt) = @_;
4195 my $ornull = $opt{'ornull'};
4197 my $conf = new FS::Conf;
4199 # '?' placeholders in _location_sql_where
4200 my $x = $ornull ? 3 : 2;
4211 if ( $conf->exists('tax-ship_address') ) {
4214 ( ( ship_last IS NULL OR ship_last = '' )
4215 AND ". _location_sql_where('cust_main', '', $ornull ). "
4217 OR ( ship_last IS NOT NULL AND ship_last != ''
4218 AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
4221 # AND payby != 'COMP'
4223 @main_param = ( @bill_param, @bill_param );
4227 $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
4228 @main_param = @bill_param;
4234 if ( $conf->exists('tax-pkg_address') ) {
4236 my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
4239 ( cust_pkg.locationnum IS NULL AND $main_where )
4240 OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where )
4243 @param = ( @main_param, @bill_param );
4247 $where = $main_where;
4248 @param = @main_param;
4256 #subroutine, helper for location_sql
4257 sub _location_sql_where {
4259 my $prefix = @_ ? shift : '';
4260 my $ornull = @_ ? shift : '';
4262 # $ornull = $ornull ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
4264 $ornull = $ornull ? ' OR ? IS NULL ' : '';
4266 my $or_empty_city = " OR ( ? = '' AND $table.${prefix}city IS NULL )";
4267 my $or_empty_county = " OR ( ? = '' AND $table.${prefix}county IS NULL )";
4268 my $or_empty_state = " OR ( ? = '' AND $table.${prefix}state IS NULL )";
4270 my $text = (driver_name =~ /^mysql/i) ? 'char' : 'text';
4272 # ( $table.${prefix}city = ? $or_empty_city $ornull )
4274 ( $table.district = ? OR ? = '' OR CAST(? AS $text) IS NULL )
4275 AND ( $table.${prefix}city = ? OR ? = '' OR CAST(? AS $text) IS NULL )
4276 AND ( $table.${prefix}county = ? $or_empty_county $ornull )
4277 AND ( $table.${prefix}state = ? $or_empty_state $ornull )
4278 AND $table.${prefix}country = ?
4283 my( $self, $what ) = @_;
4285 my $what_show_zero = $what. '_show_zero';
4286 length($self->$what_show_zero())
4287 ? ($self->$what_show_zero() eq 'Y')
4288 : $self->part_pkg->$what_show_zero();
4295 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
4297 CUSTNUM is a customer (see L<FS::cust_main>)
4299 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
4300 L<FS::part_pkg>) to order for this customer. Duplicates are of course
4303 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
4304 remove for this customer. The services (see L<FS::cust_svc>) are moved to the
4305 new billing items. An error is returned if this is not possible (see
4306 L<FS::pkg_svc>). An empty arrayref is equivalent to not specifying this
4309 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
4310 newly-created cust_pkg objects.
4312 REFNUM, if specified, will specify the FS::pkg_referral record to be created
4313 and inserted. Multiple FS::pkg_referral records can be created by
4314 setting I<refnum> to an array reference of refnums or a hash reference with
4315 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
4316 record will be created corresponding to cust_main.refnum.
4321 my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
4323 my $conf = new FS::Conf;
4325 # Transactionize this whole mess
4326 local $SIG{HUP} = 'IGNORE';
4327 local $SIG{INT} = 'IGNORE';
4328 local $SIG{QUIT} = 'IGNORE';
4329 local $SIG{TERM} = 'IGNORE';
4330 local $SIG{TSTP} = 'IGNORE';
4331 local $SIG{PIPE} = 'IGNORE';
4333 my $oldAutoCommit = $FS::UID::AutoCommit;
4334 local $FS::UID::AutoCommit = 0;
4338 # my $cust_main = qsearchs('cust_main', { custnum => $custnum });
4339 # return "Customer not found: $custnum" unless $cust_main;
4341 warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
4344 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
4347 my $change = scalar(@old_cust_pkg) != 0;
4350 if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
4352 warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
4353 " to pkgpart ". $pkgparts->[0]. "\n"
4356 my $err_or_cust_pkg =
4357 $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
4358 'refnum' => $refnum,
4361 unless (ref($err_or_cust_pkg)) {
4362 $dbh->rollback if $oldAutoCommit;
4363 return $err_or_cust_pkg;
4366 push @$return_cust_pkg, $err_or_cust_pkg;
4367 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4372 # Create the new packages.
4373 foreach my $pkgpart (@$pkgparts) {
4375 warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
4377 my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
4378 pkgpart => $pkgpart,
4382 $error = $cust_pkg->insert( 'change' => $change );
4383 push @$return_cust_pkg, $cust_pkg;
4385 foreach my $link ($cust_pkg->part_pkg->supp_part_pkg_link) {
4386 my $supp_pkg = FS::cust_pkg->new({
4387 custnum => $custnum,
4388 pkgpart => $link->dst_pkgpart,
4390 main_pkgnum => $cust_pkg->pkgnum,
4393 $error ||= $supp_pkg->insert( 'change' => $change );
4394 push @$return_cust_pkg, $supp_pkg;
4398 $dbh->rollback if $oldAutoCommit;
4403 # $return_cust_pkg now contains refs to all of the newly
4406 # Transfer services and cancel old packages.
4407 foreach my $old_pkg (@old_cust_pkg) {
4409 warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
4412 foreach my $new_pkg (@$return_cust_pkg) {
4413 $error = $old_pkg->transfer($new_pkg);
4414 if ($error and $error == 0) {
4415 # $old_pkg->transfer failed.
4416 $dbh->rollback if $oldAutoCommit;
4421 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
4422 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
4423 foreach my $new_pkg (@$return_cust_pkg) {
4424 $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
4425 if ($error and $error == 0) {
4426 # $old_pkg->transfer failed.
4427 $dbh->rollback if $oldAutoCommit;
4434 # Transfers were successful, but we went through all of the
4435 # new packages and still had services left on the old package.
4436 # We can't cancel the package under the circumstances, so abort.
4437 $dbh->rollback if $oldAutoCommit;
4438 return "Unable to transfer all services from package ".$old_pkg->pkgnum;
4440 $error = $old_pkg->cancel( quiet=>1 );
4446 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4450 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
4452 A bulk change method to change packages for multiple customers.
4454 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
4455 L<FS::part_pkg>) to order for each customer. Duplicates are of course
4458 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
4459 replace. The services (see L<FS::cust_svc>) are moved to the
4460 new billing items. An error is returned if this is not possible (see
4463 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
4464 newly-created cust_pkg objects.
4469 my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
4471 # Transactionize this whole mess
4472 local $SIG{HUP} = 'IGNORE';
4473 local $SIG{INT} = 'IGNORE';
4474 local $SIG{QUIT} = 'IGNORE';
4475 local $SIG{TERM} = 'IGNORE';
4476 local $SIG{TSTP} = 'IGNORE';
4477 local $SIG{PIPE} = 'IGNORE';
4479 my $oldAutoCommit = $FS::UID::AutoCommit;
4480 local $FS::UID::AutoCommit = 0;
4484 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
4487 while(scalar(@old_cust_pkg)) {
4489 my $custnum = $old_cust_pkg[0]->custnum;
4490 my (@remove) = map { $_->pkgnum }
4491 grep { $_->custnum == $custnum } @old_cust_pkg;
4492 @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
4494 my $error = order $custnum, $pkgparts, \@remove, \@return;
4496 push @errors, $error
4498 push @$return_cust_pkg, @return;
4501 if (scalar(@errors)) {
4502 $dbh->rollback if $oldAutoCommit;
4503 return join(' / ', @errors);
4506 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4510 # Used by FS::Upgrade to migrate to a new database.
4511 sub _upgrade_data { # class method
4512 my ($class, %opts) = @_;
4513 $class->_upgrade_otaker(%opts);
4515 # RT#10139, bug resulting in contract_end being set when it shouldn't
4516 'UPDATE cust_pkg SET contract_end = NULL WHERE contract_end = -1',
4517 # RT#10830, bad calculation of prorate date near end of year
4518 # the date range for bill is December 2009, and we move it forward
4519 # one year if it's before the previous bill date (which it should
4521 'UPDATE cust_pkg SET bill = bill + (365*24*60*60) WHERE bill < last_bill
4522 AND bill > 1259654400 AND bill < 1262332800 AND (SELECT plan FROM part_pkg
4523 WHERE part_pkg.pkgpart = cust_pkg.pkgpart) = \'prorate\'',
4524 # RT6628, add order_date to cust_pkg
4525 'update cust_pkg set order_date = (select history_date from h_cust_pkg
4526 where h_cust_pkg.pkgnum = cust_pkg.pkgnum and
4527 history_action = \'insert\') where order_date is null',
4529 foreach my $sql (@statements) {
4530 my $sth = dbh->prepare($sql);
4531 $sth->execute or die $sth->errstr;
4539 sub order is not OO. Perhaps it should be moved to FS::cust_main and made so?
4541 In sub order, the @pkgparts array (passed by reference) is clobbered.
4543 Also in sub order, no money is adjusted. Once FS::part_pkg defines a standard
4544 method to pass dates to the recur_prog expression, it should do so.
4546 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
4547 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
4548 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
4549 configuration values. Probably need a subroutine which decides what to do
4550 based on whether or not we've fetched the user yet, rather than a hash. See
4551 FS::UID and the TODO.
4553 Now that things are transactional should the check in the insert method be
4558 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
4559 L<FS::pkg_svc>, schema.html from the base documentation