2 use base qw( FS::otaker_Mixin FS::cust_main_Mixin FS::Sales_Mixin
3 FS::contact_Mixin FS::location_Mixin
4 FS::m2m_Common FS::option_Common );
8 use Scalar::Util qw( blessed );
9 use List::Util qw(min max);
11 use Time::Local qw( timelocal timelocal_nocheck );
13 use FS::UID qw( dbh driver_name );
14 use FS::Misc qw( send_email );
15 use FS::Record qw( qsearch qsearchs fields );
21 use FS::cust_location;
23 use FS::cust_bill_pkg;
24 use FS::cust_pkg_detail;
25 use FS::cust_pkg_usage;
26 use FS::cdr_cust_pkg_usage;
31 use FS::cust_pkg_reason;
33 use FS::cust_pkg_discount;
40 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
42 # because they load configuration by setting FS::UID::callback (see TODO)
48 # for sending cancel emails in sub cancel
51 our ($disable_agentcheck, $DEBUG, $me) = (0, 0, '[FS::cust_pkg]');
55 my ( $hashref, $cache ) = @_;
56 #if ( $hashref->{'pkgpart'} ) {
57 if ( $hashref->{'pkg'} ) {
58 # #@{ $self->{'_pkgnum'} } = ();
59 # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
60 # $self->{'_pkgpart'} = $subcache;
61 # #push @{ $self->{'_pkgnum'} },
62 # FS::part_pkg->new_or_cached($hashref, $subcache);
63 $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
65 if ( exists $hashref->{'svcnum'} ) {
66 #@{ $self->{'_pkgnum'} } = ();
67 my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
68 $self->{'_svcnum'} = $subcache;
69 #push @{ $self->{'_pkgnum'} },
70 FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
76 FS::cust_pkg - Object methods for cust_pkg objects
82 $record = new FS::cust_pkg \%hash;
83 $record = new FS::cust_pkg { 'column' => 'value' };
85 $error = $record->insert;
87 $error = $new_record->replace($old_record);
89 $error = $record->delete;
91 $error = $record->check;
93 $error = $record->cancel;
95 $error = $record->suspend;
97 $error = $record->unsuspend;
99 $part_pkg = $record->part_pkg;
101 @labels = $record->labels;
103 $seconds = $record->seconds_since($timestamp);
105 $error = FS::cust_pkg::order( $custnum, \@pkgparts );
106 $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
110 An FS::cust_pkg object represents a customer billing item. FS::cust_pkg
111 inherits from FS::Record. The following fields are currently supported:
117 Primary key (assigned automatically for new billing items)
121 Customer (see L<FS::cust_main>)
125 Billing item definition (see L<FS::part_pkg>)
129 Optional link to package location (see L<FS::location>)
133 date package was ordered (also remains same on changes)
145 date (next bill date)
173 order taker (see L<FS::access_user>)
177 If this field is set to 1, disables the automatic
178 unsuspension of this package when using the B<unsuspendauto> config option.
182 If not set, defaults to 1
186 Date of change from previous package
196 =item change_locationnum
204 The pkgnum of the package that this package is supplemental to, if any.
208 The package link (L<FS::part_pkg_link>) that defines this supplemental
209 package, if it is one.
211 =item change_to_pkgnum
213 The pkgnum of the package this one will be "changed to" in the future
214 (on its expiration date).
218 Note: setup, last_bill, bill, adjourn, susp, expire, cancel and change_date
219 are specified as UNIX timestamps; see L<perlfunc/"time">. Also see
220 L<Time::Local> and L<Date::Parse> for conversion functions.
228 Create a new billing item. To add the item to the database, see L<"insert">.
232 sub table { 'cust_pkg'; }
233 sub cust_linked { $_[0]->cust_main_custnum || $_[0]->custnum }
234 sub cust_unlinked_msg {
236 "WARNING: can't find cust_main.custnum ". $self->custnum.
237 ' (cust_pkg.pkgnum '. $self->pkgnum. ')';
240 =item insert [ OPTION => VALUE ... ]
242 Adds this billing item to the database ("Orders" the item). If there is an
243 error, returns the error, otherwise returns false.
245 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
246 will be used to look up the package definition and agent restrictions will be
249 If the additional field I<refnum> is defined, an FS::pkg_referral record will
250 be created and inserted. Multiple FS::pkg_referral records can be created by
251 setting I<refnum> to an array reference of refnums or a hash reference with
252 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
253 record will be created corresponding to cust_main.refnum.
255 The following options are available:
261 If set true, supresses actions that should only be taken for new package
262 orders. (Currently this includes: intro periods when delay_setup is on.)
266 cust_pkg_option records will be created
270 a ticket will be added to this customer with this subject
274 an optional queue name for ticket additions
278 Don't check the legality of the package definition. This should be used
279 when performing a package change that doesn't change the pkgpart (i.e.
287 my( $self, %options ) = @_;
290 $error = $self->check_pkgpart unless $options{'allow_pkgpart'};
291 return $error if $error;
293 my $part_pkg = $self->part_pkg;
295 if (! $options{'import'}) {
296 # if the package def says to start only on the first of the month:
297 if ( $part_pkg->option('start_1st', 1) && !$self->start_date ) {
298 my ($sec,$min,$hour,$mday,$mon,$year) = (localtime(time) )[0,1,2,3,4,5];
299 $mon += 1 unless $mday == 1;
300 until ( $mon < 12 ) { $mon -= 12; $year++; }
301 $self->start_date( timelocal_nocheck(0,0,0,1,$mon,$year) );
304 # set up any automatic expire/adjourn/contract_end timers
305 # based on the start date
306 foreach my $action ( qw(expire adjourn contract_end) ) {
307 my $months = $part_pkg->option("${action}_months",1);
308 if($months and !$self->$action) {
309 my $start = $self->start_date || $self->setup || time;
310 $self->$action( $part_pkg->add_freq($start, $months) );
314 # if this package has "free days" and delayed setup fee, tehn
315 # set start date that many days in the future.
316 # (this should have been set in the UI, but enforce it here)
317 if ( ! $options{'change'}
318 && ( my $free_days = $part_pkg->option('free_days',1) )
319 && $part_pkg->option('delay_setup',1)
320 #&& ! $self->start_date
323 $self->start_date( $part_pkg->default_start_date );
327 # set order date unless it was specified as part of an import
328 $self->order_date(time) unless $options{'import'} && $self->order_date;
330 local $SIG{HUP} = 'IGNORE';
331 local $SIG{INT} = 'IGNORE';
332 local $SIG{QUIT} = 'IGNORE';
333 local $SIG{TERM} = 'IGNORE';
334 local $SIG{TSTP} = 'IGNORE';
335 local $SIG{PIPE} = 'IGNORE';
337 my $oldAutoCommit = $FS::UID::AutoCommit;
338 local $FS::UID::AutoCommit = 0;
341 $error = $self->SUPER::insert($options{options} ? %{$options{options}} : ());
343 $dbh->rollback if $oldAutoCommit;
347 $self->refnum($self->cust_main->refnum) unless $self->refnum;
348 $self->refnum( [ $self->refnum ] ) unless ref($self->refnum);
349 $self->process_m2m( 'link_table' => 'pkg_referral',
350 'target_table' => 'part_referral',
351 'params' => $self->refnum,
354 if ( $self->discountnum ) {
355 my $error = $self->insert_discount();
357 $dbh->rollback if $oldAutoCommit;
362 my $conf = new FS::Conf;
364 if ( ! $options{'import'} && $conf->config('ticket_system') && $options{ticket_subject} ) {
366 #this init stuff is still inefficient, but at least its limited to
367 # the small number (any?) folks using ticket emailing on pkg order
370 # use lib ( "/opt/rt3/local/lib", "/opt/rt3/lib" );
377 use FS::TicketSystem;
378 FS::TicketSystem->init();
380 my $q = new RT::Queue($RT::SystemUser);
381 $q->Load($options{ticket_queue}) if $options{ticket_queue};
382 my $t = new RT::Ticket($RT::SystemUser);
383 my $mime = new MIME::Entity;
384 $mime->build( Type => 'text/plain', Data => $options{ticket_subject} );
385 $t->Create( $options{ticket_queue} ? (Queue => $q) : (),
386 Subject => $options{ticket_subject},
389 $t->AddLink( Type => 'MemberOf',
390 Target => 'freeside://freeside/cust_main/'. $self->custnum,
394 if (! $options{'import'} && $conf->config('welcome_letter') && $self->cust_main->num_pkgs == 1) {
395 my $queue = new FS::queue {
396 'job' => 'FS::cust_main::queueable_print',
398 $error = $queue->insert(
399 'custnum' => $self->custnum,
400 'template' => 'welcome_letter',
404 warn "can't send welcome letter: $error";
409 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
416 This method now works but you probably shouldn't use it.
418 You don't want to delete packages, because there would then be no record
419 the customer ever purchased the package. Instead, see the cancel method and
420 hide cancelled packages.
427 local $SIG{HUP} = 'IGNORE';
428 local $SIG{INT} = 'IGNORE';
429 local $SIG{QUIT} = 'IGNORE';
430 local $SIG{TERM} = 'IGNORE';
431 local $SIG{TSTP} = 'IGNORE';
432 local $SIG{PIPE} = 'IGNORE';
434 my $oldAutoCommit = $FS::UID::AutoCommit;
435 local $FS::UID::AutoCommit = 0;
438 foreach my $cust_pkg_discount ($self->cust_pkg_discount) {
439 my $error = $cust_pkg_discount->delete;
441 $dbh->rollback if $oldAutoCommit;
445 #cust_bill_pkg_discount?
447 foreach my $cust_pkg_detail ($self->cust_pkg_detail) {
448 my $error = $cust_pkg_detail->delete;
450 $dbh->rollback if $oldAutoCommit;
455 foreach my $cust_pkg_reason (
457 'table' => 'cust_pkg_reason',
458 'hashref' => { 'pkgnum' => $self->pkgnum },
462 my $error = $cust_pkg_reason->delete;
464 $dbh->rollback if $oldAutoCommit;
471 my $error = $self->SUPER::delete(@_);
473 $dbh->rollback if $oldAutoCommit;
477 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
483 =item replace [ OLD_RECORD ] [ HASHREF | OPTION => VALUE ... ]
485 Replaces the OLD_RECORD with this one in the database. If there is an error,
486 returns the error, otherwise returns false.
488 Currently, custnum, setup, bill, adjourn, susp, expire, and cancel may be changed.
490 Changing pkgpart may have disasterous effects. See the order subroutine.
492 setup and bill are normally updated by calling the bill method of a customer
493 object (see L<FS::cust_main>).
495 suspend is normally updated by the suspend and unsuspend methods.
497 cancel is normally updated by the cancel method (and also the order subroutine
500 Available options are:
506 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.
510 the access_user (see L<FS::access_user>) providing the reason
514 hashref of keys and values - cust_pkg_option records will be created, updated or removed as appopriate
523 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
528 ( ref($_[0]) eq 'HASH' )
532 #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
533 #return "Can't change otaker!" if $old->otaker ne $new->otaker;
536 #return "Can't change setup once it exists!"
537 # if $old->getfield('setup') &&
538 # $old->getfield('setup') != $new->getfield('setup');
540 #some logic for bill, susp, cancel?
542 local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
544 local $SIG{HUP} = 'IGNORE';
545 local $SIG{INT} = 'IGNORE';
546 local $SIG{QUIT} = 'IGNORE';
547 local $SIG{TERM} = 'IGNORE';
548 local $SIG{TSTP} = 'IGNORE';
549 local $SIG{PIPE} = 'IGNORE';
551 my $oldAutoCommit = $FS::UID::AutoCommit;
552 local $FS::UID::AutoCommit = 0;
555 foreach my $method ( qw(adjourn expire) ) { # How many reasons?
556 if ($options->{'reason'} && $new->$method && $old->$method ne $new->$method) {
557 my $error = $new->insert_reason(
558 'reason' => $options->{'reason'},
559 'date' => $new->$method,
561 'reason_otaker' => $options->{'reason_otaker'},
564 dbh->rollback if $oldAutoCommit;
565 return "Error inserting cust_pkg_reason: $error";
570 #save off and freeze RADIUS attributes for any associated svc_acct records
572 if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
574 #also check for specific exports?
575 # to avoid spurious modify export events
576 @svc_acct = map { $_->svc_x }
577 grep { $_->part_svc->svcdb eq 'svc_acct' }
580 $_->snapshot foreach @svc_acct;
584 my $error = $new->export_pkg_change($old)
585 || $new->SUPER::replace( $old,
587 ? $options->{options}
591 $dbh->rollback if $oldAutoCommit;
595 #for prepaid packages,
596 #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
597 foreach my $old_svc_acct ( @svc_acct ) {
598 my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
600 $new_svc_acct->replace( $old_svc_acct,
601 'depend_jobnum' => $options->{depend_jobnum},
604 $dbh->rollback if $oldAutoCommit;
609 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
616 Checks all fields to make sure this is a valid billing item. If there is an
617 error, returns the error, otherwise returns false. Called by the insert and
625 if ( !$self->locationnum or $self->locationnum == -1 ) {
626 $self->set('locationnum', $self->cust_main->ship_locationnum);
630 $self->ut_numbern('pkgnum')
631 || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
632 || $self->ut_numbern('pkgpart')
633 || $self->ut_foreign_keyn('contactnum', 'contact', 'contactnum' )
634 || $self->ut_foreign_keyn('locationnum', 'cust_location', 'locationnum')
635 || $self->ut_foreign_keyn('salesnum', 'sales', 'salesnum')
636 || $self->ut_numbern('quantity')
637 || $self->ut_numbern('start_date')
638 || $self->ut_numbern('setup')
639 || $self->ut_numbern('bill')
640 || $self->ut_numbern('susp')
641 || $self->ut_numbern('cancel')
642 || $self->ut_numbern('adjourn')
643 || $self->ut_numbern('resume')
644 || $self->ut_numbern('expire')
645 || $self->ut_numbern('dundate')
646 || $self->ut_enum('no_auto', [ '', 'Y' ])
647 || $self->ut_enum('waive_setup', [ '', 'Y' ])
648 || $self->ut_numbern('agent_pkgid')
649 || $self->ut_enum('recur_show_zero', [ '', 'Y', 'N', ])
650 || $self->ut_enum('setup_show_zero', [ '', 'Y', 'N', ])
651 || $self->ut_foreign_keyn('main_pkgnum', 'cust_pkg', 'pkgnum')
652 || $self->ut_foreign_keyn('pkglinknum', 'part_pkg_link', 'pkglinknum')
653 || $self->ut_foreign_keyn('change_to_pkgnum', 'cust_pkg', 'pkgnum')
655 return $error if $error;
657 return "A package with both start date (future start) and setup date (already started) will never bill"
658 if $self->start_date && $self->setup;
660 return "A future unsuspend date can only be set for a package with a suspend date"
661 if $self->resume and !$self->susp and !$self->adjourn;
663 $self->usernum($FS::CurrentUser::CurrentUser->usernum) unless $self->usernum;
665 if ( $self->dbdef_table->column('manual_flag') ) {
666 $self->manual_flag('') if $self->manual_flag eq ' ';
667 $self->manual_flag =~ /^([01]?)$/
668 or return "Illegal manual_flag ". $self->manual_flag;
669 $self->manual_flag($1);
677 Check the pkgpart to make sure it's allowed with the reg_code and/or
678 promo_code of the package (if present) and with the customer's agent.
679 Called from C<insert>, unless we are doing a package change that doesn't
687 # my $error = $self->ut_numbern('pkgpart'); # already done
690 if ( $self->reg_code ) {
692 unless ( grep { $self->pkgpart == $_->pkgpart }
693 map { $_->reg_code_pkg }
694 qsearchs( 'reg_code', { 'code' => $self->reg_code,
695 'agentnum' => $self->cust_main->agentnum })
697 return "Unknown registration code";
700 } elsif ( $self->promo_code ) {
703 qsearchs('part_pkg', {
704 'pkgpart' => $self->pkgpart,
705 'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
707 return 'Unknown promotional code' unless $promo_part_pkg;
711 unless ( $disable_agentcheck ) {
713 qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
714 return "agent ". $agent->agentnum. ':'. $agent->agent.
715 " can't purchase pkgpart ". $self->pkgpart
716 unless $agent->pkgpart_hashref->{ $self->pkgpart }
717 || $agent->agentnum == $self->part_pkg->agentnum;
720 $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
721 return $error if $error;
729 =item cancel [ OPTION => VALUE ... ]
731 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
732 in this package, then cancels the package itself (sets the cancel field to
735 Available options are:
739 =item quiet - can be set true to supress email cancellation notices.
741 =item time - can be set to cancel the package based on a specific future or
742 historical date. Using time ensures that the remaining amount is calculated
743 correctly. Note however that this is an immediate cancel and just changes
744 the date. You are PROBABLY looking to expire the account instead of using
747 =item reason - can be set to a cancellation reason (see L<FS:reason>),
748 either a reasonnum of an existing reason, or passing a hashref will create
749 a new reason. The hashref should have the following keys: typenum - Reason
750 type (see L<FS::reason_type>, reason - Text of the new reason.
752 =item date - can be set to a unix style timestamp to specify when to
755 =item nobill - can be set true to skip billing if it might otherwise be done.
757 =item unused_credit - can be set to 1 to credit the remaining time, or 0 to
758 not credit it. This must be set (by change()) when changing the package
759 to a different pkgpart or location, and probably shouldn't be in any other
760 case. If it's not set, the 'unused_credit_cancel' part_pkg option will
765 If there is an error, returns the error, otherwise returns false.
770 my( $self, %options ) = @_;
773 # pass all suspend/cancel actions to the main package
774 if ( $self->main_pkgnum and !$options{'from_main'} ) {
775 return $self->main_pkg->cancel(%options);
778 my $conf = new FS::Conf;
780 warn "cust_pkg::cancel called with options".
781 join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
784 local $SIG{HUP} = 'IGNORE';
785 local $SIG{INT} = 'IGNORE';
786 local $SIG{QUIT} = 'IGNORE';
787 local $SIG{TERM} = 'IGNORE';
788 local $SIG{TSTP} = 'IGNORE';
789 local $SIG{PIPE} = 'IGNORE';
791 my $oldAutoCommit = $FS::UID::AutoCommit;
792 local $FS::UID::AutoCommit = 0;
795 my $old = $self->select_for_update;
797 if ( $old->get('cancel') || $self->get('cancel') ) {
798 dbh->rollback if $oldAutoCommit;
799 return ""; # no error
802 # XXX possibly set cancel_time to the expire date?
803 my $cancel_time = $options{'time'} || time;
804 my $date = $options{'date'} if $options{'date'}; # expire/cancel later
805 $date = '' if ($date && $date <= $cancel_time); # complain instead?
807 #race condition: usage could be ongoing until unprovisioned
808 #resolved by performing a change package instead (which unprovisions) and
810 if ( !$options{nobill} && !$date ) {
811 # && $conf->exists('bill_usage_on_cancel') ) { #calc_cancel checks this
812 my $copy = $self->new({$self->hash});
814 $copy->cust_main->bill( 'pkg_list' => [ $copy ],
816 'time' => $cancel_time );
817 warn "Error billing during cancel, custnum ".
818 #$self->cust_main->custnum. ": $error"
823 if ( $options{'reason'} ) {
824 $error = $self->insert_reason( 'reason' => $options{'reason'},
825 'action' => $date ? 'expire' : 'cancel',
826 'date' => $date ? $date : $cancel_time,
827 'reason_otaker' => $options{'reason_otaker'},
830 dbh->rollback if $oldAutoCommit;
831 return "Error inserting cust_pkg_reason: $error";
835 my %svc_cancel_opt = ();
836 $svc_cancel_opt{'date'} = $date if $date;
837 foreach my $cust_svc (
840 sort { $a->[1] <=> $b->[1] }
841 map { [ $_, $_->svc_x ? $_->svc_x->table_info->{'cancel_weight'} : -1 ]; }
842 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
844 my $part_svc = $cust_svc->part_svc;
845 next if ( defined($part_svc) and $part_svc->preserve );
846 my $error = $cust_svc->cancel( %svc_cancel_opt );
849 $dbh->rollback if $oldAutoCommit;
850 return 'Error '. ($svc_cancel_opt{'date'} ? 'expiring' : 'canceling' ).
856 # credit remaining time if appropriate
858 if ( exists($options{'unused_credit'}) ) {
859 $do_credit = $options{'unused_credit'};
862 $do_credit = $self->part_pkg->option('unused_credit_cancel', 1);
865 my $error = $self->credit_remaining('cancel', $cancel_time);
867 $dbh->rollback if $oldAutoCommit;
874 my %hash = $self->hash;
876 $hash{'expire'} = $date;
878 $hash{'cancel'} = $cancel_time;
880 $hash{'change_custnum'} = $options{'change_custnum'};
882 my $new = new FS::cust_pkg ( \%hash );
883 $error = $new->replace( $self, options => { $self->options } );
884 if ( $self->change_to_pkgnum ) {
885 my $change_to = FS::cust_pkg->by_key($self->change_to_pkgnum);
886 $error ||= $change_to->cancel || $change_to->delete;
889 $dbh->rollback if $oldAutoCommit;
893 foreach my $supp_pkg ( $self->supplemental_pkgs ) {
894 $error = $supp_pkg->cancel(%options, 'from_main' => 1);
896 $dbh->rollback if $oldAutoCommit;
897 return "canceling supplemental pkg#".$supp_pkg->pkgnum.": $error";
901 foreach my $usage ( $self->cust_pkg_usage ) {
902 $error = $usage->delete;
904 $dbh->rollback if $oldAutoCommit;
905 return "deleting usage pools: $error";
909 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
910 return '' if $date; #no errors
912 my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
913 if ( !$options{'quiet'} &&
914 $conf->exists('emailcancel', $self->cust_main->agentnum) &&
916 my $msgnum = $conf->config('cancel_msgnum', $self->cust_main->agentnum);
919 my $msg_template = qsearchs('msg_template', { msgnum => $msgnum });
920 $error = $msg_template->send( 'cust_main' => $self->cust_main,
925 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
926 'to' => \@invoicing_list,
927 'subject' => ( $conf->config('cancelsubject') || 'Cancellation Notice' ),
928 'body' => [ map "$_\n", $conf->config('cancelmessage') ],
931 #should this do something on errors?
938 =item cancel_if_expired [ NOW_TIMESTAMP ]
940 Cancels this package if its expire date has been reached.
944 sub cancel_if_expired {
946 my $time = shift || time;
947 return '' unless $self->expire && $self->expire <= $time;
948 my $error = $self->cancel;
950 return "Error cancelling expired pkg ". $self->pkgnum. " for custnum ".
951 $self->custnum. ": $error";
958 "Un-cancels" this package: Orders a new package with the same custnum, pkgpart,
959 locationnum, (other fields?). Attempts to re-provision cancelled services
960 using history information (errors at this stage are not fatal).
962 cust_pkg: pass a scalar reference, will be filled in with the new cust_pkg object
964 svc_fatal: service provisioning errors are fatal
966 svc_errors: pass an array reference, will be filled in with any provisioning errors
968 main_pkgnum: link the package as a supplemental package of this one. For
974 my( $self, %options ) = @_;
976 #in case you try do do $uncancel-date = $cust_pkg->uncacel
977 return '' unless $self->get('cancel');
979 if ( $self->main_pkgnum and !$options{'main_pkgnum'} ) {
980 return $self->main_pkg->uncancel(%options);
987 local $SIG{HUP} = 'IGNORE';
988 local $SIG{INT} = 'IGNORE';
989 local $SIG{QUIT} = 'IGNORE';
990 local $SIG{TERM} = 'IGNORE';
991 local $SIG{TSTP} = 'IGNORE';
992 local $SIG{PIPE} = 'IGNORE';
994 my $oldAutoCommit = $FS::UID::AutoCommit;
995 local $FS::UID::AutoCommit = 0;
999 # insert the new package
1002 my $cust_pkg = new FS::cust_pkg {
1003 last_bill => ( $options{'last_bill'} || $self->get('last_bill') ),
1004 bill => ( $options{'bill'} || $self->get('bill') ),
1006 uncancel_pkgnum => $self->pkgnum,
1007 main_pkgnum => ($options{'main_pkgnum'} || ''),
1008 map { $_ => $self->get($_) } qw(
1009 custnum pkgpart locationnum
1011 susp adjourn resume expire start_date contract_end dundate
1012 change_date change_pkgpart change_locationnum
1013 manual_flag no_auto quantity agent_pkgid recur_show_zero setup_show_zero
1017 my $error = $cust_pkg->insert(
1018 'change' => 1, #supresses any referral credit to a referring customer
1019 'allow_pkgpart' => 1, # allow this even if the package def is disabled
1022 $dbh->rollback if $oldAutoCommit;
1030 #find historical services within this timeframe before the package cancel
1031 # (incompatible with "time" option to cust_pkg->cancel?)
1032 my $fuzz = 2 * 60; #2 minutes? too much? (might catch separate unprovision)
1033 # too little? (unprovisioing export delay?)
1034 my($end, $start) = ( $self->get('cancel'), $self->get('cancel') - $fuzz );
1035 my @h_cust_svc = $self->h_cust_svc( $end, $start );
1038 foreach my $h_cust_svc (@h_cust_svc) {
1039 my $h_svc_x = $h_cust_svc->h_svc_x( $end, $start );
1040 #next unless $h_svc_x; #should this happen?
1041 (my $table = $h_svc_x->table) =~ s/^h_//;
1042 require "FS/$table.pm";
1043 my $class = "FS::$table";
1044 my $svc_x = $class->new( {
1045 'pkgnum' => $cust_pkg->pkgnum,
1046 'svcpart' => $h_cust_svc->svcpart,
1047 map { $_ => $h_svc_x->get($_) } fields($table)
1051 if ( $h_svc_x->isa('FS::h_svc_Radius_Mixin') ) {
1052 $svc_x->usergroup( [ $h_svc_x->h_usergroup($end, $start) ] );
1055 my $svc_error = $svc_x->insert;
1057 if ( $options{svc_fatal} ) {
1058 $dbh->rollback if $oldAutoCommit;
1061 # if we've failed to insert the svc_x object, svc_Common->insert
1062 # will have removed the cust_svc already. if not, then both records
1063 # were inserted but we failed for some other reason (export, most
1064 # likely). in that case, report the error and delete the records.
1065 push @svc_errors, $svc_error;
1066 my $cust_svc = qsearchs('cust_svc', { 'svcnum' => $svc_x->svcnum });
1068 # except if export_insert failed, export_delete probably won't be
1070 local $FS::svc_Common::noexport_hack = 1;
1071 my $cleanup_error = $svc_x->delete; # also deletes cust_svc
1072 if ( $cleanup_error ) { # and if THAT fails, then run away
1073 $dbh->rollback if $oldAutoCommit;
1074 return $cleanup_error;
1079 } #foreach $h_cust_svc
1081 #these are pretty rare, but should handle them
1082 # - dsl_device (mac addresses)
1083 # - phone_device (mac addresses)
1084 # - dsl_note (ikano notes)
1085 # - domain_record (i.e. restore DNS information w/domains)
1086 # - inventory_item(?) (inventory w/un-cancelling service?)
1087 # - nas (svc_broaband nas stuff)
1088 #this stuff is unused in the wild afaik
1089 # - mailinglistmember
1091 # - svc_domain.parent_svcnum?
1092 # - acct_snarf (ancient mail fetching config)
1093 # - cgp_rule (communigate)
1094 # - cust_svc_option (used by our Tron stuff)
1095 # - acct_rt_transaction (used by our time worked stuff)
1098 # also move over any services that didn't unprovision at cancellation
1101 foreach my $cust_svc ( qsearch('cust_svc', { pkgnum => $self->pkgnum } ) ) {
1102 $cust_svc->pkgnum( $cust_pkg->pkgnum );
1103 my $error = $cust_svc->replace;
1105 $dbh->rollback if $oldAutoCommit;
1111 # Uncancel any supplemental packages, and make them supplemental to the
1115 foreach my $supp_pkg ( $self->supplemental_pkgs ) {
1117 $error = $supp_pkg->uncancel(%options, 'main_pkgnum' => $cust_pkg->pkgnum);
1119 $dbh->rollback if $oldAutoCommit;
1120 return "canceling supplemental pkg#".$supp_pkg->pkgnum.": $error";
1128 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1130 ${ $options{cust_pkg} } = $cust_pkg if ref($options{cust_pkg});
1131 @{ $options{svc_errors} } = @svc_errors if ref($options{svc_errors});
1138 Cancels any pending expiration (sets the expire field to null).
1140 If there is an error, returns the error, otherwise returns false.
1145 my( $self, %options ) = @_;
1148 local $SIG{HUP} = 'IGNORE';
1149 local $SIG{INT} = 'IGNORE';
1150 local $SIG{QUIT} = 'IGNORE';
1151 local $SIG{TERM} = 'IGNORE';
1152 local $SIG{TSTP} = 'IGNORE';
1153 local $SIG{PIPE} = 'IGNORE';
1155 my $oldAutoCommit = $FS::UID::AutoCommit;
1156 local $FS::UID::AutoCommit = 0;
1159 my $old = $self->select_for_update;
1161 my $pkgnum = $old->pkgnum;
1162 if ( $old->get('cancel') || $self->get('cancel') ) {
1163 dbh->rollback if $oldAutoCommit;
1164 return "Can't unexpire cancelled package $pkgnum";
1165 # or at least it's pointless
1168 unless ( $old->get('expire') && $self->get('expire') ) {
1169 dbh->rollback if $oldAutoCommit;
1170 return ""; # no error
1173 my %hash = $self->hash;
1174 $hash{'expire'} = '';
1175 my $new = new FS::cust_pkg ( \%hash );
1176 $error = $new->replace( $self, options => { $self->options } );
1178 $dbh->rollback if $oldAutoCommit;
1182 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1188 =item suspend [ OPTION => VALUE ... ]
1190 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
1191 package, then suspends the package itself (sets the susp field to now).
1193 Available options are:
1197 =item reason - can be set to a cancellation reason (see L<FS:reason>),
1198 either a reasonnum of an existing reason, or passing a hashref will create
1199 a new reason. The hashref should have the following keys:
1200 - typenum - Reason type (see L<FS::reason_type>
1201 - reason - Text of the new reason.
1203 =item date - can be set to a unix style timestamp to specify when to
1206 =item time - can be set to override the current time, for calculation
1207 of final invoices or unused-time credits
1209 =item resume_date - can be set to a time when the package should be
1210 unsuspended. This may be more convenient than calling C<unsuspend()>
1213 =item from_main - allows a supplemental package to be suspended, rather
1214 than redirecting the method call to its main package. For internal use.
1218 If there is an error, returns the error, otherwise returns false.
1223 my( $self, %options ) = @_;
1226 # pass all suspend/cancel actions to the main package
1227 if ( $self->main_pkgnum and !$options{'from_main'} ) {
1228 return $self->main_pkg->suspend(%options);
1231 local $SIG{HUP} = 'IGNORE';
1232 local $SIG{INT} = 'IGNORE';
1233 local $SIG{QUIT} = 'IGNORE';
1234 local $SIG{TERM} = 'IGNORE';
1235 local $SIG{TSTP} = 'IGNORE';
1236 local $SIG{PIPE} = 'IGNORE';
1238 my $oldAutoCommit = $FS::UID::AutoCommit;
1239 local $FS::UID::AutoCommit = 0;
1242 my $old = $self->select_for_update;
1244 my $pkgnum = $old->pkgnum;
1245 if ( $old->get('cancel') || $self->get('cancel') ) {
1246 dbh->rollback if $oldAutoCommit;
1247 return "Can't suspend cancelled package $pkgnum";
1250 if ( $old->get('susp') || $self->get('susp') ) {
1251 dbh->rollback if $oldAutoCommit;
1252 return ""; # no error # complain on adjourn?
1255 my $suspend_time = $options{'time'} || time;
1256 my $date = $options{date} if $options{date}; # adjourn/suspend later
1257 $date = '' if ($date && $date <= $suspend_time); # complain instead?
1259 if ( $date && $old->get('expire') && $old->get('expire') < $date ) {
1260 dbh->rollback if $oldAutoCommit;
1261 return "Package $pkgnum expires before it would be suspended.";
1264 # some false laziness with sub cancel
1265 if ( !$options{nobill} && !$date &&
1266 $self->part_pkg->option('bill_suspend_as_cancel',1) ) {
1267 # kind of a kludge--'bill_suspend_as_cancel' to avoid having to
1268 # make the entire cust_main->bill path recognize 'suspend' and
1269 # 'cancel' separately.
1270 warn "Billing $pkgnum on suspension (at $suspend_time)\n" if $DEBUG;
1271 my $copy = $self->new({$self->hash});
1273 $copy->cust_main->bill( 'pkg_list' => [ $copy ],
1275 'time' => $suspend_time );
1276 warn "Error billing during suspend, custnum ".
1277 #$self->cust_main->custnum. ": $error"
1282 if ( $options{'reason'} ) {
1283 $error = $self->insert_reason( 'reason' => $options{'reason'},
1284 'action' => $date ? 'adjourn' : 'suspend',
1285 'date' => $date ? $date : $suspend_time,
1286 'reason_otaker' => $options{'reason_otaker'},
1289 dbh->rollback if $oldAutoCommit;
1290 return "Error inserting cust_pkg_reason: $error";
1294 my %hash = $self->hash;
1296 $hash{'adjourn'} = $date;
1298 $hash{'susp'} = $suspend_time;
1301 my $resume_date = $options{'resume_date'} || 0;
1302 if ( $resume_date > ($date || $suspend_time) ) {
1303 $hash{'resume'} = $resume_date;
1306 $options{options} ||= {};
1308 my $new = new FS::cust_pkg ( \%hash );
1309 $error = $new->replace( $self, options => { $self->options,
1310 %{ $options{options} },
1314 $dbh->rollback if $oldAutoCommit;
1319 # credit remaining time if appropriate
1320 if ( $self->part_pkg->option('unused_credit_suspend', 1) ) {
1321 my $error = $self->credit_remaining('suspend', $suspend_time);
1323 $dbh->rollback if $oldAutoCommit;
1330 foreach my $cust_svc (
1331 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
1333 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
1335 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
1336 $dbh->rollback if $oldAutoCommit;
1337 return "Illegal svcdb value in part_svc!";
1340 require "FS/$svcdb.pm";
1342 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
1344 $error = $svc->suspend;
1346 $dbh->rollback if $oldAutoCommit;
1349 my( $label, $value ) = $cust_svc->label;
1350 push @labels, "$label: $value";
1354 my $conf = new FS::Conf;
1355 if ( $conf->config('suspend_email_admin') ) {
1357 my $error = send_email(
1358 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
1359 #invoice_from ??? well as good as any
1360 'to' => $conf->config('suspend_email_admin'),
1361 'subject' => 'FREESIDE NOTIFICATION: Customer package suspended',
1363 "This is an automatic message from your Freeside installation\n",
1364 "informing you that the following customer package has been suspended:\n",
1366 'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
1367 'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
1368 ( map { "Service : $_\n" } @labels ),
1373 warn "WARNING: can't send suspension admin email (suspending anyway): ".
1381 foreach my $supp_pkg ( $self->supplemental_pkgs ) {
1382 $error = $supp_pkg->suspend(%options, 'from_main' => 1);
1384 $dbh->rollback if $oldAutoCommit;
1385 return "suspending supplemental pkg#".$supp_pkg->pkgnum.": $error";
1389 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1394 =item credit_remaining MODE TIME
1396 Generate a credit for this package for the time remaining in the current
1397 billing period. MODE is either "suspend" or "cancel" (determines the
1398 credit type). TIME is the time of suspension/cancellation. Both arguments
1403 sub credit_remaining {
1404 # Add a credit for remaining service
1405 my ($self, $mode, $time) = @_;
1406 die 'credit_remaining requires suspend or cancel'
1407 unless $mode eq 'suspend' or $mode eq 'cancel';
1408 die 'no suspend/cancel time' unless $time > 0;
1410 my $conf = FS::Conf->new;
1411 my $reason_type = $conf->config($mode.'_credit_type');
1413 my $last_bill = $self->getfield('last_bill') || 0;
1414 my $next_bill = $self->getfield('bill') || 0;
1415 if ( $last_bill > 0 # the package has been billed
1416 and $next_bill > 0 # the package has a next bill date
1417 and $next_bill >= $time # which is in the future
1419 my $remaining_value = $self->calc_remain('time' => $time);
1420 if ( $remaining_value > 0 ) {
1421 warn "Crediting for $remaining_value on package ".$self->pkgnum."\n"
1423 my $error = $self->cust_main->credit(
1425 'Credit for unused time on '. $self->part_pkg->pkg,
1426 'reason_type' => $reason_type,
1428 return "Error crediting customer \$$remaining_value for unused time".
1429 " on ". $self->part_pkg->pkg. ": $error"
1431 } #if $remaining_value
1432 } #if $last_bill, etc.
1436 =item unsuspend [ OPTION => VALUE ... ]
1438 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
1439 package, then unsuspends the package itself (clears the susp field and the
1440 adjourn field if it is in the past). If the suspend reason includes an
1441 unsuspension package, that package will be ordered.
1443 Available options are:
1449 Can be set to a date to unsuspend the package in the future (the 'resume'
1452 =item adjust_next_bill
1454 Can be set true to adjust the next bill date forward by
1455 the amount of time the account was inactive. This was set true by default
1456 in the past (from 1.4.2 and 1.5.0pre6 through 1.7.0), but now needs to be
1457 explicitly requested with this option or in the price plan.
1461 If there is an error, returns the error, otherwise returns false.
1466 my( $self, %opt ) = @_;
1469 # pass all suspend/cancel actions to the main package
1470 if ( $self->main_pkgnum and !$opt{'from_main'} ) {
1471 return $self->main_pkg->unsuspend(%opt);
1474 local $SIG{HUP} = 'IGNORE';
1475 local $SIG{INT} = 'IGNORE';
1476 local $SIG{QUIT} = 'IGNORE';
1477 local $SIG{TERM} = 'IGNORE';
1478 local $SIG{TSTP} = 'IGNORE';
1479 local $SIG{PIPE} = 'IGNORE';
1481 my $oldAutoCommit = $FS::UID::AutoCommit;
1482 local $FS::UID::AutoCommit = 0;
1485 my $old = $self->select_for_update;
1487 my $pkgnum = $old->pkgnum;
1488 if ( $old->get('cancel') || $self->get('cancel') ) {
1489 $dbh->rollback if $oldAutoCommit;
1490 return "Can't unsuspend cancelled package $pkgnum";
1493 unless ( $old->get('susp') && $self->get('susp') ) {
1494 $dbh->rollback if $oldAutoCommit;
1495 return ""; # no error # complain instead?
1498 my $date = $opt{'date'};
1499 if ( $date and $date > time ) { # return an error if $date <= time?
1501 if ( $old->get('expire') && $old->get('expire') < $date ) {
1502 $dbh->rollback if $oldAutoCommit;
1503 return "Package $pkgnum expires before it would be unsuspended.";
1506 my $new = new FS::cust_pkg { $self->hash };
1507 $new->set('resume', $date);
1508 $error = $new->replace($self, options => $self->options);
1511 $dbh->rollback if $oldAutoCommit;
1515 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1523 foreach my $cust_svc (
1524 qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
1526 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
1528 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
1529 $dbh->rollback if $oldAutoCommit;
1530 return "Illegal svcdb value in part_svc!";
1533 require "FS/$svcdb.pm";
1535 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
1537 $error = $svc->unsuspend;
1539 $dbh->rollback if $oldAutoCommit;
1542 my( $label, $value ) = $cust_svc->label;
1543 push @labels, "$label: $value";
1548 my $cust_pkg_reason = $self->last_cust_pkg_reason('susp');
1549 my $reason = $cust_pkg_reason ? $cust_pkg_reason->reason : '';
1551 my %hash = $self->hash;
1552 my $inactive = time - $hash{'susp'};
1554 my $conf = new FS::Conf;
1556 if ( $inactive > 0 &&
1557 ( $hash{'bill'} || $hash{'setup'} ) &&
1558 ( $opt{'adjust_next_bill'} ||
1559 $conf->exists('unsuspend-always_adjust_next_bill_date') ||
1560 $self->part_pkg->option('unsuspend_adjust_bill', 1) )
1563 $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive;
1568 $hash{'adjourn'} = '' if $hash{'adjourn'} and $hash{'adjourn'} < time;
1569 $hash{'resume'} = '' if !$hash{'adjourn'};
1570 my $new = new FS::cust_pkg ( \%hash );
1571 $error = $new->replace( $self, options => { $self->options } );
1573 $dbh->rollback if $oldAutoCommit;
1579 if ( $reason && $reason->unsuspend_pkgpart ) {
1580 my $part_pkg = FS::part_pkg->by_key($reason->unsuspend_pkgpart)
1581 or $error = "Unsuspend package definition ".$reason->unsuspend_pkgpart.
1583 my $start_date = $self->cust_main->next_bill_date
1584 if $reason->unsuspend_hold;
1587 $unsusp_pkg = FS::cust_pkg->new({
1588 'custnum' => $self->custnum,
1589 'pkgpart' => $reason->unsuspend_pkgpart,
1590 'start_date' => $start_date,
1591 'locationnum' => $self->locationnum,
1592 # discount? probably not...
1595 $error ||= $self->cust_main->order_pkg( 'cust_pkg' => $unsusp_pkg );
1599 $dbh->rollback if $oldAutoCommit;
1604 if ( $conf->config('unsuspend_email_admin') ) {
1606 my $error = send_email(
1607 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
1608 #invoice_from ??? well as good as any
1609 'to' => $conf->config('unsuspend_email_admin'),
1610 'subject' => 'FREESIDE NOTIFICATION: Customer package unsuspended', 'body' => [
1611 "This is an automatic message from your Freeside installation\n",
1612 "informing you that the following customer package has been unsuspended:\n",
1614 'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
1615 'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
1616 ( map { "Service : $_\n" } @labels ),
1618 "An unsuspension fee was charged: ".
1619 $unsusp_pkg->part_pkg->pkg_comment."\n"
1626 warn "WARNING: can't send unsuspension admin email (unsuspending anyway): ".
1632 foreach my $supp_pkg ( $self->supplemental_pkgs ) {
1633 $error = $supp_pkg->unsuspend(%opt, 'from_main' => 1);
1635 $dbh->rollback if $oldAutoCommit;
1636 return "unsuspending supplemental pkg#".$supp_pkg->pkgnum.": $error";
1640 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1647 Cancels any pending suspension (sets the adjourn field to null).
1649 If there is an error, returns the error, otherwise returns false.
1654 my( $self, %options ) = @_;
1657 local $SIG{HUP} = 'IGNORE';
1658 local $SIG{INT} = 'IGNORE';
1659 local $SIG{QUIT} = 'IGNORE';
1660 local $SIG{TERM} = 'IGNORE';
1661 local $SIG{TSTP} = 'IGNORE';
1662 local $SIG{PIPE} = 'IGNORE';
1664 my $oldAutoCommit = $FS::UID::AutoCommit;
1665 local $FS::UID::AutoCommit = 0;
1668 my $old = $self->select_for_update;
1670 my $pkgnum = $old->pkgnum;
1671 if ( $old->get('cancel') || $self->get('cancel') ) {
1672 dbh->rollback if $oldAutoCommit;
1673 return "Can't unadjourn cancelled package $pkgnum";
1674 # or at least it's pointless
1677 if ( $old->get('susp') || $self->get('susp') ) {
1678 dbh->rollback if $oldAutoCommit;
1679 return "Can't unadjourn suspended package $pkgnum";
1680 # perhaps this is arbitrary
1683 unless ( $old->get('adjourn') && $self->get('adjourn') ) {
1684 dbh->rollback if $oldAutoCommit;
1685 return ""; # no error
1688 my %hash = $self->hash;
1689 $hash{'adjourn'} = '';
1690 $hash{'resume'} = '';
1691 my $new = new FS::cust_pkg ( \%hash );
1692 $error = $new->replace( $self, options => { $self->options } );
1694 $dbh->rollback if $oldAutoCommit;
1698 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1705 =item change HASHREF | OPTION => VALUE ...
1707 Changes this package: cancels it and creates a new one, with a different
1708 pkgpart or locationnum or both. All services are transferred to the new
1709 package (no change will be made if this is not possible).
1711 Options may be passed as a list of key/value pairs or as a hash reference.
1718 New locationnum, to change the location for this package.
1722 New FS::cust_location object, to create a new location and assign it
1727 New FS::cust_main object, to create a new customer and assign the new package
1732 New pkgpart (see L<FS::part_pkg>).
1736 New refnum (see L<FS::part_referral>).
1740 New quantity; if unspecified, the new package will have the same quantity
1745 "New" (existing) FS::cust_pkg object. The package's services and other
1746 attributes will be transferred to this package.
1750 Set to true to transfer billing dates (start_date, setup, last_bill, bill,
1751 susp, adjourn, cancel, expire, and contract_end) to the new package.
1753 =item unprotect_svcs
1755 Normally, change() will rollback and return an error if some services
1756 can't be transferred (also see the I<cust_pkg-change_svcpart> config option).
1757 If unprotect_svcs is true, this method will transfer as many services as
1758 it can and then unconditionally cancel the old package.
1762 At least one of locationnum, cust_location, pkgpart, refnum, cust_main, or
1763 cust_pkg must be specified (otherwise, what's the point?)
1765 Returns either the new FS::cust_pkg object or a scalar error.
1769 my $err_or_new_cust_pkg = $old_cust_pkg->change
1773 #some false laziness w/order
1776 my $opt = ref($_[0]) ? shift : { @_ };
1778 my $conf = new FS::Conf;
1780 # Transactionize this whole mess
1781 local $SIG{HUP} = 'IGNORE';
1782 local $SIG{INT} = 'IGNORE';
1783 local $SIG{QUIT} = 'IGNORE';
1784 local $SIG{TERM} = 'IGNORE';
1785 local $SIG{TSTP} = 'IGNORE';
1786 local $SIG{PIPE} = 'IGNORE';
1788 my $oldAutoCommit = $FS::UID::AutoCommit;
1789 local $FS::UID::AutoCommit = 0;
1798 $hash{'setup'} = $time if $self->setup;
1800 $hash{'change_date'} = $time;
1801 $hash{"change_$_"} = $self->$_()
1802 foreach qw( pkgnum pkgpart locationnum );
1804 if ( $opt->{'cust_location'} ) {
1805 $error = $opt->{'cust_location'}->find_or_insert;
1807 $dbh->rollback if $oldAutoCommit;
1808 return "inserting cust_location (transaction rolled back): $error";
1810 $opt->{'locationnum'} = $opt->{'cust_location'}->locationnum;
1813 if ( $opt->{'cust_pkg'} ) {
1814 # treat changing to a package with a different pkgpart as a
1815 # pkgpart change (because it is)
1816 $opt->{'pkgpart'} = $opt->{'cust_pkg'}->pkgpart;
1819 # whether to override pkgpart checking on the new package
1820 my $same_pkgpart = 1;
1821 if ( $opt->{'pkgpart'} and ( $opt->{'pkgpart'} != $self->pkgpart ) ) {
1825 my $unused_credit = 0;
1826 my $keep_dates = $opt->{'keep_dates'};
1827 # Special case. If the pkgpart is changing, and the customer is
1828 # going to be credited for remaining time, don't keep setup, bill,
1829 # or last_bill dates, and DO pass the flag to cancel() to credit
1831 if ( $opt->{'pkgpart'}
1832 and $opt->{'pkgpart'} != $self->pkgpart
1833 and $self->part_pkg->option('unused_credit_change', 1) ) {
1836 $hash{$_} = '' foreach qw(setup bill last_bill);
1839 if ( $keep_dates ) {
1840 foreach my $date ( qw(setup bill last_bill susp adjourn cancel expire
1841 resume start_date contract_end ) ) {
1842 $hash{$date} = $self->getfield($date);
1846 # allow $opt->{'locationnum'} = '' to specifically set it to null
1847 # (i.e. customer default location)
1848 $opt->{'locationnum'} = $self->locationnum if !exists($opt->{'locationnum'});
1850 # usually this doesn't matter. the two cases where it does are:
1851 # 1. unused_credit_change + pkgpart change + setup fee on the new package
1853 # 2. (more importantly) changing a package before it's billed
1854 $hash{'waive_setup'} = $self->waive_setup;
1856 my $custnum = $self->custnum;
1857 if ( $opt->{cust_main} ) {
1858 my $cust_main = $opt->{cust_main};
1859 unless ( $cust_main->custnum ) {
1860 my $error = $cust_main->insert;
1862 $dbh->rollback if $oldAutoCommit;
1863 return "inserting cust_main (transaction rolled back): $error";
1866 $custnum = $cust_main->custnum;
1869 $hash{'contactnum'} = $opt->{'contactnum'} if $opt->{'contactnum'};
1872 if ( $opt->{'cust_pkg'} ) {
1873 # The target package already exists; update it to show that it was
1874 # changed from this package.
1875 $cust_pkg = $opt->{'cust_pkg'};
1877 foreach ( qw( pkgnum pkgpart locationnum ) ) {
1878 $cust_pkg->set("change_$_", $self->get($_));
1880 $cust_pkg->set('change_date', $time);
1881 $error = $cust_pkg->replace;
1884 # Create the new package.
1885 $cust_pkg = new FS::cust_pkg {
1886 custnum => $custnum,
1887 locationnum => $opt->{'locationnum'},
1888 ( map { $_ => ( $opt->{$_} || $self->$_() ) }
1889 qw( pkgpart quantity refnum salesnum )
1893 $error = $cust_pkg->insert( 'change' => 1,
1894 'allow_pkgpart' => $same_pkgpart );
1897 $dbh->rollback if $oldAutoCommit;
1901 # Transfer services and cancel old package.
1903 $error = $self->transfer($cust_pkg);
1904 if ($error and $error == 0) {
1905 # $old_pkg->transfer failed.
1906 $dbh->rollback if $oldAutoCommit;
1910 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1911 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1912 $error = $self->transfer($cust_pkg, 'change_svcpart'=>1 );
1913 if ($error and $error == 0) {
1914 # $old_pkg->transfer failed.
1915 $dbh->rollback if $oldAutoCommit;
1920 # We set unprotect_svcs when executing a "future package change". It's
1921 # not a user-interactive operation, so returning an error means the
1922 # package change will just fail. Rather than have that happen, we'll
1923 # let leftover services be deleted.
1924 if ($error > 0 and !$opt->{'unprotect_svcs'}) {
1925 # Transfers were successful, but we still had services left on the old
1926 # package. We can't change the package under this circumstances, so abort.
1927 $dbh->rollback if $oldAutoCommit;
1928 return "Unable to transfer all services from package ". $self->pkgnum;
1931 #reset usage if changing pkgpart
1932 # AND usage rollover is off (otherwise adds twice, now and at package bill)
1933 if ($self->pkgpart != $cust_pkg->pkgpart) {
1934 my $part_pkg = $cust_pkg->part_pkg;
1935 $error = $part_pkg->reset_usage($cust_pkg, $part_pkg->is_prepaid
1939 if $part_pkg->can('reset_usage') && ! $part_pkg->option('usage_rollover',1);
1942 $dbh->rollback if $oldAutoCommit;
1943 return "Error setting usage values: $error";
1946 # if NOT changing pkgpart, transfer any usage pools over
1947 foreach my $usage ($self->cust_pkg_usage) {
1948 $usage->set('pkgnum', $cust_pkg->pkgnum);
1949 $error = $usage->replace;
1951 $dbh->rollback if $oldAutoCommit;
1952 return "Error transferring usage pools: $error";
1957 # transfer discounts, if we're not changing pkgpart
1958 if ( $same_pkgpart ) {
1959 foreach my $old_discount ($self->cust_pkg_discount_active) {
1960 # don't remove the old discount, we may still need to bill that package.
1961 my $new_discount = new FS::cust_pkg_discount {
1962 'pkgnum' => $cust_pkg->pkgnum,
1963 'discountnum' => $old_discount->discountnum,
1964 'months_used' => $old_discount->months_used,
1966 $error = $new_discount->insert;
1968 $dbh->rollback if $oldAutoCommit;
1969 return "Error transferring discounts: $error";
1974 # transfer (copy) invoice details
1975 foreach my $detail ($self->cust_pkg_detail) {
1976 my $new_detail = FS::cust_pkg_detail->new({ $detail->hash });
1977 $new_detail->set('pkgdetailnum', '');
1978 $new_detail->set('pkgnum', $cust_pkg->pkgnum);
1979 $error = $new_detail->insert;
1981 $dbh->rollback if $oldAutoCommit;
1982 return "Error transferring package notes: $error";
1988 if ( !$opt->{'cust_pkg'} ) {
1989 # Order any supplemental packages.
1990 my $part_pkg = $cust_pkg->part_pkg;
1991 my @old_supp_pkgs = $self->supplemental_pkgs;
1992 foreach my $link ($part_pkg->supp_part_pkg_link) {
1994 foreach (@old_supp_pkgs) {
1995 if ($_->pkgpart == $link->dst_pkgpart) {
1997 $_->pkgpart(0); # so that it can't match more than once
2001 # false laziness with FS::cust_main::Packages::order_pkg
2002 my $new = FS::cust_pkg->new({
2003 pkgpart => $link->dst_pkgpart,
2004 pkglinknum => $link->pkglinknum,
2005 custnum => $custnum,
2006 main_pkgnum => $cust_pkg->pkgnum,
2007 locationnum => $cust_pkg->locationnum,
2008 start_date => $cust_pkg->start_date,
2009 order_date => $cust_pkg->order_date,
2010 expire => $cust_pkg->expire,
2011 adjourn => $cust_pkg->adjourn,
2012 contract_end => $cust_pkg->contract_end,
2013 refnum => $cust_pkg->refnum,
2014 discountnum => $cust_pkg->discountnum,
2015 waive_setup => $cust_pkg->waive_setup,
2017 if ( $old and $opt->{'keep_dates'} ) {
2018 foreach (qw(setup bill last_bill)) {
2019 $new->set($_, $old->get($_));
2022 $error = $new->insert( allow_pkgpart => $same_pkgpart );
2025 $error ||= $old->transfer($new);
2027 if ( $error and $error > 0 ) {
2028 # no reason why this should ever fail, but still...
2029 $error = "Unable to transfer all services from supplemental package ".
2033 $dbh->rollback if $oldAutoCommit;
2036 push @new_supp_pkgs, $new;
2038 } # if !$opt->{'cust_pkg'}
2039 # because if there is one, then supplemental packages would already
2040 # have been created for it.
2042 #Good to go, cancel old package. Notify 'cancel' of whether to credit
2044 #Don't allow billing the package (preceding period packages and/or
2045 #outstanding usage) if we are keeping dates (i.e. location changing),
2046 #because the new package will be billed for the same date range.
2047 #Supplemental packages are also canceled here.
2049 # during scheduled changes, avoid canceling the package we just
2051 $self->set('change_to_pkgnum' => '');
2053 $error = $self->cancel(
2055 unused_credit => $unused_credit,
2056 nobill => $keep_dates,
2057 change_custnum => ( $self->custnum != $custnum ? $custnum : '' ),
2060 $dbh->rollback if $oldAutoCommit;
2064 if ( $conf->exists('cust_pkg-change_pkgpart-bill_now') ) {
2066 my $error = $cust_pkg->cust_main->bill(
2067 'pkg_list' => [ $cust_pkg, @new_supp_pkgs ]
2070 $dbh->rollback if $oldAutoCommit;
2075 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2081 =item change_later OPTION => VALUE...
2083 Schedule a package change for a later date. This actually orders the new
2084 package immediately, but sets its start date for a future date, and sets
2085 the current package to expire on the same date.
2087 If the package is already scheduled for a change, this can be called with
2088 'start_date' to change the scheduled date, or with pkgpart and/or
2089 locationnum to modify the package change. To cancel the scheduled change
2090 entirely, see C<abort_change>.
2098 The date for the package change. Required, and must be in the future.
2106 The pkgpart. locationnum, and quantity of the new package, with the same
2107 meaning as in C<change>.
2115 my $opt = ref($_[0]) ? shift : { @_ };
2117 my $oldAutoCommit = $FS::UID::AutoCommit;
2118 local $FS::UID::AutoCommit = 0;
2121 my $cust_main = $self->cust_main;
2123 my $date = delete $opt->{'start_date'} or return 'start_date required';
2125 if ( $date <= time ) {
2126 $dbh->rollback if $oldAutoCommit;
2127 return "start_date $date is in the past";
2132 if ( $self->change_to_pkgnum ) {
2133 my $change_to = FS::cust_pkg->by_key($self->change_to_pkgnum);
2134 my $new_pkgpart = $opt->{'pkgpart'}
2135 if $opt->{'pkgpart'} and $opt->{'pkgpart'} != $change_to->pkgpart;
2136 my $new_locationnum = $opt->{'locationnum'}
2137 if $opt->{'locationnum'} and $opt->{'locationnum'} != $change_to->locationnum;
2138 my $new_quantity = $opt->{'quantity'}
2139 if $opt->{'quantity'} and $opt->{'quantity'} != $change_to->quantity;
2140 if ( $new_pkgpart or $new_locationnum or $new_quantity ) {
2141 # it hasn't been billed yet, so in principle we could just edit
2142 # it in place (w/o a package change), but that's bad form.
2143 # So change the package according to the new options...
2144 my $err_or_pkg = $change_to->change(%$opt);
2145 if ( ref $err_or_pkg ) {
2146 # Then set that package up for a future start.
2147 $self->set('change_to_pkgnum', $err_or_pkg->pkgnum);
2148 $self->set('expire', $date); # in case it's different
2149 $err_or_pkg->set('start_date', $date);
2150 $err_or_pkg->set('change_date', '');
2151 $err_or_pkg->set('change_pkgnum', '');
2153 $error = $self->replace ||
2154 $err_or_pkg->replace ||
2155 $change_to->cancel ||
2158 $error = $err_or_pkg;
2160 } else { # change the start date only.
2161 $self->set('expire', $date);
2162 $change_to->set('start_date', $date);
2163 $error = $self->replace || $change_to->replace;
2166 $dbh->rollback if $oldAutoCommit;
2169 $dbh->commit if $oldAutoCommit;
2172 } # if $self->change_to_pkgnum
2174 my $new_pkgpart = $opt->{'pkgpart'}
2175 if $opt->{'pkgpart'} and $opt->{'pkgpart'} != $self->pkgpart;
2176 my $new_locationnum = $opt->{'locationnum'}
2177 if $opt->{'locationnum'} and $opt->{'locationnum'} != $self->locationnum;
2178 my $new_quantity = $opt->{'quantity'}
2179 if $opt->{'quantity'} and $opt->{'quantity'} != $self->quantity;
2181 return '' unless $new_pkgpart or $new_locationnum or $new_quantity; # wouldn't do anything
2183 # allow $opt->{'locationnum'} = '' to specifically set it to null
2184 # (i.e. customer default location)
2185 $opt->{'locationnum'} = $self->locationnum if !exists($opt->{'locationnum'});
2187 my $new = FS::cust_pkg->new( {
2188 custnum => $self->custnum,
2189 locationnum => $opt->{'locationnum'},
2190 start_date => $date,
2191 map { $_ => ( $opt->{$_} || $self->$_() ) }
2192 qw( pkgpart quantity refnum salesnum )
2194 $error = $new->insert('change' => 1,
2195 'allow_pkgpart' => ($new_pkgpart ? 0 : 1));
2197 $self->set('change_to_pkgnum', $new->pkgnum);
2198 $self->set('expire', $date);
2199 $error = $self->replace;
2202 $dbh->rollback if $oldAutoCommit;
2204 $dbh->commit if $oldAutoCommit;
2212 Cancels a future package change scheduled by C<change_later>.
2218 my $pkgnum = $self->change_to_pkgnum;
2219 my $change_to = FS::cust_pkg->by_key($pkgnum) if $pkgnum;
2222 $error = $change_to->cancel || $change_to->delete;
2223 return $error if $error;
2225 $self->set('change_to_pkgnum', '');
2226 $self->set('expire', '');
2230 =item set_quantity QUANTITY
2232 Change the package's quantity field. This is one of the few package properties
2233 that can safely be changed without canceling and reordering the package
2234 (because it doesn't affect tax eligibility). Returns an error or an
2241 $self = $self->replace_old; # just to make sure
2242 $self->quantity(shift);
2246 =item set_salesnum SALESNUM
2248 Change the package's salesnum (sales person) field. This is one of the few
2249 package properties that can safely be changed without canceling and reordering
2250 the package (because it doesn't affect tax eligibility). Returns an error or
2257 $self = $self->replace_old; # just to make sure
2258 $self->salesnum(shift);
2260 # XXX this should probably reassign any credit that's already been given
2263 =item modify_charge OPTIONS
2265 Change the properties of a one-time charge. Currently the only properties
2266 that can be changed this way are those that have no impact on billing
2268 - pkg: the package description
2269 - classnum: the package class
2270 - additional: arrayref of additional invoice details to add to this package
2272 If you pass 'adjust_commission' => 1, and the classnum changes, and there are
2273 commission credits linked to this charge, they will be recalculated.
2280 my $part_pkg = $self->part_pkg;
2281 my $pkgnum = $self->pkgnum;
2284 my $oldAutoCommit = $FS::UID::AutoCommit;
2285 local $FS::UID::AutoCommit = 0;
2287 return "Can't use modify_charge except on one-time charges"
2288 unless $part_pkg->freq eq '0';
2290 if ( length($opt{'pkg'}) and $part_pkg->pkg ne $opt{'pkg'} ) {
2291 $part_pkg->set('pkg', $opt{'pkg'});
2294 my %pkg_opt = $part_pkg->options;
2295 if ( ref($opt{'additional'}) ) {
2296 delete $pkg_opt{$_} foreach grep /^additional/, keys %pkg_opt;
2298 for ( $i = 0; exists($opt{'additional'}->[$i]); $i++ ) {
2299 $pkg_opt{ "additional_info$i" } = $opt{'additional'}->[$i];
2301 $pkg_opt{'additional_count'} = $i if $i > 0;
2305 if ( exists($opt{'classnum'}) and $part_pkg->classnum ne $opt{'classnum'} ) {
2307 $old_classnum = $part_pkg->classnum;
2308 $part_pkg->set('classnum', $opt{'classnum'});
2311 my $error = $part_pkg->replace( options => \%pkg_opt );
2312 return $error if $error;
2314 if (defined $old_classnum) {
2315 # fix invoice grouping records
2316 my $old_catname = $old_classnum
2317 ? FS::pkg_class->by_key($old_classnum)->categoryname
2319 my $new_catname = $opt{'classnum'}
2320 ? $part_pkg->pkg_class->categoryname
2322 if ( $old_catname ne $new_catname ) {
2323 foreach my $cust_bill_pkg ($self->cust_bill_pkg) {
2324 # (there should only be one...)
2325 my @display = qsearch( 'cust_bill_pkg_display', {
2326 'billpkgnum' => $cust_bill_pkg->billpkgnum,
2327 'section' => $old_catname,
2329 foreach (@display) {
2330 $_->set('section', $new_catname);
2331 $error = $_->replace;
2333 $dbh->rollback if $oldAutoCommit;
2337 } # foreach $cust_bill_pkg
2340 if ( $opt{'adjust_commission'} ) {
2341 # fix commission credits...tricky.
2342 foreach my $cust_event ($self->cust_event) {
2343 my $part_event = $cust_event->part_event;
2344 foreach my $table (qw(sales agent)) {
2346 "FS::part_event::Action::Mixin::credit_${table}_pkg_class";
2347 my $credit = qsearchs('cust_credit', {
2348 'eventnum' => $cust_event->eventnum,
2350 if ( $part_event->isa($class) ) {
2351 # Yes, this results in current commission rates being applied
2352 # retroactively to a one-time charge. For accounting purposes
2353 # there ought to be some kind of time limit on doing this.
2354 my $amount = $part_event->_calc_credit($self);
2355 if ( $credit and $credit->amount ne $amount ) {
2356 # Void the old credit.
2357 $error = $credit->void('Package class changed');
2359 $dbh->rollback if $oldAutoCommit;
2360 return "$error (adjusting commission credit)";
2363 # redo the event action to recreate the credit.
2365 eval { $part_event->do_action( $self, $cust_event ) };
2367 $dbh->rollback if $oldAutoCommit;
2370 } # if $part_event->isa($class)
2372 } # foreach $cust_event
2373 } # if $opt{'adjust_commission'}
2374 } # if defined $old_classnum
2376 $dbh->commit if $oldAutoCommit;
2382 use Storable 'thaw';
2385 sub process_bulk_cust_pkg {
2387 my $param = thaw(decode_base64(shift));
2388 warn Dumper($param) if $DEBUG;
2390 my $old_part_pkg = qsearchs('part_pkg',
2391 { pkgpart => $param->{'old_pkgpart'} });
2392 my $new_part_pkg = qsearchs('part_pkg',
2393 { pkgpart => $param->{'new_pkgpart'} });
2394 die "Must select a new package type\n" unless $new_part_pkg;
2395 #my $keep_dates = $param->{'keep_dates'} || 0;
2396 my $keep_dates = 1; # there is no good reason to turn this off
2398 local $SIG{HUP} = 'IGNORE';
2399 local $SIG{INT} = 'IGNORE';
2400 local $SIG{QUIT} = 'IGNORE';
2401 local $SIG{TERM} = 'IGNORE';
2402 local $SIG{TSTP} = 'IGNORE';
2403 local $SIG{PIPE} = 'IGNORE';
2405 my $oldAutoCommit = $FS::UID::AutoCommit;
2406 local $FS::UID::AutoCommit = 0;
2409 my @cust_pkgs = qsearch('cust_pkg', { 'pkgpart' => $param->{'old_pkgpart'} } );
2412 foreach my $old_cust_pkg ( @cust_pkgs ) {
2414 $job->update_statustext(int(100*$i/(scalar @cust_pkgs)));
2415 if ( $old_cust_pkg->getfield('cancel') ) {
2416 warn '[process_bulk_cust_pkg ] skipping canceled pkgnum '.
2417 $old_cust_pkg->pkgnum."\n"
2421 warn '[process_bulk_cust_pkg] changing pkgnum '.$old_cust_pkg->pkgnum."\n"
2423 my $error = $old_cust_pkg->change(
2424 'pkgpart' => $param->{'new_pkgpart'},
2425 'keep_dates' => $keep_dates
2427 if ( !ref($error) ) { # change returns the cust_pkg on success
2429 die "Error changing pkgnum ".$old_cust_pkg->pkgnum.": '$error'\n";
2432 $dbh->commit if $oldAutoCommit;
2438 Returns the last bill date, or if there is no last bill date, the setup date.
2439 Useful for billing metered services.
2445 return $self->setfield('last_bill', $_[0]) if @_;
2446 return $self->getfield('last_bill') if $self->getfield('last_bill');
2447 my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
2448 'edate' => $self->bill, } );
2449 $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
2452 =item last_cust_pkg_reason ACTION
2454 Returns the most recent ACTION FS::cust_pkg_reason associated with the package.
2455 Returns false if there is no reason or the package is not currenly ACTION'd
2456 ACTION is one of adjourn, susp, cancel, or expire.
2460 sub last_cust_pkg_reason {
2461 my ( $self, $action ) = ( shift, shift );
2462 my $date = $self->get($action);
2464 'table' => 'cust_pkg_reason',
2465 'hashref' => { 'pkgnum' => $self->pkgnum,
2466 'action' => substr(uc($action), 0, 1),
2469 'order_by' => 'ORDER BY num DESC LIMIT 1',
2473 =item last_reason ACTION
2475 Returns the most recent ACTION FS::reason associated with the package.
2476 Returns false if there is no reason or the package is not currenly ACTION'd
2477 ACTION is one of adjourn, susp, cancel, or expire.
2482 my $cust_pkg_reason = shift->last_cust_pkg_reason(@_);
2483 $cust_pkg_reason->reason
2484 if $cust_pkg_reason;
2489 Returns the definition for this billing item, as an FS::part_pkg object (see
2496 return $self->{'_pkgpart'} if $self->{'_pkgpart'};
2497 cluck "cust_pkg->part_pkg called" if $DEBUG > 1;
2498 qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
2503 Returns the cancelled package this package was changed from, if any.
2509 return '' unless $self->change_pkgnum;
2510 qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
2513 =item change_cust_main
2515 Returns the customter this package was detached to, if any.
2519 sub change_cust_main {
2521 return '' unless $self->change_custnum;
2522 qsearchs('cust_main', { 'custnum' => $self->change_custnum } );
2527 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
2534 $self->part_pkg->calc_setup($self, @_);
2539 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
2546 $self->part_pkg->calc_recur($self, @_);
2551 Calls the I<base_setup> of the FS::part_pkg object associated with this billing
2558 $self->part_pkg->base_setup($self, @_);
2563 Calls the I<base_recur> of the FS::part_pkg object associated with this billing
2570 $self->part_pkg->base_recur($self, @_);
2575 Calls the I<calc_remain> of the FS::part_pkg object associated with this
2582 $self->part_pkg->calc_remain($self, @_);
2587 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
2594 $self->part_pkg->calc_cancel($self, @_);
2599 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
2605 qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
2608 =item cust_pkg_detail [ DETAILTYPE ]
2610 Returns any customer package details for this package (see
2611 L<FS::cust_pkg_detail>).
2613 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
2617 sub cust_pkg_detail {
2619 my %hash = ( 'pkgnum' => $self->pkgnum );
2620 $hash{detailtype} = shift if @_;
2622 'table' => 'cust_pkg_detail',
2623 'hashref' => \%hash,
2624 'order_by' => 'ORDER BY weight, pkgdetailnum',
2628 =item set_cust_pkg_detail DETAILTYPE [ DETAIL, DETAIL, ... ]
2630 Sets customer package details for this package (see L<FS::cust_pkg_detail>).
2632 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
2634 If there is an error, returns the error, otherwise returns false.
2638 sub set_cust_pkg_detail {
2639 my( $self, $detailtype, @details ) = @_;
2641 local $SIG{HUP} = 'IGNORE';
2642 local $SIG{INT} = 'IGNORE';
2643 local $SIG{QUIT} = 'IGNORE';
2644 local $SIG{TERM} = 'IGNORE';
2645 local $SIG{TSTP} = 'IGNORE';
2646 local $SIG{PIPE} = 'IGNORE';
2648 my $oldAutoCommit = $FS::UID::AutoCommit;
2649 local $FS::UID::AutoCommit = 0;
2652 foreach my $current ( $self->cust_pkg_detail($detailtype) ) {
2653 my $error = $current->delete;
2655 $dbh->rollback if $oldAutoCommit;
2656 return "error removing old detail: $error";
2660 foreach my $detail ( @details ) {
2661 my $cust_pkg_detail = new FS::cust_pkg_detail {
2662 'pkgnum' => $self->pkgnum,
2663 'detailtype' => $detailtype,
2664 'detail' => $detail,
2666 my $error = $cust_pkg_detail->insert;
2668 $dbh->rollback if $oldAutoCommit;
2669 return "error adding new detail: $error";
2674 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2681 Returns the new-style customer billing events (see L<FS::cust_event>) for this invoice.
2685 #false laziness w/cust_bill.pm
2689 'table' => 'cust_event',
2690 'addl_from' => 'JOIN part_event USING ( eventpart )',
2691 'hashref' => { 'tablenum' => $self->pkgnum },
2692 'extra_sql' => " AND eventtable = 'cust_pkg' ",
2696 =item num_cust_event
2698 Returns the number of new-style customer billing events (see L<FS::cust_event>) for this invoice.
2702 #false laziness w/cust_bill.pm
2703 sub num_cust_event {
2706 "SELECT COUNT(*) FROM cust_event JOIN part_event USING ( eventpart ) ".
2707 " WHERE tablenum = ? AND eventtable = 'cust_pkg'";
2708 my $sth = dbh->prepare($sql) or die dbh->errstr. " preparing $sql";
2709 $sth->execute($self->pkgnum) or die $sth->errstr. " executing $sql";
2710 $sth->fetchrow_arrayref->[0];
2713 =item part_pkg_currency_option OPTIONNAME
2715 Returns a two item list consisting of the currency of this customer, if any,
2716 and a value for the provided option. If the customer has a currency, the value
2717 is the option value the given name and the currency (see
2718 L<FS::part_pkg_currency>). Otherwise, if the customer has no currency, is the
2719 regular option value for the given name (see L<FS::part_pkg_option>).
2723 sub part_pkg_currency_option {
2724 my( $self, $optionname ) = @_;
2725 my $part_pkg = $self->part_pkg;
2726 if ( my $currency = $self->cust_main->currency ) {
2727 ($currency, $part_pkg->part_pkg_currency_option($currency, $optionname) );
2729 ('', $part_pkg->option($optionname) );
2733 =item cust_svc [ SVCPART ] (old, deprecated usage)
2735 =item cust_svc [ OPTION => VALUE ... ] (current usage)
2737 =item cust_svc_unsorted [ OPTION => VALUE ... ]
2739 Returns the services for this package, as FS::cust_svc objects (see
2740 L<FS::cust_svc>). Available options are svcpart and svcdb. If either is
2741 spcififed, returns only the matching services.
2743 As an optimization, use the cust_svc_unsorted version if you are not displaying
2750 cluck "cust_pkg->cust_svc called" if $DEBUG > 2;
2751 $self->_sort_cust_svc( $self->cust_svc_unsorted_arrayref );
2754 sub cust_svc_unsorted {
2756 @{ $self->cust_svc_unsorted_arrayref };
2759 sub cust_svc_unsorted_arrayref {
2762 return () unless $self->num_cust_svc(@_);
2765 if ( @_ && $_[0] =~ /^\d+/ ) {
2766 $opt{svcpart} = shift;
2767 } elsif ( @_ && ref($_[0]) eq 'HASH' ) {
2774 'table' => 'cust_svc',
2775 'hashref' => { 'pkgnum' => $self->pkgnum },
2777 if ( $opt{svcpart} ) {
2778 $search{hashref}->{svcpart} = $opt{'svcpart'};
2780 if ( $opt{'svcdb'} ) {
2781 $search{addl_from} = ' LEFT JOIN part_svc USING ( svcpart ) ';
2782 $search{extra_sql} = ' AND svcdb = '. dbh->quote( $opt{'svcdb'} );
2785 [ qsearch(\%search) ];
2789 =item overlimit [ SVCPART ]
2791 Returns the services for this package which have exceeded their
2792 usage limit as FS::cust_svc objects (see L<FS::cust_svc>). If a svcpart
2793 is specified, return only the matching services.
2799 return () unless $self->num_cust_svc(@_);
2800 grep { $_->overlimit } $self->cust_svc(@_);
2803 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
2805 Returns historical services for this package created before END TIMESTAMP and
2806 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
2807 (see L<FS::h_cust_svc>). If MODE is 'I' (for 'invoice'), services with the
2808 I<pkg_svc.hidden> flag will be omitted.
2814 warn "$me _h_cust_svc called on $self\n"
2817 my ($end, $start, $mode) = @_;
2818 my @cust_svc = $self->_sort_cust_svc(
2819 [ qsearch( 'h_cust_svc',
2820 { 'pkgnum' => $self->pkgnum, },
2821 FS::h_cust_svc->sql_h_search(@_),
2824 if ( defined($mode) && $mode eq 'I' ) {
2825 my %hidden_svcpart = map { $_->svcpart => $_->hidden } $self->part_svc;
2826 return grep { !$hidden_svcpart{$_->svcpart} } @cust_svc;
2832 sub _sort_cust_svc {
2833 my( $self, $arrayref ) = @_;
2836 sub ($$) { my ($a, $b) = @_; $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] };
2838 my %pkg_svc = map { $_->svcpart => $_ }
2839 qsearch( 'pkg_svc', { 'pkgpart' => $self->pkgpart } );
2844 my $pkg_svc = $pkg_svc{ $_->svcpart } || '';
2846 $pkg_svc ? $pkg_svc->primary_svc : '',
2847 $pkg_svc ? $pkg_svc->quantity : 0,
2854 =item num_cust_svc [ SVCPART ] (old, deprecated usage)
2856 =item num_cust_svc [ OPTION => VALUE ... ] (current usage)
2858 Returns the number of services for this package. Available options are svcpart
2859 and svcdb. If either is spcififed, returns only the matching services.
2866 return $self->{'_num_cust_svc'}
2868 && exists($self->{'_num_cust_svc'})
2869 && $self->{'_num_cust_svc'} =~ /\d/;
2871 cluck "cust_pkg->num_cust_svc called, _num_cust_svc:".$self->{'_num_cust_svc'}
2875 if ( @_ && $_[0] =~ /^\d+/ ) {
2876 $opt{svcpart} = shift;
2877 } elsif ( @_ && ref($_[0]) eq 'HASH' ) {
2883 my $select = 'SELECT COUNT(*) FROM cust_svc ';
2884 my $where = ' WHERE pkgnum = ? ';
2885 my @param = ($self->pkgnum);
2887 if ( $opt{'svcpart'} ) {
2888 $where .= ' AND svcpart = ? ';
2889 push @param, $opt{'svcpart'};
2891 if ( $opt{'svcdb'} ) {
2892 $select .= ' LEFT JOIN part_svc USING ( svcpart ) ';
2893 $where .= ' AND svcdb = ? ';
2894 push @param, $opt{'svcdb'};
2897 my $sth = dbh->prepare("$select $where") or die dbh->errstr;
2898 $sth->execute(@param) or die $sth->errstr;
2899 $sth->fetchrow_arrayref->[0];
2902 =item available_part_svc
2904 Returns a list of FS::part_svc objects representing services included in this
2905 package but not yet provisioned. Each FS::part_svc object also has an extra
2906 field, I<num_avail>, which specifies the number of available services.
2910 sub available_part_svc {
2913 my $pkg_quantity = $self->quantity || 1;
2915 grep { $_->num_avail > 0 }
2917 my $part_svc = $_->part_svc;
2918 $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
2919 $pkg_quantity * $_->quantity - $self->num_cust_svc($_->svcpart);
2921 # more evil encapsulation breakage
2922 if($part_svc->{'Hash'}{'num_avail'} > 0) {
2923 my @exports = $part_svc->part_export_did;
2924 $part_svc->{'Hash'}{'can_get_dids'} = scalar(@exports);
2929 $self->part_pkg->pkg_svc;
2932 =item part_svc [ OPTION => VALUE ... ]
2934 Returns a list of FS::part_svc objects representing provisioned and available
2935 services included in this package. Each FS::part_svc object also has the
2936 following extra fields:
2940 =item num_cust_svc (count)
2942 =item num_avail (quantity - count)
2944 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
2948 Accepts one option: summarize_size. If specified and non-zero, will omit the
2949 extra cust_pkg_svc option for objects where num_cust_svc is this size or
2955 #label -> ($cust_svc->label)[1]
2961 my $pkg_quantity = $self->quantity || 1;
2963 #XXX some sort of sort order besides numeric by svcpart...
2964 my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
2966 my $part_svc = $pkg_svc->part_svc;
2967 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
2968 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
2969 $part_svc->{'Hash'}{'num_avail'} =
2970 max( 0, $pkg_quantity * $pkg_svc->quantity - $num_cust_svc );
2971 $part_svc->{'Hash'}{'cust_pkg_svc'} =
2972 $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : []
2973 unless exists($opt{summarize_size}) && $opt{summarize_size} > 0
2974 && $num_cust_svc >= $opt{summarize_size};
2975 $part_svc->{'Hash'}{'hidden'} = $pkg_svc->hidden;
2977 } $self->part_pkg->pkg_svc;
2980 push @part_svc, map {
2982 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
2983 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
2984 $part_svc->{'Hash'}{'num_avail'} = 0; #0-$num_cust_svc ?
2985 $part_svc->{'Hash'}{'cust_pkg_svc'} =
2986 $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
2988 } $self->extra_part_svc;
2994 =item extra_part_svc
2996 Returns a list of FS::part_svc objects corresponding to services in this
2997 package which are still provisioned but not (any longer) available in the
3002 sub extra_part_svc {
3005 my $pkgnum = $self->pkgnum;
3006 #my $pkgpart = $self->pkgpart;
3009 # 'table' => 'part_svc',
3012 # "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
3013 # WHERE pkg_svc.svcpart = part_svc.svcpart
3014 # AND pkg_svc.pkgpart = ?
3017 # AND 0 < ( SELECT COUNT(*) FROM cust_svc
3018 # LEFT JOIN cust_pkg USING ( pkgnum )
3019 # WHERE cust_svc.svcpart = part_svc.svcpart
3022 # 'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
3025 #seems to benchmark slightly faster... (or did?)
3027 my @pkgparts = map $_->pkgpart, $self->part_pkg->self_and_svc_linked;
3028 my $pkgparts = join(',', @pkgparts);
3031 #'select' => 'DISTINCT ON (svcpart) part_svc.*',
3032 #MySQL doesn't grok DISINCT ON
3033 'select' => 'DISTINCT part_svc.*',
3034 'table' => 'part_svc',
3036 "LEFT JOIN pkg_svc ON ( pkg_svc.svcpart = part_svc.svcpart
3037 AND pkg_svc.pkgpart IN ($pkgparts)
3040 LEFT JOIN cust_svc ON ( cust_svc.svcpart = part_svc.svcpart )
3041 LEFT JOIN cust_pkg USING ( pkgnum )
3044 'extra_sql' => "WHERE pkgsvcnum IS NULL AND cust_pkg.pkgnum = ? ",
3045 'extra_param' => [ [$self->pkgnum=>'int'] ],
3051 Returns a short status string for this package, currently:
3055 =item not yet billed
3057 =item one-time charge
3072 my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
3074 return 'cancelled' if $self->get('cancel');
3075 return 'suspended' if $self->susp;
3076 return 'not yet billed' unless $self->setup;
3077 return 'one-time charge' if $freq =~ /^(0|$)/;
3081 =item ucfirst_status
3083 Returns the status with the first character capitalized.
3087 sub ucfirst_status {
3088 ucfirst(shift->status);
3093 Class method that returns the list of possible status strings for packages
3094 (see L<the status method|/status>). For example:
3096 @statuses = FS::cust_pkg->statuses();
3100 tie my %statuscolor, 'Tie::IxHash',
3101 'not yet billed' => '009999', #teal? cyan?
3102 'one-time charge' => '000000',
3103 'active' => '00CC00',
3104 'suspended' => 'FF9900',
3105 'cancelled' => 'FF0000',
3109 my $self = shift; #could be class...
3110 #grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
3111 # # mayble split btw one-time vs. recur
3117 Returns a hex triplet color string for this package's status.
3123 $statuscolor{$self->status};
3128 Returns a label for this package. (Currently "pkgnum: pkg - comment" or
3129 "pkg - comment" depending on user preference).
3135 my $label = $self->part_pkg->pkg_comment( 'nopkgpart' => 1 );
3136 $label = $self->pkgnum. ": $label"
3137 if $FS::CurrentUser::CurrentUser->option('show_pkgnum');
3141 =item pkg_label_long
3143 Returns a long label for this package, adding the primary service's label to
3148 sub pkg_label_long {
3150 my $label = $self->pkg_label;
3151 my $cust_svc = $self->primary_cust_svc;
3152 $label .= ' ('. ($cust_svc->label)[1]. ')' if $cust_svc;
3158 Returns a customer-localized label for this package.
3164 $self->part_pkg->pkg_locale( $self->cust_main->locale );
3167 =item primary_cust_svc
3169 Returns a primary service (as FS::cust_svc object) if one can be identified.
3173 #for labeling purposes - might not 100% match up with part_pkg->svcpart's idea
3175 sub primary_cust_svc {
3178 my @cust_svc = $self->cust_svc;
3180 return '' unless @cust_svc; #no serivces - irrelevant then
3182 return $cust_svc[0] if scalar(@cust_svc) == 1; #always return a single service
3184 # primary service as specified in the package definition
3185 # or exactly one service definition with quantity one
3186 my $svcpart = $self->part_pkg->svcpart;
3187 @cust_svc = grep { $_->svcpart == $svcpart } @cust_svc;
3188 return $cust_svc[0] if scalar(@cust_svc) == 1;
3190 #couldn't identify one thing..
3196 Returns a list of lists, calling the label method for all services
3197 (see L<FS::cust_svc>) of this billing item.
3203 map { [ $_->label ] } $self->cust_svc;
3206 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
3208 Like the labels method, but returns historical information on services that
3209 were active as of END_TIMESTAMP and (optionally) not cancelled before
3210 START_TIMESTAMP. If MODE is 'I' (for 'invoice'), services with the
3211 I<pkg_svc.hidden> flag will be omitted.
3213 Returns a list of lists, calling the label method for all (historical) services
3214 (see L<FS::h_cust_svc>) of this billing item.
3220 warn "$me _h_labels called on $self\n"
3222 map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
3227 Like labels, except returns a simple flat list, and shortens long
3228 (currently >5 or the cust_bill-max_same_services configuration value) lists of
3229 identical services to one line that lists the service label and the number of
3230 individual services rather than individual items.
3235 shift->_labels_short( 'labels', @_ );
3238 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
3240 Like h_labels, except returns a simple flat list, and shortens long
3241 (currently >5 or the cust_bill-max_same_services configuration value) lists of
3242 identical services to one line that lists the service label and the number of
3243 individual services rather than individual items.
3247 sub h_labels_short {
3248 shift->_labels_short( 'h_labels', @_ );
3252 my( $self, $method ) = ( shift, shift );
3254 warn "$me _labels_short called on $self with $method method\n"
3257 my $conf = new FS::Conf;
3258 my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
3260 warn "$me _labels_short populating \%labels\n"
3264 #tie %labels, 'Tie::IxHash';
3265 push @{ $labels{$_->[0]} }, $_->[1]
3266 foreach $self->$method(@_);
3268 warn "$me _labels_short populating \@labels\n"
3272 foreach my $label ( keys %labels ) {
3274 my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
3275 my $num = scalar(@values);
3276 warn "$me _labels_short $num items for $label\n"
3279 if ( $num > $max_same_services ) {
3280 warn "$me _labels_short more than $max_same_services, so summarizing\n"
3282 push @labels, "$label ($num)";
3284 if ( $conf->exists('cust_bill-consolidate_services') ) {
3285 warn "$me _labels_short consolidating services\n"
3287 # push @labels, "$label: ". join(', ', @values);
3289 my $detail = "$label: ";
3290 $detail .= shift(@values). ', '
3292 && ( length($detail.$values[0]) < 78 || $detail eq "$label: " );
3294 push @labels, $detail;
3296 warn "$me _labels_short done consolidating services\n"
3299 warn "$me _labels_short adding service data\n"
3301 push @labels, map { "$label: $_" } @values;
3312 Returns the parent customer object (see L<FS::cust_main>).
3318 qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
3323 Returns the balance for this specific package, when using
3324 experimental package balance.
3330 $self->cust_main->balance_pkgnum( $self->pkgnum );
3333 #these subs are in location_Mixin.pm now... unfortunately the POD doesn't mixin
3337 Returns the location object, if any (see L<FS::cust_location>).
3339 =item cust_location_or_main
3341 If this package is associated with a location, returns the locaiton (see
3342 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
3344 =item location_label [ OPTION => VALUE ... ]
3346 Returns the label of the location object (see L<FS::cust_location>).
3350 #end of subs in location_Mixin.pm now... unfortunately the POD doesn't mixin
3352 =item tax_locationnum
3354 Returns the foreign key to a L<FS::cust_location> object for calculating
3355 tax on this package, as determined by the C<tax-pkg_address> and
3356 C<tax-ship_address> configuration flags.
3360 sub tax_locationnum {
3362 my $conf = FS::Conf->new;
3363 if ( $conf->exists('tax-pkg_address') ) {
3364 return $self->locationnum;
3366 elsif ( $conf->exists('tax-ship_address') ) {
3367 return $self->cust_main->ship_locationnum;
3370 return $self->cust_main->bill_locationnum;
3376 Returns the L<FS::cust_location> object for tax_locationnum.
3382 FS::cust_location->by_key( $self->tax_locationnum )
3385 =item seconds_since TIMESTAMP
3387 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
3388 package have been online since TIMESTAMP, according to the session monitor.
3390 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
3391 L<Time::Local> and L<Date::Parse> for conversion functions.
3396 my($self, $since) = @_;
3399 foreach my $cust_svc (
3400 grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
3402 $seconds += $cust_svc->seconds_since($since);
3409 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
3411 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
3412 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
3415 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
3416 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
3422 sub seconds_since_sqlradacct {
3423 my($self, $start, $end) = @_;
3427 foreach my $cust_svc (
3429 my $part_svc = $_->part_svc;
3430 $part_svc->svcdb eq 'svc_acct'
3431 && scalar($part_svc->part_export_usage);
3434 $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
3441 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
3443 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
3444 in this package for sessions ending between TIMESTAMP_START (inclusive) and
3448 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
3449 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
3454 sub attribute_since_sqlradacct {
3455 my($self, $start, $end, $attrib) = @_;
3459 foreach my $cust_svc (
3461 my $part_svc = $_->part_svc;
3462 $part_svc->svcdb eq 'svc_acct'
3463 && scalar($part_svc->part_export_usage);
3466 $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
3478 my( $self, $value ) = @_;
3479 if ( defined($value) ) {
3480 $self->setfield('quantity', $value);
3482 $self->getfield('quantity') || 1;
3485 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
3487 Transfers as many services as possible from this package to another package.
3489 The destination package can be specified by pkgnum by passing an FS::cust_pkg
3490 object. The destination package must already exist.
3492 Services are moved only if the destination allows services with the correct
3493 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true. Use
3494 this option with caution! No provision is made for export differences
3495 between the old and new service definitions. Probably only should be used
3496 when your exports for all service definitions of a given svcdb are identical.
3497 (attempt a transfer without it first, to move all possible svcpart-matching
3500 Any services that can't be moved remain in the original package.
3502 Returns an error, if there is one; otherwise, returns the number of services
3503 that couldn't be moved.
3508 my ($self, $dest_pkgnum, %opt) = @_;
3514 if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
3515 $dest = $dest_pkgnum;
3516 $dest_pkgnum = $dest->pkgnum;
3518 $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
3521 return ('Package does not exist: '.$dest_pkgnum) unless $dest;
3523 foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
3524 $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
3527 foreach my $cust_svc ($dest->cust_svc) {
3528 $target{$cust_svc->svcpart}--;
3531 my %svcpart2svcparts = ();
3532 if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
3533 warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
3534 foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
3535 next if exists $svcpart2svcparts{$svcpart};
3536 my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
3537 $svcpart2svcparts{$svcpart} = [
3539 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
3541 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
3542 'svcpart' => $_ } );
3544 $pkg_svc ? $pkg_svc->primary_svc : '',
3545 $pkg_svc ? $pkg_svc->quantity : 0,
3549 grep { $_ != $svcpart }
3551 qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
3553 warn "alternates for svcpart $svcpart: ".
3554 join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
3559 foreach my $cust_svc ($self->cust_svc) {
3560 if($target{$cust_svc->svcpart} > 0
3561 or $FS::cust_svc::ignore_quantity) { # maybe should be a 'force' option
3562 $target{$cust_svc->svcpart}--;
3563 my $new = new FS::cust_svc { $cust_svc->hash };
3564 $new->pkgnum($dest_pkgnum);
3565 my $error = $new->replace($cust_svc);
3566 return $error if $error;
3567 } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
3569 warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
3570 warn "alternates to consider: ".
3571 join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
3573 my @alternate = grep {
3574 warn "considering alternate svcpart $_: ".
3575 "$target{$_} available in new package\n"
3578 } @{$svcpart2svcparts{$cust_svc->svcpart}};
3580 warn "alternate(s) found\n" if $DEBUG;
3581 my $change_svcpart = $alternate[0];
3582 $target{$change_svcpart}--;
3583 my $new = new FS::cust_svc { $cust_svc->hash };
3584 $new->svcpart($change_svcpart);
3585 $new->pkgnum($dest_pkgnum);
3586 my $error = $new->replace($cust_svc);
3587 return $error if $error;
3598 =item grab_svcnums SVCNUM, SVCNUM ...
3600 Change the pkgnum for the provided services to this packages. If there is an
3601 error, returns the error, otherwise returns false.
3609 local $SIG{HUP} = 'IGNORE';
3610 local $SIG{INT} = 'IGNORE';
3611 local $SIG{QUIT} = 'IGNORE';
3612 local $SIG{TERM} = 'IGNORE';
3613 local $SIG{TSTP} = 'IGNORE';
3614 local $SIG{PIPE} = 'IGNORE';
3616 my $oldAutoCommit = $FS::UID::AutoCommit;
3617 local $FS::UID::AutoCommit = 0;
3620 foreach my $svcnum (@svcnum) {
3621 my $cust_svc = qsearchs('cust_svc', { svcnum=>$svcnum } ) or do {
3622 $dbh->rollback if $oldAutoCommit;
3623 return "unknown svcnum $svcnum";
3625 $cust_svc->pkgnum( $self->pkgnum );
3626 my $error = $cust_svc->replace;
3628 $dbh->rollback if $oldAutoCommit;
3633 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3640 This method is deprecated. See the I<depend_jobnum> option to the insert and
3641 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
3645 #looks like this is still used by the order_pkg and change_pkg methods in
3646 # ClientAPI/MyAccount, need to look into those before removing
3650 local $SIG{HUP} = 'IGNORE';
3651 local $SIG{INT} = 'IGNORE';
3652 local $SIG{QUIT} = 'IGNORE';
3653 local $SIG{TERM} = 'IGNORE';
3654 local $SIG{TSTP} = 'IGNORE';
3655 local $SIG{PIPE} = 'IGNORE';
3657 my $oldAutoCommit = $FS::UID::AutoCommit;
3658 local $FS::UID::AutoCommit = 0;
3661 foreach my $cust_svc ( $self->cust_svc ) {
3662 #false laziness w/svc_Common::insert
3663 my $svc_x = $cust_svc->svc_x;
3664 foreach my $part_export ( $cust_svc->part_svc->part_export ) {
3665 my $error = $part_export->export_insert($svc_x);
3667 $dbh->rollback if $oldAutoCommit;
3673 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3678 =item export_pkg_change OLD_CUST_PKG
3680 Calls the "pkg_change" export action for all services attached to this package.
3684 sub export_pkg_change {
3685 my( $self, $old ) = ( shift, shift );
3687 local $SIG{HUP} = 'IGNORE';
3688 local $SIG{INT} = 'IGNORE';
3689 local $SIG{QUIT} = 'IGNORE';
3690 local $SIG{TERM} = 'IGNORE';
3691 local $SIG{TSTP} = 'IGNORE';
3692 local $SIG{PIPE} = 'IGNORE';
3694 my $oldAutoCommit = $FS::UID::AutoCommit;
3695 local $FS::UID::AutoCommit = 0;
3698 foreach my $svc_x ( map $_->svc_x, $self->cust_svc ) {
3699 my $error = $svc_x->export('pkg_change', $self, $old);
3701 $dbh->rollback if $oldAutoCommit;
3706 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3713 Associates this package with a (suspension or cancellation) reason (see
3714 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
3717 Available options are:
3723 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.
3727 the access_user (see L<FS::access_user>) providing the reason
3735 the action (cancel, susp, adjourn, expire) associated with the reason
3739 If there is an error, returns the error, otherwise returns false.
3744 my ($self, %options) = @_;
3746 my $otaker = $options{reason_otaker} ||
3747 $FS::CurrentUser::CurrentUser->username;
3750 if ( $options{'reason'} =~ /^(\d+)$/ ) {
3754 } elsif ( ref($options{'reason'}) ) {
3756 return 'Enter a new reason (or select an existing one)'
3757 unless $options{'reason'}->{'reason'} !~ /^\s*$/;
3759 my $reason = new FS::reason({
3760 'reason_type' => $options{'reason'}->{'typenum'},
3761 'reason' => $options{'reason'}->{'reason'},
3763 my $error = $reason->insert;
3764 return $error if $error;
3766 $reasonnum = $reason->reasonnum;
3769 return "Unparsable reason: ". $options{'reason'};
3772 my $cust_pkg_reason =
3773 new FS::cust_pkg_reason({ 'pkgnum' => $self->pkgnum,
3774 'reasonnum' => $reasonnum,
3775 'otaker' => $otaker,
3776 'action' => substr(uc($options{'action'}),0,1),
3777 'date' => $options{'date'}
3782 $cust_pkg_reason->insert;
3785 =item insert_discount
3787 Associates this package with a discount (see L<FS::cust_pkg_discount>, possibly
3788 inserting a new discount on the fly (see L<FS::discount>).
3790 Available options are:
3798 If there is an error, returns the error, otherwise returns false.
3802 sub insert_discount {
3803 #my ($self, %options) = @_;
3806 my $cust_pkg_discount = new FS::cust_pkg_discount {
3807 'pkgnum' => $self->pkgnum,
3808 'discountnum' => $self->discountnum,
3810 'end_date' => '', #XXX
3811 #for the create a new discount case
3812 '_type' => $self->discountnum__type,
3813 'amount' => $self->discountnum_amount,
3814 'percent' => $self->discountnum_percent,
3815 'months' => $self->discountnum_months,
3816 'setup' => $self->discountnum_setup,
3817 #'disabled' => $self->discountnum_disabled,
3820 $cust_pkg_discount->insert;
3823 =item set_usage USAGE_VALUE_HASHREF
3825 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
3826 to which they should be set (see L<FS::svc_acct>). Currently seconds,
3827 upbytes, downbytes, and totalbytes are appropriate keys.
3829 All svc_accts which are part of this package have their values reset.
3834 my ($self, $valueref, %opt) = @_;
3836 #only svc_acct can set_usage for now
3837 foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
3838 my $svc_x = $cust_svc->svc_x;
3839 $svc_x->set_usage($valueref, %opt)
3840 if $svc_x->can("set_usage");
3844 =item recharge USAGE_VALUE_HASHREF
3846 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
3847 to which they should be set (see L<FS::svc_acct>). Currently seconds,
3848 upbytes, downbytes, and totalbytes are appropriate keys.
3850 All svc_accts which are part of this package have their values incremented.
3855 my ($self, $valueref) = @_;
3857 #only svc_acct can set_usage for now
3858 foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
3859 my $svc_x = $cust_svc->svc_x;
3860 $svc_x->recharge($valueref)
3861 if $svc_x->can("recharge");
3865 =item cust_pkg_discount
3869 sub cust_pkg_discount {
3871 qsearch('cust_pkg_discount', { 'pkgnum' => $self->pkgnum } );
3874 =item cust_pkg_discount_active
3878 sub cust_pkg_discount_active {
3880 grep { $_->status eq 'active' } $self->cust_pkg_discount;
3883 =item cust_pkg_usage
3885 Returns a list of all voice usage counters attached to this package.
3889 sub cust_pkg_usage {
3891 qsearch('cust_pkg_usage', { pkgnum => $self->pkgnum });
3894 =item apply_usage OPTIONS
3896 Takes the following options:
3897 - cdr: a call detail record (L<FS::cdr>)
3898 - rate_detail: the rate determined for this call (L<FS::rate_detail>)
3899 - minutes: the maximum number of minutes to be charged
3901 Finds available usage minutes for a call of this class, and subtracts
3902 up to that many minutes from the usage pool. If the usage pool is empty,
3903 and the C<cdr-minutes_priority> global config option is set, minutes may
3904 be taken from other calls as well. Either way, an allocation record will
3905 be created (L<FS::cdr_cust_pkg_usage>) and this method will return the
3906 number of minutes of usage applied to the call.
3911 my ($self, %opt) = @_;
3912 my $cdr = $opt{cdr};
3913 my $rate_detail = $opt{rate_detail};
3914 my $minutes = $opt{minutes};
3915 my $classnum = $rate_detail->classnum;
3916 my $pkgnum = $self->pkgnum;
3917 my $custnum = $self->custnum;
3919 local $SIG{HUP} = 'IGNORE';
3920 local $SIG{INT} = 'IGNORE';
3921 local $SIG{QUIT} = 'IGNORE';
3922 local $SIG{TERM} = 'IGNORE';
3923 local $SIG{TSTP} = 'IGNORE';
3924 local $SIG{PIPE} = 'IGNORE';
3926 my $oldAutoCommit = $FS::UID::AutoCommit;
3927 local $FS::UID::AutoCommit = 0;
3929 my $order = FS::Conf->new->config('cdr-minutes_priority');
3933 $is_classnum = ' part_pkg_usage_class.classnum = '.$classnum;
3935 $is_classnum = ' part_pkg_usage_class.classnum IS NULL';
3937 my @usage_recs = qsearch({
3938 'table' => 'cust_pkg_usage',
3939 'addl_from' => ' JOIN part_pkg_usage USING (pkgusagepart)'.
3940 ' JOIN cust_pkg USING (pkgnum)'.
3941 ' JOIN part_pkg_usage_class USING (pkgusagepart)',
3942 'select' => 'cust_pkg_usage.*',
3943 'extra_sql' => " WHERE ( cust_pkg.pkgnum = $pkgnum OR ".
3944 " ( cust_pkg.custnum = $custnum AND ".
3945 " part_pkg_usage.shared IS NOT NULL ) ) AND ".
3946 $is_classnum . ' AND '.
3947 " cust_pkg_usage.minutes > 0",
3948 'order_by' => " ORDER BY priority ASC",
3951 my $orig_minutes = $minutes;
3953 while (!$error and $minutes > 0 and @usage_recs) {
3954 my $cust_pkg_usage = shift @usage_recs;
3955 $cust_pkg_usage->select_for_update;
3956 my $cdr_cust_pkg_usage = FS::cdr_cust_pkg_usage->new({
3957 pkgusagenum => $cust_pkg_usage->pkgusagenum,
3958 acctid => $cdr->acctid,
3959 minutes => min($cust_pkg_usage->minutes, $minutes),
3961 $cust_pkg_usage->set('minutes',
3962 sprintf('%.0f', $cust_pkg_usage->minutes - $cdr_cust_pkg_usage->minutes)
3964 $error = $cust_pkg_usage->replace || $cdr_cust_pkg_usage->insert;
3965 $minutes -= $cdr_cust_pkg_usage->minutes;
3967 if ( $order and $minutes > 0 and !$error ) {
3968 # then try to steal minutes from another call
3970 'table' => 'cdr_cust_pkg_usage',
3971 'addl_from' => ' JOIN cust_pkg_usage USING (pkgusagenum)'.
3972 ' JOIN part_pkg_usage USING (pkgusagepart)'.
3973 ' JOIN cust_pkg USING (pkgnum)'.
3974 ' JOIN part_pkg_usage_class USING (pkgusagepart)'.
3975 ' JOIN cdr USING (acctid)',
3976 'select' => 'cdr_cust_pkg_usage.*',
3977 'extra_sql' => " WHERE cdr.freesidestatus = 'rated' AND ".
3978 " ( cust_pkg.pkgnum = $pkgnum OR ".
3979 " ( cust_pkg.custnum = $custnum AND ".
3980 " part_pkg_usage.shared IS NOT NULL ) ) AND ".
3981 " part_pkg_usage_class.classnum = $classnum",
3982 'order_by' => ' ORDER BY part_pkg_usage.priority ASC',
3984 if ( $order eq 'time' ) {
3985 # find CDRs that are using minutes, but have a later startdate
3987 my $startdate = $cdr->startdate;
3988 if ($startdate !~ /^\d+$/) {
3989 die "bad cdr startdate '$startdate'";
3991 $search{'extra_sql'} .= " AND cdr.startdate > $startdate";
3992 # minimize needless reshuffling
3993 $search{'order_by'} .= ', cdr.startdate DESC';
3995 # XXX may not work correctly with rate_time schedules. Could
3996 # fix this by storing ratedetailnum in cdr_cust_pkg_usage, I
3998 $search{'addl_from'} .=
3999 ' JOIN rate_detail'.
4000 ' ON (cdr.rated_ratedetailnum = rate_detail.ratedetailnum)';
4001 if ( $order eq 'rate_high' ) {
4002 $search{'extra_sql'} .= ' AND rate_detail.min_charge < '.
4003 $rate_detail->min_charge;
4004 $search{'order_by'} .= ', rate_detail.min_charge ASC';
4005 } elsif ( $order eq 'rate_low' ) {
4006 $search{'extra_sql'} .= ' AND rate_detail.min_charge > '.
4007 $rate_detail->min_charge;
4008 $search{'order_by'} .= ', rate_detail.min_charge DESC';
4010 # this should really never happen
4011 die "invalid cdr-minutes_priority value '$order'\n";
4014 my @cdr_usage_recs = qsearch(\%search);
4016 while (!$error and @cdr_usage_recs and $minutes > 0) {
4017 my $cdr_cust_pkg_usage = shift @cdr_usage_recs;
4018 my $cust_pkg_usage = $cdr_cust_pkg_usage->cust_pkg_usage;
4019 my $old_cdr = $cdr_cust_pkg_usage->cdr;
4020 $reproc_cdrs{$old_cdr->acctid} = $old_cdr;
4021 $cdr_cust_pkg_usage->select_for_update;
4022 $old_cdr->select_for_update;
4023 $cust_pkg_usage->select_for_update;
4024 # in case someone else stole the usage from this CDR
4025 # while waiting for the lock...
4026 next if $old_cdr->acctid != $cdr_cust_pkg_usage->acctid;
4027 # steal the usage allocation and flag the old CDR for reprocessing
4028 $cdr_cust_pkg_usage->set('acctid', $cdr->acctid);
4029 # if the allocation is more minutes than we need, adjust it...
4030 my $delta = $cdr_cust_pkg_usage->minutes - $minutes;
4032 $cdr_cust_pkg_usage->set('minutes', $minutes);
4033 $cust_pkg_usage->set('minutes', $cust_pkg_usage->minutes + $delta);
4034 $error = $cust_pkg_usage->replace;
4036 #warn 'CDR '.$cdr->acctid . ' stealing allocation '.$cdr_cust_pkg_usage->cdrusagenum.' from CDR '.$old_cdr->acctid."\n";
4037 $error ||= $cdr_cust_pkg_usage->replace;
4038 # deduct the stolen minutes
4039 $minutes -= $cdr_cust_pkg_usage->minutes;
4041 # after all minute-stealing is done, reset the affected CDRs
4042 foreach (values %reproc_cdrs) {
4043 $error ||= $_->set_status('');
4044 # XXX or should we just call $cdr->rate right here?
4045 # it's not like we can create a loop this way, since the min_charge
4046 # or call time has to go monotonically in one direction.
4047 # we COULD get some very deep recursions going, though...
4049 } # if $order and $minutes
4052 die "error applying included minutes\npkgnum ".$self->pkgnum.", class $classnum, acctid ".$cdr->acctid."\n$error\n"
4054 $dbh->commit if $oldAutoCommit;
4055 return $orig_minutes - $minutes;
4059 =item supplemental_pkgs
4061 Returns a list of all packages supplemental to this one.
4065 sub supplemental_pkgs {
4067 qsearch('cust_pkg', { 'main_pkgnum' => $self->pkgnum });
4072 Returns the package that this one is supplemental to, if any.
4078 if ( $self->main_pkgnum ) {
4079 return FS::cust_pkg->by_key($self->main_pkgnum);
4086 =head1 CLASS METHODS
4092 Returns an SQL expression identifying recurring packages.
4096 sub recurring_sql { "
4097 '0' != ( select freq from part_pkg
4098 where cust_pkg.pkgpart = part_pkg.pkgpart )
4103 Returns an SQL expression identifying one-time packages.
4108 '0' = ( select freq from part_pkg
4109 where cust_pkg.pkgpart = part_pkg.pkgpart )
4114 Returns an SQL expression identifying ordered packages (recurring packages not
4120 $_[0]->recurring_sql. " AND ". $_[0]->not_yet_billed_sql;
4125 Returns an SQL expression identifying active packages.
4130 $_[0]->recurring_sql. "
4131 AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
4132 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4133 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
4136 =item not_yet_billed_sql
4138 Returns an SQL expression identifying packages which have not yet been billed.
4142 sub not_yet_billed_sql { "
4143 ( cust_pkg.setup IS NULL OR cust_pkg.setup = 0 )
4144 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4145 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
4150 Returns an SQL expression identifying inactive packages (one-time packages
4151 that are otherwise unsuspended/uncancelled).
4155 sub inactive_sql { "
4156 ". $_[0]->onetime_sql(). "
4157 AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
4158 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4159 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
4165 Returns an SQL expression identifying suspended packages.
4169 sub suspended_sql { susp_sql(@_); }
4171 #$_[0]->recurring_sql(). ' AND '.
4173 ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4174 AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0
4181 Returns an SQL exprression identifying cancelled packages.
4185 sub cancelled_sql { cancel_sql(@_); }
4187 #$_[0]->recurring_sql(). ' AND '.
4188 "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
4193 Returns an SQL expression to give the package status as a string.
4199 WHEN cust_pkg.cancel IS NOT NULL THEN 'cancelled'
4200 WHEN cust_pkg.susp IS NOT NULL THEN 'suspended'
4201 WHEN cust_pkg.setup IS NULL THEN 'not yet billed'
4202 WHEN ".onetime_sql()." THEN 'one-time charge'
4207 =item search HASHREF
4211 Returns a qsearch hash expression to search for parameters specified in HASHREF.
4212 Valid parameters are
4220 active, inactive, suspended, cancel (or cancelled)
4224 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
4228 boolean selects custom packages
4234 pkgpart or arrayref or hashref of pkgparts
4238 arrayref of beginning and ending epoch date
4242 arrayref of beginning and ending epoch date
4246 arrayref of beginning and ending epoch date
4250 arrayref of beginning and ending epoch date
4254 arrayref of beginning and ending epoch date
4258 arrayref of beginning and ending epoch date
4262 arrayref of beginning and ending epoch date
4266 pkgnum or APKG_pkgnum
4270 a value suited to passing to FS::UI::Web::cust_header
4274 specifies the user for agent virtualization
4278 boolean; if true, returns only packages with more than 0 FCC phone lines.
4280 =item state, country
4282 Limit to packages with a service location in the specified state and country.
4283 For FCC 477 reporting, mostly.
4290 my ($class, $params) = @_;
4297 if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
4299 "cust_main.agentnum = $1";
4306 if ( $params->{'cust_status'} =~ /^([a-z]+)$/ ) {
4307 push @where, FS::cust_main->cust_status_sql . " = '$1' ";
4311 # parse customer sales person
4314 if ( $params->{'cust_main_salesnum'} =~ /^(\d+)$/ ) {
4315 push @where, ($1 > 0) ? "cust_main.salesnum = $1"
4316 : 'cust_main.salesnum IS NULL';
4321 # parse sales person
4324 if ( $params->{'salesnum'} =~ /^(\d+)$/ ) {
4325 push @where, ($1 > 0) ? "cust_pkg.salesnum = $1"
4326 : 'cust_pkg.salesnum IS NULL';
4333 if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
4335 "cust_pkg.custnum = $1";
4342 if ( $params->{'pkgbatch'} =~ /^([\w\/\-\:\.]+)$/ and $1 ) {
4344 "cust_pkg.pkgbatch = '$1'";
4351 if ( $params->{'magic'} eq 'active'
4352 || $params->{'status'} eq 'active' ) {
4354 push @where, FS::cust_pkg->active_sql();
4356 } elsif ( $params->{'magic'} =~ /^not[ _]yet[ _]billed$/
4357 || $params->{'status'} =~ /^not[ _]yet[ _]billed$/ ) {
4359 push @where, FS::cust_pkg->not_yet_billed_sql();
4361 } elsif ( $params->{'magic'} =~ /^(one-time charge|inactive)/
4362 || $params->{'status'} =~ /^(one-time charge|inactive)/ ) {
4364 push @where, FS::cust_pkg->inactive_sql();
4366 } elsif ( $params->{'magic'} eq 'suspended'
4367 || $params->{'status'} eq 'suspended' ) {
4369 push @where, FS::cust_pkg->suspended_sql();
4371 } elsif ( $params->{'magic'} =~ /^cancell?ed$/
4372 || $params->{'status'} =~ /^cancell?ed$/ ) {
4374 push @where, FS::cust_pkg->cancelled_sql();
4379 # parse package class
4382 if ( exists($params->{'classnum'}) ) {
4385 if ( ref($params->{'classnum'}) ) {
4387 if ( ref($params->{'classnum'}) eq 'HASH' ) {
4388 @classnum = grep $params->{'classnum'}{$_}, keys %{ $params->{'classnum'} };
4389 } elsif ( ref($params->{'classnum'}) eq 'ARRAY' ) {
4390 @classnum = @{ $params->{'classnum'} };
4392 die 'unhandled classnum ref '. $params->{'classnum'};
4396 } elsif ( $params->{'classnum'} =~ /^(\d*)$/ && $1 ne '0' ) {
4403 my @nums = grep $_, @classnum;
4404 push @c_where, 'part_pkg.classnum IN ('. join(',',@nums). ')' if @nums;
4405 my $null = scalar( grep { $_ eq '' } @classnum );
4406 push @c_where, 'part_pkg.classnum IS NULL' if $null;
4408 if ( scalar(@c_where) == 1 ) {
4409 push @where, @c_where;
4410 } elsif ( @c_where ) {
4411 push @where, ' ( '. join(' OR ', @c_where). ' ) ';
4420 # parse package report options
4423 my @report_option = ();
4424 if ( exists($params->{'report_option'}) ) {
4425 if ( ref($params->{'report_option'}) eq 'ARRAY' ) {
4426 @report_option = @{ $params->{'report_option'} };
4427 } elsif ( $params->{'report_option'} =~ /^([,\d]*)$/ ) {
4428 @report_option = split(',', $1);
4433 if (@report_option) {
4434 # this will result in the empty set for the dangling comma case as it should
4436 map{ "0 < ( SELECT count(*) FROM part_pkg_option
4437 WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
4438 AND optionname = 'report_option_$_'
4439 AND optionvalue = '1' )"
4443 foreach my $any ( grep /^report_option_any/, keys %$params ) {
4445 my @report_option_any = ();
4446 if ( ref($params->{$any}) eq 'ARRAY' ) {
4447 @report_option_any = @{ $params->{$any} };
4448 } elsif ( $params->{$any} =~ /^([,\d]*)$/ ) {
4449 @report_option_any = split(',', $1);
4452 if (@report_option_any) {
4453 # this will result in the empty set for the dangling comma case as it should
4454 push @where, ' ( '. join(' OR ',
4455 map{ "0 < ( SELECT count(*) FROM part_pkg_option
4456 WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
4457 AND optionname = 'report_option_$_'
4458 AND optionvalue = '1' )"
4459 } @report_option_any
4469 push @where, "part_pkg.custom = 'Y'" if $params->{custom};
4475 push @where, "(part_pkg.fcc_ds0s > 0 OR pkg_class.fcc_ds0s > 0)"
4476 if $params->{fcc_line};
4482 if ( exists($params->{'censustract'}) ) {
4483 $params->{'censustract'} =~ /^([.\d]*)$/;
4484 my $censustract = "cust_location.censustract = '$1'";
4485 $censustract .= ' OR cust_location.censustract is NULL' unless $1;
4486 push @where, "( $censustract )";
4490 # parse censustract2
4492 if ( exists($params->{'censustract2'})
4493 && $params->{'censustract2'} =~ /^(\d*)$/
4497 push @where, "cust_location.censustract LIKE '$1%'";
4500 "( cust_location.censustract = '' OR cust_location.censustract IS NULL )";
4505 # parse country/state
4507 for (qw(state country)) { # parsing rules are the same for these
4508 if ( exists($params->{$_})
4509 && uc($params->{$_}) =~ /^([A-Z]{2})$/ )
4511 # XXX post-2.3 only--before that, state/country may be in cust_main
4512 push @where, "cust_location.$_ = '$1'";
4520 if ( ref($params->{'pkgpart'}) ) {
4523 if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
4524 @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
4525 } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
4526 @pkgpart = @{ $params->{'pkgpart'} };
4528 die 'unhandled pkgpart ref '. $params->{'pkgpart'};
4531 @pkgpart = grep /^(\d+)$/, @pkgpart;
4533 push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
4535 } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
4536 push @where, "pkgpart = $1";
4545 #false laziness w/report_cust_pkg.html
4548 'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
4549 'active' => { 'susp'=>1, 'cancel'=>1 },
4550 'suspended' => { 'cancel' => 1 },
4555 if( exists($params->{'active'} ) ) {
4556 # This overrides all the other date-related fields
4557 my($beginning, $ending) = @{$params->{'active'}};
4559 "cust_pkg.setup IS NOT NULL",
4560 "cust_pkg.setup <= $ending",
4561 "(cust_pkg.cancel IS NULL OR cust_pkg.cancel >= $beginning )",
4562 "NOT (".FS::cust_pkg->onetime_sql . ")";
4565 foreach my $field (qw( setup last_bill bill adjourn susp expire contract_end change_date cancel )) {
4567 next unless exists($params->{$field});
4569 my($beginning, $ending) = @{$params->{$field}};
4571 next if $beginning == 0 && $ending == 4294967295;
4574 "cust_pkg.$field IS NOT NULL",
4575 "cust_pkg.$field >= $beginning",
4576 "cust_pkg.$field <= $ending";
4578 $orderby ||= "ORDER BY cust_pkg.$field";
4583 $orderby ||= 'ORDER BY bill';
4586 # parse magic, legacy, etc.
4589 if ( $params->{'magic'} &&
4590 $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
4593 $orderby = 'ORDER BY pkgnum';
4595 if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
4596 push @where, "pkgpart = $1";
4599 } elsif ( $params->{'query'} eq 'pkgnum' ) {
4601 $orderby = 'ORDER BY pkgnum';
4603 } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
4605 $orderby = 'ORDER BY pkgnum';
4608 SELECT count(*) FROM pkg_svc
4609 WHERE pkg_svc.pkgpart = cust_pkg.pkgpart
4610 AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
4611 WHERE cust_svc.pkgnum = cust_pkg.pkgnum
4612 AND cust_svc.svcpart = pkg_svc.svcpart
4619 # setup queries, links, subs, etc. for the search
4622 # here is the agent virtualization
4623 if ($params->{CurrentUser}) {
4625 qsearchs('access_user', { username => $params->{CurrentUser} });
4628 push @where, $access_user->agentnums_sql('table'=>'cust_main');
4633 push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
4636 my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
4638 my $addl_from = 'LEFT JOIN part_pkg USING ( pkgpart ) '.
4639 'LEFT JOIN pkg_class ON ( part_pkg.classnum = pkg_class.classnum ) '.
4640 'LEFT JOIN cust_location USING ( locationnum ) '.
4641 FS::UI::Web::join_cust_main('cust_pkg', 'cust_pkg');
4645 if ( $params->{'select_zip5'} ) {
4646 my $zip = 'cust_location.zip';
4648 $select = "DISTINCT substr($zip,1,5) as zip";
4649 $orderby = "ORDER BY substr($zip,1,5)";
4650 $count_query = "SELECT COUNT( DISTINCT substr($zip,1,5) )";
4652 $select = join(', ',
4654 ( map "part_pkg.$_", qw( pkg freq ) ),
4655 'pkg_class.classname',
4656 'cust_main.custnum AS cust_main_custnum',
4657 FS::UI::Web::cust_sql_fields(
4658 $params->{'cust_fields'}
4661 $count_query = 'SELECT COUNT(*)';
4664 $count_query .= " FROM cust_pkg $addl_from $extra_sql";
4667 'table' => 'cust_pkg',
4669 'select' => $select,
4670 'extra_sql' => $extra_sql,
4671 'order_by' => $orderby,
4672 'addl_from' => $addl_from,
4673 'count_query' => $count_query,
4680 Returns a list of two package counts. The first is a count of packages
4681 based on the supplied criteria and the second is the count of residential
4682 packages with those same criteria. Criteria are specified as in the search
4688 my ($class, $params) = @_;
4690 my $sql_query = $class->search( $params );
4692 my $count_sql = delete($sql_query->{'count_query'});
4693 $count_sql =~ s/ FROM/,count(CASE WHEN cust_main.company IS NULL OR cust_main.company = '' THEN 1 END) FROM/
4694 or die "couldn't parse count_sql";
4696 my $count_sth = dbh->prepare($count_sql)
4697 or die "Error preparing $count_sql: ". dbh->errstr;
4699 or die "Error executing $count_sql: ". $count_sth->errstr;
4700 my $count_arrayref = $count_sth->fetchrow_arrayref;
4702 return ( @$count_arrayref );
4706 =item tax_locationnum_sql
4708 Returns an SQL expression for the tax location for a package, based
4709 on the settings of 'tax-pkg_address' and 'tax-ship_address'.
4713 sub tax_locationnum_sql {
4714 my $conf = FS::Conf->new;
4715 if ( $conf->exists('tax-pkg_address') ) {
4716 'cust_pkg.locationnum';
4718 elsif ( $conf->exists('tax-ship_address') ) {
4719 'cust_main.ship_locationnum';
4722 'cust_main.bill_locationnum';
4728 Returns a list: the first item is an SQL fragment identifying matching
4729 packages/customers via location (taking into account shipping and package
4730 address taxation, if enabled), and subsequent items are the parameters to
4731 substitute for the placeholders in that fragment.
4736 my($class, %opt) = @_;
4737 my $ornull = $opt{'ornull'};
4739 my $conf = new FS::Conf;
4741 # '?' placeholders in _location_sql_where
4742 my $x = $ornull ? 3 : 2;
4753 if ( $conf->exists('tax-ship_address') ) {
4756 ( ( ship_last IS NULL OR ship_last = '' )
4757 AND ". _location_sql_where('cust_main', '', $ornull ). "
4759 OR ( ship_last IS NOT NULL AND ship_last != ''
4760 AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
4763 # AND payby != 'COMP'
4765 @main_param = ( @bill_param, @bill_param );
4769 $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
4770 @main_param = @bill_param;
4776 if ( $conf->exists('tax-pkg_address') ) {
4778 my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
4781 ( cust_pkg.locationnum IS NULL AND $main_where )
4782 OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where )
4785 @param = ( @main_param, @bill_param );
4789 $where = $main_where;
4790 @param = @main_param;
4798 #subroutine, helper for location_sql
4799 sub _location_sql_where {
4801 my $prefix = @_ ? shift : '';
4802 my $ornull = @_ ? shift : '';
4804 # $ornull = $ornull ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
4806 $ornull = $ornull ? ' OR ? IS NULL ' : '';
4808 my $or_empty_city = " OR ( ? = '' AND $table.${prefix}city IS NULL )";
4809 my $or_empty_county = " OR ( ? = '' AND $table.${prefix}county IS NULL )";
4810 my $or_empty_state = " OR ( ? = '' AND $table.${prefix}state IS NULL )";
4812 my $text = (driver_name =~ /^mysql/i) ? 'char' : 'text';
4814 # ( $table.${prefix}city = ? $or_empty_city $ornull )
4816 ( $table.district = ? OR ? = '' OR CAST(? AS $text) IS NULL )
4817 AND ( $table.${prefix}city = ? OR ? = '' OR CAST(? AS $text) IS NULL )
4818 AND ( $table.${prefix}county = ? $or_empty_county $ornull )
4819 AND ( $table.${prefix}state = ? $or_empty_state $ornull )
4820 AND $table.${prefix}country = ?
4825 my( $self, $what ) = @_;
4827 my $what_show_zero = $what. '_show_zero';
4828 length($self->$what_show_zero())
4829 ? ($self->$what_show_zero() eq 'Y')
4830 : $self->part_pkg->$what_show_zero();
4837 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
4839 CUSTNUM is a customer (see L<FS::cust_main>)
4841 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
4842 L<FS::part_pkg>) to order for this customer. Duplicates are of course
4845 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
4846 remove for this customer. The services (see L<FS::cust_svc>) are moved to the
4847 new billing items. An error is returned if this is not possible (see
4848 L<FS::pkg_svc>). An empty arrayref is equivalent to not specifying this
4851 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
4852 newly-created cust_pkg objects.
4854 REFNUM, if specified, will specify the FS::pkg_referral record to be created
4855 and inserted. Multiple FS::pkg_referral records can be created by
4856 setting I<refnum> to an array reference of refnums or a hash reference with
4857 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
4858 record will be created corresponding to cust_main.refnum.
4863 my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
4865 my $conf = new FS::Conf;
4867 # Transactionize this whole mess
4868 local $SIG{HUP} = 'IGNORE';
4869 local $SIG{INT} = 'IGNORE';
4870 local $SIG{QUIT} = 'IGNORE';
4871 local $SIG{TERM} = 'IGNORE';
4872 local $SIG{TSTP} = 'IGNORE';
4873 local $SIG{PIPE} = 'IGNORE';
4875 my $oldAutoCommit = $FS::UID::AutoCommit;
4876 local $FS::UID::AutoCommit = 0;
4880 # my $cust_main = qsearchs('cust_main', { custnum => $custnum });
4881 # return "Customer not found: $custnum" unless $cust_main;
4883 warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
4886 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
4889 my $change = scalar(@old_cust_pkg) != 0;
4892 if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
4894 warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
4895 " to pkgpart ". $pkgparts->[0]. "\n"
4898 my $err_or_cust_pkg =
4899 $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
4900 'refnum' => $refnum,
4903 unless (ref($err_or_cust_pkg)) {
4904 $dbh->rollback if $oldAutoCommit;
4905 return $err_or_cust_pkg;
4908 push @$return_cust_pkg, $err_or_cust_pkg;
4909 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4914 # Create the new packages.
4915 foreach my $pkgpart (@$pkgparts) {
4917 warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
4919 my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
4920 pkgpart => $pkgpart,
4924 $error = $cust_pkg->insert( 'change' => $change );
4925 push @$return_cust_pkg, $cust_pkg;
4927 foreach my $link ($cust_pkg->part_pkg->supp_part_pkg_link) {
4928 my $supp_pkg = FS::cust_pkg->new({
4929 custnum => $custnum,
4930 pkgpart => $link->dst_pkgpart,
4932 main_pkgnum => $cust_pkg->pkgnum,
4935 $error ||= $supp_pkg->insert( 'change' => $change );
4936 push @$return_cust_pkg, $supp_pkg;
4940 $dbh->rollback if $oldAutoCommit;
4945 # $return_cust_pkg now contains refs to all of the newly
4948 # Transfer services and cancel old packages.
4949 foreach my $old_pkg (@old_cust_pkg) {
4951 warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
4954 foreach my $new_pkg (@$return_cust_pkg) {
4955 $error = $old_pkg->transfer($new_pkg);
4956 if ($error and $error == 0) {
4957 # $old_pkg->transfer failed.
4958 $dbh->rollback if $oldAutoCommit;
4963 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
4964 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
4965 foreach my $new_pkg (@$return_cust_pkg) {
4966 $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
4967 if ($error and $error == 0) {
4968 # $old_pkg->transfer failed.
4969 $dbh->rollback if $oldAutoCommit;
4976 # Transfers were successful, but we went through all of the
4977 # new packages and still had services left on the old package.
4978 # We can't cancel the package under the circumstances, so abort.
4979 $dbh->rollback if $oldAutoCommit;
4980 return "Unable to transfer all services from package ".$old_pkg->pkgnum;
4982 $error = $old_pkg->cancel( quiet=>1 );
4988 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4992 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
4994 A bulk change method to change packages for multiple customers.
4996 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
4997 L<FS::part_pkg>) to order for each customer. Duplicates are of course
5000 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
5001 replace. The services (see L<FS::cust_svc>) are moved to the
5002 new billing items. An error is returned if this is not possible (see
5005 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
5006 newly-created cust_pkg objects.
5011 my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
5013 # Transactionize this whole mess
5014 local $SIG{HUP} = 'IGNORE';
5015 local $SIG{INT} = 'IGNORE';
5016 local $SIG{QUIT} = 'IGNORE';
5017 local $SIG{TERM} = 'IGNORE';
5018 local $SIG{TSTP} = 'IGNORE';
5019 local $SIG{PIPE} = 'IGNORE';
5021 my $oldAutoCommit = $FS::UID::AutoCommit;
5022 local $FS::UID::AutoCommit = 0;
5026 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
5029 while(scalar(@old_cust_pkg)) {
5031 my $custnum = $old_cust_pkg[0]->custnum;
5032 my (@remove) = map { $_->pkgnum }
5033 grep { $_->custnum == $custnum } @old_cust_pkg;
5034 @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
5036 my $error = order $custnum, $pkgparts, \@remove, \@return;
5038 push @errors, $error
5040 push @$return_cust_pkg, @return;
5043 if (scalar(@errors)) {
5044 $dbh->rollback if $oldAutoCommit;
5045 return join(' / ', @errors);
5048 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
5052 # Used by FS::Upgrade to migrate to a new database.
5053 sub _upgrade_data { # class method
5054 my ($class, %opts) = @_;
5055 $class->_upgrade_otaker(%opts);
5057 # RT#10139, bug resulting in contract_end being set when it shouldn't
5058 'UPDATE cust_pkg SET contract_end = NULL WHERE contract_end = -1',
5059 # RT#10830, bad calculation of prorate date near end of year
5060 # the date range for bill is December 2009, and we move it forward
5061 # one year if it's before the previous bill date (which it should
5063 'UPDATE cust_pkg SET bill = bill + (365*24*60*60) WHERE bill < last_bill
5064 AND bill > 1259654400 AND bill < 1262332800 AND (SELECT plan FROM part_pkg
5065 WHERE part_pkg.pkgpart = cust_pkg.pkgpart) = \'prorate\'',
5066 # RT6628, add order_date to cust_pkg
5067 'update cust_pkg set order_date = (select history_date from h_cust_pkg
5068 where h_cust_pkg.pkgnum = cust_pkg.pkgnum and
5069 history_action = \'insert\') where order_date is null',
5071 foreach my $sql (@statements) {
5072 my $sth = dbh->prepare($sql);
5073 $sth->execute or die $sth->errstr;
5081 sub order is not OO. Perhaps it should be moved to FS::cust_main and made so?
5083 In sub order, the @pkgparts array (passed by reference) is clobbered.
5085 Also in sub order, no money is adjusted. Once FS::part_pkg defines a standard
5086 method to pass dates to the recur_prog expression, it should do so.
5088 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
5089 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
5090 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
5091 configuration values. Probably need a subroutine which decides what to do
5092 based on whether or not we've fetched the user yet, rather than a hash. See
5093 FS::UID and the TODO.
5095 Now that things are transactional should the check in the insert method be
5100 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
5101 L<FS::pkg_svc>, schema.html from the base documentation