4 use base qw( FS::otaker_Mixin FS::cust_main_Mixin
5 FS::contact_Mixin FS::location_Mixin
6 FS::m2m_Common FS::option_Common );
7 use vars qw($disable_agentcheck $DEBUG $me);
9 use Scalar::Util qw( blessed );
10 use List::Util qw(min max);
12 use Time::Local qw( timelocal timelocal_nocheck );
14 use FS::UID qw( getotaker dbh driver_name );
15 use FS::Misc qw( send_email );
16 use FS::Record qw( qsearch qsearchs fields );
22 use FS::cust_location;
24 use FS::cust_bill_pkg;
25 use FS::cust_pkg_detail;
26 use FS::cust_pkg_usage;
27 use FS::cdr_cust_pkg_usage;
32 use FS::cust_pkg_reason;
34 use FS::cust_pkg_discount;
39 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
41 # because they load configuration by setting FS::UID::callback (see TODO)
47 # for sending cancel emails in sub cancel
51 $me = '[FS::cust_pkg]';
53 $disable_agentcheck = 0;
57 my ( $hashref, $cache ) = @_;
58 #if ( $hashref->{'pkgpart'} ) {
59 if ( $hashref->{'pkg'} ) {
60 # #@{ $self->{'_pkgnum'} } = ();
61 # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
62 # $self->{'_pkgpart'} = $subcache;
63 # #push @{ $self->{'_pkgnum'} },
64 # FS::part_pkg->new_or_cached($hashref, $subcache);
65 $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
67 if ( exists $hashref->{'svcnum'} ) {
68 #@{ $self->{'_pkgnum'} } = ();
69 my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
70 $self->{'_svcnum'} = $subcache;
71 #push @{ $self->{'_pkgnum'} },
72 FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
78 FS::cust_pkg - Object methods for cust_pkg objects
84 $record = new FS::cust_pkg \%hash;
85 $record = new FS::cust_pkg { 'column' => 'value' };
87 $error = $record->insert;
89 $error = $new_record->replace($old_record);
91 $error = $record->delete;
93 $error = $record->check;
95 $error = $record->cancel;
97 $error = $record->suspend;
99 $error = $record->unsuspend;
101 $part_pkg = $record->part_pkg;
103 @labels = $record->labels;
105 $seconds = $record->seconds_since($timestamp);
107 $error = FS::cust_pkg::order( $custnum, \@pkgparts );
108 $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
112 An FS::cust_pkg object represents a customer billing item. FS::cust_pkg
113 inherits from FS::Record. The following fields are currently supported:
119 Primary key (assigned automatically for new billing items)
123 Customer (see L<FS::cust_main>)
127 Billing item definition (see L<FS::part_pkg>)
131 Optional link to package location (see L<FS::location>)
135 date package was ordered (also remains same on changes)
147 date (next bill date)
175 order taker (see L<FS::access_user>)
179 If this field is set to 1, disables the automatic
180 unsuspension of this package when using the B<unsuspendauto> config option.
184 If not set, defaults to 1
188 Date of change from previous package
198 =item change_locationnum
206 The pkgnum of the package that this package is supplemental to, if any.
210 The package link (L<FS::part_pkg_link>) that defines this supplemental
211 package, if it is one.
215 Note: setup, last_bill, bill, adjourn, susp, expire, cancel and change_date
216 are specified as UNIX timestamps; see L<perlfunc/"time">. Also see
217 L<Time::Local> and L<Date::Parse> for conversion functions.
225 Create a new billing item. To add the item to the database, see L<"insert">.
229 sub table { 'cust_pkg'; }
230 sub cust_linked { $_[0]->cust_main_custnum || $_[0]->custnum }
231 sub cust_unlinked_msg {
233 "WARNING: can't find cust_main.custnum ". $self->custnum.
234 ' (cust_pkg.pkgnum '. $self->pkgnum. ')';
237 =item insert [ OPTION => VALUE ... ]
239 Adds this billing item to the database ("Orders" the item). If there is an
240 error, returns the error, otherwise returns false.
242 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
243 will be used to look up the package definition and agent restrictions will be
246 If the additional field I<refnum> is defined, an FS::pkg_referral record will
247 be created and inserted. Multiple FS::pkg_referral records can be created by
248 setting I<refnum> to an array reference of refnums or a hash reference with
249 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
250 record will be created corresponding to cust_main.refnum.
252 The following options are available:
258 If set true, supresses any referral credit to a referring customer.
262 cust_pkg_option records will be created
266 a ticket will be added to this customer with this subject
270 an optional queue name for ticket additions
274 Don't check the legality of the package definition. This should be used
275 when performing a package change that doesn't change the pkgpart (i.e.
283 my( $self, %options ) = @_;
286 $error = $self->check_pkgpart unless $options{'allow_pkgpart'};
287 return $error if $error;
289 my $part_pkg = $self->part_pkg;
291 if ( $part_pkg->option('start_1st', 1) && !$self->start_date ) {
292 my ($sec,$min,$hour,$mday,$mon,$year) = (localtime(time) )[0,1,2,3,4,5];
293 $mon += 1 unless $mday == 1;
294 until ( $mon < 12 ) { $mon -= 12; $year++; }
295 $self->start_date( timelocal_nocheck(0,0,0,1,$mon,$year) );
298 foreach my $action ( qw(expire adjourn contract_end) ) {
299 my $months = $part_pkg->option("${action}_months",1);
300 if($months and !$self->$action) {
301 my $start = $self->start_date || $self->setup || time;
302 $self->$action( $part_pkg->add_freq($start, $months) );
306 my $free_days = $part_pkg->option('free_days',1);
307 if ( $free_days && $part_pkg->option('delay_setup',1) ) { #&& !$self->start_date
308 my ($mday,$mon,$year) = (localtime(time) )[3,4,5];
309 #my $start_date = ($self->start_date || timelocal(0,0,0,$mday,$mon,$year)) + 86400 * $free_days;
310 my $start_date = timelocal(0,0,0,$mday,$mon,$year) + 86400 * $free_days;
311 $self->start_date($start_date);
314 $self->order_date(time);
316 local $SIG{HUP} = 'IGNORE';
317 local $SIG{INT} = 'IGNORE';
318 local $SIG{QUIT} = 'IGNORE';
319 local $SIG{TERM} = 'IGNORE';
320 local $SIG{TSTP} = 'IGNORE';
321 local $SIG{PIPE} = 'IGNORE';
323 my $oldAutoCommit = $FS::UID::AutoCommit;
324 local $FS::UID::AutoCommit = 0;
327 $error = $self->SUPER::insert($options{options} ? %{$options{options}} : ());
329 $dbh->rollback if $oldAutoCommit;
333 $self->refnum($self->cust_main->refnum) unless $self->refnum;
334 $self->refnum( [ $self->refnum ] ) unless ref($self->refnum);
335 $self->process_m2m( 'link_table' => 'pkg_referral',
336 'target_table' => 'part_referral',
337 'params' => $self->refnum,
340 if ( $self->discountnum ) {
341 my $error = $self->insert_discount();
343 $dbh->rollback if $oldAutoCommit;
348 #if ( $self->reg_code ) {
349 # my $reg_code = qsearchs('reg_code', { 'code' => $self->reg_code } );
350 # $error = $reg_code->delete;
352 # $dbh->rollback if $oldAutoCommit;
357 my $conf = new FS::Conf;
359 if ( $conf->config('ticket_system') && $options{ticket_subject} ) {
361 #this init stuff is still inefficient, but at least its limited to
362 # the small number (any?) folks using ticket emailing on pkg order
365 # use lib ( "/opt/rt3/local/lib", "/opt/rt3/lib" );
372 use FS::TicketSystem;
373 FS::TicketSystem->init();
375 my $q = new RT::Queue($RT::SystemUser);
376 $q->Load($options{ticket_queue}) if $options{ticket_queue};
377 my $t = new RT::Ticket($RT::SystemUser);
378 my $mime = new MIME::Entity;
379 $mime->build( Type => 'text/plain', Data => $options{ticket_subject} );
380 $t->Create( $options{ticket_queue} ? (Queue => $q) : (),
381 Subject => $options{ticket_subject},
384 $t->AddLink( Type => 'MemberOf',
385 Target => 'freeside://freeside/cust_main/'. $self->custnum,
389 if ($conf->config('welcome_letter') && $self->cust_main->num_pkgs == 1) {
390 my $queue = new FS::queue {
391 'job' => 'FS::cust_main::queueable_print',
393 $error = $queue->insert(
394 'custnum' => $self->custnum,
395 'template' => 'welcome_letter',
399 warn "can't send welcome letter: $error";
404 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
411 This method now works but you probably shouldn't use it.
413 You don't want to delete packages, because there would then be no record
414 the customer ever purchased the package. Instead, see the cancel method and
415 hide cancelled packages.
422 local $SIG{HUP} = 'IGNORE';
423 local $SIG{INT} = 'IGNORE';
424 local $SIG{QUIT} = 'IGNORE';
425 local $SIG{TERM} = 'IGNORE';
426 local $SIG{TSTP} = 'IGNORE';
427 local $SIG{PIPE} = 'IGNORE';
429 my $oldAutoCommit = $FS::UID::AutoCommit;
430 local $FS::UID::AutoCommit = 0;
433 foreach my $cust_pkg_discount ($self->cust_pkg_discount) {
434 my $error = $cust_pkg_discount->delete;
436 $dbh->rollback if $oldAutoCommit;
440 #cust_bill_pkg_discount?
442 foreach my $cust_pkg_detail ($self->cust_pkg_detail) {
443 my $error = $cust_pkg_detail->delete;
445 $dbh->rollback if $oldAutoCommit;
450 foreach my $cust_pkg_reason (
452 'table' => 'cust_pkg_reason',
453 'hashref' => { 'pkgnum' => $self->pkgnum },
457 my $error = $cust_pkg_reason->delete;
459 $dbh->rollback if $oldAutoCommit;
466 my $error = $self->SUPER::delete(@_);
468 $dbh->rollback if $oldAutoCommit;
472 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
478 =item replace [ OLD_RECORD ] [ HASHREF | OPTION => VALUE ... ]
480 Replaces the OLD_RECORD with this one in the database. If there is an error,
481 returns the error, otherwise returns false.
483 Currently, custnum, setup, bill, adjourn, susp, expire, and cancel may be changed.
485 Changing pkgpart may have disasterous effects. See the order subroutine.
487 setup and bill are normally updated by calling the bill method of a customer
488 object (see L<FS::cust_main>).
490 suspend is normally updated by the suspend and unsuspend methods.
492 cancel is normally updated by the cancel method (and also the order subroutine
495 Available options are:
501 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.
505 the access_user (see L<FS::access_user>) providing the reason
509 hashref of keys and values - cust_pkg_option records will be created, updated or removed as appopriate
518 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
523 ( ref($_[0]) eq 'HASH' )
527 #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
528 #return "Can't change otaker!" if $old->otaker ne $new->otaker;
531 #return "Can't change setup once it exists!"
532 # if $old->getfield('setup') &&
533 # $old->getfield('setup') != $new->getfield('setup');
535 #some logic for bill, susp, cancel?
537 local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
539 local $SIG{HUP} = 'IGNORE';
540 local $SIG{INT} = 'IGNORE';
541 local $SIG{QUIT} = 'IGNORE';
542 local $SIG{TERM} = 'IGNORE';
543 local $SIG{TSTP} = 'IGNORE';
544 local $SIG{PIPE} = 'IGNORE';
546 my $oldAutoCommit = $FS::UID::AutoCommit;
547 local $FS::UID::AutoCommit = 0;
550 foreach my $method ( qw(adjourn expire) ) { # How many reasons?
551 if ($options->{'reason'} && $new->$method && $old->$method ne $new->$method) {
552 my $error = $new->insert_reason(
553 'reason' => $options->{'reason'},
554 'date' => $new->$method,
556 'reason_otaker' => $options->{'reason_otaker'},
559 dbh->rollback if $oldAutoCommit;
560 return "Error inserting cust_pkg_reason: $error";
565 #save off and freeze RADIUS attributes for any associated svc_acct records
567 if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
569 #also check for specific exports?
570 # to avoid spurious modify export events
571 @svc_acct = map { $_->svc_x }
572 grep { $_->part_svc->svcdb eq 'svc_acct' }
575 $_->snapshot foreach @svc_acct;
579 my $error = $new->SUPER::replace($old,
580 $options->{options} ? $options->{options} : ()
583 $dbh->rollback if $oldAutoCommit;
587 #for prepaid packages,
588 #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
589 foreach my $old_svc_acct ( @svc_acct ) {
590 my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
592 $new_svc_acct->replace( $old_svc_acct,
593 'depend_jobnum' => $options->{depend_jobnum},
596 $dbh->rollback if $oldAutoCommit;
601 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
608 Checks all fields to make sure this is a valid billing item. If there is an
609 error, returns the error, otherwise returns false. Called by the insert and
617 if ( !$self->locationnum or $self->locationnum == -1 ) {
618 $self->set('locationnum', $self->cust_main->ship_locationnum);
622 $self->ut_numbern('pkgnum')
623 || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
624 || $self->ut_numbern('pkgpart')
625 || $self->ut_foreign_keyn('contactnum', 'contact', 'contactnum' )
626 || $self->ut_foreign_keyn('locationnum', 'cust_location', 'locationnum')
627 || $self->ut_numbern('start_date')
628 || $self->ut_numbern('setup')
629 || $self->ut_numbern('bill')
630 || $self->ut_numbern('susp')
631 || $self->ut_numbern('cancel')
632 || $self->ut_numbern('adjourn')
633 || $self->ut_numbern('resume')
634 || $self->ut_numbern('expire')
635 || $self->ut_numbern('dundate')
636 || $self->ut_enum('no_auto', [ '', 'Y' ])
637 || $self->ut_enum('waive_setup', [ '', 'Y' ])
638 || $self->ut_numbern('agent_pkgid')
639 || $self->ut_enum('recur_show_zero', [ '', 'Y', 'N', ])
640 || $self->ut_enum('setup_show_zero', [ '', 'Y', 'N', ])
641 || $self->ut_foreign_keyn('main_pkgnum', 'cust_pkg', 'pkgnum')
642 || $self->ut_foreign_keyn('pkglinknum', 'part_pkg_link', 'pkglinknum')
644 return $error if $error;
646 return "A package with both start date (future start) and setup date (already started) will never bill"
647 if $self->start_date && $self->setup;
649 return "A future unsuspend date can only be set for a package with a suspend date"
650 if $self->resume and !$self->susp and !$self->adjourn;
652 $self->usernum($FS::CurrentUser::CurrentUser->usernum) unless $self->usernum;
654 if ( $self->dbdef_table->column('manual_flag') ) {
655 $self->manual_flag('') if $self->manual_flag eq ' ';
656 $self->manual_flag =~ /^([01]?)$/
657 or return "Illegal manual_flag ". $self->manual_flag;
658 $self->manual_flag($1);
666 Check the pkgpart to make sure it's allowed with the reg_code and/or
667 promo_code of the package (if present) and with the customer's agent.
668 Called from C<insert>, unless we are doing a package change that doesn't
676 # my $error = $self->ut_numbern('pkgpart'); # already done
679 if ( $self->reg_code ) {
681 unless ( grep { $self->pkgpart == $_->pkgpart }
682 map { $_->reg_code_pkg }
683 qsearchs( 'reg_code', { 'code' => $self->reg_code,
684 'agentnum' => $self->cust_main->agentnum })
686 return "Unknown registration code";
689 } elsif ( $self->promo_code ) {
692 qsearchs('part_pkg', {
693 'pkgpart' => $self->pkgpart,
694 'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
696 return 'Unknown promotional code' unless $promo_part_pkg;
700 unless ( $disable_agentcheck ) {
702 qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
703 return "agent ". $agent->agentnum. ':'. $agent->agent.
704 " can't purchase pkgpart ". $self->pkgpart
705 unless $agent->pkgpart_hashref->{ $self->pkgpart }
706 || $agent->agentnum == $self->part_pkg->agentnum;
709 $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
710 return $error if $error;
718 =item cancel [ OPTION => VALUE ... ]
720 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
721 in this package, then cancels the package itself (sets the cancel field to
724 Available options are:
728 =item quiet - can be set true to supress email cancellation notices.
730 =item time - can be set to cancel the package based on a specific future or
731 historical date. Using time ensures that the remaining amount is calculated
732 correctly. Note however that this is an immediate cancel and just changes
733 the date. You are PROBABLY looking to expire the account instead of using
736 =item reason - can be set to a cancellation reason (see L<FS:reason>),
737 either a reasonnum of an existing reason, or passing a hashref will create
738 a new reason. The hashref should have the following keys: typenum - Reason
739 type (see L<FS::reason_type>, reason - Text of the new reason.
741 =item date - can be set to a unix style timestamp to specify when to
744 =item nobill - can be set true to skip billing if it might otherwise be done.
746 =item unused_credit - can be set to 1 to credit the remaining time, or 0 to
747 not credit it. This must be set (by change()) when changing the package
748 to a different pkgpart or location, and probably shouldn't be in any other
749 case. If it's not set, the 'unused_credit_cancel' part_pkg option will
754 If there is an error, returns the error, otherwise returns false.
759 my( $self, %options ) = @_;
762 # pass all suspend/cancel actions to the main package
763 if ( $self->main_pkgnum and !$options{'from_main'} ) {
764 return $self->main_pkg->cancel(%options);
767 my $conf = new FS::Conf;
769 warn "cust_pkg::cancel called with options".
770 join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
773 local $SIG{HUP} = 'IGNORE';
774 local $SIG{INT} = 'IGNORE';
775 local $SIG{QUIT} = 'IGNORE';
776 local $SIG{TERM} = 'IGNORE';
777 local $SIG{TSTP} = 'IGNORE';
778 local $SIG{PIPE} = 'IGNORE';
780 my $oldAutoCommit = $FS::UID::AutoCommit;
781 local $FS::UID::AutoCommit = 0;
784 my $old = $self->select_for_update;
786 if ( $old->get('cancel') || $self->get('cancel') ) {
787 dbh->rollback if $oldAutoCommit;
788 return ""; # no error
791 # XXX possibly set cancel_time to the expire date?
792 my $cancel_time = $options{'time'} || time;
793 my $date = $options{'date'} if $options{'date'}; # expire/cancel later
794 $date = '' if ($date && $date <= $cancel_time); # complain instead?
796 #race condition: usage could be ongoing until unprovisioned
797 #resolved by performing a change package instead (which unprovisions) and
799 if ( !$options{nobill} && !$date ) {
800 # && $conf->exists('bill_usage_on_cancel') ) { #calc_cancel checks this
801 my $copy = $self->new({$self->hash});
803 $copy->cust_main->bill( 'pkg_list' => [ $copy ],
805 'time' => $cancel_time );
806 warn "Error billing during cancel, custnum ".
807 #$self->cust_main->custnum. ": $error"
812 if ( $options{'reason'} ) {
813 $error = $self->insert_reason( 'reason' => $options{'reason'},
814 'action' => $date ? 'expire' : 'cancel',
815 'date' => $date ? $date : $cancel_time,
816 'reason_otaker' => $options{'reason_otaker'},
819 dbh->rollback if $oldAutoCommit;
820 return "Error inserting cust_pkg_reason: $error";
824 my %svc_cancel_opt = ();
825 $svc_cancel_opt{'date'} = $date if $date;
826 foreach my $cust_svc (
829 sort { $a->[1] <=> $b->[1] }
830 map { [ $_, $_->svc_x ? $_->svc_x->table_info->{'cancel_weight'} : -1 ]; }
831 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
833 my $part_svc = $cust_svc->part_svc;
834 next if ( defined($part_svc) and $part_svc->preserve );
835 my $error = $cust_svc->cancel( %svc_cancel_opt );
838 $dbh->rollback if $oldAutoCommit;
839 return 'Error '. ($svc_cancel_opt{'date'} ? 'expiring' : 'canceling' ).
845 # credit remaining time if appropriate
847 if ( exists($options{'unused_credit'}) ) {
848 $do_credit = $options{'unused_credit'};
851 $do_credit = $self->part_pkg->option('unused_credit_cancel', 1);
854 my $error = $self->credit_remaining('cancel', $cancel_time);
856 $dbh->rollback if $oldAutoCommit;
863 my %hash = $self->hash;
864 $date ? ($hash{'expire'} = $date) : ($hash{'cancel'} = $cancel_time);
865 my $new = new FS::cust_pkg ( \%hash );
866 $error = $new->replace( $self, options => { $self->options } );
868 $dbh->rollback if $oldAutoCommit;
872 foreach my $supp_pkg ( $self->supplemental_pkgs ) {
873 $error = $supp_pkg->cancel(%options, 'from_main' => 1);
875 $dbh->rollback if $oldAutoCommit;
876 return "canceling supplemental pkg#".$supp_pkg->pkgnum.": $error";
880 foreach my $usage ( $self->cust_pkg_usage ) {
881 $error = $usage->delete;
883 $dbh->rollback if $oldAutoCommit;
884 return "deleting usage pools: $error";
888 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
889 return '' if $date; #no errors
891 my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
892 if ( !$options{'quiet'} &&
893 $conf->exists('emailcancel', $self->cust_main->agentnum) &&
895 my $msgnum = $conf->config('cancel_msgnum', $self->cust_main->agentnum);
898 my $msg_template = qsearchs('msg_template', { msgnum => $msgnum });
899 $error = $msg_template->send( 'cust_main' => $self->cust_main,
904 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
905 'to' => \@invoicing_list,
906 'subject' => ( $conf->config('cancelsubject') || 'Cancellation Notice' ),
907 'body' => [ map "$_\n", $conf->config('cancelmessage') ],
910 #should this do something on errors?
917 =item cancel_if_expired [ NOW_TIMESTAMP ]
919 Cancels this package if its expire date has been reached.
923 sub cancel_if_expired {
925 my $time = shift || time;
926 return '' unless $self->expire && $self->expire <= $time;
927 my $error = $self->cancel;
929 return "Error cancelling expired pkg ". $self->pkgnum. " for custnum ".
930 $self->custnum. ": $error";
937 "Un-cancels" this package: Orders a new package with the same custnum, pkgpart,
938 locationnum, (other fields?). Attempts to re-provision cancelled services
939 using history information (errors at this stage are not fatal).
941 cust_pkg: pass a scalar reference, will be filled in with the new cust_pkg object
943 svc_fatal: service provisioning errors are fatal
945 svc_errors: pass an array reference, will be filled in with any provisioning errors
947 main_pkgnum: link the package as a supplemental package of this one. For
953 my( $self, %options ) = @_;
955 #in case you try do do $uncancel-date = $cust_pkg->uncacel
956 return '' unless $self->get('cancel');
958 if ( $self->main_pkgnum and !$options{'main_pkgnum'} ) {
959 return $self->main_pkg->uncancel(%options);
966 local $SIG{HUP} = 'IGNORE';
967 local $SIG{INT} = 'IGNORE';
968 local $SIG{QUIT} = 'IGNORE';
969 local $SIG{TERM} = 'IGNORE';
970 local $SIG{TSTP} = 'IGNORE';
971 local $SIG{PIPE} = 'IGNORE';
973 my $oldAutoCommit = $FS::UID::AutoCommit;
974 local $FS::UID::AutoCommit = 0;
978 # insert the new package
981 my $cust_pkg = new FS::cust_pkg {
982 last_bill => ( $options{'last_bill'} || $self->get('last_bill') ),
983 bill => ( $options{'bill'} || $self->get('bill') ),
985 uncancel_pkgnum => $self->pkgnum,
986 main_pkgnum => ($options{'main_pkgnum'} || ''),
987 map { $_ => $self->get($_) } qw(
988 custnum pkgpart locationnum
990 susp adjourn resume expire start_date contract_end dundate
991 change_date change_pkgpart change_locationnum
992 manual_flag no_auto quantity agent_pkgid recur_show_zero setup_show_zero
996 my $error = $cust_pkg->insert(
997 'change' => 1, #supresses any referral credit to a referring customer
998 'allow_pkgpart' => 1, # allow this even if the package def is disabled
1001 $dbh->rollback if $oldAutoCommit;
1009 #find historical services within this timeframe before the package cancel
1010 # (incompatible with "time" option to cust_pkg->cancel?)
1011 my $fuzz = 2 * 60; #2 minutes? too much? (might catch separate unprovision)
1012 # too little? (unprovisioing export delay?)
1013 my($end, $start) = ( $self->get('cancel'), $self->get('cancel') - $fuzz );
1014 my @h_cust_svc = $self->h_cust_svc( $end, $start );
1017 foreach my $h_cust_svc (@h_cust_svc) {
1018 my $h_svc_x = $h_cust_svc->h_svc_x( $end, $start );
1019 #next unless $h_svc_x; #should this happen?
1020 (my $table = $h_svc_x->table) =~ s/^h_//;
1021 require "FS/$table.pm";
1022 my $class = "FS::$table";
1023 my $svc_x = $class->new( {
1024 'pkgnum' => $cust_pkg->pkgnum,
1025 'svcpart' => $h_cust_svc->svcpart,
1026 map { $_ => $h_svc_x->get($_) } fields($table)
1030 if ( $h_svc_x->isa('FS::h_svc_Radius_Mixin') ) {
1031 $svc_x->usergroup( [ $h_svc_x->h_usergroup($end, $start) ] );
1034 my $svc_error = $svc_x->insert;
1036 if ( $options{svc_fatal} ) {
1037 $dbh->rollback if $oldAutoCommit;
1040 push @svc_errors, $svc_error;
1041 # is this necessary? svc_Common::insert already deletes the
1042 # cust_svc if inserting svc_x fails.
1043 my $cust_svc = qsearchs('cust_svc', { 'svcnum' => $svc_x->svcnum });
1045 my $cs_error = $cust_svc->delete;
1047 $dbh->rollback if $oldAutoCommit;
1053 } #foreach $h_cust_svc
1055 #these are pretty rare, but should handle them
1056 # - dsl_device (mac addresses)
1057 # - phone_device (mac addresses)
1058 # - dsl_note (ikano notes)
1059 # - domain_record (i.e. restore DNS information w/domains)
1060 # - inventory_item(?) (inventory w/un-cancelling service?)
1061 # - nas (svc_broaband nas stuff)
1062 #this stuff is unused in the wild afaik
1063 # - mailinglistmember
1065 # - svc_domain.parent_svcnum?
1066 # - acct_snarf (ancient mail fetching config)
1067 # - cgp_rule (communigate)
1068 # - cust_svc_option (used by our Tron stuff)
1069 # - acct_rt_transaction (used by our time worked stuff)
1072 # also move over any services that didn't unprovision at cancellation
1075 foreach my $cust_svc ( qsearch('cust_svc', { pkgnum => $self->pkgnum } ) ) {
1076 $cust_svc->pkgnum( $cust_pkg->pkgnum );
1077 my $error = $cust_svc->replace;
1079 $dbh->rollback if $oldAutoCommit;
1085 # Uncancel any supplemental packages, and make them supplemental to the
1089 foreach my $supp_pkg ( $self->supplemental_pkgs ) {
1091 $error = $supp_pkg->uncancel(%options, 'main_pkgnum' => $cust_pkg->pkgnum);
1093 $dbh->rollback if $oldAutoCommit;
1094 return "canceling supplemental pkg#".$supp_pkg->pkgnum.": $error";
1102 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1104 ${ $options{cust_pkg} } = $cust_pkg if ref($options{cust_pkg});
1105 @{ $options{svc_errors} } = @svc_errors if ref($options{svc_errors});
1112 Cancels any pending expiration (sets the expire field to null).
1114 If there is an error, returns the error, otherwise returns false.
1119 my( $self, %options ) = @_;
1122 local $SIG{HUP} = 'IGNORE';
1123 local $SIG{INT} = 'IGNORE';
1124 local $SIG{QUIT} = 'IGNORE';
1125 local $SIG{TERM} = 'IGNORE';
1126 local $SIG{TSTP} = 'IGNORE';
1127 local $SIG{PIPE} = 'IGNORE';
1129 my $oldAutoCommit = $FS::UID::AutoCommit;
1130 local $FS::UID::AutoCommit = 0;
1133 my $old = $self->select_for_update;
1135 my $pkgnum = $old->pkgnum;
1136 if ( $old->get('cancel') || $self->get('cancel') ) {
1137 dbh->rollback if $oldAutoCommit;
1138 return "Can't unexpire cancelled package $pkgnum";
1139 # or at least it's pointless
1142 unless ( $old->get('expire') && $self->get('expire') ) {
1143 dbh->rollback if $oldAutoCommit;
1144 return ""; # no error
1147 my %hash = $self->hash;
1148 $hash{'expire'} = '';
1149 my $new = new FS::cust_pkg ( \%hash );
1150 $error = $new->replace( $self, options => { $self->options } );
1152 $dbh->rollback if $oldAutoCommit;
1156 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1162 =item suspend [ OPTION => VALUE ... ]
1164 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
1165 package, then suspends the package itself (sets the susp field to now).
1167 Available options are:
1171 =item reason - can be set to a cancellation reason (see L<FS:reason>),
1172 either a reasonnum of an existing reason, or passing a hashref will create
1173 a new reason. The hashref should have the following keys:
1174 - typenum - Reason type (see L<FS::reason_type>
1175 - reason - Text of the new reason.
1177 =item date - can be set to a unix style timestamp to specify when to
1180 =item time - can be set to override the current time, for calculation
1181 of final invoices or unused-time credits
1183 =item resume_date - can be set to a time when the package should be
1184 unsuspended. This may be more convenient than calling C<unsuspend()>
1187 =item from_main - allows a supplemental package to be suspended, rather
1188 than redirecting the method call to its main package. For internal use.
1192 If there is an error, returns the error, otherwise returns false.
1197 my( $self, %options ) = @_;
1200 # pass all suspend/cancel actions to the main package
1201 if ( $self->main_pkgnum and !$options{'from_main'} ) {
1202 return $self->main_pkg->suspend(%options);
1205 local $SIG{HUP} = 'IGNORE';
1206 local $SIG{INT} = 'IGNORE';
1207 local $SIG{QUIT} = 'IGNORE';
1208 local $SIG{TERM} = 'IGNORE';
1209 local $SIG{TSTP} = 'IGNORE';
1210 local $SIG{PIPE} = 'IGNORE';
1212 my $oldAutoCommit = $FS::UID::AutoCommit;
1213 local $FS::UID::AutoCommit = 0;
1216 my $old = $self->select_for_update;
1218 my $pkgnum = $old->pkgnum;
1219 if ( $old->get('cancel') || $self->get('cancel') ) {
1220 dbh->rollback if $oldAutoCommit;
1221 return "Can't suspend cancelled package $pkgnum";
1224 if ( $old->get('susp') || $self->get('susp') ) {
1225 dbh->rollback if $oldAutoCommit;
1226 return ""; # no error # complain on adjourn?
1229 my $suspend_time = $options{'time'} || time;
1230 my $date = $options{date} if $options{date}; # adjourn/suspend later
1231 $date = '' if ($date && $date <= $suspend_time); # complain instead?
1233 if ( $date && $old->get('expire') && $old->get('expire') < $date ) {
1234 dbh->rollback if $oldAutoCommit;
1235 return "Package $pkgnum expires before it would be suspended.";
1238 # some false laziness with sub cancel
1239 if ( !$options{nobill} && !$date &&
1240 $self->part_pkg->option('bill_suspend_as_cancel',1) ) {
1241 # kind of a kludge--'bill_suspend_as_cancel' to avoid having to
1242 # make the entire cust_main->bill path recognize 'suspend' and
1243 # 'cancel' separately.
1244 warn "Billing $pkgnum on suspension (at $suspend_time)\n" if $DEBUG;
1245 my $copy = $self->new({$self->hash});
1247 $copy->cust_main->bill( 'pkg_list' => [ $copy ],
1249 'time' => $suspend_time );
1250 warn "Error billing during suspend, custnum ".
1251 #$self->cust_main->custnum. ": $error"
1256 if ( $options{'reason'} ) {
1257 $error = $self->insert_reason( 'reason' => $options{'reason'},
1258 'action' => $date ? 'adjourn' : 'suspend',
1259 'date' => $date ? $date : $suspend_time,
1260 'reason_otaker' => $options{'reason_otaker'},
1263 dbh->rollback if $oldAutoCommit;
1264 return "Error inserting cust_pkg_reason: $error";
1268 my %hash = $self->hash;
1270 $hash{'adjourn'} = $date;
1272 $hash{'susp'} = $suspend_time;
1275 my $resume_date = $options{'resume_date'} || 0;
1276 if ( $resume_date > ($date || $suspend_time) ) {
1277 $hash{'resume'} = $resume_date;
1280 $options{options} ||= {};
1282 my $new = new FS::cust_pkg ( \%hash );
1283 $error = $new->replace( $self, options => { $self->options,
1284 %{ $options{options} },
1288 $dbh->rollback if $oldAutoCommit;
1293 # credit remaining time if appropriate
1294 if ( $self->part_pkg->option('unused_credit_suspend', 1) ) {
1295 my $error = $self->credit_remaining('suspend', $suspend_time);
1297 $dbh->rollback if $oldAutoCommit;
1304 foreach my $cust_svc (
1305 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
1307 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
1309 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
1310 $dbh->rollback if $oldAutoCommit;
1311 return "Illegal svcdb value in part_svc!";
1314 require "FS/$svcdb.pm";
1316 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
1318 $error = $svc->suspend;
1320 $dbh->rollback if $oldAutoCommit;
1323 my( $label, $value ) = $cust_svc->label;
1324 push @labels, "$label: $value";
1328 my $conf = new FS::Conf;
1329 if ( $conf->config('suspend_email_admin') ) {
1331 my $error = send_email(
1332 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
1333 #invoice_from ??? well as good as any
1334 'to' => $conf->config('suspend_email_admin'),
1335 'subject' => 'FREESIDE NOTIFICATION: Customer package suspended',
1337 "This is an automatic message from your Freeside installation\n",
1338 "informing you that the following customer package has been suspended:\n",
1340 'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
1341 'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
1342 ( map { "Service : $_\n" } @labels ),
1347 warn "WARNING: can't send suspension admin email (suspending anyway): ".
1355 foreach my $supp_pkg ( $self->supplemental_pkgs ) {
1356 $error = $supp_pkg->suspend(%options, 'from_main' => 1);
1358 $dbh->rollback if $oldAutoCommit;
1359 return "suspending supplemental pkg#".$supp_pkg->pkgnum.": $error";
1363 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1368 =item credit_remaining MODE TIME
1370 Generate a credit for this package for the time remaining in the current
1371 billing period. MODE is either "suspend" or "cancel" (determines the
1372 credit type). TIME is the time of suspension/cancellation. Both arguments
1377 sub credit_remaining {
1378 # Add a credit for remaining service
1379 my ($self, $mode, $time) = @_;
1380 die 'credit_remaining requires suspend or cancel'
1381 unless $mode eq 'suspend' or $mode eq 'cancel';
1382 die 'no suspend/cancel time' unless $time > 0;
1384 my $conf = FS::Conf->new;
1385 my $reason_type = $conf->config($mode.'_credit_type');
1387 my $last_bill = $self->getfield('last_bill') || 0;
1388 my $next_bill = $self->getfield('bill') || 0;
1389 if ( $last_bill > 0 # the package has been billed
1390 and $next_bill > 0 # the package has a next bill date
1391 and $next_bill >= $time # which is in the future
1393 my $remaining_value = $self->calc_remain('time' => $time);
1394 if ( $remaining_value > 0 ) {
1395 warn "Crediting for $remaining_value on package ".$self->pkgnum."\n"
1397 my $error = $self->cust_main->credit(
1399 'Credit for unused time on '. $self->part_pkg->pkg,
1400 'reason_type' => $reason_type,
1402 return "Error crediting customer \$$remaining_value for unused time".
1403 " on ". $self->part_pkg->pkg. ": $error"
1405 } #if $remaining_value
1406 } #if $last_bill, etc.
1410 =item unsuspend [ OPTION => VALUE ... ]
1412 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
1413 package, then unsuspends the package itself (clears the susp field and the
1414 adjourn field if it is in the past). If the suspend reason includes an
1415 unsuspension package, that package will be ordered.
1417 Available options are:
1423 Can be set to a date to unsuspend the package in the future (the 'resume'
1426 =item adjust_next_bill
1428 Can be set true to adjust the next bill date forward by
1429 the amount of time the account was inactive. This was set true by default
1430 since 1.4.2 and 1.5.0pre6; however, starting with 1.7.0 this needs to be
1431 explicitly requested. Price plans for which this makes sense (anniversary-date
1432 based than prorate or subscription) could have an option to enable this
1437 If there is an error, returns the error, otherwise returns false.
1442 my( $self, %opt ) = @_;
1445 # pass all suspend/cancel actions to the main package
1446 if ( $self->main_pkgnum and !$opt{'from_main'} ) {
1447 return $self->main_pkg->unsuspend(%opt);
1450 local $SIG{HUP} = 'IGNORE';
1451 local $SIG{INT} = 'IGNORE';
1452 local $SIG{QUIT} = 'IGNORE';
1453 local $SIG{TERM} = 'IGNORE';
1454 local $SIG{TSTP} = 'IGNORE';
1455 local $SIG{PIPE} = 'IGNORE';
1457 my $oldAutoCommit = $FS::UID::AutoCommit;
1458 local $FS::UID::AutoCommit = 0;
1461 my $old = $self->select_for_update;
1463 my $pkgnum = $old->pkgnum;
1464 if ( $old->get('cancel') || $self->get('cancel') ) {
1465 $dbh->rollback if $oldAutoCommit;
1466 return "Can't unsuspend cancelled package $pkgnum";
1469 unless ( $old->get('susp') && $self->get('susp') ) {
1470 $dbh->rollback if $oldAutoCommit;
1471 return ""; # no error # complain instead?
1474 my $date = $opt{'date'};
1475 if ( $date and $date > time ) { # return an error if $date <= time?
1477 if ( $old->get('expire') && $old->get('expire') < $date ) {
1478 $dbh->rollback if $oldAutoCommit;
1479 return "Package $pkgnum expires before it would be unsuspended.";
1482 my $new = new FS::cust_pkg { $self->hash };
1483 $new->set('resume', $date);
1484 $error = $new->replace($self, options => $self->options);
1487 $dbh->rollback if $oldAutoCommit;
1491 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1499 foreach my $cust_svc (
1500 qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
1502 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
1504 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
1505 $dbh->rollback if $oldAutoCommit;
1506 return "Illegal svcdb value in part_svc!";
1509 require "FS/$svcdb.pm";
1511 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
1513 $error = $svc->unsuspend;
1515 $dbh->rollback if $oldAutoCommit;
1518 my( $label, $value ) = $cust_svc->label;
1519 push @labels, "$label: $value";
1524 my $cust_pkg_reason = $self->last_cust_pkg_reason('susp');
1525 my $reason = $cust_pkg_reason ? $cust_pkg_reason->reason : '';
1527 my %hash = $self->hash;
1528 my $inactive = time - $hash{'susp'};
1530 my $conf = new FS::Conf;
1532 if ( $inactive > 0 &&
1533 ( $hash{'bill'} || $hash{'setup'} ) &&
1534 ( $opt{'adjust_next_bill'} ||
1535 $conf->exists('unsuspend-always_adjust_next_bill_date') ||
1536 $self->part_pkg->option('unsuspend_adjust_bill', 1) )
1539 $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive;
1544 $hash{'adjourn'} = '' if $hash{'adjourn'} and $hash{'adjourn'} < time;
1545 $hash{'resume'} = '' if !$hash{'adjourn'};
1546 my $new = new FS::cust_pkg ( \%hash );
1547 $error = $new->replace( $self, options => { $self->options } );
1549 $dbh->rollback if $oldAutoCommit;
1555 if ( $reason && $reason->unsuspend_pkgpart ) {
1556 my $part_pkg = FS::part_pkg->by_key($reason->unsuspend_pkgpart)
1557 or $error = "Unsuspend package definition ".$reason->unsuspend_pkgpart.
1559 my $start_date = $self->cust_main->next_bill_date
1560 if $reason->unsuspend_hold;
1563 $unsusp_pkg = FS::cust_pkg->new({
1564 'custnum' => $self->custnum,
1565 'pkgpart' => $reason->unsuspend_pkgpart,
1566 'start_date' => $start_date,
1567 'locationnum' => $self->locationnum,
1568 # discount? probably not...
1571 $error ||= $self->cust_main->order_pkg( 'cust_pkg' => $unsusp_pkg );
1575 $dbh->rollback if $oldAutoCommit;
1580 if ( $conf->config('unsuspend_email_admin') ) {
1582 my $error = send_email(
1583 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
1584 #invoice_from ??? well as good as any
1585 'to' => $conf->config('unsuspend_email_admin'),
1586 'subject' => 'FREESIDE NOTIFICATION: Customer package unsuspended', 'body' => [
1587 "This is an automatic message from your Freeside installation\n",
1588 "informing you that the following customer package has been unsuspended:\n",
1590 'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
1591 'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
1592 ( map { "Service : $_\n" } @labels ),
1594 "An unsuspension fee was charged: ".
1595 $unsusp_pkg->part_pkg->pkg_comment."\n"
1602 warn "WARNING: can't send unsuspension admin email (unsuspending anyway): ".
1608 foreach my $supp_pkg ( $self->supplemental_pkgs ) {
1609 $error = $supp_pkg->unsuspend(%opt, 'from_main' => 1);
1611 $dbh->rollback if $oldAutoCommit;
1612 return "unsuspending supplemental pkg#".$supp_pkg->pkgnum.": $error";
1616 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1623 Cancels any pending suspension (sets the adjourn field to null).
1625 If there is an error, returns the error, otherwise returns false.
1630 my( $self, %options ) = @_;
1633 local $SIG{HUP} = 'IGNORE';
1634 local $SIG{INT} = 'IGNORE';
1635 local $SIG{QUIT} = 'IGNORE';
1636 local $SIG{TERM} = 'IGNORE';
1637 local $SIG{TSTP} = 'IGNORE';
1638 local $SIG{PIPE} = 'IGNORE';
1640 my $oldAutoCommit = $FS::UID::AutoCommit;
1641 local $FS::UID::AutoCommit = 0;
1644 my $old = $self->select_for_update;
1646 my $pkgnum = $old->pkgnum;
1647 if ( $old->get('cancel') || $self->get('cancel') ) {
1648 dbh->rollback if $oldAutoCommit;
1649 return "Can't unadjourn cancelled package $pkgnum";
1650 # or at least it's pointless
1653 if ( $old->get('susp') || $self->get('susp') ) {
1654 dbh->rollback if $oldAutoCommit;
1655 return "Can't unadjourn suspended package $pkgnum";
1656 # perhaps this is arbitrary
1659 unless ( $old->get('adjourn') && $self->get('adjourn') ) {
1660 dbh->rollback if $oldAutoCommit;
1661 return ""; # no error
1664 my %hash = $self->hash;
1665 $hash{'adjourn'} = '';
1666 $hash{'resume'} = '';
1667 my $new = new FS::cust_pkg ( \%hash );
1668 $error = $new->replace( $self, options => { $self->options } );
1670 $dbh->rollback if $oldAutoCommit;
1674 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1681 =item change HASHREF | OPTION => VALUE ...
1683 Changes this package: cancels it and creates a new one, with a different
1684 pkgpart or locationnum or both. All services are transferred to the new
1685 package (no change will be made if this is not possible).
1687 Options may be passed as a list of key/value pairs or as a hash reference.
1694 New locationnum, to change the location for this package.
1698 New FS::cust_location object, to create a new location and assign it
1703 New pkgpart (see L<FS::part_pkg>).
1707 New refnum (see L<FS::part_referral>).
1711 Set to true to transfer billing dates (start_date, setup, last_bill, bill,
1712 susp, adjourn, cancel, expire, and contract_end) to the new package.
1716 At least one of locationnum, cust_location, pkgpart, refnum must be specified
1717 (otherwise, what's the point?)
1719 Returns either the new FS::cust_pkg object or a scalar error.
1723 my $err_or_new_cust_pkg = $old_cust_pkg->change
1727 #some false laziness w/order
1730 my $opt = ref($_[0]) ? shift : { @_ };
1732 # my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
1735 my $conf = new FS::Conf;
1737 # Transactionize this whole mess
1738 local $SIG{HUP} = 'IGNORE';
1739 local $SIG{INT} = 'IGNORE';
1740 local $SIG{QUIT} = 'IGNORE';
1741 local $SIG{TERM} = 'IGNORE';
1742 local $SIG{TSTP} = 'IGNORE';
1743 local $SIG{PIPE} = 'IGNORE';
1745 my $oldAutoCommit = $FS::UID::AutoCommit;
1746 local $FS::UID::AutoCommit = 0;
1755 #$hash{$_} = $self->$_() foreach qw( last_bill bill );
1757 #$hash{$_} = $self->$_() foreach qw( setup );
1759 $hash{'setup'} = $time if $self->setup;
1761 $hash{'change_date'} = $time;
1762 $hash{"change_$_"} = $self->$_()
1763 foreach qw( pkgnum pkgpart locationnum );
1765 if ( $opt->{'cust_location'} &&
1766 ( ! $opt->{'locationnum'} || $opt->{'locationnum'} == -1 ) ) {
1768 if ( ! $opt->{'cust_location'}->locationnum ) {
1770 $error = $opt->{'cust_location'}->insert;
1772 $dbh->rollback if $oldAutoCommit;
1773 return "inserting cust_location (transaction rolled back): $error";
1776 $opt->{'locationnum'} = $opt->{'cust_location'}->locationnum;
1780 # whether to override pkgpart checking on the new package
1781 my $same_pkgpart = 1;
1782 if ( $opt->{'pkgpart'} and ( $opt->{'pkgpart'} != $self->pkgpart ) ) {
1786 my $unused_credit = 0;
1787 my $keep_dates = $opt->{'keep_dates'};
1788 # Special case. If the pkgpart is changing, and the customer is
1789 # going to be credited for remaining time, don't keep setup, bill,
1790 # or last_bill dates, and DO pass the flag to cancel() to credit
1792 if ( $opt->{'pkgpart'}
1793 and $opt->{'pkgpart'} != $self->pkgpart
1794 and $self->part_pkg->option('unused_credit_change', 1) ) {
1797 $hash{$_} = '' foreach qw(setup bill last_bill);
1800 if ( $keep_dates ) {
1801 foreach my $date ( qw(setup bill last_bill susp adjourn cancel expire
1802 resume start_date contract_end ) ) {
1803 $hash{$date} = $self->getfield($date);
1806 # allow $opt->{'locationnum'} = '' to specifically set it to null
1807 # (i.e. customer default location)
1808 $opt->{'locationnum'} = $self->locationnum if !exists($opt->{'locationnum'});
1810 # usually this doesn't matter. the two cases where it does are:
1811 # 1. unused_credit_change + pkgpart change + setup fee on the new package
1813 # 2. (more importantly) changing a package before it's billed
1814 $hash{'waive_setup'} = $self->waive_setup;
1816 # Create the new package.
1817 my $cust_pkg = new FS::cust_pkg {
1818 custnum => $self->custnum,
1819 pkgpart => ( $opt->{'pkgpart'} || $self->pkgpart ),
1820 refnum => ( $opt->{'refnum'} || $self->refnum ),
1821 locationnum => ( $opt->{'locationnum'} ),
1824 $error = $cust_pkg->insert( 'change' => 1,
1825 'allow_pkgpart' => $same_pkgpart );
1827 $dbh->rollback if $oldAutoCommit;
1831 # Transfer services and cancel old package.
1833 $error = $self->transfer($cust_pkg);
1834 if ($error and $error == 0) {
1835 # $old_pkg->transfer failed.
1836 $dbh->rollback if $oldAutoCommit;
1840 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1841 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1842 $error = $self->transfer($cust_pkg, 'change_svcpart'=>1 );
1843 if ($error and $error == 0) {
1844 # $old_pkg->transfer failed.
1845 $dbh->rollback if $oldAutoCommit;
1851 # Transfers were successful, but we still had services left on the old
1852 # package. We can't change the package under this circumstances, so abort.
1853 $dbh->rollback if $oldAutoCommit;
1854 return "Unable to transfer all services from package ". $self->pkgnum;
1857 #reset usage if changing pkgpart
1858 # AND usage rollover is off (otherwise adds twice, now and at package bill)
1859 if ($self->pkgpart != $cust_pkg->pkgpart) {
1860 my $part_pkg = $cust_pkg->part_pkg;
1861 $error = $part_pkg->reset_usage($cust_pkg, $part_pkg->is_prepaid
1865 if $part_pkg->can('reset_usage') && ! $part_pkg->option('usage_rollover',1);
1868 $dbh->rollback if $oldAutoCommit;
1869 return "Error setting usage values: $error";
1872 # if NOT changing pkgpart, transfer any usage pools over
1873 foreach my $usage ($self->cust_pkg_usage) {
1874 $usage->set('pkgnum', $cust_pkg->pkgnum);
1875 $error = $usage->replace;
1877 $dbh->rollback if $oldAutoCommit;
1878 return "Error transferring usage pools: $error";
1883 # transfer discounts, if we're not changing pkgpart
1884 if ( $same_pkgpart ) {
1885 foreach my $old_discount ($self->cust_pkg_discount_active) {
1886 # don't remove the old discount, we may still need to bill that package.
1887 my $new_discount = new FS::cust_pkg_discount {
1888 'pkgnum' => $cust_pkg->pkgnum,
1889 'discountnum' => $old_discount->discountnum,
1890 'months_used' => $old_discount->months_used,
1892 $error = $new_discount->insert;
1894 $dbh->rollback if $oldAutoCommit;
1895 return "Error transferring discounts: $error";
1900 # Order any supplemental packages.
1901 my $part_pkg = $cust_pkg->part_pkg;
1902 my @old_supp_pkgs = $self->supplemental_pkgs;
1904 foreach my $link ($part_pkg->supp_part_pkg_link) {
1906 foreach (@old_supp_pkgs) {
1907 if ($_->pkgpart == $link->dst_pkgpart) {
1909 $_->pkgpart(0); # so that it can't match more than once
1913 # false laziness with FS::cust_main::Packages::order_pkg
1914 my $new = FS::cust_pkg->new({
1915 pkgpart => $link->dst_pkgpart,
1916 pkglinknum => $link->pkglinknum,
1917 custnum => $self->custnum,
1918 main_pkgnum => $cust_pkg->pkgnum,
1919 locationnum => $cust_pkg->locationnum,
1920 start_date => $cust_pkg->start_date,
1921 order_date => $cust_pkg->order_date,
1922 expire => $cust_pkg->expire,
1923 adjourn => $cust_pkg->adjourn,
1924 contract_end => $cust_pkg->contract_end,
1925 refnum => $cust_pkg->refnum,
1926 discountnum => $cust_pkg->discountnum,
1927 waive_setup => $cust_pkg->waive_setup,
1929 if ( $old and $opt->{'keep_dates'} ) {
1930 foreach (qw(setup bill last_bill)) {
1931 $new->set($_, $old->get($_));
1934 $error = $new->insert( allow_pkgpart => $same_pkgpart );
1937 $error ||= $old->transfer($new);
1939 if ( $error and $error > 0 ) {
1940 # no reason why this should ever fail, but still...
1941 $error = "Unable to transfer all services from supplemental package ".
1945 $dbh->rollback if $oldAutoCommit;
1948 push @new_supp_pkgs, $new;
1951 #Good to go, cancel old package. Notify 'cancel' of whether to credit
1953 #Don't allow billing the package (preceding period packages and/or
1954 #outstanding usage) if we are keeping dates (i.e. location changing),
1955 #because the new package will be billed for the same date range.
1956 #Supplemental packages are also canceled here.
1957 $error = $self->cancel(
1959 unused_credit => $unused_credit,
1960 nobill => $keep_dates
1963 $dbh->rollback if $oldAutoCommit;
1967 if ( $conf->exists('cust_pkg-change_pkgpart-bill_now') ) {
1969 my $error = $cust_pkg->cust_main->bill(
1970 'pkg_list' => [ $cust_pkg, @new_supp_pkgs ]
1973 $dbh->rollback if $oldAutoCommit;
1978 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1984 =item set_quantity QUANTITY
1986 Change the package's quantity field. This is the one package property
1987 that can safely be changed without canceling and reordering the package
1988 (because it doesn't affect tax eligibility). Returns an error or an
1995 $self = $self->replace_old; # just to make sure
1997 ($qty =~ /^\d+$/ and $qty > 0) or return "bad package quantity $qty";
1998 $self->set('quantity' => $qty);
2002 use Storable 'thaw';
2004 sub process_bulk_cust_pkg {
2006 my $param = thaw(decode_base64(shift));
2007 warn Dumper($param) if $DEBUG;
2009 my $old_part_pkg = qsearchs('part_pkg',
2010 { pkgpart => $param->{'old_pkgpart'} });
2011 my $new_part_pkg = qsearchs('part_pkg',
2012 { pkgpart => $param->{'new_pkgpart'} });
2013 die "Must select a new package type\n" unless $new_part_pkg;
2014 #my $keep_dates = $param->{'keep_dates'} || 0;
2015 my $keep_dates = 1; # there is no good reason to turn this off
2017 local $SIG{HUP} = 'IGNORE';
2018 local $SIG{INT} = 'IGNORE';
2019 local $SIG{QUIT} = 'IGNORE';
2020 local $SIG{TERM} = 'IGNORE';
2021 local $SIG{TSTP} = 'IGNORE';
2022 local $SIG{PIPE} = 'IGNORE';
2024 my $oldAutoCommit = $FS::UID::AutoCommit;
2025 local $FS::UID::AutoCommit = 0;
2028 my @cust_pkgs = qsearch('cust_pkg', { 'pkgpart' => $param->{'old_pkgpart'} } );
2031 foreach my $old_cust_pkg ( @cust_pkgs ) {
2033 $job->update_statustext(int(100*$i/(scalar @cust_pkgs)));
2034 if ( $old_cust_pkg->getfield('cancel') ) {
2035 warn '[process_bulk_cust_pkg ] skipping canceled pkgnum '.
2036 $old_cust_pkg->pkgnum."\n"
2040 warn '[process_bulk_cust_pkg] changing pkgnum '.$old_cust_pkg->pkgnum."\n"
2042 my $error = $old_cust_pkg->change(
2043 'pkgpart' => $param->{'new_pkgpart'},
2044 'keep_dates' => $keep_dates
2046 if ( !ref($error) ) { # change returns the cust_pkg on success
2048 die "Error changing pkgnum ".$old_cust_pkg->pkgnum.": '$error'\n";
2051 $dbh->commit if $oldAutoCommit;
2057 Returns the last bill date, or if there is no last bill date, the setup date.
2058 Useful for billing metered services.
2064 return $self->setfield('last_bill', $_[0]) if @_;
2065 return $self->getfield('last_bill') if $self->getfield('last_bill');
2066 my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
2067 'edate' => $self->bill, } );
2068 $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
2071 =item last_cust_pkg_reason ACTION
2073 Returns the most recent ACTION FS::cust_pkg_reason associated with the package.
2074 Returns false if there is no reason or the package is not currenly ACTION'd
2075 ACTION is one of adjourn, susp, cancel, or expire.
2079 sub last_cust_pkg_reason {
2080 my ( $self, $action ) = ( shift, shift );
2081 my $date = $self->get($action);
2083 'table' => 'cust_pkg_reason',
2084 'hashref' => { 'pkgnum' => $self->pkgnum,
2085 'action' => substr(uc($action), 0, 1),
2088 'order_by' => 'ORDER BY num DESC LIMIT 1',
2092 =item last_reason ACTION
2094 Returns the most recent ACTION FS::reason associated with the package.
2095 Returns false if there is no reason or the package is not currenly ACTION'd
2096 ACTION is one of adjourn, susp, cancel, or expire.
2101 my $cust_pkg_reason = shift->last_cust_pkg_reason(@_);
2102 $cust_pkg_reason->reason
2103 if $cust_pkg_reason;
2108 Returns the definition for this billing item, as an FS::part_pkg object (see
2115 return $self->{'_pkgpart'} if $self->{'_pkgpart'};
2116 cluck "cust_pkg->part_pkg called" if $DEBUG > 1;
2117 qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
2122 Returns the cancelled package this package was changed from, if any.
2128 return '' unless $self->change_pkgnum;
2129 qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
2134 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
2141 $self->part_pkg->calc_setup($self, @_);
2146 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
2153 $self->part_pkg->calc_recur($self, @_);
2158 Calls the I<base_recur> of the FS::part_pkg object associated with this billing
2165 $self->part_pkg->base_recur($self, @_);
2170 Calls the I<calc_remain> of the FS::part_pkg object associated with this
2177 $self->part_pkg->calc_remain($self, @_);
2182 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
2189 $self->part_pkg->calc_cancel($self, @_);
2194 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
2200 qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
2203 =item cust_pkg_detail [ DETAILTYPE ]
2205 Returns any customer package details for this package (see
2206 L<FS::cust_pkg_detail>).
2208 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
2212 sub cust_pkg_detail {
2214 my %hash = ( 'pkgnum' => $self->pkgnum );
2215 $hash{detailtype} = shift if @_;
2217 'table' => 'cust_pkg_detail',
2218 'hashref' => \%hash,
2219 'order_by' => 'ORDER BY weight, pkgdetailnum',
2223 =item set_cust_pkg_detail DETAILTYPE [ DETAIL, DETAIL, ... ]
2225 Sets customer package details for this package (see L<FS::cust_pkg_detail>).
2227 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
2229 If there is an error, returns the error, otherwise returns false.
2233 sub set_cust_pkg_detail {
2234 my( $self, $detailtype, @details ) = @_;
2236 local $SIG{HUP} = 'IGNORE';
2237 local $SIG{INT} = 'IGNORE';
2238 local $SIG{QUIT} = 'IGNORE';
2239 local $SIG{TERM} = 'IGNORE';
2240 local $SIG{TSTP} = 'IGNORE';
2241 local $SIG{PIPE} = 'IGNORE';
2243 my $oldAutoCommit = $FS::UID::AutoCommit;
2244 local $FS::UID::AutoCommit = 0;
2247 foreach my $current ( $self->cust_pkg_detail($detailtype) ) {
2248 my $error = $current->delete;
2250 $dbh->rollback if $oldAutoCommit;
2251 return "error removing old detail: $error";
2255 foreach my $detail ( @details ) {
2256 my $cust_pkg_detail = new FS::cust_pkg_detail {
2257 'pkgnum' => $self->pkgnum,
2258 'detailtype' => $detailtype,
2259 'detail' => $detail,
2261 my $error = $cust_pkg_detail->insert;
2263 $dbh->rollback if $oldAutoCommit;
2264 return "error adding new detail: $error";
2269 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2276 Returns the new-style customer billing events (see L<FS::cust_event>) for this invoice.
2280 #false laziness w/cust_bill.pm
2284 'table' => 'cust_event',
2285 'addl_from' => 'JOIN part_event USING ( eventpart )',
2286 'hashref' => { 'tablenum' => $self->pkgnum },
2287 'extra_sql' => " AND eventtable = 'cust_pkg' ",
2291 =item num_cust_event
2293 Returns the number of new-style customer billing events (see L<FS::cust_event>) for this invoice.
2297 #false laziness w/cust_bill.pm
2298 sub num_cust_event {
2301 "SELECT COUNT(*) FROM cust_event JOIN part_event USING ( eventpart ) ".
2302 " WHERE tablenum = ? AND eventtable = 'cust_pkg'";
2303 my $sth = dbh->prepare($sql) or die dbh->errstr. " preparing $sql";
2304 $sth->execute($self->pkgnum) or die $sth->errstr. " executing $sql";
2305 $sth->fetchrow_arrayref->[0];
2308 =item cust_svc [ SVCPART ] (old, deprecated usage)
2310 =item cust_svc [ OPTION => VALUE ... ] (current usage)
2312 Returns the services for this package, as FS::cust_svc objects (see
2313 L<FS::cust_svc>). Available options are svcpart and svcdb. If either is
2314 spcififed, returns only the matching services.
2321 return () unless $self->num_cust_svc(@_);
2324 if ( @_ && $_[0] =~ /^\d+/ ) {
2325 $opt{svcpart} = shift;
2326 } elsif ( @_ && ref($_[0]) eq 'HASH' ) {
2333 'table' => 'cust_svc',
2334 'hashref' => { 'pkgnum' => $self->pkgnum },
2336 if ( $opt{svcpart} ) {
2337 $search{hashref}->{svcpart} = $opt{'svcpart'};
2339 if ( $opt{'svcdb'} ) {
2340 $search{addl_from} = ' LEFT JOIN part_svc USING ( svcpart ) ';
2341 $search{extra_sql} = ' AND svcdb = '. dbh->quote( $opt{'svcdb'} );
2344 cluck "cust_pkg->cust_svc called" if $DEBUG > 2;
2346 #if ( $self->{'_svcnum'} ) {
2347 # values %{ $self->{'_svcnum'}->cache };
2349 $self->_sort_cust_svc( [ qsearch(\%search) ] );
2354 =item overlimit [ SVCPART ]
2356 Returns the services for this package which have exceeded their
2357 usage limit as FS::cust_svc objects (see L<FS::cust_svc>). If a svcpart
2358 is specified, return only the matching services.
2364 return () unless $self->num_cust_svc(@_);
2365 grep { $_->overlimit } $self->cust_svc(@_);
2368 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
2370 Returns historical services for this package created before END TIMESTAMP and
2371 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
2372 (see L<FS::h_cust_svc>). If MODE is 'I' (for 'invoice'), services with the
2373 I<pkg_svc.hidden> flag will be omitted.
2379 warn "$me _h_cust_svc called on $self\n"
2382 my ($end, $start, $mode) = @_;
2383 my @cust_svc = $self->_sort_cust_svc(
2384 [ qsearch( 'h_cust_svc',
2385 { 'pkgnum' => $self->pkgnum, },
2386 FS::h_cust_svc->sql_h_search(@_),
2389 if ( defined($mode) && $mode eq 'I' ) {
2390 my %hidden_svcpart = map { $_->svcpart => $_->hidden } $self->part_svc;
2391 return grep { !$hidden_svcpart{$_->svcpart} } @cust_svc;
2397 sub _sort_cust_svc {
2398 my( $self, $arrayref ) = @_;
2401 sub ($$) { my ($a, $b) = @_; $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] };
2406 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
2407 'svcpart' => $_->svcpart } );
2409 $pkg_svc ? $pkg_svc->primary_svc : '',
2410 $pkg_svc ? $pkg_svc->quantity : 0,
2417 =item num_cust_svc [ SVCPART ] (old, deprecated usage)
2419 =item num_cust_svc [ OPTION => VALUE ... ] (current usage)
2421 Returns the number of services for this package. Available options are svcpart
2422 and svcdb. If either is spcififed, returns only the matching services.
2429 return $self->{'_num_cust_svc'}
2431 && exists($self->{'_num_cust_svc'})
2432 && $self->{'_num_cust_svc'} =~ /\d/;
2434 cluck "cust_pkg->num_cust_svc called, _num_cust_svc:".$self->{'_num_cust_svc'}
2438 if ( @_ && $_[0] =~ /^\d+/ ) {
2439 $opt{svcpart} = shift;
2440 } elsif ( @_ && ref($_[0]) eq 'HASH' ) {
2446 my $select = 'SELECT COUNT(*) FROM cust_svc ';
2447 my $where = ' WHERE pkgnum = ? ';
2448 my @param = ($self->pkgnum);
2450 if ( $opt{'svcpart'} ) {
2451 $where .= ' AND svcpart = ? ';
2452 push @param, $opt{'svcpart'};
2454 if ( $opt{'svcdb'} ) {
2455 $select .= ' LEFT JOIN part_svc USING ( svcpart ) ';
2456 $where .= ' AND svcdb = ? ';
2457 push @param, $opt{'svcdb'};
2460 my $sth = dbh->prepare("$select $where") or die dbh->errstr;
2461 $sth->execute(@param) or die $sth->errstr;
2462 $sth->fetchrow_arrayref->[0];
2465 =item available_part_svc
2467 Returns a list of FS::part_svc objects representing services included in this
2468 package but not yet provisioned. Each FS::part_svc object also has an extra
2469 field, I<num_avail>, which specifies the number of available services.
2473 sub available_part_svc {
2476 my $pkg_quantity = $self->quantity || 1;
2478 grep { $_->num_avail > 0 }
2480 my $part_svc = $_->part_svc;
2481 $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
2482 $pkg_quantity * $_->quantity - $self->num_cust_svc($_->svcpart);
2484 # more evil encapsulation breakage
2485 if($part_svc->{'Hash'}{'num_avail'} > 0) {
2486 my @exports = $part_svc->part_export_did;
2487 $part_svc->{'Hash'}{'can_get_dids'} = scalar(@exports);
2492 $self->part_pkg->pkg_svc;
2495 =item part_svc [ OPTION => VALUE ... ]
2497 Returns a list of FS::part_svc objects representing provisioned and available
2498 services included in this package. Each FS::part_svc object also has the
2499 following extra fields:
2503 =item num_cust_svc (count)
2505 =item num_avail (quantity - count)
2507 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
2511 Accepts one option: summarize_size. If specified and non-zero, will omit the
2512 extra cust_pkg_svc option for objects where num_cust_svc is this size or
2518 #label -> ($cust_svc->label)[1]
2524 my $pkg_quantity = $self->quantity || 1;
2526 #XXX some sort of sort order besides numeric by svcpart...
2527 my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
2529 my $part_svc = $pkg_svc->part_svc;
2530 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
2531 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
2532 $part_svc->{'Hash'}{'num_avail'} =
2533 max( 0, $pkg_quantity * $pkg_svc->quantity - $num_cust_svc );
2534 $part_svc->{'Hash'}{'cust_pkg_svc'} =
2535 $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : []
2536 unless exists($opt{summarize_size}) && $opt{summarize_size} > 0
2537 && $num_cust_svc >= $opt{summarize_size};
2538 $part_svc->{'Hash'}{'hidden'} = $pkg_svc->hidden;
2540 } $self->part_pkg->pkg_svc;
2543 push @part_svc, map {
2545 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
2546 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
2547 $part_svc->{'Hash'}{'num_avail'} = 0; #0-$num_cust_svc ?
2548 $part_svc->{'Hash'}{'cust_pkg_svc'} =
2549 $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
2551 } $self->extra_part_svc;
2557 =item extra_part_svc
2559 Returns a list of FS::part_svc objects corresponding to services in this
2560 package which are still provisioned but not (any longer) available in the
2565 sub extra_part_svc {
2568 my $pkgnum = $self->pkgnum;
2569 #my $pkgpart = $self->pkgpart;
2572 # 'table' => 'part_svc',
2575 # "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
2576 # WHERE pkg_svc.svcpart = part_svc.svcpart
2577 # AND pkg_svc.pkgpart = ?
2580 # AND 0 < ( SELECT COUNT(*) FROM cust_svc
2581 # LEFT JOIN cust_pkg USING ( pkgnum )
2582 # WHERE cust_svc.svcpart = part_svc.svcpart
2585 # 'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
2588 #seems to benchmark slightly faster... (or did?)
2590 my @pkgparts = map $_->pkgpart, $self->part_pkg->self_and_svc_linked;
2591 my $pkgparts = join(',', @pkgparts);
2594 #'select' => 'DISTINCT ON (svcpart) part_svc.*',
2595 #MySQL doesn't grok DISINCT ON
2596 'select' => 'DISTINCT part_svc.*',
2597 'table' => 'part_svc',
2599 "LEFT JOIN pkg_svc ON ( pkg_svc.svcpart = part_svc.svcpart
2600 AND pkg_svc.pkgpart IN ($pkgparts)
2603 LEFT JOIN cust_svc ON ( cust_svc.svcpart = part_svc.svcpart )
2604 LEFT JOIN cust_pkg USING ( pkgnum )
2607 'extra_sql' => "WHERE pkgsvcnum IS NULL AND cust_pkg.pkgnum = ? ",
2608 'extra_param' => [ [$self->pkgnum=>'int'] ],
2614 Returns a short status string for this package, currently:
2618 =item not yet billed
2620 =item one-time charge
2635 my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
2637 return 'cancelled' if $self->get('cancel');
2638 return 'suspended' if $self->susp;
2639 return 'not yet billed' unless $self->setup;
2640 return 'one-time charge' if $freq =~ /^(0|$)/;
2644 =item ucfirst_status
2646 Returns the status with the first character capitalized.
2650 sub ucfirst_status {
2651 ucfirst(shift->status);
2656 Class method that returns the list of possible status strings for packages
2657 (see L<the status method|/status>). For example:
2659 @statuses = FS::cust_pkg->statuses();
2663 tie my %statuscolor, 'Tie::IxHash',
2664 'not yet billed' => '009999', #teal? cyan?
2665 'one-time charge' => '000000',
2666 'active' => '00CC00',
2667 'suspended' => 'FF9900',
2668 'cancelled' => 'FF0000',
2672 my $self = shift; #could be class...
2673 #grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
2674 # # mayble split btw one-time vs. recur
2680 Returns a hex triplet color string for this package's status.
2686 $statuscolor{$self->status};
2691 Returns a label for this package. (Currently "pkgnum: pkg - comment" or
2692 "pkg - comment" depending on user preference).
2698 my $label = $self->part_pkg->pkg_comment( 'nopkgpart' => 1 );
2699 $label = $self->pkgnum. ": $label"
2700 if $FS::CurrentUser::CurrentUser->option('show_pkgnum');
2704 =item pkg_label_long
2706 Returns a long label for this package, adding the primary service's label to
2711 sub pkg_label_long {
2713 my $label = $self->pkg_label;
2714 my $cust_svc = $self->primary_cust_svc;
2715 $label .= ' ('. ($cust_svc->label)[1]. ')' if $cust_svc;
2721 Returns a customer-localized label for this package.
2727 $self->part_pkg->pkg_locale( $self->cust_main->locale );
2730 =item primary_cust_svc
2732 Returns a primary service (as FS::cust_svc object) if one can be identified.
2736 #for labeling purposes - might not 100% match up with part_pkg->svcpart's idea
2738 sub primary_cust_svc {
2741 my @cust_svc = $self->cust_svc;
2743 return '' unless @cust_svc; #no serivces - irrelevant then
2745 return $cust_svc[0] if scalar(@cust_svc) == 1; #always return a single service
2747 # primary service as specified in the package definition
2748 # or exactly one service definition with quantity one
2749 my $svcpart = $self->part_pkg->svcpart;
2750 @cust_svc = grep { $_->svcpart == $svcpart } @cust_svc;
2751 return $cust_svc[0] if scalar(@cust_svc) == 1;
2753 #couldn't identify one thing..
2759 Returns a list of lists, calling the label method for all services
2760 (see L<FS::cust_svc>) of this billing item.
2766 map { [ $_->label ] } $self->cust_svc;
2769 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
2771 Like the labels method, but returns historical information on services that
2772 were active as of END_TIMESTAMP and (optionally) not cancelled before
2773 START_TIMESTAMP. If MODE is 'I' (for 'invoice'), services with the
2774 I<pkg_svc.hidden> flag will be omitted.
2776 Returns a list of lists, calling the label method for all (historical) services
2777 (see L<FS::h_cust_svc>) of this billing item.
2783 warn "$me _h_labels called on $self\n"
2785 map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
2790 Like labels, except returns a simple flat list, and shortens long
2791 (currently >5 or the cust_bill-max_same_services configuration value) lists of
2792 identical services to one line that lists the service label and the number of
2793 individual services rather than individual items.
2798 shift->_labels_short( 'labels', @_ );
2801 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
2803 Like h_labels, except returns a simple flat list, and shortens long
2804 (currently >5 or the cust_bill-max_same_services configuration value) lists of
2805 identical services to one line that lists the service label and the number of
2806 individual services rather than individual items.
2810 sub h_labels_short {
2811 shift->_labels_short( 'h_labels', @_ );
2815 my( $self, $method ) = ( shift, shift );
2817 warn "$me _labels_short called on $self with $method method\n"
2820 my $conf = new FS::Conf;
2821 my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
2823 warn "$me _labels_short populating \%labels\n"
2827 #tie %labels, 'Tie::IxHash';
2828 push @{ $labels{$_->[0]} }, $_->[1]
2829 foreach $self->$method(@_);
2831 warn "$me _labels_short populating \@labels\n"
2835 foreach my $label ( keys %labels ) {
2837 my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
2838 my $num = scalar(@values);
2839 warn "$me _labels_short $num items for $label\n"
2842 if ( $num > $max_same_services ) {
2843 warn "$me _labels_short more than $max_same_services, so summarizing\n"
2845 push @labels, "$label ($num)";
2847 if ( $conf->exists('cust_bill-consolidate_services') ) {
2848 warn "$me _labels_short consolidating services\n"
2850 # push @labels, "$label: ". join(', ', @values);
2852 my $detail = "$label: ";
2853 $detail .= shift(@values). ', '
2855 && ( length($detail.$values[0]) < 78 || $detail eq "$label: " );
2857 push @labels, $detail;
2859 warn "$me _labels_short done consolidating services\n"
2862 warn "$me _labels_short adding service data\n"
2864 push @labels, map { "$label: $_" } @values;
2875 Returns the parent customer object (see L<FS::cust_main>).
2881 qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
2886 Returns the balance for this specific package, when using
2887 experimental package balance.
2893 $self->cust_main->balance_pkgnum( $self->pkgnum );
2896 #these subs are in location_Mixin.pm now... unfortunately the POD doesn't mixin
2900 Returns the location object, if any (see L<FS::cust_location>).
2902 =item cust_location_or_main
2904 If this package is associated with a location, returns the locaiton (see
2905 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
2907 =item location_label [ OPTION => VALUE ... ]
2909 Returns the label of the location object (see L<FS::cust_location>).
2913 #end of subs in location_Mixin.pm now... unfortunately the POD doesn't mixin
2915 =item tax_locationnum
2917 Returns the foreign key to a L<FS::cust_location> object for calculating
2918 tax on this package, as determined by the C<tax-pkg_address> and
2919 C<tax-ship_address> configuration flags.
2923 sub tax_locationnum {
2925 my $conf = FS::Conf->new;
2926 if ( $conf->exists('tax-pkg_address') ) {
2927 return $self->locationnum;
2929 elsif ( $conf->exists('tax-ship_address') ) {
2930 return $self->cust_main->ship_locationnum;
2933 return $self->cust_main->bill_locationnum;
2939 Returns the L<FS::cust_location> object for tax_locationnum.
2945 FS::cust_location->by_key( $self->tax_locationnum )
2948 =item seconds_since TIMESTAMP
2950 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
2951 package have been online since TIMESTAMP, according to the session monitor.
2953 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
2954 L<Time::Local> and L<Date::Parse> for conversion functions.
2959 my($self, $since) = @_;
2962 foreach my $cust_svc (
2963 grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
2965 $seconds += $cust_svc->seconds_since($since);
2972 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2974 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
2975 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
2978 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2979 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2985 sub seconds_since_sqlradacct {
2986 my($self, $start, $end) = @_;
2990 foreach my $cust_svc (
2992 my $part_svc = $_->part_svc;
2993 $part_svc->svcdb eq 'svc_acct'
2994 && scalar($part_svc->part_export_usage);
2997 $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
3004 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
3006 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
3007 in this package for sessions ending between TIMESTAMP_START (inclusive) and
3011 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
3012 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
3017 sub attribute_since_sqlradacct {
3018 my($self, $start, $end, $attrib) = @_;
3022 foreach my $cust_svc (
3024 my $part_svc = $_->part_svc;
3025 $part_svc->svcdb eq 'svc_acct'
3026 && scalar($part_svc->part_export_usage);
3029 $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
3041 my( $self, $value ) = @_;
3042 if ( defined($value) ) {
3043 $self->setfield('quantity', $value);
3045 $self->getfield('quantity') || 1;
3048 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
3050 Transfers as many services as possible from this package to another package.
3052 The destination package can be specified by pkgnum by passing an FS::cust_pkg
3053 object. The destination package must already exist.
3055 Services are moved only if the destination allows services with the correct
3056 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true. Use
3057 this option with caution! No provision is made for export differences
3058 between the old and new service definitions. Probably only should be used
3059 when your exports for all service definitions of a given svcdb are identical.
3060 (attempt a transfer without it first, to move all possible svcpart-matching
3063 Any services that can't be moved remain in the original package.
3065 Returns an error, if there is one; otherwise, returns the number of services
3066 that couldn't be moved.
3071 my ($self, $dest_pkgnum, %opt) = @_;
3077 if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
3078 $dest = $dest_pkgnum;
3079 $dest_pkgnum = $dest->pkgnum;
3081 $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
3084 return ('Package does not exist: '.$dest_pkgnum) unless $dest;
3086 foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
3087 $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
3090 foreach my $cust_svc ($dest->cust_svc) {
3091 $target{$cust_svc->svcpart}--;
3094 my %svcpart2svcparts = ();
3095 if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
3096 warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
3097 foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
3098 next if exists $svcpart2svcparts{$svcpart};
3099 my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
3100 $svcpart2svcparts{$svcpart} = [
3102 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
3104 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
3105 'svcpart' => $_ } );
3107 $pkg_svc ? $pkg_svc->primary_svc : '',
3108 $pkg_svc ? $pkg_svc->quantity : 0,
3112 grep { $_ != $svcpart }
3114 qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
3116 warn "alternates for svcpart $svcpart: ".
3117 join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
3122 foreach my $cust_svc ($self->cust_svc) {
3123 if($target{$cust_svc->svcpart} > 0
3124 or $FS::cust_svc::ignore_quantity) { # maybe should be a 'force' option
3125 $target{$cust_svc->svcpart}--;
3126 my $new = new FS::cust_svc { $cust_svc->hash };
3127 $new->pkgnum($dest_pkgnum);
3128 my $error = $new->replace($cust_svc);
3129 return $error if $error;
3130 } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
3132 warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
3133 warn "alternates to consider: ".
3134 join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
3136 my @alternate = grep {
3137 warn "considering alternate svcpart $_: ".
3138 "$target{$_} available in new package\n"
3141 } @{$svcpart2svcparts{$cust_svc->svcpart}};
3143 warn "alternate(s) found\n" if $DEBUG;
3144 my $change_svcpart = $alternate[0];
3145 $target{$change_svcpart}--;
3146 my $new = new FS::cust_svc { $cust_svc->hash };
3147 $new->svcpart($change_svcpart);
3148 $new->pkgnum($dest_pkgnum);
3149 my $error = $new->replace($cust_svc);
3150 return $error if $error;
3163 This method is deprecated. See the I<depend_jobnum> option to the insert and
3164 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
3171 local $SIG{HUP} = 'IGNORE';
3172 local $SIG{INT} = 'IGNORE';
3173 local $SIG{QUIT} = 'IGNORE';
3174 local $SIG{TERM} = 'IGNORE';
3175 local $SIG{TSTP} = 'IGNORE';
3176 local $SIG{PIPE} = 'IGNORE';
3178 my $oldAutoCommit = $FS::UID::AutoCommit;
3179 local $FS::UID::AutoCommit = 0;
3182 foreach my $cust_svc ( $self->cust_svc ) {
3183 #false laziness w/svc_Common::insert
3184 my $svc_x = $cust_svc->svc_x;
3185 foreach my $part_export ( $cust_svc->part_svc->part_export ) {
3186 my $error = $part_export->export_insert($svc_x);
3188 $dbh->rollback if $oldAutoCommit;
3194 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3201 Associates this package with a (suspension or cancellation) reason (see
3202 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
3205 Available options are:
3211 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.
3215 the access_user (see L<FS::access_user>) providing the reason
3223 the action (cancel, susp, adjourn, expire) associated with the reason
3227 If there is an error, returns the error, otherwise returns false.
3232 my ($self, %options) = @_;
3234 my $otaker = $options{reason_otaker} ||
3235 $FS::CurrentUser::CurrentUser->username;
3238 if ( $options{'reason'} =~ /^(\d+)$/ ) {
3242 } elsif ( ref($options{'reason'}) ) {
3244 return 'Enter a new reason (or select an existing one)'
3245 unless $options{'reason'}->{'reason'} !~ /^\s*$/;
3247 my $reason = new FS::reason({
3248 'reason_type' => $options{'reason'}->{'typenum'},
3249 'reason' => $options{'reason'}->{'reason'},
3251 my $error = $reason->insert;
3252 return $error if $error;
3254 $reasonnum = $reason->reasonnum;
3257 return "Unparsable reason: ". $options{'reason'};
3260 my $cust_pkg_reason =
3261 new FS::cust_pkg_reason({ 'pkgnum' => $self->pkgnum,
3262 'reasonnum' => $reasonnum,
3263 'otaker' => $otaker,
3264 'action' => substr(uc($options{'action'}),0,1),
3265 'date' => $options{'date'}
3270 $cust_pkg_reason->insert;
3273 =item insert_discount
3275 Associates this package with a discount (see L<FS::cust_pkg_discount>, possibly
3276 inserting a new discount on the fly (see L<FS::discount>).
3278 Available options are:
3286 If there is an error, returns the error, otherwise returns false.
3290 sub insert_discount {
3291 #my ($self, %options) = @_;
3294 my $cust_pkg_discount = new FS::cust_pkg_discount {
3295 'pkgnum' => $self->pkgnum,
3296 'discountnum' => $self->discountnum,
3298 'end_date' => '', #XXX
3299 #for the create a new discount case
3300 '_type' => $self->discountnum__type,
3301 'amount' => $self->discountnum_amount,
3302 'percent' => $self->discountnum_percent,
3303 'months' => $self->discountnum_months,
3304 'setup' => $self->discountnum_setup,
3305 #'disabled' => $self->discountnum_disabled,
3308 $cust_pkg_discount->insert;
3311 =item set_usage USAGE_VALUE_HASHREF
3313 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
3314 to which they should be set (see L<FS::svc_acct>). Currently seconds,
3315 upbytes, downbytes, and totalbytes are appropriate keys.
3317 All svc_accts which are part of this package have their values reset.
3322 my ($self, $valueref, %opt) = @_;
3324 #only svc_acct can set_usage for now
3325 foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
3326 my $svc_x = $cust_svc->svc_x;
3327 $svc_x->set_usage($valueref, %opt)
3328 if $svc_x->can("set_usage");
3332 =item recharge USAGE_VALUE_HASHREF
3334 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
3335 to which they should be set (see L<FS::svc_acct>). Currently seconds,
3336 upbytes, downbytes, and totalbytes are appropriate keys.
3338 All svc_accts which are part of this package have their values incremented.
3343 my ($self, $valueref) = @_;
3345 #only svc_acct can set_usage for now
3346 foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
3347 my $svc_x = $cust_svc->svc_x;
3348 $svc_x->recharge($valueref)
3349 if $svc_x->can("recharge");
3353 =item cust_pkg_discount
3357 sub cust_pkg_discount {
3359 qsearch('cust_pkg_discount', { 'pkgnum' => $self->pkgnum } );
3362 =item cust_pkg_discount_active
3366 sub cust_pkg_discount_active {
3368 grep { $_->status eq 'active' } $self->cust_pkg_discount;
3371 =item cust_pkg_usage
3373 Returns a list of all voice usage counters attached to this package.
3377 sub cust_pkg_usage {
3379 qsearch('cust_pkg_usage', { pkgnum => $self->pkgnum });
3382 =item apply_usage OPTIONS
3384 Takes the following options:
3385 - cdr: a call detail record (L<FS::cdr>)
3386 - rate_detail: the rate determined for this call (L<FS::rate_detail>)
3387 - minutes: the maximum number of minutes to be charged
3389 Finds available usage minutes for a call of this class, and subtracts
3390 up to that many minutes from the usage pool. If the usage pool is empty,
3391 and the C<cdr-minutes_priority> global config option is set, minutes may
3392 be taken from other calls as well. Either way, an allocation record will
3393 be created (L<FS::cdr_cust_pkg_usage>) and this method will return the
3394 number of minutes of usage applied to the call.
3399 my ($self, %opt) = @_;
3400 my $cdr = $opt{cdr};
3401 my $rate_detail = $opt{rate_detail};
3402 my $minutes = $opt{minutes};
3403 my $classnum = $rate_detail->classnum;
3404 my $pkgnum = $self->pkgnum;
3405 my $custnum = $self->custnum;
3407 local $SIG{HUP} = 'IGNORE';
3408 local $SIG{INT} = 'IGNORE';
3409 local $SIG{QUIT} = 'IGNORE';
3410 local $SIG{TERM} = 'IGNORE';
3411 local $SIG{TSTP} = 'IGNORE';
3412 local $SIG{PIPE} = 'IGNORE';
3414 my $oldAutoCommit = $FS::UID::AutoCommit;
3415 local $FS::UID::AutoCommit = 0;
3417 my $order = FS::Conf->new->config('cdr-minutes_priority');
3421 $is_classnum = ' part_pkg_usage_class.classnum = '.$classnum;
3423 $is_classnum = ' part_pkg_usage_class.classnum IS NULL';
3425 my @usage_recs = qsearch({
3426 'table' => 'cust_pkg_usage',
3427 'addl_from' => ' JOIN part_pkg_usage USING (pkgusagepart)'.
3428 ' JOIN cust_pkg USING (pkgnum)'.
3429 ' JOIN part_pkg_usage_class USING (pkgusagepart)',
3430 'select' => 'cust_pkg_usage.*',
3431 'extra_sql' => " WHERE ( cust_pkg.pkgnum = $pkgnum OR ".
3432 " ( cust_pkg.custnum = $custnum AND ".
3433 " part_pkg_usage.shared IS NOT NULL ) ) AND ".
3434 $is_classnum . ' AND '.
3435 " cust_pkg_usage.minutes > 0",
3436 'order_by' => " ORDER BY priority ASC",
3439 my $orig_minutes = $minutes;
3441 while (!$error and $minutes > 0 and @usage_recs) {
3442 my $cust_pkg_usage = shift @usage_recs;
3443 $cust_pkg_usage->select_for_update;
3444 my $cdr_cust_pkg_usage = FS::cdr_cust_pkg_usage->new({
3445 pkgusagenum => $cust_pkg_usage->pkgusagenum,
3446 acctid => $cdr->acctid,
3447 minutes => min($cust_pkg_usage->minutes, $minutes),
3449 $cust_pkg_usage->set('minutes',
3450 sprintf('%.0f', $cust_pkg_usage->minutes - $cdr_cust_pkg_usage->minutes)
3452 $error = $cust_pkg_usage->replace || $cdr_cust_pkg_usage->insert;
3453 $minutes -= $cdr_cust_pkg_usage->minutes;
3455 if ( $order and $minutes > 0 and !$error ) {
3456 # then try to steal minutes from another call
3458 'table' => 'cdr_cust_pkg_usage',
3459 'addl_from' => ' JOIN cust_pkg_usage USING (pkgusagenum)'.
3460 ' JOIN part_pkg_usage USING (pkgusagepart)'.
3461 ' JOIN cust_pkg USING (pkgnum)'.
3462 ' JOIN part_pkg_usage_class USING (pkgusagepart)'.
3463 ' JOIN cdr USING (acctid)',
3464 'select' => 'cdr_cust_pkg_usage.*',
3465 'extra_sql' => " WHERE cdr.freesidestatus = 'rated' AND ".
3466 " ( cust_pkg.pkgnum = $pkgnum OR ".
3467 " ( cust_pkg.custnum = $custnum AND ".
3468 " part_pkg_usage.shared IS NOT NULL ) ) AND ".
3469 " part_pkg_usage_class.classnum = $classnum",
3470 'order_by' => ' ORDER BY part_pkg_usage.priority ASC',
3472 if ( $order eq 'time' ) {
3473 # find CDRs that are using minutes, but have a later startdate
3475 my $startdate = $cdr->startdate;
3476 if ($startdate !~ /^\d+$/) {
3477 die "bad cdr startdate '$startdate'";
3479 $search{'extra_sql'} .= " AND cdr.startdate > $startdate";
3480 # minimize needless reshuffling
3481 $search{'order_by'} .= ', cdr.startdate DESC';
3483 # XXX may not work correctly with rate_time schedules. Could
3484 # fix this by storing ratedetailnum in cdr_cust_pkg_usage, I
3486 $search{'addl_from'} .=
3487 ' JOIN rate_detail'.
3488 ' ON (cdr.rated_ratedetailnum = rate_detail.ratedetailnum)';
3489 if ( $order eq 'rate_high' ) {
3490 $search{'extra_sql'} .= ' AND rate_detail.min_charge < '.
3491 $rate_detail->min_charge;
3492 $search{'order_by'} .= ', rate_detail.min_charge ASC';
3493 } elsif ( $order eq 'rate_low' ) {
3494 $search{'extra_sql'} .= ' AND rate_detail.min_charge > '.
3495 $rate_detail->min_charge;
3496 $search{'order_by'} .= ', rate_detail.min_charge DESC';
3498 # this should really never happen
3499 die "invalid cdr-minutes_priority value '$order'\n";
3502 my @cdr_usage_recs = qsearch(\%search);
3504 while (!$error and @cdr_usage_recs and $minutes > 0) {
3505 my $cdr_cust_pkg_usage = shift @cdr_usage_recs;
3506 my $cust_pkg_usage = $cdr_cust_pkg_usage->cust_pkg_usage;
3507 my $old_cdr = $cdr_cust_pkg_usage->cdr;
3508 $reproc_cdrs{$old_cdr->acctid} = $old_cdr;
3509 $cdr_cust_pkg_usage->select_for_update;
3510 $old_cdr->select_for_update;
3511 $cust_pkg_usage->select_for_update;
3512 # in case someone else stole the usage from this CDR
3513 # while waiting for the lock...
3514 next if $old_cdr->acctid != $cdr_cust_pkg_usage->acctid;
3515 # steal the usage allocation and flag the old CDR for reprocessing
3516 $cdr_cust_pkg_usage->set('acctid', $cdr->acctid);
3517 # if the allocation is more minutes than we need, adjust it...
3518 my $delta = $cdr_cust_pkg_usage->minutes - $minutes;
3520 $cdr_cust_pkg_usage->set('minutes', $minutes);
3521 $cust_pkg_usage->set('minutes', $cust_pkg_usage->minutes + $delta);
3522 $error = $cust_pkg_usage->replace;
3524 #warn 'CDR '.$cdr->acctid . ' stealing allocation '.$cdr_cust_pkg_usage->cdrusagenum.' from CDR '.$old_cdr->acctid."\n";
3525 $error ||= $cdr_cust_pkg_usage->replace;
3526 # deduct the stolen minutes
3527 $minutes -= $cdr_cust_pkg_usage->minutes;
3529 # after all minute-stealing is done, reset the affected CDRs
3530 foreach (values %reproc_cdrs) {
3531 $error ||= $_->set_status('');
3532 # XXX or should we just call $cdr->rate right here?
3533 # it's not like we can create a loop this way, since the min_charge
3534 # or call time has to go monotonically in one direction.
3535 # we COULD get some very deep recursions going, though...
3537 } # if $order and $minutes
3540 die "error applying included minutes\npkgnum ".$self->pkgnum.", class $classnum, acctid ".$cdr->acctid."\n$error\n"
3542 $dbh->commit if $oldAutoCommit;
3543 return $orig_minutes - $minutes;
3547 =item supplemental_pkgs
3549 Returns a list of all packages supplemental to this one.
3553 sub supplemental_pkgs {
3555 qsearch('cust_pkg', { 'main_pkgnum' => $self->pkgnum });
3560 Returns the package that this one is supplemental to, if any.
3566 if ( $self->main_pkgnum ) {
3567 return FS::cust_pkg->by_key($self->main_pkgnum);
3574 =head1 CLASS METHODS
3580 Returns an SQL expression identifying recurring packages.
3584 sub recurring_sql { "
3585 '0' != ( select freq from part_pkg
3586 where cust_pkg.pkgpart = part_pkg.pkgpart )
3591 Returns an SQL expression identifying one-time packages.
3596 '0' = ( select freq from part_pkg
3597 where cust_pkg.pkgpart = part_pkg.pkgpart )
3602 Returns an SQL expression identifying ordered packages (recurring packages not
3608 $_[0]->recurring_sql. " AND ". $_[0]->not_yet_billed_sql;
3613 Returns an SQL expression identifying active packages.
3618 $_[0]->recurring_sql. "
3619 AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
3620 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
3621 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
3624 =item not_yet_billed_sql
3626 Returns an SQL expression identifying packages which have not yet been billed.
3630 sub not_yet_billed_sql { "
3631 ( cust_pkg.setup IS NULL OR cust_pkg.setup = 0 )
3632 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
3633 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
3638 Returns an SQL expression identifying inactive packages (one-time packages
3639 that are otherwise unsuspended/uncancelled).
3643 sub inactive_sql { "
3644 ". $_[0]->onetime_sql(). "
3645 AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
3646 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
3647 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
3653 Returns an SQL expression identifying suspended packages.
3657 sub suspended_sql { susp_sql(@_); }
3659 #$_[0]->recurring_sql(). ' AND '.
3661 ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
3662 AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0
3669 Returns an SQL exprression identifying cancelled packages.
3673 sub cancelled_sql { cancel_sql(@_); }
3675 #$_[0]->recurring_sql(). ' AND '.
3676 "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
3681 Returns an SQL expression to give the package status as a string.
3687 WHEN cust_pkg.cancel IS NOT NULL THEN 'cancelled'
3688 WHEN cust_pkg.susp IS NOT NULL THEN 'suspended'
3689 WHEN cust_pkg.setup IS NULL THEN 'not yet billed'
3690 WHEN ".onetime_sql()." THEN 'one-time charge'
3695 =item search HASHREF
3699 Returns a qsearch hash expression to search for parameters specified in HASHREF.
3700 Valid parameters are
3708 active, inactive, suspended, cancel (or cancelled)
3712 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
3716 boolean selects custom packages
3722 pkgpart or arrayref or hashref of pkgparts
3726 arrayref of beginning and ending epoch date
3730 arrayref of beginning and ending epoch date
3734 arrayref of beginning and ending epoch date
3738 arrayref of beginning and ending epoch date
3742 arrayref of beginning and ending epoch date
3746 arrayref of beginning and ending epoch date
3750 arrayref of beginning and ending epoch date
3754 pkgnum or APKG_pkgnum
3758 a value suited to passing to FS::UI::Web::cust_header
3762 specifies the user for agent virtualization
3766 boolean; if true, returns only packages with more than 0 FCC phone lines.
3768 =item state, country
3770 Limit to packages with a service location in the specified state and country.
3771 For FCC 477 reporting, mostly.
3778 my ($class, $params) = @_;
3785 if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
3787 "cust_main.agentnum = $1";
3794 if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
3796 "cust_pkg.custnum = $1";
3803 if ( $params->{'pkgbatch'} =~ /^([\w\/\-\:\.]+)$/ and $1 ) {
3805 "cust_pkg.pkgbatch = '$1'";
3812 if ( $params->{'magic'} eq 'active'
3813 || $params->{'status'} eq 'active' ) {
3815 push @where, FS::cust_pkg->active_sql();
3817 } elsif ( $params->{'magic'} =~ /^not[ _]yet[ _]billed$/
3818 || $params->{'status'} =~ /^not[ _]yet[ _]billed$/ ) {
3820 push @where, FS::cust_pkg->not_yet_billed_sql();
3822 } elsif ( $params->{'magic'} =~ /^(one-time charge|inactive)/
3823 || $params->{'status'} =~ /^(one-time charge|inactive)/ ) {
3825 push @where, FS::cust_pkg->inactive_sql();
3827 } elsif ( $params->{'magic'} eq 'suspended'
3828 || $params->{'status'} eq 'suspended' ) {
3830 push @where, FS::cust_pkg->suspended_sql();
3832 } elsif ( $params->{'magic'} =~ /^cancell?ed$/
3833 || $params->{'status'} =~ /^cancell?ed$/ ) {
3835 push @where, FS::cust_pkg->cancelled_sql();
3840 # parse package class
3843 if ( exists($params->{'classnum'}) ) {
3846 if ( ref($params->{'classnum'}) ) {
3848 if ( ref($params->{'classnum'}) eq 'HASH' ) {
3849 @classnum = grep $params->{'classnum'}{$_}, keys %{ $params->{'classnum'} };
3850 } elsif ( ref($params->{'classnum'}) eq 'ARRAY' ) {
3851 @classnum = @{ $params->{'classnum'} };
3853 die 'unhandled classnum ref '. $params->{'classnum'};
3857 } elsif ( $params->{'classnum'} =~ /^(\d*)$/ && $1 ne '0' ) {
3864 my @nums = grep $_, @classnum;
3865 push @c_where, 'part_pkg.classnum IN ('. join(',',@nums). ')' if @nums;
3866 my $null = scalar( grep { $_ eq '' } @classnum );
3867 push @c_where, 'part_pkg.classnum IS NULL' if $null;
3869 if ( scalar(@c_where) == 1 ) {
3870 push @where, @c_where;
3871 } elsif ( @c_where ) {
3872 push @where, ' ( '. join(' OR ', @c_where). ' ) ';
3881 # parse package report options
3884 my @report_option = ();
3885 if ( exists($params->{'report_option'}) ) {
3886 if ( ref($params->{'report_option'}) eq 'ARRAY' ) {
3887 @report_option = @{ $params->{'report_option'} };
3888 } elsif ( $params->{'report_option'} =~ /^([,\d]*)$/ ) {
3889 @report_option = split(',', $1);
3894 if (@report_option) {
3895 # this will result in the empty set for the dangling comma case as it should
3897 map{ "0 < ( SELECT count(*) FROM part_pkg_option
3898 WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
3899 AND optionname = 'report_option_$_'
3900 AND optionvalue = '1' )"
3904 foreach my $any ( grep /^report_option_any/, keys %$params ) {
3906 my @report_option_any = ();
3907 if ( ref($params->{$any}) eq 'ARRAY' ) {
3908 @report_option_any = @{ $params->{$any} };
3909 } elsif ( $params->{$any} =~ /^([,\d]*)$/ ) {
3910 @report_option_any = split(',', $1);
3913 if (@report_option_any) {
3914 # this will result in the empty set for the dangling comma case as it should
3915 push @where, ' ( '. join(' OR ',
3916 map{ "0 < ( SELECT count(*) FROM part_pkg_option
3917 WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
3918 AND optionname = 'report_option_$_'
3919 AND optionvalue = '1' )"
3920 } @report_option_any
3930 push @where, "part_pkg.custom = 'Y'" if $params->{custom};
3936 push @where, "(part_pkg.fcc_ds0s > 0 OR pkg_class.fcc_ds0s > 0)"
3937 if $params->{fcc_line};
3943 if ( exists($params->{'censustract'}) ) {
3944 $params->{'censustract'} =~ /^([.\d]*)$/;
3945 my $censustract = "cust_location.censustract = '$1'";
3946 $censustract .= ' OR cust_location.censustract is NULL' unless $1;
3947 push @where, "( $censustract )";
3951 # parse censustract2
3953 if ( exists($params->{'censustract2'})
3954 && $params->{'censustract2'} =~ /^(\d*)$/
3958 push @where, "cust_location.censustract LIKE '$1%'";
3961 "( cust_location.censustract = '' OR cust_location.censustract IS NULL )";
3966 # parse country/state
3968 for (qw(state country)) { # parsing rules are the same for these
3969 if ( exists($params->{$_})
3970 && uc($params->{$_}) =~ /^([A-Z]{2})$/ )
3972 # XXX post-2.3 only--before that, state/country may be in cust_main
3973 push @where, "cust_location.$_ = '$1'";
3981 if ( ref($params->{'pkgpart'}) ) {
3984 if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
3985 @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
3986 } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
3987 @pkgpart = @{ $params->{'pkgpart'} };
3989 die 'unhandled pkgpart ref '. $params->{'pkgpart'};
3992 @pkgpart = grep /^(\d+)$/, @pkgpart;
3994 push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
3996 } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
3997 push @where, "pkgpart = $1";
4006 #false laziness w/report_cust_pkg.html
4009 'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
4010 'active' => { 'susp'=>1, 'cancel'=>1 },
4011 'suspended' => { 'cancel' => 1 },
4016 if( exists($params->{'active'} ) ) {
4017 # This overrides all the other date-related fields
4018 my($beginning, $ending) = @{$params->{'active'}};
4020 "cust_pkg.setup IS NOT NULL",
4021 "cust_pkg.setup <= $ending",
4022 "(cust_pkg.cancel IS NULL OR cust_pkg.cancel >= $beginning )",
4023 "NOT (".FS::cust_pkg->onetime_sql . ")";
4026 foreach my $field (qw( setup last_bill bill adjourn susp expire contract_end change_date cancel )) {
4028 next unless exists($params->{$field});
4030 my($beginning, $ending) = @{$params->{$field}};
4032 next if $beginning == 0 && $ending == 4294967295;
4035 "cust_pkg.$field IS NOT NULL",
4036 "cust_pkg.$field >= $beginning",
4037 "cust_pkg.$field <= $ending";
4039 $orderby ||= "ORDER BY cust_pkg.$field";
4044 $orderby ||= 'ORDER BY bill';
4047 # parse magic, legacy, etc.
4050 if ( $params->{'magic'} &&
4051 $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
4054 $orderby = 'ORDER BY pkgnum';
4056 if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
4057 push @where, "pkgpart = $1";
4060 } elsif ( $params->{'query'} eq 'pkgnum' ) {
4062 $orderby = 'ORDER BY pkgnum';
4064 } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
4066 $orderby = 'ORDER BY pkgnum';
4069 SELECT count(*) FROM pkg_svc
4070 WHERE pkg_svc.pkgpart = cust_pkg.pkgpart
4071 AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
4072 WHERE cust_svc.pkgnum = cust_pkg.pkgnum
4073 AND cust_svc.svcpart = pkg_svc.svcpart
4080 # setup queries, links, subs, etc. for the search
4083 # here is the agent virtualization
4084 if ($params->{CurrentUser}) {
4086 qsearchs('access_user', { username => $params->{CurrentUser} });
4089 push @where, $access_user->agentnums_sql('table'=>'cust_main');
4094 push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
4097 my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
4099 my $addl_from = 'LEFT JOIN part_pkg USING ( pkgpart ) '.
4100 'LEFT JOIN pkg_class ON ( part_pkg.classnum = pkg_class.classnum ) '.
4101 'LEFT JOIN cust_location USING ( locationnum ) '.
4102 FS::UI::Web::join_cust_main('cust_pkg', 'cust_pkg');
4106 if ( $params->{'select_zip5'} ) {
4107 my $zip = 'cust_location.zip';
4109 $select = "DISTINCT substr($zip,1,5) as zip";
4110 $orderby = "ORDER BY substr($zip,1,5)";
4111 $count_query = "SELECT COUNT( DISTINCT substr($zip,1,5) )";
4113 $select = join(', ',
4115 ( map "part_pkg.$_", qw( pkg freq ) ),
4116 'pkg_class.classname',
4117 'cust_main.custnum AS cust_main_custnum',
4118 FS::UI::Web::cust_sql_fields(
4119 $params->{'cust_fields'}
4122 $count_query = 'SELECT COUNT(*)';
4125 $count_query .= " FROM cust_pkg $addl_from $extra_sql";
4128 'table' => 'cust_pkg',
4130 'select' => $select,
4131 'extra_sql' => $extra_sql,
4132 'order_by' => $orderby,
4133 'addl_from' => $addl_from,
4134 'count_query' => $count_query,
4141 Returns a list of two package counts. The first is a count of packages
4142 based on the supplied criteria and the second is the count of residential
4143 packages with those same criteria. Criteria are specified as in the search
4149 my ($class, $params) = @_;
4151 my $sql_query = $class->search( $params );
4153 my $count_sql = delete($sql_query->{'count_query'});
4154 $count_sql =~ s/ FROM/,count(CASE WHEN cust_main.company IS NULL OR cust_main.company = '' THEN 1 END) FROM/
4155 or die "couldn't parse count_sql";
4157 my $count_sth = dbh->prepare($count_sql)
4158 or die "Error preparing $count_sql: ". dbh->errstr;
4160 or die "Error executing $count_sql: ". $count_sth->errstr;
4161 my $count_arrayref = $count_sth->fetchrow_arrayref;
4163 return ( @$count_arrayref );
4167 =item tax_locationnum_sql
4169 Returns an SQL expression for the tax location for a package, based
4170 on the settings of 'tax-pkg_address' and 'tax-ship_address'.
4174 sub tax_locationnum_sql {
4175 my $conf = FS::Conf->new;
4176 if ( $conf->exists('tax-pkg_address') ) {
4177 'cust_pkg.locationnum';
4179 elsif ( $conf->exists('tax-ship_address') ) {
4180 'cust_main.ship_locationnum';
4183 'cust_main.bill_locationnum';
4189 Returns a list: the first item is an SQL fragment identifying matching
4190 packages/customers via location (taking into account shipping and package
4191 address taxation, if enabled), and subsequent items are the parameters to
4192 substitute for the placeholders in that fragment.
4197 my($class, %opt) = @_;
4198 my $ornull = $opt{'ornull'};
4200 my $conf = new FS::Conf;
4202 # '?' placeholders in _location_sql_where
4203 my $x = $ornull ? 3 : 2;
4214 if ( $conf->exists('tax-ship_address') ) {
4217 ( ( ship_last IS NULL OR ship_last = '' )
4218 AND ". _location_sql_where('cust_main', '', $ornull ). "
4220 OR ( ship_last IS NOT NULL AND ship_last != ''
4221 AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
4224 # AND payby != 'COMP'
4226 @main_param = ( @bill_param, @bill_param );
4230 $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
4231 @main_param = @bill_param;
4237 if ( $conf->exists('tax-pkg_address') ) {
4239 my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
4242 ( cust_pkg.locationnum IS NULL AND $main_where )
4243 OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where )
4246 @param = ( @main_param, @bill_param );
4250 $where = $main_where;
4251 @param = @main_param;
4259 #subroutine, helper for location_sql
4260 sub _location_sql_where {
4262 my $prefix = @_ ? shift : '';
4263 my $ornull = @_ ? shift : '';
4265 # $ornull = $ornull ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
4267 $ornull = $ornull ? ' OR ? IS NULL ' : '';
4269 my $or_empty_city = " OR ( ? = '' AND $table.${prefix}city IS NULL )";
4270 my $or_empty_county = " OR ( ? = '' AND $table.${prefix}county IS NULL )";
4271 my $or_empty_state = " OR ( ? = '' AND $table.${prefix}state IS NULL )";
4273 my $text = (driver_name =~ /^mysql/i) ? 'char' : 'text';
4275 # ( $table.${prefix}city = ? $or_empty_city $ornull )
4277 ( $table.district = ? OR ? = '' OR CAST(? AS $text) IS NULL )
4278 AND ( $table.${prefix}city = ? OR ? = '' OR CAST(? AS $text) IS NULL )
4279 AND ( $table.${prefix}county = ? $or_empty_county $ornull )
4280 AND ( $table.${prefix}state = ? $or_empty_state $ornull )
4281 AND $table.${prefix}country = ?
4286 my( $self, $what ) = @_;
4288 my $what_show_zero = $what. '_show_zero';
4289 length($self->$what_show_zero())
4290 ? ($self->$what_show_zero() eq 'Y')
4291 : $self->part_pkg->$what_show_zero();
4298 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
4300 CUSTNUM is a customer (see L<FS::cust_main>)
4302 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
4303 L<FS::part_pkg>) to order for this customer. Duplicates are of course
4306 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
4307 remove for this customer. The services (see L<FS::cust_svc>) are moved to the
4308 new billing items. An error is returned if this is not possible (see
4309 L<FS::pkg_svc>). An empty arrayref is equivalent to not specifying this
4312 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
4313 newly-created cust_pkg objects.
4315 REFNUM, if specified, will specify the FS::pkg_referral record to be created
4316 and inserted. Multiple FS::pkg_referral records can be created by
4317 setting I<refnum> to an array reference of refnums or a hash reference with
4318 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
4319 record will be created corresponding to cust_main.refnum.
4324 my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
4326 my $conf = new FS::Conf;
4328 # Transactionize this whole mess
4329 local $SIG{HUP} = 'IGNORE';
4330 local $SIG{INT} = 'IGNORE';
4331 local $SIG{QUIT} = 'IGNORE';
4332 local $SIG{TERM} = 'IGNORE';
4333 local $SIG{TSTP} = 'IGNORE';
4334 local $SIG{PIPE} = 'IGNORE';
4336 my $oldAutoCommit = $FS::UID::AutoCommit;
4337 local $FS::UID::AutoCommit = 0;
4341 # my $cust_main = qsearchs('cust_main', { custnum => $custnum });
4342 # return "Customer not found: $custnum" unless $cust_main;
4344 warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
4347 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
4350 my $change = scalar(@old_cust_pkg) != 0;
4353 if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
4355 warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
4356 " to pkgpart ". $pkgparts->[0]. "\n"
4359 my $err_or_cust_pkg =
4360 $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
4361 'refnum' => $refnum,
4364 unless (ref($err_or_cust_pkg)) {
4365 $dbh->rollback if $oldAutoCommit;
4366 return $err_or_cust_pkg;
4369 push @$return_cust_pkg, $err_or_cust_pkg;
4370 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4375 # Create the new packages.
4376 foreach my $pkgpart (@$pkgparts) {
4378 warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
4380 my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
4381 pkgpart => $pkgpart,
4385 $error = $cust_pkg->insert( 'change' => $change );
4386 push @$return_cust_pkg, $cust_pkg;
4388 foreach my $link ($cust_pkg->part_pkg->supp_part_pkg_link) {
4389 my $supp_pkg = FS::cust_pkg->new({
4390 custnum => $custnum,
4391 pkgpart => $link->dst_pkgpart,
4393 main_pkgnum => $cust_pkg->pkgnum,
4396 $error ||= $supp_pkg->insert( 'change' => $change );
4397 push @$return_cust_pkg, $supp_pkg;
4401 $dbh->rollback if $oldAutoCommit;
4406 # $return_cust_pkg now contains refs to all of the newly
4409 # Transfer services and cancel old packages.
4410 foreach my $old_pkg (@old_cust_pkg) {
4412 warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
4415 foreach my $new_pkg (@$return_cust_pkg) {
4416 $error = $old_pkg->transfer($new_pkg);
4417 if ($error and $error == 0) {
4418 # $old_pkg->transfer failed.
4419 $dbh->rollback if $oldAutoCommit;
4424 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
4425 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
4426 foreach my $new_pkg (@$return_cust_pkg) {
4427 $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
4428 if ($error and $error == 0) {
4429 # $old_pkg->transfer failed.
4430 $dbh->rollback if $oldAutoCommit;
4437 # Transfers were successful, but we went through all of the
4438 # new packages and still had services left on the old package.
4439 # We can't cancel the package under the circumstances, so abort.
4440 $dbh->rollback if $oldAutoCommit;
4441 return "Unable to transfer all services from package ".$old_pkg->pkgnum;
4443 $error = $old_pkg->cancel( quiet=>1 );
4449 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4453 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
4455 A bulk change method to change packages for multiple customers.
4457 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
4458 L<FS::part_pkg>) to order for each customer. Duplicates are of course
4461 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
4462 replace. The services (see L<FS::cust_svc>) are moved to the
4463 new billing items. An error is returned if this is not possible (see
4466 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
4467 newly-created cust_pkg objects.
4472 my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
4474 # Transactionize this whole mess
4475 local $SIG{HUP} = 'IGNORE';
4476 local $SIG{INT} = 'IGNORE';
4477 local $SIG{QUIT} = 'IGNORE';
4478 local $SIG{TERM} = 'IGNORE';
4479 local $SIG{TSTP} = 'IGNORE';
4480 local $SIG{PIPE} = 'IGNORE';
4482 my $oldAutoCommit = $FS::UID::AutoCommit;
4483 local $FS::UID::AutoCommit = 0;
4487 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
4490 while(scalar(@old_cust_pkg)) {
4492 my $custnum = $old_cust_pkg[0]->custnum;
4493 my (@remove) = map { $_->pkgnum }
4494 grep { $_->custnum == $custnum } @old_cust_pkg;
4495 @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
4497 my $error = order $custnum, $pkgparts, \@remove, \@return;
4499 push @errors, $error
4501 push @$return_cust_pkg, @return;
4504 if (scalar(@errors)) {
4505 $dbh->rollback if $oldAutoCommit;
4506 return join(' / ', @errors);
4509 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4513 # Used by FS::Upgrade to migrate to a new database.
4514 sub _upgrade_data { # class method
4515 my ($class, %opts) = @_;
4516 $class->_upgrade_otaker(%opts);
4518 # RT#10139, bug resulting in contract_end being set when it shouldn't
4519 'UPDATE cust_pkg SET contract_end = NULL WHERE contract_end = -1',
4520 # RT#10830, bad calculation of prorate date near end of year
4521 # the date range for bill is December 2009, and we move it forward
4522 # one year if it's before the previous bill date (which it should
4524 'UPDATE cust_pkg SET bill = bill + (365*24*60*60) WHERE bill < last_bill
4525 AND bill > 1259654400 AND bill < 1262332800 AND (SELECT plan FROM part_pkg
4526 WHERE part_pkg.pkgpart = cust_pkg.pkgpart) = \'prorate\'',
4527 # RT6628, add order_date to cust_pkg
4528 'update cust_pkg set order_date = (select history_date from h_cust_pkg
4529 where h_cust_pkg.pkgnum = cust_pkg.pkgnum and
4530 history_action = \'insert\') where order_date is null',
4532 foreach my $sql (@statements) {
4533 my $sth = dbh->prepare($sql);
4534 $sth->execute or die $sth->errstr;
4542 sub order is not OO. Perhaps it should be moved to FS::cust_main and made so?
4544 In sub order, the @pkgparts array (passed by reference) is clobbered.
4546 Also in sub order, no money is adjusted. Once FS::part_pkg defines a standard
4547 method to pass dates to the recur_prog expression, it should do so.
4549 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
4550 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
4551 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
4552 configuration values. Probably need a subroutine which decides what to do
4553 based on whether or not we've fetched the user yet, rather than a hash. See
4554 FS::UID and the TODO.
4556 Now that things are transactional should the check in the insert method be
4561 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
4562 L<FS::pkg_svc>, schema.html from the base documentation