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 # if we've failed to insert the svc_x object, svc_Common->insert
1041 # will have removed the cust_svc already. if not, then both records
1042 # were inserted but we failed for some other reason (export, most
1043 # likely). in that case, report the error and delete the records.
1044 push @svc_errors, $svc_error;
1045 my $cust_svc = qsearchs('cust_svc', { 'svcnum' => $svc_x->svcnum });
1047 # except if export_insert failed, export_delete probably won't be
1049 local $FS::svc_Common::noexport_hack = 1;
1050 my $cleanup_error = $svc_x->delete; # also deletes cust_svc
1051 if ( $cleanup_error ) { # and if THAT fails, then run away
1052 $dbh->rollback if $oldAutoCommit;
1053 return $cleanup_error;
1058 } #foreach $h_cust_svc
1060 #these are pretty rare, but should handle them
1061 # - dsl_device (mac addresses)
1062 # - phone_device (mac addresses)
1063 # - dsl_note (ikano notes)
1064 # - domain_record (i.e. restore DNS information w/domains)
1065 # - inventory_item(?) (inventory w/un-cancelling service?)
1066 # - nas (svc_broaband nas stuff)
1067 #this stuff is unused in the wild afaik
1068 # - mailinglistmember
1070 # - svc_domain.parent_svcnum?
1071 # - acct_snarf (ancient mail fetching config)
1072 # - cgp_rule (communigate)
1073 # - cust_svc_option (used by our Tron stuff)
1074 # - acct_rt_transaction (used by our time worked stuff)
1077 # also move over any services that didn't unprovision at cancellation
1080 foreach my $cust_svc ( qsearch('cust_svc', { pkgnum => $self->pkgnum } ) ) {
1081 $cust_svc->pkgnum( $cust_pkg->pkgnum );
1082 my $error = $cust_svc->replace;
1084 $dbh->rollback if $oldAutoCommit;
1090 # Uncancel any supplemental packages, and make them supplemental to the
1094 foreach my $supp_pkg ( $self->supplemental_pkgs ) {
1096 $error = $supp_pkg->uncancel(%options, 'main_pkgnum' => $cust_pkg->pkgnum);
1098 $dbh->rollback if $oldAutoCommit;
1099 return "canceling supplemental pkg#".$supp_pkg->pkgnum.": $error";
1107 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1109 ${ $options{cust_pkg} } = $cust_pkg if ref($options{cust_pkg});
1110 @{ $options{svc_errors} } = @svc_errors if ref($options{svc_errors});
1117 Cancels any pending expiration (sets the expire field to null).
1119 If there is an error, returns the error, otherwise returns false.
1124 my( $self, %options ) = @_;
1127 local $SIG{HUP} = 'IGNORE';
1128 local $SIG{INT} = 'IGNORE';
1129 local $SIG{QUIT} = 'IGNORE';
1130 local $SIG{TERM} = 'IGNORE';
1131 local $SIG{TSTP} = 'IGNORE';
1132 local $SIG{PIPE} = 'IGNORE';
1134 my $oldAutoCommit = $FS::UID::AutoCommit;
1135 local $FS::UID::AutoCommit = 0;
1138 my $old = $self->select_for_update;
1140 my $pkgnum = $old->pkgnum;
1141 if ( $old->get('cancel') || $self->get('cancel') ) {
1142 dbh->rollback if $oldAutoCommit;
1143 return "Can't unexpire cancelled package $pkgnum";
1144 # or at least it's pointless
1147 unless ( $old->get('expire') && $self->get('expire') ) {
1148 dbh->rollback if $oldAutoCommit;
1149 return ""; # no error
1152 my %hash = $self->hash;
1153 $hash{'expire'} = '';
1154 my $new = new FS::cust_pkg ( \%hash );
1155 $error = $new->replace( $self, options => { $self->options } );
1157 $dbh->rollback if $oldAutoCommit;
1161 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1167 =item suspend [ OPTION => VALUE ... ]
1169 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
1170 package, then suspends the package itself (sets the susp field to now).
1172 Available options are:
1176 =item reason - can be set to a cancellation reason (see L<FS:reason>),
1177 either a reasonnum of an existing reason, or passing a hashref will create
1178 a new reason. The hashref should have the following keys:
1179 - typenum - Reason type (see L<FS::reason_type>
1180 - reason - Text of the new reason.
1182 =item date - can be set to a unix style timestamp to specify when to
1185 =item time - can be set to override the current time, for calculation
1186 of final invoices or unused-time credits
1188 =item resume_date - can be set to a time when the package should be
1189 unsuspended. This may be more convenient than calling C<unsuspend()>
1192 =item from_main - allows a supplemental package to be suspended, rather
1193 than redirecting the method call to its main package. For internal use.
1197 If there is an error, returns the error, otherwise returns false.
1202 my( $self, %options ) = @_;
1205 # pass all suspend/cancel actions to the main package
1206 if ( $self->main_pkgnum and !$options{'from_main'} ) {
1207 return $self->main_pkg->suspend(%options);
1210 local $SIG{HUP} = 'IGNORE';
1211 local $SIG{INT} = 'IGNORE';
1212 local $SIG{QUIT} = 'IGNORE';
1213 local $SIG{TERM} = 'IGNORE';
1214 local $SIG{TSTP} = 'IGNORE';
1215 local $SIG{PIPE} = 'IGNORE';
1217 my $oldAutoCommit = $FS::UID::AutoCommit;
1218 local $FS::UID::AutoCommit = 0;
1221 my $old = $self->select_for_update;
1223 my $pkgnum = $old->pkgnum;
1224 if ( $old->get('cancel') || $self->get('cancel') ) {
1225 dbh->rollback if $oldAutoCommit;
1226 return "Can't suspend cancelled package $pkgnum";
1229 if ( $old->get('susp') || $self->get('susp') ) {
1230 dbh->rollback if $oldAutoCommit;
1231 return ""; # no error # complain on adjourn?
1234 my $suspend_time = $options{'time'} || time;
1235 my $date = $options{date} if $options{date}; # adjourn/suspend later
1236 $date = '' if ($date && $date <= $suspend_time); # complain instead?
1238 if ( $date && $old->get('expire') && $old->get('expire') < $date ) {
1239 dbh->rollback if $oldAutoCommit;
1240 return "Package $pkgnum expires before it would be suspended.";
1243 # some false laziness with sub cancel
1244 if ( !$options{nobill} && !$date &&
1245 $self->part_pkg->option('bill_suspend_as_cancel',1) ) {
1246 # kind of a kludge--'bill_suspend_as_cancel' to avoid having to
1247 # make the entire cust_main->bill path recognize 'suspend' and
1248 # 'cancel' separately.
1249 warn "Billing $pkgnum on suspension (at $suspend_time)\n" if $DEBUG;
1250 my $copy = $self->new({$self->hash});
1252 $copy->cust_main->bill( 'pkg_list' => [ $copy ],
1254 'time' => $suspend_time );
1255 warn "Error billing during suspend, custnum ".
1256 #$self->cust_main->custnum. ": $error"
1261 if ( $options{'reason'} ) {
1262 $error = $self->insert_reason( 'reason' => $options{'reason'},
1263 'action' => $date ? 'adjourn' : 'suspend',
1264 'date' => $date ? $date : $suspend_time,
1265 'reason_otaker' => $options{'reason_otaker'},
1268 dbh->rollback if $oldAutoCommit;
1269 return "Error inserting cust_pkg_reason: $error";
1273 my %hash = $self->hash;
1275 $hash{'adjourn'} = $date;
1277 $hash{'susp'} = $suspend_time;
1280 my $resume_date = $options{'resume_date'} || 0;
1281 if ( $resume_date > ($date || $suspend_time) ) {
1282 $hash{'resume'} = $resume_date;
1285 $options{options} ||= {};
1287 my $new = new FS::cust_pkg ( \%hash );
1288 $error = $new->replace( $self, options => { $self->options,
1289 %{ $options{options} },
1293 $dbh->rollback if $oldAutoCommit;
1298 # credit remaining time if appropriate
1299 if ( $self->part_pkg->option('unused_credit_suspend', 1) ) {
1300 my $error = $self->credit_remaining('suspend', $suspend_time);
1302 $dbh->rollback if $oldAutoCommit;
1309 foreach my $cust_svc (
1310 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
1312 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
1314 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
1315 $dbh->rollback if $oldAutoCommit;
1316 return "Illegal svcdb value in part_svc!";
1319 require "FS/$svcdb.pm";
1321 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
1323 $error = $svc->suspend;
1325 $dbh->rollback if $oldAutoCommit;
1328 my( $label, $value ) = $cust_svc->label;
1329 push @labels, "$label: $value";
1333 my $conf = new FS::Conf;
1334 if ( $conf->config('suspend_email_admin') ) {
1336 my $error = send_email(
1337 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
1338 #invoice_from ??? well as good as any
1339 'to' => $conf->config('suspend_email_admin'),
1340 'subject' => 'FREESIDE NOTIFICATION: Customer package suspended',
1342 "This is an automatic message from your Freeside installation\n",
1343 "informing you that the following customer package has been suspended:\n",
1345 'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
1346 'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
1347 ( map { "Service : $_\n" } @labels ),
1352 warn "WARNING: can't send suspension admin email (suspending anyway): ".
1360 foreach my $supp_pkg ( $self->supplemental_pkgs ) {
1361 $error = $supp_pkg->suspend(%options, 'from_main' => 1);
1363 $dbh->rollback if $oldAutoCommit;
1364 return "suspending supplemental pkg#".$supp_pkg->pkgnum.": $error";
1368 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1373 =item credit_remaining MODE TIME
1375 Generate a credit for this package for the time remaining in the current
1376 billing period. MODE is either "suspend" or "cancel" (determines the
1377 credit type). TIME is the time of suspension/cancellation. Both arguments
1382 sub credit_remaining {
1383 # Add a credit for remaining service
1384 my ($self, $mode, $time) = @_;
1385 die 'credit_remaining requires suspend or cancel'
1386 unless $mode eq 'suspend' or $mode eq 'cancel';
1387 die 'no suspend/cancel time' unless $time > 0;
1389 my $conf = FS::Conf->new;
1390 my $reason_type = $conf->config($mode.'_credit_type');
1392 my $last_bill = $self->getfield('last_bill') || 0;
1393 my $next_bill = $self->getfield('bill') || 0;
1394 if ( $last_bill > 0 # the package has been billed
1395 and $next_bill > 0 # the package has a next bill date
1396 and $next_bill >= $time # which is in the future
1398 my $remaining_value = $self->calc_remain('time' => $time);
1399 if ( $remaining_value > 0 ) {
1400 warn "Crediting for $remaining_value on package ".$self->pkgnum."\n"
1402 my $error = $self->cust_main->credit(
1404 'Credit for unused time on '. $self->part_pkg->pkg,
1405 'reason_type' => $reason_type,
1407 return "Error crediting customer \$$remaining_value for unused time".
1408 " on ". $self->part_pkg->pkg. ": $error"
1410 } #if $remaining_value
1411 } #if $last_bill, etc.
1415 =item unsuspend [ OPTION => VALUE ... ]
1417 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
1418 package, then unsuspends the package itself (clears the susp field and the
1419 adjourn field if it is in the past). If the suspend reason includes an
1420 unsuspension package, that package will be ordered.
1422 Available options are:
1428 Can be set to a date to unsuspend the package in the future (the 'resume'
1431 =item adjust_next_bill
1433 Can be set true to adjust the next bill date forward by
1434 the amount of time the account was inactive. This was set true by default
1435 since 1.4.2 and 1.5.0pre6; however, starting with 1.7.0 this needs to be
1436 explicitly requested. Price plans for which this makes sense (anniversary-date
1437 based than prorate or subscription) could have an option to enable this
1442 If there is an error, returns the error, otherwise returns false.
1447 my( $self, %opt ) = @_;
1450 # pass all suspend/cancel actions to the main package
1451 if ( $self->main_pkgnum and !$opt{'from_main'} ) {
1452 return $self->main_pkg->unsuspend(%opt);
1455 local $SIG{HUP} = 'IGNORE';
1456 local $SIG{INT} = 'IGNORE';
1457 local $SIG{QUIT} = 'IGNORE';
1458 local $SIG{TERM} = 'IGNORE';
1459 local $SIG{TSTP} = 'IGNORE';
1460 local $SIG{PIPE} = 'IGNORE';
1462 my $oldAutoCommit = $FS::UID::AutoCommit;
1463 local $FS::UID::AutoCommit = 0;
1466 my $old = $self->select_for_update;
1468 my $pkgnum = $old->pkgnum;
1469 if ( $old->get('cancel') || $self->get('cancel') ) {
1470 $dbh->rollback if $oldAutoCommit;
1471 return "Can't unsuspend cancelled package $pkgnum";
1474 unless ( $old->get('susp') && $self->get('susp') ) {
1475 $dbh->rollback if $oldAutoCommit;
1476 return ""; # no error # complain instead?
1479 my $date = $opt{'date'};
1480 if ( $date and $date > time ) { # return an error if $date <= time?
1482 if ( $old->get('expire') && $old->get('expire') < $date ) {
1483 $dbh->rollback if $oldAutoCommit;
1484 return "Package $pkgnum expires before it would be unsuspended.";
1487 my $new = new FS::cust_pkg { $self->hash };
1488 $new->set('resume', $date);
1489 $error = $new->replace($self, options => $self->options);
1492 $dbh->rollback if $oldAutoCommit;
1496 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1504 foreach my $cust_svc (
1505 qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
1507 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
1509 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
1510 $dbh->rollback if $oldAutoCommit;
1511 return "Illegal svcdb value in part_svc!";
1514 require "FS/$svcdb.pm";
1516 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
1518 $error = $svc->unsuspend;
1520 $dbh->rollback if $oldAutoCommit;
1523 my( $label, $value ) = $cust_svc->label;
1524 push @labels, "$label: $value";
1529 my $cust_pkg_reason = $self->last_cust_pkg_reason('susp');
1530 my $reason = $cust_pkg_reason ? $cust_pkg_reason->reason : '';
1532 my %hash = $self->hash;
1533 my $inactive = time - $hash{'susp'};
1535 my $conf = new FS::Conf;
1537 if ( $inactive > 0 &&
1538 ( $hash{'bill'} || $hash{'setup'} ) &&
1539 ( $opt{'adjust_next_bill'} ||
1540 $conf->exists('unsuspend-always_adjust_next_bill_date') ||
1541 $self->part_pkg->option('unsuspend_adjust_bill', 1) )
1544 $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive;
1549 $hash{'adjourn'} = '' if $hash{'adjourn'} and $hash{'adjourn'} < time;
1550 $hash{'resume'} = '' if !$hash{'adjourn'};
1551 my $new = new FS::cust_pkg ( \%hash );
1552 $error = $new->replace( $self, options => { $self->options } );
1554 $dbh->rollback if $oldAutoCommit;
1560 if ( $reason && $reason->unsuspend_pkgpart ) {
1561 my $part_pkg = FS::part_pkg->by_key($reason->unsuspend_pkgpart)
1562 or $error = "Unsuspend package definition ".$reason->unsuspend_pkgpart.
1564 my $start_date = $self->cust_main->next_bill_date
1565 if $reason->unsuspend_hold;
1568 $unsusp_pkg = FS::cust_pkg->new({
1569 'custnum' => $self->custnum,
1570 'pkgpart' => $reason->unsuspend_pkgpart,
1571 'start_date' => $start_date,
1572 'locationnum' => $self->locationnum,
1573 # discount? probably not...
1576 $error ||= $self->cust_main->order_pkg( 'cust_pkg' => $unsusp_pkg );
1580 $dbh->rollback if $oldAutoCommit;
1585 if ( $conf->config('unsuspend_email_admin') ) {
1587 my $error = send_email(
1588 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
1589 #invoice_from ??? well as good as any
1590 'to' => $conf->config('unsuspend_email_admin'),
1591 'subject' => 'FREESIDE NOTIFICATION: Customer package unsuspended', 'body' => [
1592 "This is an automatic message from your Freeside installation\n",
1593 "informing you that the following customer package has been unsuspended:\n",
1595 'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
1596 'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
1597 ( map { "Service : $_\n" } @labels ),
1599 "An unsuspension fee was charged: ".
1600 $unsusp_pkg->part_pkg->pkg_comment."\n"
1607 warn "WARNING: can't send unsuspension admin email (unsuspending anyway): ".
1613 foreach my $supp_pkg ( $self->supplemental_pkgs ) {
1614 $error = $supp_pkg->unsuspend(%opt, 'from_main' => 1);
1616 $dbh->rollback if $oldAutoCommit;
1617 return "unsuspending supplemental pkg#".$supp_pkg->pkgnum.": $error";
1621 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1628 Cancels any pending suspension (sets the adjourn field to null).
1630 If there is an error, returns the error, otherwise returns false.
1635 my( $self, %options ) = @_;
1638 local $SIG{HUP} = 'IGNORE';
1639 local $SIG{INT} = 'IGNORE';
1640 local $SIG{QUIT} = 'IGNORE';
1641 local $SIG{TERM} = 'IGNORE';
1642 local $SIG{TSTP} = 'IGNORE';
1643 local $SIG{PIPE} = 'IGNORE';
1645 my $oldAutoCommit = $FS::UID::AutoCommit;
1646 local $FS::UID::AutoCommit = 0;
1649 my $old = $self->select_for_update;
1651 my $pkgnum = $old->pkgnum;
1652 if ( $old->get('cancel') || $self->get('cancel') ) {
1653 dbh->rollback if $oldAutoCommit;
1654 return "Can't unadjourn cancelled package $pkgnum";
1655 # or at least it's pointless
1658 if ( $old->get('susp') || $self->get('susp') ) {
1659 dbh->rollback if $oldAutoCommit;
1660 return "Can't unadjourn suspended package $pkgnum";
1661 # perhaps this is arbitrary
1664 unless ( $old->get('adjourn') && $self->get('adjourn') ) {
1665 dbh->rollback if $oldAutoCommit;
1666 return ""; # no error
1669 my %hash = $self->hash;
1670 $hash{'adjourn'} = '';
1671 $hash{'resume'} = '';
1672 my $new = new FS::cust_pkg ( \%hash );
1673 $error = $new->replace( $self, options => { $self->options } );
1675 $dbh->rollback if $oldAutoCommit;
1679 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1686 =item change HASHREF | OPTION => VALUE ...
1688 Changes this package: cancels it and creates a new one, with a different
1689 pkgpart or locationnum or both. All services are transferred to the new
1690 package (no change will be made if this is not possible).
1692 Options may be passed as a list of key/value pairs or as a hash reference.
1699 New locationnum, to change the location for this package.
1703 New FS::cust_location object, to create a new location and assign it
1708 New pkgpart (see L<FS::part_pkg>).
1712 New refnum (see L<FS::part_referral>).
1716 Set to true to transfer billing dates (start_date, setup, last_bill, bill,
1717 susp, adjourn, cancel, expire, and contract_end) to the new package.
1721 At least one of locationnum, cust_location, pkgpart, refnum must be specified
1722 (otherwise, what's the point?)
1724 Returns either the new FS::cust_pkg object or a scalar error.
1728 my $err_or_new_cust_pkg = $old_cust_pkg->change
1732 #some false laziness w/order
1735 my $opt = ref($_[0]) ? shift : { @_ };
1737 # my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
1740 my $conf = new FS::Conf;
1742 # Transactionize this whole mess
1743 local $SIG{HUP} = 'IGNORE';
1744 local $SIG{INT} = 'IGNORE';
1745 local $SIG{QUIT} = 'IGNORE';
1746 local $SIG{TERM} = 'IGNORE';
1747 local $SIG{TSTP} = 'IGNORE';
1748 local $SIG{PIPE} = 'IGNORE';
1750 my $oldAutoCommit = $FS::UID::AutoCommit;
1751 local $FS::UID::AutoCommit = 0;
1760 #$hash{$_} = $self->$_() foreach qw( last_bill bill );
1762 #$hash{$_} = $self->$_() foreach qw( setup );
1764 $hash{'setup'} = $time if $self->setup;
1766 $hash{'change_date'} = $time;
1767 $hash{"change_$_"} = $self->$_()
1768 foreach qw( pkgnum pkgpart locationnum );
1770 if ( $opt->{'cust_location'} &&
1771 ( ! $opt->{'locationnum'} || $opt->{'locationnum'} == -1 ) ) {
1773 if ( ! $opt->{'cust_location'}->locationnum ) {
1775 $error = $opt->{'cust_location'}->insert;
1777 $dbh->rollback if $oldAutoCommit;
1778 return "inserting cust_location (transaction rolled back): $error";
1781 $opt->{'locationnum'} = $opt->{'cust_location'}->locationnum;
1785 # whether to override pkgpart checking on the new package
1786 my $same_pkgpart = 1;
1787 if ( $opt->{'pkgpart'} and ( $opt->{'pkgpart'} != $self->pkgpart ) ) {
1791 my $unused_credit = 0;
1792 my $keep_dates = $opt->{'keep_dates'};
1793 # Special case. If the pkgpart is changing, and the customer is
1794 # going to be credited for remaining time, don't keep setup, bill,
1795 # or last_bill dates, and DO pass the flag to cancel() to credit
1797 if ( $opt->{'pkgpart'}
1798 and $opt->{'pkgpart'} != $self->pkgpart
1799 and $self->part_pkg->option('unused_credit_change', 1) ) {
1802 $hash{$_} = '' foreach qw(setup bill last_bill);
1805 if ( $keep_dates ) {
1806 foreach my $date ( qw(setup bill last_bill susp adjourn cancel expire
1807 resume start_date contract_end ) ) {
1808 $hash{$date} = $self->getfield($date);
1811 # allow $opt->{'locationnum'} = '' to specifically set it to null
1812 # (i.e. customer default location)
1813 $opt->{'locationnum'} = $self->locationnum if !exists($opt->{'locationnum'});
1815 # usually this doesn't matter. the two cases where it does are:
1816 # 1. unused_credit_change + pkgpart change + setup fee on the new package
1818 # 2. (more importantly) changing a package before it's billed
1819 $hash{'waive_setup'} = $self->waive_setup;
1821 # Create the new package.
1822 my $cust_pkg = new FS::cust_pkg {
1823 custnum => $self->custnum,
1824 pkgpart => ( $opt->{'pkgpart'} || $self->pkgpart ),
1825 refnum => ( $opt->{'refnum'} || $self->refnum ),
1826 locationnum => ( $opt->{'locationnum'} ),
1829 $error = $cust_pkg->insert( 'change' => 1,
1830 'allow_pkgpart' => $same_pkgpart );
1832 $dbh->rollback if $oldAutoCommit;
1836 # Transfer services and cancel old package.
1838 $error = $self->transfer($cust_pkg);
1839 if ($error and $error == 0) {
1840 # $old_pkg->transfer failed.
1841 $dbh->rollback if $oldAutoCommit;
1845 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1846 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1847 $error = $self->transfer($cust_pkg, 'change_svcpart'=>1 );
1848 if ($error and $error == 0) {
1849 # $old_pkg->transfer failed.
1850 $dbh->rollback if $oldAutoCommit;
1856 # Transfers were successful, but we still had services left on the old
1857 # package. We can't change the package under this circumstances, so abort.
1858 $dbh->rollback if $oldAutoCommit;
1859 return "Unable to transfer all services from package ". $self->pkgnum;
1862 #reset usage if changing pkgpart
1863 # AND usage rollover is off (otherwise adds twice, now and at package bill)
1864 if ($self->pkgpart != $cust_pkg->pkgpart) {
1865 my $part_pkg = $cust_pkg->part_pkg;
1866 $error = $part_pkg->reset_usage($cust_pkg, $part_pkg->is_prepaid
1870 if $part_pkg->can('reset_usage') && ! $part_pkg->option('usage_rollover',1);
1873 $dbh->rollback if $oldAutoCommit;
1874 return "Error setting usage values: $error";
1877 # if NOT changing pkgpart, transfer any usage pools over
1878 foreach my $usage ($self->cust_pkg_usage) {
1879 $usage->set('pkgnum', $cust_pkg->pkgnum);
1880 $error = $usage->replace;
1882 $dbh->rollback if $oldAutoCommit;
1883 return "Error transferring usage pools: $error";
1888 # transfer discounts, if we're not changing pkgpart
1889 if ( $same_pkgpart ) {
1890 foreach my $old_discount ($self->cust_pkg_discount_active) {
1891 # don't remove the old discount, we may still need to bill that package.
1892 my $new_discount = new FS::cust_pkg_discount {
1893 'pkgnum' => $cust_pkg->pkgnum,
1894 'discountnum' => $old_discount->discountnum,
1895 'months_used' => $old_discount->months_used,
1897 $error = $new_discount->insert;
1899 $dbh->rollback if $oldAutoCommit;
1900 return "Error transferring discounts: $error";
1905 # Order any supplemental packages.
1906 my $part_pkg = $cust_pkg->part_pkg;
1907 my @old_supp_pkgs = $self->supplemental_pkgs;
1909 foreach my $link ($part_pkg->supp_part_pkg_link) {
1911 foreach (@old_supp_pkgs) {
1912 if ($_->pkgpart == $link->dst_pkgpart) {
1914 $_->pkgpart(0); # so that it can't match more than once
1918 # false laziness with FS::cust_main::Packages::order_pkg
1919 my $new = FS::cust_pkg->new({
1920 pkgpart => $link->dst_pkgpart,
1921 pkglinknum => $link->pkglinknum,
1922 custnum => $self->custnum,
1923 main_pkgnum => $cust_pkg->pkgnum,
1924 locationnum => $cust_pkg->locationnum,
1925 start_date => $cust_pkg->start_date,
1926 order_date => $cust_pkg->order_date,
1927 expire => $cust_pkg->expire,
1928 adjourn => $cust_pkg->adjourn,
1929 contract_end => $cust_pkg->contract_end,
1930 refnum => $cust_pkg->refnum,
1931 discountnum => $cust_pkg->discountnum,
1932 waive_setup => $cust_pkg->waive_setup,
1934 if ( $old and $opt->{'keep_dates'} ) {
1935 foreach (qw(setup bill last_bill)) {
1936 $new->set($_, $old->get($_));
1939 $error = $new->insert( allow_pkgpart => $same_pkgpart );
1942 $error ||= $old->transfer($new);
1944 if ( $error and $error > 0 ) {
1945 # no reason why this should ever fail, but still...
1946 $error = "Unable to transfer all services from supplemental package ".
1950 $dbh->rollback if $oldAutoCommit;
1953 push @new_supp_pkgs, $new;
1956 #Good to go, cancel old package. Notify 'cancel' of whether to credit
1958 #Don't allow billing the package (preceding period packages and/or
1959 #outstanding usage) if we are keeping dates (i.e. location changing),
1960 #because the new package will be billed for the same date range.
1961 #Supplemental packages are also canceled here.
1962 $error = $self->cancel(
1964 unused_credit => $unused_credit,
1965 nobill => $keep_dates
1968 $dbh->rollback if $oldAutoCommit;
1972 if ( $conf->exists('cust_pkg-change_pkgpart-bill_now') ) {
1974 my $error = $cust_pkg->cust_main->bill(
1975 'pkg_list' => [ $cust_pkg, @new_supp_pkgs ]
1978 $dbh->rollback if $oldAutoCommit;
1983 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1989 =item set_quantity QUANTITY
1991 Change the package's quantity field. This is the one package property
1992 that can safely be changed without canceling and reordering the package
1993 (because it doesn't affect tax eligibility). Returns an error or an
2000 $self = $self->replace_old; # just to make sure
2002 ($qty =~ /^\d+$/ and $qty > 0) or return "bad package quantity $qty";
2003 $self->set('quantity' => $qty);
2007 use Storable 'thaw';
2009 sub process_bulk_cust_pkg {
2011 my $param = thaw(decode_base64(shift));
2012 warn Dumper($param) if $DEBUG;
2014 my $old_part_pkg = qsearchs('part_pkg',
2015 { pkgpart => $param->{'old_pkgpart'} });
2016 my $new_part_pkg = qsearchs('part_pkg',
2017 { pkgpart => $param->{'new_pkgpart'} });
2018 die "Must select a new package type\n" unless $new_part_pkg;
2019 #my $keep_dates = $param->{'keep_dates'} || 0;
2020 my $keep_dates = 1; # there is no good reason to turn this off
2022 local $SIG{HUP} = 'IGNORE';
2023 local $SIG{INT} = 'IGNORE';
2024 local $SIG{QUIT} = 'IGNORE';
2025 local $SIG{TERM} = 'IGNORE';
2026 local $SIG{TSTP} = 'IGNORE';
2027 local $SIG{PIPE} = 'IGNORE';
2029 my $oldAutoCommit = $FS::UID::AutoCommit;
2030 local $FS::UID::AutoCommit = 0;
2033 my @cust_pkgs = qsearch('cust_pkg', { 'pkgpart' => $param->{'old_pkgpart'} } );
2036 foreach my $old_cust_pkg ( @cust_pkgs ) {
2038 $job->update_statustext(int(100*$i/(scalar @cust_pkgs)));
2039 if ( $old_cust_pkg->getfield('cancel') ) {
2040 warn '[process_bulk_cust_pkg ] skipping canceled pkgnum '.
2041 $old_cust_pkg->pkgnum."\n"
2045 warn '[process_bulk_cust_pkg] changing pkgnum '.$old_cust_pkg->pkgnum."\n"
2047 my $error = $old_cust_pkg->change(
2048 'pkgpart' => $param->{'new_pkgpart'},
2049 'keep_dates' => $keep_dates
2051 if ( !ref($error) ) { # change returns the cust_pkg on success
2053 die "Error changing pkgnum ".$old_cust_pkg->pkgnum.": '$error'\n";
2056 $dbh->commit if $oldAutoCommit;
2062 Returns the last bill date, or if there is no last bill date, the setup date.
2063 Useful for billing metered services.
2069 return $self->setfield('last_bill', $_[0]) if @_;
2070 return $self->getfield('last_bill') if $self->getfield('last_bill');
2071 my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
2072 'edate' => $self->bill, } );
2073 $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
2076 =item last_cust_pkg_reason ACTION
2078 Returns the most recent ACTION FS::cust_pkg_reason associated with the package.
2079 Returns false if there is no reason or the package is not currenly ACTION'd
2080 ACTION is one of adjourn, susp, cancel, or expire.
2084 sub last_cust_pkg_reason {
2085 my ( $self, $action ) = ( shift, shift );
2086 my $date = $self->get($action);
2088 'table' => 'cust_pkg_reason',
2089 'hashref' => { 'pkgnum' => $self->pkgnum,
2090 'action' => substr(uc($action), 0, 1),
2093 'order_by' => 'ORDER BY num DESC LIMIT 1',
2097 =item last_reason ACTION
2099 Returns the most recent ACTION FS::reason associated with the package.
2100 Returns false if there is no reason or the package is not currenly ACTION'd
2101 ACTION is one of adjourn, susp, cancel, or expire.
2106 my $cust_pkg_reason = shift->last_cust_pkg_reason(@_);
2107 $cust_pkg_reason->reason
2108 if $cust_pkg_reason;
2113 Returns the definition for this billing item, as an FS::part_pkg object (see
2120 return $self->{'_pkgpart'} if $self->{'_pkgpart'};
2121 cluck "cust_pkg->part_pkg called" if $DEBUG > 1;
2122 qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
2127 Returns the cancelled package this package was changed from, if any.
2133 return '' unless $self->change_pkgnum;
2134 qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
2139 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
2146 $self->part_pkg->calc_setup($self, @_);
2151 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
2158 $self->part_pkg->calc_recur($self, @_);
2163 Calls the I<base_recur> of the FS::part_pkg object associated with this billing
2170 $self->part_pkg->base_recur($self, @_);
2175 Calls the I<calc_remain> of the FS::part_pkg object associated with this
2182 $self->part_pkg->calc_remain($self, @_);
2187 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
2194 $self->part_pkg->calc_cancel($self, @_);
2199 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
2205 qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
2208 =item cust_pkg_detail [ DETAILTYPE ]
2210 Returns any customer package details for this package (see
2211 L<FS::cust_pkg_detail>).
2213 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
2217 sub cust_pkg_detail {
2219 my %hash = ( 'pkgnum' => $self->pkgnum );
2220 $hash{detailtype} = shift if @_;
2222 'table' => 'cust_pkg_detail',
2223 'hashref' => \%hash,
2224 'order_by' => 'ORDER BY weight, pkgdetailnum',
2228 =item set_cust_pkg_detail DETAILTYPE [ DETAIL, DETAIL, ... ]
2230 Sets customer package details for this package (see L<FS::cust_pkg_detail>).
2232 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
2234 If there is an error, returns the error, otherwise returns false.
2238 sub set_cust_pkg_detail {
2239 my( $self, $detailtype, @details ) = @_;
2241 local $SIG{HUP} = 'IGNORE';
2242 local $SIG{INT} = 'IGNORE';
2243 local $SIG{QUIT} = 'IGNORE';
2244 local $SIG{TERM} = 'IGNORE';
2245 local $SIG{TSTP} = 'IGNORE';
2246 local $SIG{PIPE} = 'IGNORE';
2248 my $oldAutoCommit = $FS::UID::AutoCommit;
2249 local $FS::UID::AutoCommit = 0;
2252 foreach my $current ( $self->cust_pkg_detail($detailtype) ) {
2253 my $error = $current->delete;
2255 $dbh->rollback if $oldAutoCommit;
2256 return "error removing old detail: $error";
2260 foreach my $detail ( @details ) {
2261 my $cust_pkg_detail = new FS::cust_pkg_detail {
2262 'pkgnum' => $self->pkgnum,
2263 'detailtype' => $detailtype,
2264 'detail' => $detail,
2266 my $error = $cust_pkg_detail->insert;
2268 $dbh->rollback if $oldAutoCommit;
2269 return "error adding new detail: $error";
2274 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2281 Returns the new-style customer billing events (see L<FS::cust_event>) for this invoice.
2285 #false laziness w/cust_bill.pm
2289 'table' => 'cust_event',
2290 'addl_from' => 'JOIN part_event USING ( eventpart )',
2291 'hashref' => { 'tablenum' => $self->pkgnum },
2292 'extra_sql' => " AND eventtable = 'cust_pkg' ",
2296 =item num_cust_event
2298 Returns the number of new-style customer billing events (see L<FS::cust_event>) for this invoice.
2302 #false laziness w/cust_bill.pm
2303 sub num_cust_event {
2306 "SELECT COUNT(*) FROM cust_event JOIN part_event USING ( eventpart ) ".
2307 " WHERE tablenum = ? AND eventtable = 'cust_pkg'";
2308 my $sth = dbh->prepare($sql) or die dbh->errstr. " preparing $sql";
2309 $sth->execute($self->pkgnum) or die $sth->errstr. " executing $sql";
2310 $sth->fetchrow_arrayref->[0];
2313 =item cust_svc [ SVCPART ] (old, deprecated usage)
2315 =item cust_svc [ OPTION => VALUE ... ] (current usage)
2317 Returns the services for this package, as FS::cust_svc objects (see
2318 L<FS::cust_svc>). Available options are svcpart and svcdb. If either is
2319 spcififed, returns only the matching services.
2326 return () unless $self->num_cust_svc(@_);
2329 if ( @_ && $_[0] =~ /^\d+/ ) {
2330 $opt{svcpart} = shift;
2331 } elsif ( @_ && ref($_[0]) eq 'HASH' ) {
2338 'table' => 'cust_svc',
2339 'hashref' => { 'pkgnum' => $self->pkgnum },
2341 if ( $opt{svcpart} ) {
2342 $search{hashref}->{svcpart} = $opt{'svcpart'};
2344 if ( $opt{'svcdb'} ) {
2345 $search{addl_from} = ' LEFT JOIN part_svc USING ( svcpart ) ';
2346 $search{extra_sql} = ' AND svcdb = '. dbh->quote( $opt{'svcdb'} );
2349 cluck "cust_pkg->cust_svc called" if $DEBUG > 2;
2351 #if ( $self->{'_svcnum'} ) {
2352 # values %{ $self->{'_svcnum'}->cache };
2354 $self->_sort_cust_svc( [ qsearch(\%search) ] );
2359 =item overlimit [ SVCPART ]
2361 Returns the services for this package which have exceeded their
2362 usage limit as FS::cust_svc objects (see L<FS::cust_svc>). If a svcpart
2363 is specified, return only the matching services.
2369 return () unless $self->num_cust_svc(@_);
2370 grep { $_->overlimit } $self->cust_svc(@_);
2373 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
2375 Returns historical services for this package created before END TIMESTAMP and
2376 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
2377 (see L<FS::h_cust_svc>). If MODE is 'I' (for 'invoice'), services with the
2378 I<pkg_svc.hidden> flag will be omitted.
2384 warn "$me _h_cust_svc called on $self\n"
2387 my ($end, $start, $mode) = @_;
2388 my @cust_svc = $self->_sort_cust_svc(
2389 [ qsearch( 'h_cust_svc',
2390 { 'pkgnum' => $self->pkgnum, },
2391 FS::h_cust_svc->sql_h_search(@_),
2394 if ( defined($mode) && $mode eq 'I' ) {
2395 my %hidden_svcpart = map { $_->svcpart => $_->hidden } $self->part_svc;
2396 return grep { !$hidden_svcpart{$_->svcpart} } @cust_svc;
2402 sub _sort_cust_svc {
2403 my( $self, $arrayref ) = @_;
2406 sub ($$) { my ($a, $b) = @_; $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] };
2411 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
2412 'svcpart' => $_->svcpart } );
2414 $pkg_svc ? $pkg_svc->primary_svc : '',
2415 $pkg_svc ? $pkg_svc->quantity : 0,
2422 =item num_cust_svc [ SVCPART ] (old, deprecated usage)
2424 =item num_cust_svc [ OPTION => VALUE ... ] (current usage)
2426 Returns the number of services for this package. Available options are svcpart
2427 and svcdb. If either is spcififed, returns only the matching services.
2434 return $self->{'_num_cust_svc'}
2436 && exists($self->{'_num_cust_svc'})
2437 && $self->{'_num_cust_svc'} =~ /\d/;
2439 cluck "cust_pkg->num_cust_svc called, _num_cust_svc:".$self->{'_num_cust_svc'}
2443 if ( @_ && $_[0] =~ /^\d+/ ) {
2444 $opt{svcpart} = shift;
2445 } elsif ( @_ && ref($_[0]) eq 'HASH' ) {
2451 my $select = 'SELECT COUNT(*) FROM cust_svc ';
2452 my $where = ' WHERE pkgnum = ? ';
2453 my @param = ($self->pkgnum);
2455 if ( $opt{'svcpart'} ) {
2456 $where .= ' AND svcpart = ? ';
2457 push @param, $opt{'svcpart'};
2459 if ( $opt{'svcdb'} ) {
2460 $select .= ' LEFT JOIN part_svc USING ( svcpart ) ';
2461 $where .= ' AND svcdb = ? ';
2462 push @param, $opt{'svcdb'};
2465 my $sth = dbh->prepare("$select $where") or die dbh->errstr;
2466 $sth->execute(@param) or die $sth->errstr;
2467 $sth->fetchrow_arrayref->[0];
2470 =item available_part_svc
2472 Returns a list of FS::part_svc objects representing services included in this
2473 package but not yet provisioned. Each FS::part_svc object also has an extra
2474 field, I<num_avail>, which specifies the number of available services.
2478 sub available_part_svc {
2481 my $pkg_quantity = $self->quantity || 1;
2483 grep { $_->num_avail > 0 }
2485 my $part_svc = $_->part_svc;
2486 $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
2487 $pkg_quantity * $_->quantity - $self->num_cust_svc($_->svcpart);
2489 # more evil encapsulation breakage
2490 if($part_svc->{'Hash'}{'num_avail'} > 0) {
2491 my @exports = $part_svc->part_export_did;
2492 $part_svc->{'Hash'}{'can_get_dids'} = scalar(@exports);
2497 $self->part_pkg->pkg_svc;
2500 =item part_svc [ OPTION => VALUE ... ]
2502 Returns a list of FS::part_svc objects representing provisioned and available
2503 services included in this package. Each FS::part_svc object also has the
2504 following extra fields:
2508 =item num_cust_svc (count)
2510 =item num_avail (quantity - count)
2512 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
2516 Accepts one option: summarize_size. If specified and non-zero, will omit the
2517 extra cust_pkg_svc option for objects where num_cust_svc is this size or
2523 #label -> ($cust_svc->label)[1]
2529 my $pkg_quantity = $self->quantity || 1;
2531 #XXX some sort of sort order besides numeric by svcpart...
2532 my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
2534 my $part_svc = $pkg_svc->part_svc;
2535 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
2536 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
2537 $part_svc->{'Hash'}{'num_avail'} =
2538 max( 0, $pkg_quantity * $pkg_svc->quantity - $num_cust_svc );
2539 $part_svc->{'Hash'}{'cust_pkg_svc'} =
2540 $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : []
2541 unless exists($opt{summarize_size}) && $opt{summarize_size} > 0
2542 && $num_cust_svc >= $opt{summarize_size};
2543 $part_svc->{'Hash'}{'hidden'} = $pkg_svc->hidden;
2545 } $self->part_pkg->pkg_svc;
2548 push @part_svc, map {
2550 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
2551 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
2552 $part_svc->{'Hash'}{'num_avail'} = 0; #0-$num_cust_svc ?
2553 $part_svc->{'Hash'}{'cust_pkg_svc'} =
2554 $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
2556 } $self->extra_part_svc;
2562 =item extra_part_svc
2564 Returns a list of FS::part_svc objects corresponding to services in this
2565 package which are still provisioned but not (any longer) available in the
2570 sub extra_part_svc {
2573 my $pkgnum = $self->pkgnum;
2574 #my $pkgpart = $self->pkgpart;
2577 # 'table' => 'part_svc',
2580 # "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
2581 # WHERE pkg_svc.svcpart = part_svc.svcpart
2582 # AND pkg_svc.pkgpart = ?
2585 # AND 0 < ( SELECT COUNT(*) FROM cust_svc
2586 # LEFT JOIN cust_pkg USING ( pkgnum )
2587 # WHERE cust_svc.svcpart = part_svc.svcpart
2590 # 'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
2593 #seems to benchmark slightly faster... (or did?)
2595 my @pkgparts = map $_->pkgpart, $self->part_pkg->self_and_svc_linked;
2596 my $pkgparts = join(',', @pkgparts);
2599 #'select' => 'DISTINCT ON (svcpart) part_svc.*',
2600 #MySQL doesn't grok DISINCT ON
2601 'select' => 'DISTINCT part_svc.*',
2602 'table' => 'part_svc',
2604 "LEFT JOIN pkg_svc ON ( pkg_svc.svcpart = part_svc.svcpart
2605 AND pkg_svc.pkgpart IN ($pkgparts)
2608 LEFT JOIN cust_svc ON ( cust_svc.svcpart = part_svc.svcpart )
2609 LEFT JOIN cust_pkg USING ( pkgnum )
2612 'extra_sql' => "WHERE pkgsvcnum IS NULL AND cust_pkg.pkgnum = ? ",
2613 'extra_param' => [ [$self->pkgnum=>'int'] ],
2619 Returns a short status string for this package, currently:
2623 =item not yet billed
2625 =item one-time charge
2640 my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
2642 return 'cancelled' if $self->get('cancel');
2643 return 'suspended' if $self->susp;
2644 return 'not yet billed' unless $self->setup;
2645 return 'one-time charge' if $freq =~ /^(0|$)/;
2649 =item ucfirst_status
2651 Returns the status with the first character capitalized.
2655 sub ucfirst_status {
2656 ucfirst(shift->status);
2661 Class method that returns the list of possible status strings for packages
2662 (see L<the status method|/status>). For example:
2664 @statuses = FS::cust_pkg->statuses();
2668 tie my %statuscolor, 'Tie::IxHash',
2669 'not yet billed' => '009999', #teal? cyan?
2670 'one-time charge' => '000000',
2671 'active' => '00CC00',
2672 'suspended' => 'FF9900',
2673 'cancelled' => 'FF0000',
2677 my $self = shift; #could be class...
2678 #grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
2679 # # mayble split btw one-time vs. recur
2685 Returns a hex triplet color string for this package's status.
2691 $statuscolor{$self->status};
2696 Returns a label for this package. (Currently "pkgnum: pkg - comment" or
2697 "pkg - comment" depending on user preference).
2703 my $label = $self->part_pkg->pkg_comment( 'nopkgpart' => 1 );
2704 $label = $self->pkgnum. ": $label"
2705 if $FS::CurrentUser::CurrentUser->option('show_pkgnum');
2709 =item pkg_label_long
2711 Returns a long label for this package, adding the primary service's label to
2716 sub pkg_label_long {
2718 my $label = $self->pkg_label;
2719 my $cust_svc = $self->primary_cust_svc;
2720 $label .= ' ('. ($cust_svc->label)[1]. ')' if $cust_svc;
2726 Returns a customer-localized label for this package.
2732 $self->part_pkg->pkg_locale( $self->cust_main->locale );
2735 =item primary_cust_svc
2737 Returns a primary service (as FS::cust_svc object) if one can be identified.
2741 #for labeling purposes - might not 100% match up with part_pkg->svcpart's idea
2743 sub primary_cust_svc {
2746 my @cust_svc = $self->cust_svc;
2748 return '' unless @cust_svc; #no serivces - irrelevant then
2750 return $cust_svc[0] if scalar(@cust_svc) == 1; #always return a single service
2752 # primary service as specified in the package definition
2753 # or exactly one service definition with quantity one
2754 my $svcpart = $self->part_pkg->svcpart;
2755 @cust_svc = grep { $_->svcpart == $svcpart } @cust_svc;
2756 return $cust_svc[0] if scalar(@cust_svc) == 1;
2758 #couldn't identify one thing..
2764 Returns a list of lists, calling the label method for all services
2765 (see L<FS::cust_svc>) of this billing item.
2771 map { [ $_->label ] } $self->cust_svc;
2774 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
2776 Like the labels method, but returns historical information on services that
2777 were active as of END_TIMESTAMP and (optionally) not cancelled before
2778 START_TIMESTAMP. If MODE is 'I' (for 'invoice'), services with the
2779 I<pkg_svc.hidden> flag will be omitted.
2781 Returns a list of lists, calling the label method for all (historical) services
2782 (see L<FS::h_cust_svc>) of this billing item.
2788 warn "$me _h_labels called on $self\n"
2790 map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
2795 Like labels, except returns a simple flat list, and shortens long
2796 (currently >5 or the cust_bill-max_same_services configuration value) lists of
2797 identical services to one line that lists the service label and the number of
2798 individual services rather than individual items.
2803 shift->_labels_short( 'labels', @_ );
2806 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
2808 Like h_labels, except returns a simple flat list, and shortens long
2809 (currently >5 or the cust_bill-max_same_services configuration value) lists of
2810 identical services to one line that lists the service label and the number of
2811 individual services rather than individual items.
2815 sub h_labels_short {
2816 shift->_labels_short( 'h_labels', @_ );
2820 my( $self, $method ) = ( shift, shift );
2822 warn "$me _labels_short called on $self with $method method\n"
2825 my $conf = new FS::Conf;
2826 my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
2828 warn "$me _labels_short populating \%labels\n"
2832 #tie %labels, 'Tie::IxHash';
2833 push @{ $labels{$_->[0]} }, $_->[1]
2834 foreach $self->$method(@_);
2836 warn "$me _labels_short populating \@labels\n"
2840 foreach my $label ( keys %labels ) {
2842 my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
2843 my $num = scalar(@values);
2844 warn "$me _labels_short $num items for $label\n"
2847 if ( $num > $max_same_services ) {
2848 warn "$me _labels_short more than $max_same_services, so summarizing\n"
2850 push @labels, "$label ($num)";
2852 if ( $conf->exists('cust_bill-consolidate_services') ) {
2853 warn "$me _labels_short consolidating services\n"
2855 # push @labels, "$label: ". join(', ', @values);
2857 my $detail = "$label: ";
2858 $detail .= shift(@values). ', '
2860 && ( length($detail.$values[0]) < 78 || $detail eq "$label: " );
2862 push @labels, $detail;
2864 warn "$me _labels_short done consolidating services\n"
2867 warn "$me _labels_short adding service data\n"
2869 push @labels, map { "$label: $_" } @values;
2880 Returns the parent customer object (see L<FS::cust_main>).
2886 qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
2891 Returns the balance for this specific package, when using
2892 experimental package balance.
2898 $self->cust_main->balance_pkgnum( $self->pkgnum );
2901 #these subs are in location_Mixin.pm now... unfortunately the POD doesn't mixin
2905 Returns the location object, if any (see L<FS::cust_location>).
2907 =item cust_location_or_main
2909 If this package is associated with a location, returns the locaiton (see
2910 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
2912 =item location_label [ OPTION => VALUE ... ]
2914 Returns the label of the location object (see L<FS::cust_location>).
2918 #end of subs in location_Mixin.pm now... unfortunately the POD doesn't mixin
2920 =item tax_locationnum
2922 Returns the foreign key to a L<FS::cust_location> object for calculating
2923 tax on this package, as determined by the C<tax-pkg_address> and
2924 C<tax-ship_address> configuration flags.
2928 sub tax_locationnum {
2930 my $conf = FS::Conf->new;
2931 if ( $conf->exists('tax-pkg_address') ) {
2932 return $self->locationnum;
2934 elsif ( $conf->exists('tax-ship_address') ) {
2935 return $self->cust_main->ship_locationnum;
2938 return $self->cust_main->bill_locationnum;
2944 Returns the L<FS::cust_location> object for tax_locationnum.
2950 FS::cust_location->by_key( $self->tax_locationnum )
2953 =item seconds_since TIMESTAMP
2955 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
2956 package have been online since TIMESTAMP, according to the session monitor.
2958 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
2959 L<Time::Local> and L<Date::Parse> for conversion functions.
2964 my($self, $since) = @_;
2967 foreach my $cust_svc (
2968 grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
2970 $seconds += $cust_svc->seconds_since($since);
2977 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2979 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
2980 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
2983 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2984 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2990 sub seconds_since_sqlradacct {
2991 my($self, $start, $end) = @_;
2995 foreach my $cust_svc (
2997 my $part_svc = $_->part_svc;
2998 $part_svc->svcdb eq 'svc_acct'
2999 && scalar($part_svc->part_export_usage);
3002 $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
3009 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
3011 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
3012 in this package for sessions ending between TIMESTAMP_START (inclusive) and
3016 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
3017 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
3022 sub attribute_since_sqlradacct {
3023 my($self, $start, $end, $attrib) = @_;
3027 foreach my $cust_svc (
3029 my $part_svc = $_->part_svc;
3030 $part_svc->svcdb eq 'svc_acct'
3031 && scalar($part_svc->part_export_usage);
3034 $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
3046 my( $self, $value ) = @_;
3047 if ( defined($value) ) {
3048 $self->setfield('quantity', $value);
3050 $self->getfield('quantity') || 1;
3053 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
3055 Transfers as many services as possible from this package to another package.
3057 The destination package can be specified by pkgnum by passing an FS::cust_pkg
3058 object. The destination package must already exist.
3060 Services are moved only if the destination allows services with the correct
3061 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true. Use
3062 this option with caution! No provision is made for export differences
3063 between the old and new service definitions. Probably only should be used
3064 when your exports for all service definitions of a given svcdb are identical.
3065 (attempt a transfer without it first, to move all possible svcpart-matching
3068 Any services that can't be moved remain in the original package.
3070 Returns an error, if there is one; otherwise, returns the number of services
3071 that couldn't be moved.
3076 my ($self, $dest_pkgnum, %opt) = @_;
3082 if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
3083 $dest = $dest_pkgnum;
3084 $dest_pkgnum = $dest->pkgnum;
3086 $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
3089 return ('Package does not exist: '.$dest_pkgnum) unless $dest;
3091 foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
3092 $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
3095 foreach my $cust_svc ($dest->cust_svc) {
3096 $target{$cust_svc->svcpart}--;
3099 my %svcpart2svcparts = ();
3100 if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
3101 warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
3102 foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
3103 next if exists $svcpart2svcparts{$svcpart};
3104 my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
3105 $svcpart2svcparts{$svcpart} = [
3107 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
3109 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
3110 'svcpart' => $_ } );
3112 $pkg_svc ? $pkg_svc->primary_svc : '',
3113 $pkg_svc ? $pkg_svc->quantity : 0,
3117 grep { $_ != $svcpart }
3119 qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
3121 warn "alternates for svcpart $svcpart: ".
3122 join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
3127 foreach my $cust_svc ($self->cust_svc) {
3128 if($target{$cust_svc->svcpart} > 0
3129 or $FS::cust_svc::ignore_quantity) { # maybe should be a 'force' option
3130 $target{$cust_svc->svcpart}--;
3131 my $new = new FS::cust_svc { $cust_svc->hash };
3132 $new->pkgnum($dest_pkgnum);
3133 my $error = $new->replace($cust_svc);
3134 return $error if $error;
3135 } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
3137 warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
3138 warn "alternates to consider: ".
3139 join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
3141 my @alternate = grep {
3142 warn "considering alternate svcpart $_: ".
3143 "$target{$_} available in new package\n"
3146 } @{$svcpart2svcparts{$cust_svc->svcpart}};
3148 warn "alternate(s) found\n" if $DEBUG;
3149 my $change_svcpart = $alternate[0];
3150 $target{$change_svcpart}--;
3151 my $new = new FS::cust_svc { $cust_svc->hash };
3152 $new->svcpart($change_svcpart);
3153 $new->pkgnum($dest_pkgnum);
3154 my $error = $new->replace($cust_svc);
3155 return $error if $error;
3168 This method is deprecated. See the I<depend_jobnum> option to the insert and
3169 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
3176 local $SIG{HUP} = 'IGNORE';
3177 local $SIG{INT} = 'IGNORE';
3178 local $SIG{QUIT} = 'IGNORE';
3179 local $SIG{TERM} = 'IGNORE';
3180 local $SIG{TSTP} = 'IGNORE';
3181 local $SIG{PIPE} = 'IGNORE';
3183 my $oldAutoCommit = $FS::UID::AutoCommit;
3184 local $FS::UID::AutoCommit = 0;
3187 foreach my $cust_svc ( $self->cust_svc ) {
3188 #false laziness w/svc_Common::insert
3189 my $svc_x = $cust_svc->svc_x;
3190 foreach my $part_export ( $cust_svc->part_svc->part_export ) {
3191 my $error = $part_export->export_insert($svc_x);
3193 $dbh->rollback if $oldAutoCommit;
3199 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3206 Associates this package with a (suspension or cancellation) reason (see
3207 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
3210 Available options are:
3216 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.
3220 the access_user (see L<FS::access_user>) providing the reason
3228 the action (cancel, susp, adjourn, expire) associated with the reason
3232 If there is an error, returns the error, otherwise returns false.
3237 my ($self, %options) = @_;
3239 my $otaker = $options{reason_otaker} ||
3240 $FS::CurrentUser::CurrentUser->username;
3243 if ( $options{'reason'} =~ /^(\d+)$/ ) {
3247 } elsif ( ref($options{'reason'}) ) {
3249 return 'Enter a new reason (or select an existing one)'
3250 unless $options{'reason'}->{'reason'} !~ /^\s*$/;
3252 my $reason = new FS::reason({
3253 'reason_type' => $options{'reason'}->{'typenum'},
3254 'reason' => $options{'reason'}->{'reason'},
3256 my $error = $reason->insert;
3257 return $error if $error;
3259 $reasonnum = $reason->reasonnum;
3262 return "Unparsable reason: ". $options{'reason'};
3265 my $cust_pkg_reason =
3266 new FS::cust_pkg_reason({ 'pkgnum' => $self->pkgnum,
3267 'reasonnum' => $reasonnum,
3268 'otaker' => $otaker,
3269 'action' => substr(uc($options{'action'}),0,1),
3270 'date' => $options{'date'}
3275 $cust_pkg_reason->insert;
3278 =item insert_discount
3280 Associates this package with a discount (see L<FS::cust_pkg_discount>, possibly
3281 inserting a new discount on the fly (see L<FS::discount>).
3283 Available options are:
3291 If there is an error, returns the error, otherwise returns false.
3295 sub insert_discount {
3296 #my ($self, %options) = @_;
3299 my $cust_pkg_discount = new FS::cust_pkg_discount {
3300 'pkgnum' => $self->pkgnum,
3301 'discountnum' => $self->discountnum,
3303 'end_date' => '', #XXX
3304 #for the create a new discount case
3305 '_type' => $self->discountnum__type,
3306 'amount' => $self->discountnum_amount,
3307 'percent' => $self->discountnum_percent,
3308 'months' => $self->discountnum_months,
3309 'setup' => $self->discountnum_setup,
3310 #'disabled' => $self->discountnum_disabled,
3313 $cust_pkg_discount->insert;
3316 =item set_usage USAGE_VALUE_HASHREF
3318 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
3319 to which they should be set (see L<FS::svc_acct>). Currently seconds,
3320 upbytes, downbytes, and totalbytes are appropriate keys.
3322 All svc_accts which are part of this package have their values reset.
3327 my ($self, $valueref, %opt) = @_;
3329 #only svc_acct can set_usage for now
3330 foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
3331 my $svc_x = $cust_svc->svc_x;
3332 $svc_x->set_usage($valueref, %opt)
3333 if $svc_x->can("set_usage");
3337 =item recharge USAGE_VALUE_HASHREF
3339 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
3340 to which they should be set (see L<FS::svc_acct>). Currently seconds,
3341 upbytes, downbytes, and totalbytes are appropriate keys.
3343 All svc_accts which are part of this package have their values incremented.
3348 my ($self, $valueref) = @_;
3350 #only svc_acct can set_usage for now
3351 foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
3352 my $svc_x = $cust_svc->svc_x;
3353 $svc_x->recharge($valueref)
3354 if $svc_x->can("recharge");
3358 =item cust_pkg_discount
3362 sub cust_pkg_discount {
3364 qsearch('cust_pkg_discount', { 'pkgnum' => $self->pkgnum } );
3367 =item cust_pkg_discount_active
3371 sub cust_pkg_discount_active {
3373 grep { $_->status eq 'active' } $self->cust_pkg_discount;
3376 =item cust_pkg_usage
3378 Returns a list of all voice usage counters attached to this package.
3382 sub cust_pkg_usage {
3384 qsearch('cust_pkg_usage', { pkgnum => $self->pkgnum });
3387 =item apply_usage OPTIONS
3389 Takes the following options:
3390 - cdr: a call detail record (L<FS::cdr>)
3391 - rate_detail: the rate determined for this call (L<FS::rate_detail>)
3392 - minutes: the maximum number of minutes to be charged
3394 Finds available usage minutes for a call of this class, and subtracts
3395 up to that many minutes from the usage pool. If the usage pool is empty,
3396 and the C<cdr-minutes_priority> global config option is set, minutes may
3397 be taken from other calls as well. Either way, an allocation record will
3398 be created (L<FS::cdr_cust_pkg_usage>) and this method will return the
3399 number of minutes of usage applied to the call.
3404 my ($self, %opt) = @_;
3405 my $cdr = $opt{cdr};
3406 my $rate_detail = $opt{rate_detail};
3407 my $minutes = $opt{minutes};
3408 my $classnum = $rate_detail->classnum;
3409 my $pkgnum = $self->pkgnum;
3410 my $custnum = $self->custnum;
3412 local $SIG{HUP} = 'IGNORE';
3413 local $SIG{INT} = 'IGNORE';
3414 local $SIG{QUIT} = 'IGNORE';
3415 local $SIG{TERM} = 'IGNORE';
3416 local $SIG{TSTP} = 'IGNORE';
3417 local $SIG{PIPE} = 'IGNORE';
3419 my $oldAutoCommit = $FS::UID::AutoCommit;
3420 local $FS::UID::AutoCommit = 0;
3422 my $order = FS::Conf->new->config('cdr-minutes_priority');
3426 $is_classnum = ' part_pkg_usage_class.classnum = '.$classnum;
3428 $is_classnum = ' part_pkg_usage_class.classnum IS NULL';
3430 my @usage_recs = qsearch({
3431 'table' => 'cust_pkg_usage',
3432 'addl_from' => ' JOIN part_pkg_usage USING (pkgusagepart)'.
3433 ' JOIN cust_pkg USING (pkgnum)'.
3434 ' JOIN part_pkg_usage_class USING (pkgusagepart)',
3435 'select' => 'cust_pkg_usage.*',
3436 'extra_sql' => " WHERE ( cust_pkg.pkgnum = $pkgnum OR ".
3437 " ( cust_pkg.custnum = $custnum AND ".
3438 " part_pkg_usage.shared IS NOT NULL ) ) AND ".
3439 $is_classnum . ' AND '.
3440 " cust_pkg_usage.minutes > 0",
3441 'order_by' => " ORDER BY priority ASC",
3444 my $orig_minutes = $minutes;
3446 while (!$error and $minutes > 0 and @usage_recs) {
3447 my $cust_pkg_usage = shift @usage_recs;
3448 $cust_pkg_usage->select_for_update;
3449 my $cdr_cust_pkg_usage = FS::cdr_cust_pkg_usage->new({
3450 pkgusagenum => $cust_pkg_usage->pkgusagenum,
3451 acctid => $cdr->acctid,
3452 minutes => min($cust_pkg_usage->minutes, $minutes),
3454 $cust_pkg_usage->set('minutes',
3455 sprintf('%.0f', $cust_pkg_usage->minutes - $cdr_cust_pkg_usage->minutes)
3457 $error = $cust_pkg_usage->replace || $cdr_cust_pkg_usage->insert;
3458 $minutes -= $cdr_cust_pkg_usage->minutes;
3460 if ( $order and $minutes > 0 and !$error ) {
3461 # then try to steal minutes from another call
3463 'table' => 'cdr_cust_pkg_usage',
3464 'addl_from' => ' JOIN cust_pkg_usage USING (pkgusagenum)'.
3465 ' JOIN part_pkg_usage USING (pkgusagepart)'.
3466 ' JOIN cust_pkg USING (pkgnum)'.
3467 ' JOIN part_pkg_usage_class USING (pkgusagepart)'.
3468 ' JOIN cdr USING (acctid)',
3469 'select' => 'cdr_cust_pkg_usage.*',
3470 'extra_sql' => " WHERE cdr.freesidestatus = 'rated' AND ".
3471 " ( cust_pkg.pkgnum = $pkgnum OR ".
3472 " ( cust_pkg.custnum = $custnum AND ".
3473 " part_pkg_usage.shared IS NOT NULL ) ) AND ".
3474 " part_pkg_usage_class.classnum = $classnum",
3475 'order_by' => ' ORDER BY part_pkg_usage.priority ASC',
3477 if ( $order eq 'time' ) {
3478 # find CDRs that are using minutes, but have a later startdate
3480 my $startdate = $cdr->startdate;
3481 if ($startdate !~ /^\d+$/) {
3482 die "bad cdr startdate '$startdate'";
3484 $search{'extra_sql'} .= " AND cdr.startdate > $startdate";
3485 # minimize needless reshuffling
3486 $search{'order_by'} .= ', cdr.startdate DESC';
3488 # XXX may not work correctly with rate_time schedules. Could
3489 # fix this by storing ratedetailnum in cdr_cust_pkg_usage, I
3491 $search{'addl_from'} .=
3492 ' JOIN rate_detail'.
3493 ' ON (cdr.rated_ratedetailnum = rate_detail.ratedetailnum)';
3494 if ( $order eq 'rate_high' ) {
3495 $search{'extra_sql'} .= ' AND rate_detail.min_charge < '.
3496 $rate_detail->min_charge;
3497 $search{'order_by'} .= ', rate_detail.min_charge ASC';
3498 } elsif ( $order eq 'rate_low' ) {
3499 $search{'extra_sql'} .= ' AND rate_detail.min_charge > '.
3500 $rate_detail->min_charge;
3501 $search{'order_by'} .= ', rate_detail.min_charge DESC';
3503 # this should really never happen
3504 die "invalid cdr-minutes_priority value '$order'\n";
3507 my @cdr_usage_recs = qsearch(\%search);
3509 while (!$error and @cdr_usage_recs and $minutes > 0) {
3510 my $cdr_cust_pkg_usage = shift @cdr_usage_recs;
3511 my $cust_pkg_usage = $cdr_cust_pkg_usage->cust_pkg_usage;
3512 my $old_cdr = $cdr_cust_pkg_usage->cdr;
3513 $reproc_cdrs{$old_cdr->acctid} = $old_cdr;
3514 $cdr_cust_pkg_usage->select_for_update;
3515 $old_cdr->select_for_update;
3516 $cust_pkg_usage->select_for_update;
3517 # in case someone else stole the usage from this CDR
3518 # while waiting for the lock...
3519 next if $old_cdr->acctid != $cdr_cust_pkg_usage->acctid;
3520 # steal the usage allocation and flag the old CDR for reprocessing
3521 $cdr_cust_pkg_usage->set('acctid', $cdr->acctid);
3522 # if the allocation is more minutes than we need, adjust it...
3523 my $delta = $cdr_cust_pkg_usage->minutes - $minutes;
3525 $cdr_cust_pkg_usage->set('minutes', $minutes);
3526 $cust_pkg_usage->set('minutes', $cust_pkg_usage->minutes + $delta);
3527 $error = $cust_pkg_usage->replace;
3529 #warn 'CDR '.$cdr->acctid . ' stealing allocation '.$cdr_cust_pkg_usage->cdrusagenum.' from CDR '.$old_cdr->acctid."\n";
3530 $error ||= $cdr_cust_pkg_usage->replace;
3531 # deduct the stolen minutes
3532 $minutes -= $cdr_cust_pkg_usage->minutes;
3534 # after all minute-stealing is done, reset the affected CDRs
3535 foreach (values %reproc_cdrs) {
3536 $error ||= $_->set_status('');
3537 # XXX or should we just call $cdr->rate right here?
3538 # it's not like we can create a loop this way, since the min_charge
3539 # or call time has to go monotonically in one direction.
3540 # we COULD get some very deep recursions going, though...
3542 } # if $order and $minutes
3545 die "error applying included minutes\npkgnum ".$self->pkgnum.", class $classnum, acctid ".$cdr->acctid."\n$error\n"
3547 $dbh->commit if $oldAutoCommit;
3548 return $orig_minutes - $minutes;
3552 =item supplemental_pkgs
3554 Returns a list of all packages supplemental to this one.
3558 sub supplemental_pkgs {
3560 qsearch('cust_pkg', { 'main_pkgnum' => $self->pkgnum });
3565 Returns the package that this one is supplemental to, if any.
3571 if ( $self->main_pkgnum ) {
3572 return FS::cust_pkg->by_key($self->main_pkgnum);
3579 =head1 CLASS METHODS
3585 Returns an SQL expression identifying recurring packages.
3589 sub recurring_sql { "
3590 '0' != ( select freq from part_pkg
3591 where cust_pkg.pkgpart = part_pkg.pkgpart )
3596 Returns an SQL expression identifying one-time packages.
3601 '0' = ( select freq from part_pkg
3602 where cust_pkg.pkgpart = part_pkg.pkgpart )
3607 Returns an SQL expression identifying ordered packages (recurring packages not
3613 $_[0]->recurring_sql. " AND ". $_[0]->not_yet_billed_sql;
3618 Returns an SQL expression identifying active packages.
3623 $_[0]->recurring_sql. "
3624 AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
3625 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
3626 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
3629 =item not_yet_billed_sql
3631 Returns an SQL expression identifying packages which have not yet been billed.
3635 sub not_yet_billed_sql { "
3636 ( cust_pkg.setup IS NULL OR cust_pkg.setup = 0 )
3637 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
3638 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
3643 Returns an SQL expression identifying inactive packages (one-time packages
3644 that are otherwise unsuspended/uncancelled).
3648 sub inactive_sql { "
3649 ". $_[0]->onetime_sql(). "
3650 AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
3651 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
3652 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
3658 Returns an SQL expression identifying suspended packages.
3662 sub suspended_sql { susp_sql(@_); }
3664 #$_[0]->recurring_sql(). ' AND '.
3666 ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
3667 AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0
3674 Returns an SQL exprression identifying cancelled packages.
3678 sub cancelled_sql { cancel_sql(@_); }
3680 #$_[0]->recurring_sql(). ' AND '.
3681 "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
3686 Returns an SQL expression to give the package status as a string.
3692 WHEN cust_pkg.cancel IS NOT NULL THEN 'cancelled'
3693 WHEN cust_pkg.susp IS NOT NULL THEN 'suspended'
3694 WHEN cust_pkg.setup IS NULL THEN 'not yet billed'
3695 WHEN ".onetime_sql()." THEN 'one-time charge'
3700 =item search HASHREF
3704 Returns a qsearch hash expression to search for parameters specified in HASHREF.
3705 Valid parameters are
3713 active, inactive, suspended, cancel (or cancelled)
3717 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
3721 boolean selects custom packages
3727 pkgpart or arrayref or hashref of pkgparts
3731 arrayref of beginning and ending epoch date
3735 arrayref of beginning and ending epoch date
3739 arrayref of beginning and ending epoch date
3743 arrayref of beginning and ending epoch date
3747 arrayref of beginning and ending epoch date
3751 arrayref of beginning and ending epoch date
3755 arrayref of beginning and ending epoch date
3759 pkgnum or APKG_pkgnum
3763 a value suited to passing to FS::UI::Web::cust_header
3767 specifies the user for agent virtualization
3771 boolean; if true, returns only packages with more than 0 FCC phone lines.
3773 =item state, country
3775 Limit to packages with a service location in the specified state and country.
3776 For FCC 477 reporting, mostly.
3783 my ($class, $params) = @_;
3790 if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
3792 "cust_main.agentnum = $1";
3799 if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
3801 "cust_pkg.custnum = $1";
3808 if ( $params->{'pkgbatch'} =~ /^([\w\/\-\:\.]+)$/ and $1 ) {
3810 "cust_pkg.pkgbatch = '$1'";
3817 if ( $params->{'magic'} eq 'active'
3818 || $params->{'status'} eq 'active' ) {
3820 push @where, FS::cust_pkg->active_sql();
3822 } elsif ( $params->{'magic'} =~ /^not[ _]yet[ _]billed$/
3823 || $params->{'status'} =~ /^not[ _]yet[ _]billed$/ ) {
3825 push @where, FS::cust_pkg->not_yet_billed_sql();
3827 } elsif ( $params->{'magic'} =~ /^(one-time charge|inactive)/
3828 || $params->{'status'} =~ /^(one-time charge|inactive)/ ) {
3830 push @where, FS::cust_pkg->inactive_sql();
3832 } elsif ( $params->{'magic'} eq 'suspended'
3833 || $params->{'status'} eq 'suspended' ) {
3835 push @where, FS::cust_pkg->suspended_sql();
3837 } elsif ( $params->{'magic'} =~ /^cancell?ed$/
3838 || $params->{'status'} =~ /^cancell?ed$/ ) {
3840 push @where, FS::cust_pkg->cancelled_sql();
3845 # parse package class
3848 if ( exists($params->{'classnum'}) ) {
3851 if ( ref($params->{'classnum'}) ) {
3853 if ( ref($params->{'classnum'}) eq 'HASH' ) {
3854 @classnum = grep $params->{'classnum'}{$_}, keys %{ $params->{'classnum'} };
3855 } elsif ( ref($params->{'classnum'}) eq 'ARRAY' ) {
3856 @classnum = @{ $params->{'classnum'} };
3858 die 'unhandled classnum ref '. $params->{'classnum'};
3862 } elsif ( $params->{'classnum'} =~ /^(\d*)$/ && $1 ne '0' ) {
3869 my @nums = grep $_, @classnum;
3870 push @c_where, 'part_pkg.classnum IN ('. join(',',@nums). ')' if @nums;
3871 my $null = scalar( grep { $_ eq '' } @classnum );
3872 push @c_where, 'part_pkg.classnum IS NULL' if $null;
3874 if ( scalar(@c_where) == 1 ) {
3875 push @where, @c_where;
3876 } elsif ( @c_where ) {
3877 push @where, ' ( '. join(' OR ', @c_where). ' ) ';
3886 # parse package report options
3889 my @report_option = ();
3890 if ( exists($params->{'report_option'}) ) {
3891 if ( ref($params->{'report_option'}) eq 'ARRAY' ) {
3892 @report_option = @{ $params->{'report_option'} };
3893 } elsif ( $params->{'report_option'} =~ /^([,\d]*)$/ ) {
3894 @report_option = split(',', $1);
3899 if (@report_option) {
3900 # this will result in the empty set for the dangling comma case as it should
3902 map{ "0 < ( SELECT count(*) FROM part_pkg_option
3903 WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
3904 AND optionname = 'report_option_$_'
3905 AND optionvalue = '1' )"
3909 foreach my $any ( grep /^report_option_any/, keys %$params ) {
3911 my @report_option_any = ();
3912 if ( ref($params->{$any}) eq 'ARRAY' ) {
3913 @report_option_any = @{ $params->{$any} };
3914 } elsif ( $params->{$any} =~ /^([,\d]*)$/ ) {
3915 @report_option_any = split(',', $1);
3918 if (@report_option_any) {
3919 # this will result in the empty set for the dangling comma case as it should
3920 push @where, ' ( '. join(' OR ',
3921 map{ "0 < ( SELECT count(*) FROM part_pkg_option
3922 WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
3923 AND optionname = 'report_option_$_'
3924 AND optionvalue = '1' )"
3925 } @report_option_any
3935 push @where, "part_pkg.custom = 'Y'" if $params->{custom};
3941 push @where, "(part_pkg.fcc_ds0s > 0 OR pkg_class.fcc_ds0s > 0)"
3942 if $params->{fcc_line};
3948 if ( exists($params->{'censustract'}) ) {
3949 $params->{'censustract'} =~ /^([.\d]*)$/;
3950 my $censustract = "cust_location.censustract = '$1'";
3951 $censustract .= ' OR cust_location.censustract is NULL' unless $1;
3952 push @where, "( $censustract )";
3956 # parse censustract2
3958 if ( exists($params->{'censustract2'})
3959 && $params->{'censustract2'} =~ /^(\d*)$/
3963 push @where, "cust_location.censustract LIKE '$1%'";
3966 "( cust_location.censustract = '' OR cust_location.censustract IS NULL )";
3971 # parse country/state
3973 for (qw(state country)) { # parsing rules are the same for these
3974 if ( exists($params->{$_})
3975 && uc($params->{$_}) =~ /^([A-Z]{2})$/ )
3977 # XXX post-2.3 only--before that, state/country may be in cust_main
3978 push @where, "cust_location.$_ = '$1'";
3986 if ( ref($params->{'pkgpart'}) ) {
3989 if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
3990 @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
3991 } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
3992 @pkgpart = @{ $params->{'pkgpart'} };
3994 die 'unhandled pkgpart ref '. $params->{'pkgpart'};
3997 @pkgpart = grep /^(\d+)$/, @pkgpart;
3999 push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
4001 } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
4002 push @where, "pkgpart = $1";
4011 #false laziness w/report_cust_pkg.html
4014 'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
4015 'active' => { 'susp'=>1, 'cancel'=>1 },
4016 'suspended' => { 'cancel' => 1 },
4021 if( exists($params->{'active'} ) ) {
4022 # This overrides all the other date-related fields
4023 my($beginning, $ending) = @{$params->{'active'}};
4025 "cust_pkg.setup IS NOT NULL",
4026 "cust_pkg.setup <= $ending",
4027 "(cust_pkg.cancel IS NULL OR cust_pkg.cancel >= $beginning )",
4028 "NOT (".FS::cust_pkg->onetime_sql . ")";
4031 foreach my $field (qw( setup last_bill bill adjourn susp expire contract_end change_date cancel )) {
4033 next unless exists($params->{$field});
4035 my($beginning, $ending) = @{$params->{$field}};
4037 next if $beginning == 0 && $ending == 4294967295;
4040 "cust_pkg.$field IS NOT NULL",
4041 "cust_pkg.$field >= $beginning",
4042 "cust_pkg.$field <= $ending";
4044 $orderby ||= "ORDER BY cust_pkg.$field";
4049 $orderby ||= 'ORDER BY bill';
4052 # parse magic, legacy, etc.
4055 if ( $params->{'magic'} &&
4056 $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
4059 $orderby = 'ORDER BY pkgnum';
4061 if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
4062 push @where, "pkgpart = $1";
4065 } elsif ( $params->{'query'} eq 'pkgnum' ) {
4067 $orderby = 'ORDER BY pkgnum';
4069 } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
4071 $orderby = 'ORDER BY pkgnum';
4074 SELECT count(*) FROM pkg_svc
4075 WHERE pkg_svc.pkgpart = cust_pkg.pkgpart
4076 AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
4077 WHERE cust_svc.pkgnum = cust_pkg.pkgnum
4078 AND cust_svc.svcpart = pkg_svc.svcpart
4085 # setup queries, links, subs, etc. for the search
4088 # here is the agent virtualization
4089 if ($params->{CurrentUser}) {
4091 qsearchs('access_user', { username => $params->{CurrentUser} });
4094 push @where, $access_user->agentnums_sql('table'=>'cust_main');
4099 push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
4102 my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
4104 my $addl_from = 'LEFT JOIN part_pkg USING ( pkgpart ) '.
4105 'LEFT JOIN pkg_class ON ( part_pkg.classnum = pkg_class.classnum ) '.
4106 'LEFT JOIN cust_location USING ( locationnum ) '.
4107 FS::UI::Web::join_cust_main('cust_pkg', 'cust_pkg');
4111 if ( $params->{'select_zip5'} ) {
4112 my $zip = 'cust_location.zip';
4114 $select = "DISTINCT substr($zip,1,5) as zip";
4115 $orderby = "ORDER BY substr($zip,1,5)";
4116 $count_query = "SELECT COUNT( DISTINCT substr($zip,1,5) )";
4118 $select = join(', ',
4120 ( map "part_pkg.$_", qw( pkg freq ) ),
4121 'pkg_class.classname',
4122 'cust_main.custnum AS cust_main_custnum',
4123 FS::UI::Web::cust_sql_fields(
4124 $params->{'cust_fields'}
4127 $count_query = 'SELECT COUNT(*)';
4130 $count_query .= " FROM cust_pkg $addl_from $extra_sql";
4133 'table' => 'cust_pkg',
4135 'select' => $select,
4136 'extra_sql' => $extra_sql,
4137 'order_by' => $orderby,
4138 'addl_from' => $addl_from,
4139 'count_query' => $count_query,
4146 Returns a list of two package counts. The first is a count of packages
4147 based on the supplied criteria and the second is the count of residential
4148 packages with those same criteria. Criteria are specified as in the search
4154 my ($class, $params) = @_;
4156 my $sql_query = $class->search( $params );
4158 my $count_sql = delete($sql_query->{'count_query'});
4159 $count_sql =~ s/ FROM/,count(CASE WHEN cust_main.company IS NULL OR cust_main.company = '' THEN 1 END) FROM/
4160 or die "couldn't parse count_sql";
4162 my $count_sth = dbh->prepare($count_sql)
4163 or die "Error preparing $count_sql: ". dbh->errstr;
4165 or die "Error executing $count_sql: ". $count_sth->errstr;
4166 my $count_arrayref = $count_sth->fetchrow_arrayref;
4168 return ( @$count_arrayref );
4172 =item tax_locationnum_sql
4174 Returns an SQL expression for the tax location for a package, based
4175 on the settings of 'tax-pkg_address' and 'tax-ship_address'.
4179 sub tax_locationnum_sql {
4180 my $conf = FS::Conf->new;
4181 if ( $conf->exists('tax-pkg_address') ) {
4182 'cust_pkg.locationnum';
4184 elsif ( $conf->exists('tax-ship_address') ) {
4185 'cust_main.ship_locationnum';
4188 'cust_main.bill_locationnum';
4194 Returns a list: the first item is an SQL fragment identifying matching
4195 packages/customers via location (taking into account shipping and package
4196 address taxation, if enabled), and subsequent items are the parameters to
4197 substitute for the placeholders in that fragment.
4202 my($class, %opt) = @_;
4203 my $ornull = $opt{'ornull'};
4205 my $conf = new FS::Conf;
4207 # '?' placeholders in _location_sql_where
4208 my $x = $ornull ? 3 : 2;
4219 if ( $conf->exists('tax-ship_address') ) {
4222 ( ( ship_last IS NULL OR ship_last = '' )
4223 AND ". _location_sql_where('cust_main', '', $ornull ). "
4225 OR ( ship_last IS NOT NULL AND ship_last != ''
4226 AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
4229 # AND payby != 'COMP'
4231 @main_param = ( @bill_param, @bill_param );
4235 $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
4236 @main_param = @bill_param;
4242 if ( $conf->exists('tax-pkg_address') ) {
4244 my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
4247 ( cust_pkg.locationnum IS NULL AND $main_where )
4248 OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where )
4251 @param = ( @main_param, @bill_param );
4255 $where = $main_where;
4256 @param = @main_param;
4264 #subroutine, helper for location_sql
4265 sub _location_sql_where {
4267 my $prefix = @_ ? shift : '';
4268 my $ornull = @_ ? shift : '';
4270 # $ornull = $ornull ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
4272 $ornull = $ornull ? ' OR ? IS NULL ' : '';
4274 my $or_empty_city = " OR ( ? = '' AND $table.${prefix}city IS NULL )";
4275 my $or_empty_county = " OR ( ? = '' AND $table.${prefix}county IS NULL )";
4276 my $or_empty_state = " OR ( ? = '' AND $table.${prefix}state IS NULL )";
4278 my $text = (driver_name =~ /^mysql/i) ? 'char' : 'text';
4280 # ( $table.${prefix}city = ? $or_empty_city $ornull )
4282 ( $table.district = ? OR ? = '' OR CAST(? AS $text) IS NULL )
4283 AND ( $table.${prefix}city = ? OR ? = '' OR CAST(? AS $text) IS NULL )
4284 AND ( $table.${prefix}county = ? $or_empty_county $ornull )
4285 AND ( $table.${prefix}state = ? $or_empty_state $ornull )
4286 AND $table.${prefix}country = ?
4291 my( $self, $what ) = @_;
4293 my $what_show_zero = $what. '_show_zero';
4294 length($self->$what_show_zero())
4295 ? ($self->$what_show_zero() eq 'Y')
4296 : $self->part_pkg->$what_show_zero();
4303 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
4305 CUSTNUM is a customer (see L<FS::cust_main>)
4307 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
4308 L<FS::part_pkg>) to order for this customer. Duplicates are of course
4311 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
4312 remove for this customer. The services (see L<FS::cust_svc>) are moved to the
4313 new billing items. An error is returned if this is not possible (see
4314 L<FS::pkg_svc>). An empty arrayref is equivalent to not specifying this
4317 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
4318 newly-created cust_pkg objects.
4320 REFNUM, if specified, will specify the FS::pkg_referral record to be created
4321 and inserted. Multiple FS::pkg_referral records can be created by
4322 setting I<refnum> to an array reference of refnums or a hash reference with
4323 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
4324 record will be created corresponding to cust_main.refnum.
4329 my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
4331 my $conf = new FS::Conf;
4333 # Transactionize this whole mess
4334 local $SIG{HUP} = 'IGNORE';
4335 local $SIG{INT} = 'IGNORE';
4336 local $SIG{QUIT} = 'IGNORE';
4337 local $SIG{TERM} = 'IGNORE';
4338 local $SIG{TSTP} = 'IGNORE';
4339 local $SIG{PIPE} = 'IGNORE';
4341 my $oldAutoCommit = $FS::UID::AutoCommit;
4342 local $FS::UID::AutoCommit = 0;
4346 # my $cust_main = qsearchs('cust_main', { custnum => $custnum });
4347 # return "Customer not found: $custnum" unless $cust_main;
4349 warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
4352 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
4355 my $change = scalar(@old_cust_pkg) != 0;
4358 if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
4360 warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
4361 " to pkgpart ". $pkgparts->[0]. "\n"
4364 my $err_or_cust_pkg =
4365 $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
4366 'refnum' => $refnum,
4369 unless (ref($err_or_cust_pkg)) {
4370 $dbh->rollback if $oldAutoCommit;
4371 return $err_or_cust_pkg;
4374 push @$return_cust_pkg, $err_or_cust_pkg;
4375 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4380 # Create the new packages.
4381 foreach my $pkgpart (@$pkgparts) {
4383 warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
4385 my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
4386 pkgpart => $pkgpart,
4390 $error = $cust_pkg->insert( 'change' => $change );
4391 push @$return_cust_pkg, $cust_pkg;
4393 foreach my $link ($cust_pkg->part_pkg->supp_part_pkg_link) {
4394 my $supp_pkg = FS::cust_pkg->new({
4395 custnum => $custnum,
4396 pkgpart => $link->dst_pkgpart,
4398 main_pkgnum => $cust_pkg->pkgnum,
4401 $error ||= $supp_pkg->insert( 'change' => $change );
4402 push @$return_cust_pkg, $supp_pkg;
4406 $dbh->rollback if $oldAutoCommit;
4411 # $return_cust_pkg now contains refs to all of the newly
4414 # Transfer services and cancel old packages.
4415 foreach my $old_pkg (@old_cust_pkg) {
4417 warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
4420 foreach my $new_pkg (@$return_cust_pkg) {
4421 $error = $old_pkg->transfer($new_pkg);
4422 if ($error and $error == 0) {
4423 # $old_pkg->transfer failed.
4424 $dbh->rollback if $oldAutoCommit;
4429 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
4430 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
4431 foreach my $new_pkg (@$return_cust_pkg) {
4432 $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
4433 if ($error and $error == 0) {
4434 # $old_pkg->transfer failed.
4435 $dbh->rollback if $oldAutoCommit;
4442 # Transfers were successful, but we went through all of the
4443 # new packages and still had services left on the old package.
4444 # We can't cancel the package under the circumstances, so abort.
4445 $dbh->rollback if $oldAutoCommit;
4446 return "Unable to transfer all services from package ".$old_pkg->pkgnum;
4448 $error = $old_pkg->cancel( quiet=>1 );
4454 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4458 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
4460 A bulk change method to change packages for multiple customers.
4462 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
4463 L<FS::part_pkg>) to order for each customer. Duplicates are of course
4466 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
4467 replace. The services (see L<FS::cust_svc>) are moved to the
4468 new billing items. An error is returned if this is not possible (see
4471 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
4472 newly-created cust_pkg objects.
4477 my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
4479 # Transactionize this whole mess
4480 local $SIG{HUP} = 'IGNORE';
4481 local $SIG{INT} = 'IGNORE';
4482 local $SIG{QUIT} = 'IGNORE';
4483 local $SIG{TERM} = 'IGNORE';
4484 local $SIG{TSTP} = 'IGNORE';
4485 local $SIG{PIPE} = 'IGNORE';
4487 my $oldAutoCommit = $FS::UID::AutoCommit;
4488 local $FS::UID::AutoCommit = 0;
4492 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
4495 while(scalar(@old_cust_pkg)) {
4497 my $custnum = $old_cust_pkg[0]->custnum;
4498 my (@remove) = map { $_->pkgnum }
4499 grep { $_->custnum == $custnum } @old_cust_pkg;
4500 @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
4502 my $error = order $custnum, $pkgparts, \@remove, \@return;
4504 push @errors, $error
4506 push @$return_cust_pkg, @return;
4509 if (scalar(@errors)) {
4510 $dbh->rollback if $oldAutoCommit;
4511 return join(' / ', @errors);
4514 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4518 # Used by FS::Upgrade to migrate to a new database.
4519 sub _upgrade_data { # class method
4520 my ($class, %opts) = @_;
4521 $class->_upgrade_otaker(%opts);
4523 # RT#10139, bug resulting in contract_end being set when it shouldn't
4524 'UPDATE cust_pkg SET contract_end = NULL WHERE contract_end = -1',
4525 # RT#10830, bad calculation of prorate date near end of year
4526 # the date range for bill is December 2009, and we move it forward
4527 # one year if it's before the previous bill date (which it should
4529 'UPDATE cust_pkg SET bill = bill + (365*24*60*60) WHERE bill < last_bill
4530 AND bill > 1259654400 AND bill < 1262332800 AND (SELECT plan FROM part_pkg
4531 WHERE part_pkg.pkgpart = cust_pkg.pkgpart) = \'prorate\'',
4532 # RT6628, add order_date to cust_pkg
4533 'update cust_pkg set order_date = (select history_date from h_cust_pkg
4534 where h_cust_pkg.pkgnum = cust_pkg.pkgnum and
4535 history_action = \'insert\') where order_date is null',
4537 foreach my $sql (@statements) {
4538 my $sth = dbh->prepare($sql);
4539 $sth->execute or die $sth->errstr;
4547 sub order is not OO. Perhaps it should be moved to FS::cust_main and made so?
4549 In sub order, the @pkgparts array (passed by reference) is clobbered.
4551 Also in sub order, no money is adjusted. Once FS::part_pkg defines a standard
4552 method to pass dates to the recur_prog expression, it should do so.
4554 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
4555 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
4556 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
4557 configuration values. Probably need a subroutine which decides what to do
4558 based on whether or not we've fetched the user yet, rather than a hash. See
4559 FS::UID and the TODO.
4561 Now that things are transactional should the check in the insert method be
4566 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
4567 L<FS::pkg_svc>, schema.html from the base documentation