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 );
7 use vars qw( $disable_agentcheck $DEBUG $me $upgrade );
9 use Scalar::Util qw( blessed );
10 use List::Util qw(min max);
12 use Time::Local qw( timelocal timelocal_nocheck );
14 use FS::UID qw( getotaker dbh driver_name );
15 use FS::Misc qw( send_email );
16 use FS::Record qw( qsearch qsearchs fields );
22 use FS::cust_location;
24 use FS::cust_bill_pkg;
25 use FS::cust_pkg_detail;
26 use FS::cust_pkg_usage;
27 use FS::cdr_cust_pkg_usage;
32 use FS::cust_pkg_reason;
34 use FS::cust_pkg_discount;
41 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
43 # because they load configuration by setting FS::UID::callback (see TODO)
49 # for sending cancel emails in sub cancel
53 $me = '[FS::cust_pkg]';
55 $disable_agentcheck = 0;
57 $upgrade = 0; #go away after setup+start dates cleaned up for old customers
61 my ( $hashref, $cache ) = @_;
62 #if ( $hashref->{'pkgpart'} ) {
63 if ( $hashref->{'pkg'} ) {
64 # #@{ $self->{'_pkgnum'} } = ();
65 # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
66 # $self->{'_pkgpart'} = $subcache;
67 # #push @{ $self->{'_pkgnum'} },
68 # FS::part_pkg->new_or_cached($hashref, $subcache);
69 $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
71 if ( exists $hashref->{'svcnum'} ) {
72 #@{ $self->{'_pkgnum'} } = ();
73 my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
74 $self->{'_svcnum'} = $subcache;
75 #push @{ $self->{'_pkgnum'} },
76 FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
82 FS::cust_pkg - Object methods for cust_pkg objects
88 $record = new FS::cust_pkg \%hash;
89 $record = new FS::cust_pkg { 'column' => 'value' };
91 $error = $record->insert;
93 $error = $new_record->replace($old_record);
95 $error = $record->delete;
97 $error = $record->check;
99 $error = $record->cancel;
101 $error = $record->suspend;
103 $error = $record->unsuspend;
105 $part_pkg = $record->part_pkg;
107 @labels = $record->labels;
109 $seconds = $record->seconds_since($timestamp);
111 $error = FS::cust_pkg::order( $custnum, \@pkgparts );
112 $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
116 An FS::cust_pkg object represents a customer billing item. FS::cust_pkg
117 inherits from FS::Record. The following fields are currently supported:
123 Primary key (assigned automatically for new billing items)
127 Customer (see L<FS::cust_main>)
131 Billing item definition (see L<FS::part_pkg>)
135 Optional link to package location (see L<FS::location>)
139 date package was ordered (also remains same on changes)
151 date (next bill date)
179 order taker (see L<FS::access_user>)
183 If this field is set to 1, disables the automatic
184 unsuspension of this package when using the B<unsuspendauto> config option.
188 If not set, defaults to 1
192 Date of change from previous package
202 =item change_locationnum
210 The pkgnum of the package that this package is supplemental to, if any.
214 The package link (L<FS::part_pkg_link>) that defines this supplemental
215 package, if it is one.
217 =item change_to_pkgnum
219 The pkgnum of the package this one will be "changed to" in the future
220 (on its expiration date).
224 Note: setup, last_bill, bill, adjourn, susp, expire, cancel and change_date
225 are specified as UNIX timestamps; see L<perlfunc/"time">. Also see
226 L<Time::Local> and L<Date::Parse> for conversion functions.
234 Create a new billing item. To add the item to the database, see L<"insert">.
238 sub table { 'cust_pkg'; }
239 sub cust_linked { $_[0]->cust_main_custnum || $_[0]->custnum }
240 sub cust_unlinked_msg {
242 "WARNING: can't find cust_main.custnum ". $self->custnum.
243 ' (cust_pkg.pkgnum '. $self->pkgnum. ')';
246 =item set_initial_timers
248 If required by the package definition, sets any automatic expire, adjourn,
249 or contract_end timers to some number of months after the start date
250 (or setup date, if the package has already been setup). If the package has
251 a delayed setup fee after a period of "free days", will also set the
252 start date to the end of that period.
256 sub set_initial_timers {
258 my $part_pkg = $self->part_pkg;
259 foreach my $action ( qw(expire adjourn contract_end) ) {
260 my $months = $part_pkg->option("${action}_months",1);
261 if($months and !$self->get($action)) {
262 my $start = $self->start_date || $self->setup || time;
263 $self->set($action, $part_pkg->add_freq($start, $months) );
267 # if this package has "free days" and delayed setup fee, then
268 # set start date that many days in the future.
269 # (this should have been set in the UI, but enforce it here)
270 if ( $part_pkg->option('free_days',1)
271 && $part_pkg->option('delay_setup',1)
274 $self->start_date( $part_pkg->default_start_date );
279 =item insert [ OPTION => VALUE ... ]
281 Adds this billing item to the database ("Orders" the item). If there is an
282 error, returns the error, otherwise returns false.
284 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
285 will be used to look up the package definition and agent restrictions will be
288 If the additional field I<refnum> is defined, an FS::pkg_referral record will
289 be created and inserted. Multiple FS::pkg_referral records can be created by
290 setting I<refnum> to an array reference of refnums or a hash reference with
291 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
292 record will be created corresponding to cust_main.refnum.
294 The following options are available:
300 If set true, supresses actions that should only be taken for new package
301 orders. (Currently this includes: intro periods when delay_setup is on,
302 auto-adding a 1st start date, auto-adding expiration/adjourn/contract_end dates)
306 cust_pkg_option records will be created
310 a ticket will be added to this customer with this subject
314 an optional queue name for ticket additions
318 Don't check the legality of the package definition. This should be used
319 when performing a package change that doesn't change the pkgpart (i.e.
327 my( $self, %options ) = @_;
330 $error = $self->check_pkgpart unless $options{'allow_pkgpart'};
331 return $error if $error;
333 my $part_pkg = $self->part_pkg;
335 if ( ! $options{'change'} ) {
337 # set order date to now
338 $self->order_date(time);
340 # if the package def says to start only on the first of the month:
341 if ( $part_pkg->option('start_1st', 1) && !$self->start_date ) {
342 my ($sec,$min,$hour,$mday,$mon,$year) = (localtime(time) )[0,1,2,3,4,5];
343 $mon += 1 unless $mday == 1;
344 until ( $mon < 12 ) { $mon -= 12; $year++; }
345 $self->start_date( timelocal_nocheck(0,0,0,1,$mon,$year) );
348 if ($self->susp eq 'now' or $part_pkg->start_on_hold) {
349 # if the package was ordered on hold:
351 # - don't set the start date (it will be started manually)
352 $self->set('susp', $self->order_date);
353 $self->set('start_date', '');
355 # set expire/adjourn/contract_end timers, and free days, if appropriate
356 $self->set_initial_timers;
358 } # else this is a package change, and shouldn't have "new package" behavior
360 local $SIG{HUP} = 'IGNORE';
361 local $SIG{INT} = 'IGNORE';
362 local $SIG{QUIT} = 'IGNORE';
363 local $SIG{TERM} = 'IGNORE';
364 local $SIG{TSTP} = 'IGNORE';
365 local $SIG{PIPE} = 'IGNORE';
367 my $oldAutoCommit = $FS::UID::AutoCommit;
368 local $FS::UID::AutoCommit = 0;
371 $error = $self->SUPER::insert($options{options} ? %{$options{options}} : ());
373 $dbh->rollback if $oldAutoCommit;
377 $self->refnum($self->cust_main->refnum) unless $self->refnum;
378 $self->refnum( [ $self->refnum ] ) unless ref($self->refnum);
379 $self->process_m2m( 'link_table' => 'pkg_referral',
380 'target_table' => 'part_referral',
381 'params' => $self->refnum,
384 if ( $self->discountnum ) {
385 my $error = $self->insert_discount();
387 $dbh->rollback if $oldAutoCommit;
392 my $conf = new FS::Conf;
394 if ( $conf->config('ticket_system') && $options{ticket_subject} ) {
396 #this init stuff is still inefficient, but at least its limited to
397 # the small number (any?) folks using ticket emailing on pkg order
400 # use lib ( "/opt/rt3/local/lib", "/opt/rt3/lib" );
407 use FS::TicketSystem;
408 FS::TicketSystem->init();
410 my $q = new RT::Queue($RT::SystemUser);
411 $q->Load($options{ticket_queue}) if $options{ticket_queue};
412 my $t = new RT::Ticket($RT::SystemUser);
413 my $mime = new MIME::Entity;
414 $mime->build( Type => 'text/plain', Data => $options{ticket_subject} );
415 $t->Create( $options{ticket_queue} ? (Queue => $q) : (),
416 Subject => $options{ticket_subject},
419 $t->AddLink( Type => 'MemberOf',
420 Target => 'freeside://freeside/cust_main/'. $self->custnum,
424 if ($conf->config('welcome_letter') && $self->cust_main->num_pkgs == 1) {
425 my $queue = new FS::queue {
426 'job' => 'FS::cust_main::queueable_print',
428 $error = $queue->insert(
429 'custnum' => $self->custnum,
430 'template' => 'welcome_letter',
434 warn "can't send welcome letter: $error";
439 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
446 This method now works but you probably shouldn't use it.
448 You don't want to delete packages, because there would then be no record
449 the customer ever purchased the package. Instead, see the cancel method and
450 hide cancelled packages.
457 local $SIG{HUP} = 'IGNORE';
458 local $SIG{INT} = 'IGNORE';
459 local $SIG{QUIT} = 'IGNORE';
460 local $SIG{TERM} = 'IGNORE';
461 local $SIG{TSTP} = 'IGNORE';
462 local $SIG{PIPE} = 'IGNORE';
464 my $oldAutoCommit = $FS::UID::AutoCommit;
465 local $FS::UID::AutoCommit = 0;
468 foreach my $cust_pkg_discount ($self->cust_pkg_discount) {
469 my $error = $cust_pkg_discount->delete;
471 $dbh->rollback if $oldAutoCommit;
475 #cust_bill_pkg_discount?
477 foreach my $cust_pkg_detail ($self->cust_pkg_detail) {
478 my $error = $cust_pkg_detail->delete;
480 $dbh->rollback if $oldAutoCommit;
485 foreach my $cust_pkg_reason (
487 'table' => 'cust_pkg_reason',
488 'hashref' => { 'pkgnum' => $self->pkgnum },
492 my $error = $cust_pkg_reason->delete;
494 $dbh->rollback if $oldAutoCommit;
501 my $error = $self->SUPER::delete(@_);
503 $dbh->rollback if $oldAutoCommit;
507 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
513 =item replace [ OLD_RECORD ] [ HASHREF | OPTION => VALUE ... ]
515 Replaces the OLD_RECORD with this one in the database. If there is an error,
516 returns the error, otherwise returns false.
518 Currently, custnum, setup, bill, adjourn, susp, expire, and cancel may be changed.
520 Changing pkgpart may have disasterous effects. See the order subroutine.
522 setup and bill are normally updated by calling the bill method of a customer
523 object (see L<FS::cust_main>).
525 suspend is normally updated by the suspend and unsuspend methods.
527 cancel is normally updated by the cancel method (and also the order subroutine
530 Available options are:
536 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.
540 the access_user (see L<FS::access_user>) providing the reason
544 hashref of keys and values - cust_pkg_option records will be created, updated or removed as appopriate
553 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
558 ( ref($_[0]) eq 'HASH' )
562 #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
563 #return "Can't change otaker!" if $old->otaker ne $new->otaker;
566 #return "Can't change setup once it exists!"
567 # if $old->getfield('setup') &&
568 # $old->getfield('setup') != $new->getfield('setup');
570 #some logic for bill, susp, cancel?
572 local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
574 local $SIG{HUP} = 'IGNORE';
575 local $SIG{INT} = 'IGNORE';
576 local $SIG{QUIT} = 'IGNORE';
577 local $SIG{TERM} = 'IGNORE';
578 local $SIG{TSTP} = 'IGNORE';
579 local $SIG{PIPE} = 'IGNORE';
581 my $oldAutoCommit = $FS::UID::AutoCommit;
582 local $FS::UID::AutoCommit = 0;
585 foreach my $method ( qw(adjourn expire) ) { # How many reasons?
586 if ($options->{'reason'} && $new->$method && $old->$method ne $new->$method) {
587 my $error = $new->insert_reason(
588 'reason' => $options->{'reason'},
589 'date' => $new->$method,
591 'reason_otaker' => $options->{'reason_otaker'},
594 dbh->rollback if $oldAutoCommit;
595 return "Error inserting cust_pkg_reason: $error";
600 #save off and freeze RADIUS attributes for any associated svc_acct records
602 if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
604 #also check for specific exports?
605 # to avoid spurious modify export events
606 @svc_acct = map { $_->svc_x }
607 grep { $_->part_svc->svcdb eq 'svc_acct' }
610 $_->snapshot foreach @svc_acct;
614 my $error = $new->export_pkg_change($old)
615 || $new->SUPER::replace( $old,
617 ? $options->{options}
621 $dbh->rollback if $oldAutoCommit;
625 #for prepaid packages,
626 #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
627 foreach my $old_svc_acct ( @svc_acct ) {
628 my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
630 $new_svc_acct->replace( $old_svc_acct,
631 'depend_jobnum' => $options->{depend_jobnum},
634 $dbh->rollback if $oldAutoCommit;
639 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
646 Checks all fields to make sure this is a valid billing item. If there is an
647 error, returns the error, otherwise returns false. Called by the insert and
655 if ( !$self->locationnum or $self->locationnum == -1 ) {
656 $self->set('locationnum', $self->cust_main->ship_locationnum);
660 $self->ut_numbern('pkgnum')
661 || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
662 || $self->ut_numbern('pkgpart')
663 || $self->ut_foreign_keyn('contactnum', 'contact', 'contactnum' )
664 || $self->ut_foreign_keyn('locationnum', 'cust_location', 'locationnum')
665 || $self->ut_foreign_keyn('salesnum', 'sales', 'salesnum')
666 || $self->ut_numbern('quantity')
667 || $self->ut_numbern('start_date')
668 || $self->ut_numbern('setup')
669 || $self->ut_numbern('bill')
670 || $self->ut_numbern('susp')
671 || $self->ut_numbern('cancel')
672 || $self->ut_numbern('adjourn')
673 || $self->ut_numbern('resume')
674 || $self->ut_numbern('expire')
675 || $self->ut_numbern('dundate')
676 || $self->ut_enum('no_auto', [ '', 'Y' ])
677 || $self->ut_enum('waive_setup', [ '', 'Y' ])
678 || $self->ut_textn('agent_pkgid')
679 || $self->ut_enum('recur_show_zero', [ '', 'Y', 'N', ])
680 || $self->ut_enum('setup_show_zero', [ '', 'Y', 'N', ])
681 || $self->ut_foreign_keyn('main_pkgnum', 'cust_pkg', 'pkgnum')
682 || $self->ut_foreign_keyn('pkglinknum', 'part_pkg_link', 'pkglinknum')
683 || $self->ut_foreign_keyn('change_to_pkgnum', 'cust_pkg', 'pkgnum')
685 return $error if $error;
687 return "A package with both start date (future start) and setup date (already started) will never bill"
688 if $self->start_date && $self->setup && ! $upgrade;
690 return "A future unsuspend date can only be set for a package with a suspend date"
691 if $self->resume and !$self->susp and !$self->adjourn;
693 $self->usernum($FS::CurrentUser::CurrentUser->usernum) unless $self->usernum;
695 if ( $self->dbdef_table->column('manual_flag') ) {
696 $self->manual_flag('') if $self->manual_flag eq ' ';
697 $self->manual_flag =~ /^([01]?)$/
698 or return "Illegal manual_flag ". $self->manual_flag;
699 $self->manual_flag($1);
707 Check the pkgpart to make sure it's allowed with the reg_code and/or
708 promo_code of the package (if present) and with the customer's agent.
709 Called from C<insert>, unless we are doing a package change that doesn't
717 # my $error = $self->ut_numbern('pkgpart'); # already done
720 if ( $self->reg_code ) {
722 unless ( grep { $self->pkgpart == $_->pkgpart }
723 map { $_->reg_code_pkg }
724 qsearchs( 'reg_code', { 'code' => $self->reg_code,
725 'agentnum' => $self->cust_main->agentnum })
727 return "Unknown registration code";
730 } elsif ( $self->promo_code ) {
733 qsearchs('part_pkg', {
734 'pkgpart' => $self->pkgpart,
735 'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
737 return 'Unknown promotional code' unless $promo_part_pkg;
741 unless ( $disable_agentcheck ) {
743 qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
744 return "agent ". $agent->agentnum. ':'. $agent->agent.
745 " can't purchase pkgpart ". $self->pkgpart
746 unless $agent->pkgpart_hashref->{ $self->pkgpart }
747 || $agent->agentnum == $self->part_pkg->agentnum;
750 $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
751 return $error if $error;
759 =item cancel [ OPTION => VALUE ... ]
761 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
762 in this package, then cancels the package itself (sets the cancel field to
765 Available options are:
769 =item quiet - can be set true to supress email cancellation notices.
771 =item time - can be set to cancel the package based on a specific future or
772 historical date. Using time ensures that the remaining amount is calculated
773 correctly. Note however that this is an immediate cancel and just changes
774 the date. You are PROBABLY looking to expire the account instead of using
777 =item reason - can be set to a cancellation reason (see L<FS:reason>),
778 either a reasonnum of an existing reason, or passing a hashref will create
779 a new reason. The hashref should have the following keys: typenum - Reason
780 type (see L<FS::reason_type>, reason - Text of the new reason.
782 =item date - can be set to a unix style timestamp to specify when to
785 =item nobill - can be set true to skip billing if it might otherwise be done.
787 =item unused_credit - can be set to 1 to credit the remaining time, or 0 to
788 not credit it. This must be set (by change()) when changing the package
789 to a different pkgpart or location, and probably shouldn't be in any other
790 case. If it's not set, the 'unused_credit_cancel' part_pkg option will
795 If there is an error, returns the error, otherwise returns false.
800 my( $self, %options ) = @_;
803 # pass all suspend/cancel actions to the main package
804 if ( $self->main_pkgnum and !$options{'from_main'} ) {
805 return $self->main_pkg->cancel(%options);
808 my $conf = new FS::Conf;
810 warn "cust_pkg::cancel called with options".
811 join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
814 local $SIG{HUP} = 'IGNORE';
815 local $SIG{INT} = 'IGNORE';
816 local $SIG{QUIT} = 'IGNORE';
817 local $SIG{TERM} = 'IGNORE';
818 local $SIG{TSTP} = 'IGNORE';
819 local $SIG{PIPE} = 'IGNORE';
821 my $oldAutoCommit = $FS::UID::AutoCommit;
822 local $FS::UID::AutoCommit = 0;
825 my $old = $self->select_for_update;
827 if ( $old->get('cancel') || $self->get('cancel') ) {
828 dbh->rollback if $oldAutoCommit;
829 return ""; # no error
832 # XXX possibly set cancel_time to the expire date?
833 my $cancel_time = $options{'time'} || time;
834 my $date = $options{'date'} if $options{'date'}; # expire/cancel later
835 $date = '' if ($date && $date <= $cancel_time); # complain instead?
837 #race condition: usage could be ongoing until unprovisioned
838 #resolved by performing a change package instead (which unprovisions) and
840 if ( !$options{nobill} && !$date ) {
841 # && $conf->exists('bill_usage_on_cancel') ) { #calc_cancel checks this
842 my $copy = $self->new({$self->hash});
844 $copy->cust_main->bill( 'pkg_list' => [ $copy ],
846 'time' => $cancel_time );
847 warn "Error billing during cancel, custnum ".
848 #$self->cust_main->custnum. ": $error"
853 if ( $options{'reason'} ) {
854 $error = $self->insert_reason( 'reason' => $options{'reason'},
855 'action' => $date ? 'expire' : 'cancel',
856 'date' => $date ? $date : $cancel_time,
857 'reason_otaker' => $options{'reason_otaker'},
860 dbh->rollback if $oldAutoCommit;
861 return "Error inserting cust_pkg_reason: $error";
865 my %svc_cancel_opt = ();
866 $svc_cancel_opt{'date'} = $date if $date;
867 foreach my $cust_svc (
870 sort { $a->[1] <=> $b->[1] }
871 map { [ $_, $_->svc_x ? $_->svc_x->table_info->{'cancel_weight'} : -1 ]; }
872 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
874 my $part_svc = $cust_svc->part_svc;
875 next if ( defined($part_svc) and $part_svc->preserve );
876 my $error = $cust_svc->cancel( %svc_cancel_opt );
879 $dbh->rollback if $oldAutoCommit;
880 return 'Error '. ($svc_cancel_opt{'date'} ? 'expiring' : 'canceling' ).
886 # credit remaining time if appropriate
888 if ( exists($options{'unused_credit'}) ) {
889 $do_credit = $options{'unused_credit'};
892 $do_credit = $self->part_pkg->option('unused_credit_cancel', 1);
895 my $error = $self->credit_remaining('cancel', $cancel_time);
897 $dbh->rollback if $oldAutoCommit;
904 my %hash = $self->hash;
906 $hash{'expire'} = $date;
908 $hash{'cancel'} = $cancel_time;
910 $hash{'change_custnum'} = $options{'change_custnum'};
912 my $new = new FS::cust_pkg ( \%hash );
913 $error = $new->replace( $self, options => { $self->options } );
914 if ( $self->change_to_pkgnum ) {
915 my $change_to = FS::cust_pkg->by_key($self->change_to_pkgnum);
916 $error ||= $change_to->cancel || $change_to->delete;
919 $dbh->rollback if $oldAutoCommit;
923 foreach my $supp_pkg ( $self->supplemental_pkgs ) {
924 $error = $supp_pkg->cancel(%options, 'from_main' => 1);
926 $dbh->rollback if $oldAutoCommit;
927 return "canceling supplemental pkg#".$supp_pkg->pkgnum.": $error";
931 foreach my $usage ( $self->cust_pkg_usage ) {
932 $error = $usage->delete;
934 $dbh->rollback if $oldAutoCommit;
935 return "deleting usage pools: $error";
939 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
940 return '' if $date; #no errors
942 my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
943 if ( !$options{'quiet'} &&
944 $conf->exists('emailcancel', $self->cust_main->agentnum) &&
946 my $msgnum = $conf->config('cancel_msgnum', $self->cust_main->agentnum);
949 my $msg_template = qsearchs('msg_template', { msgnum => $msgnum });
950 $error = $msg_template->send( 'cust_main' => $self->cust_main,
955 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
956 'to' => \@invoicing_list,
957 'subject' => ( $conf->config('cancelsubject') || 'Cancellation Notice' ),
958 'body' => [ map "$_\n", $conf->config('cancelmessage') ],
959 'custnum' => $self->custnum,
960 'msgtype' => '', #admin?
963 #should this do something on errors?
970 =item cancel_if_expired [ NOW_TIMESTAMP ]
972 Cancels this package if its expire date has been reached.
976 sub cancel_if_expired {
978 my $time = shift || time;
979 return '' unless $self->expire && $self->expire <= $time;
980 my $error = $self->cancel;
982 return "Error cancelling expired pkg ". $self->pkgnum. " for custnum ".
983 $self->custnum. ": $error";
990 "Un-cancels" this package: Orders a new package with the same custnum, pkgpart,
991 locationnum, (other fields?). Attempts to re-provision cancelled services
992 using history information (errors at this stage are not fatal).
994 cust_pkg: pass a scalar reference, will be filled in with the new cust_pkg object
996 svc_fatal: service provisioning errors are fatal
998 svc_errors: pass an array reference, will be filled in with any provisioning errors
1000 main_pkgnum: link the package as a supplemental package of this one. For
1006 my( $self, %options ) = @_;
1008 #in case you try do do $uncancel-date = $cust_pkg->uncacel
1009 return '' unless $self->get('cancel');
1011 if ( $self->main_pkgnum and !$options{'main_pkgnum'} ) {
1012 return $self->main_pkg->uncancel(%options);
1019 local $SIG{HUP} = 'IGNORE';
1020 local $SIG{INT} = 'IGNORE';
1021 local $SIG{QUIT} = 'IGNORE';
1022 local $SIG{TERM} = 'IGNORE';
1023 local $SIG{TSTP} = 'IGNORE';
1024 local $SIG{PIPE} = 'IGNORE';
1026 my $oldAutoCommit = $FS::UID::AutoCommit;
1027 local $FS::UID::AutoCommit = 0;
1031 # insert the new package
1034 my $cust_pkg = new FS::cust_pkg {
1035 last_bill => ( $options{'last_bill'} || $self->get('last_bill') ),
1036 bill => ( $options{'bill'} || $self->get('bill') ),
1038 uncancel_pkgnum => $self->pkgnum,
1039 main_pkgnum => ($options{'main_pkgnum'} || ''),
1040 map { $_ => $self->get($_) } qw(
1041 custnum pkgpart locationnum
1043 susp adjourn resume expire start_date contract_end dundate
1044 change_date change_pkgpart change_locationnum
1045 manual_flag no_auto quantity agent_pkgid recur_show_zero setup_show_zero
1049 my $error = $cust_pkg->insert(
1050 'change' => 1, #supresses any referral credit to a referring customer
1051 'allow_pkgpart' => 1, # allow this even if the package def is disabled
1054 $dbh->rollback if $oldAutoCommit;
1062 #find historical services within this timeframe before the package cancel
1063 # (incompatible with "time" option to cust_pkg->cancel?)
1064 my $fuzz = 2 * 60; #2 minutes? too much? (might catch separate unprovision)
1065 # too little? (unprovisioing export delay?)
1066 my($end, $start) = ( $self->get('cancel'), $self->get('cancel') - $fuzz );
1067 my @h_cust_svc = $self->h_cust_svc( $end, $start );
1070 foreach my $h_cust_svc (@h_cust_svc) {
1071 my $h_svc_x = $h_cust_svc->h_svc_x( $end, $start );
1072 #next unless $h_svc_x; #should this happen?
1073 (my $table = $h_svc_x->table) =~ s/^h_//;
1074 require "FS/$table.pm";
1075 my $class = "FS::$table";
1076 my $svc_x = $class->new( {
1077 'pkgnum' => $cust_pkg->pkgnum,
1078 'svcpart' => $h_cust_svc->svcpart,
1079 map { $_ => $h_svc_x->get($_) } fields($table)
1083 if ( $h_svc_x->isa('FS::h_svc_Radius_Mixin') ) {
1084 $svc_x->usergroup( [ $h_svc_x->h_usergroup($end, $start) ] );
1087 my $svc_error = $svc_x->insert;
1089 if ( $options{svc_fatal} ) {
1090 $dbh->rollback if $oldAutoCommit;
1093 # if we've failed to insert the svc_x object, svc_Common->insert
1094 # will have removed the cust_svc already. if not, then both records
1095 # were inserted but we failed for some other reason (export, most
1096 # likely). in that case, report the error and delete the records.
1097 push @svc_errors, $svc_error;
1098 my $cust_svc = qsearchs('cust_svc', { 'svcnum' => $svc_x->svcnum });
1100 # except if export_insert failed, export_delete probably won't be
1102 local $FS::svc_Common::noexport_hack = 1;
1103 my $cleanup_error = $svc_x->delete; # also deletes cust_svc
1104 if ( $cleanup_error ) { # and if THAT fails, then run away
1105 $dbh->rollback if $oldAutoCommit;
1106 return $cleanup_error;
1111 } #foreach $h_cust_svc
1113 #these are pretty rare, but should handle them
1114 # - dsl_device (mac addresses)
1115 # - phone_device (mac addresses)
1116 # - dsl_note (ikano notes)
1117 # - domain_record (i.e. restore DNS information w/domains)
1118 # - inventory_item(?) (inventory w/un-cancelling service?)
1119 # - nas (svc_broaband nas stuff)
1120 #this stuff is unused in the wild afaik
1121 # - mailinglistmember
1123 # - svc_domain.parent_svcnum?
1124 # - acct_snarf (ancient mail fetching config)
1125 # - cgp_rule (communigate)
1126 # - cust_svc_option (used by our Tron stuff)
1127 # - acct_rt_transaction (used by our time worked stuff)
1130 # also move over any services that didn't unprovision at cancellation
1133 foreach my $cust_svc ( qsearch('cust_svc', { pkgnum => $self->pkgnum } ) ) {
1134 $cust_svc->pkgnum( $cust_pkg->pkgnum );
1135 my $error = $cust_svc->replace;
1137 $dbh->rollback if $oldAutoCommit;
1143 # Uncancel any supplemental packages, and make them supplemental to the
1147 foreach my $supp_pkg ( $self->supplemental_pkgs ) {
1149 $error = $supp_pkg->uncancel(%options, 'main_pkgnum' => $cust_pkg->pkgnum);
1151 $dbh->rollback if $oldAutoCommit;
1152 return "canceling supplemental pkg#".$supp_pkg->pkgnum.": $error";
1160 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1162 ${ $options{cust_pkg} } = $cust_pkg if ref($options{cust_pkg});
1163 @{ $options{svc_errors} } = @svc_errors if ref($options{svc_errors});
1170 Cancels any pending expiration (sets the expire field to null).
1172 If there is an error, returns the error, otherwise returns false.
1177 my( $self, %options ) = @_;
1180 local $SIG{HUP} = 'IGNORE';
1181 local $SIG{INT} = 'IGNORE';
1182 local $SIG{QUIT} = 'IGNORE';
1183 local $SIG{TERM} = 'IGNORE';
1184 local $SIG{TSTP} = 'IGNORE';
1185 local $SIG{PIPE} = 'IGNORE';
1187 my $oldAutoCommit = $FS::UID::AutoCommit;
1188 local $FS::UID::AutoCommit = 0;
1191 my $old = $self->select_for_update;
1193 my $pkgnum = $old->pkgnum;
1194 if ( $old->get('cancel') || $self->get('cancel') ) {
1195 dbh->rollback if $oldAutoCommit;
1196 return "Can't unexpire cancelled package $pkgnum";
1197 # or at least it's pointless
1200 unless ( $old->get('expire') && $self->get('expire') ) {
1201 dbh->rollback if $oldAutoCommit;
1202 return ""; # no error
1205 my %hash = $self->hash;
1206 $hash{'expire'} = '';
1207 my $new = new FS::cust_pkg ( \%hash );
1208 $error = $new->replace( $self, options => { $self->options } );
1210 $dbh->rollback if $oldAutoCommit;
1214 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1220 =item suspend [ OPTION => VALUE ... ]
1222 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
1223 package, then suspends the package itself (sets the susp field to now).
1225 Available options are:
1229 =item reason - can be set to a cancellation reason (see L<FS:reason>),
1230 either a reasonnum of an existing reason, or passing a hashref will create
1231 a new reason. The hashref should have the following keys:
1232 - typenum - Reason type (see L<FS::reason_type>
1233 - reason - Text of the new reason.
1235 =item date - can be set to a unix style timestamp to specify when to
1238 =item time - can be set to override the current time, for calculation
1239 of final invoices or unused-time credits
1241 =item resume_date - can be set to a time when the package should be
1242 unsuspended. This may be more convenient than calling C<unsuspend()>
1245 =item from_main - allows a supplemental package to be suspended, rather
1246 than redirecting the method call to its main package. For internal use.
1250 If there is an error, returns the error, otherwise returns false.
1255 my( $self, %options ) = @_;
1258 # pass all suspend/cancel actions to the main package
1259 if ( $self->main_pkgnum and !$options{'from_main'} ) {
1260 return $self->main_pkg->suspend(%options);
1263 local $SIG{HUP} = 'IGNORE';
1264 local $SIG{INT} = 'IGNORE';
1265 local $SIG{QUIT} = 'IGNORE';
1266 local $SIG{TERM} = 'IGNORE';
1267 local $SIG{TSTP} = 'IGNORE';
1268 local $SIG{PIPE} = 'IGNORE';
1270 my $oldAutoCommit = $FS::UID::AutoCommit;
1271 local $FS::UID::AutoCommit = 0;
1274 my $old = $self->select_for_update;
1276 my $pkgnum = $old->pkgnum;
1277 if ( $old->get('cancel') || $self->get('cancel') ) {
1278 dbh->rollback if $oldAutoCommit;
1279 return "Can't suspend cancelled package $pkgnum";
1282 if ( $old->get('susp') || $self->get('susp') ) {
1283 dbh->rollback if $oldAutoCommit;
1284 return ""; # no error # complain on adjourn?
1287 my $suspend_time = $options{'time'} || time;
1288 my $date = $options{date} if $options{date}; # adjourn/suspend later
1289 $date = '' if ($date && $date <= $suspend_time); # complain instead?
1291 if ( $date && $old->get('expire') && $old->get('expire') < $date ) {
1292 dbh->rollback if $oldAutoCommit;
1293 return "Package $pkgnum expires before it would be suspended.";
1296 # some false laziness with sub cancel
1297 if ( !$options{nobill} && !$date &&
1298 $self->part_pkg->option('bill_suspend_as_cancel',1) ) {
1299 # kind of a kludge--'bill_suspend_as_cancel' to avoid having to
1300 # make the entire cust_main->bill path recognize 'suspend' and
1301 # 'cancel' separately.
1302 warn "Billing $pkgnum on suspension (at $suspend_time)\n" if $DEBUG;
1303 my $copy = $self->new({$self->hash});
1305 $copy->cust_main->bill( 'pkg_list' => [ $copy ],
1307 'time' => $suspend_time );
1308 warn "Error billing during suspend, custnum ".
1309 #$self->cust_main->custnum. ": $error"
1314 if ( $options{'reason'} ) {
1315 $error = $self->insert_reason( 'reason' => $options{'reason'},
1316 'action' => $date ? 'adjourn' : 'suspend',
1317 'date' => $date ? $date : $suspend_time,
1318 'reason_otaker' => $options{'reason_otaker'},
1321 dbh->rollback if $oldAutoCommit;
1322 return "Error inserting cust_pkg_reason: $error";
1326 my %hash = $self->hash;
1328 $hash{'adjourn'} = $date;
1330 $hash{'susp'} = $suspend_time;
1333 my $resume_date = $options{'resume_date'} || 0;
1334 if ( $resume_date > ($date || $suspend_time) ) {
1335 $hash{'resume'} = $resume_date;
1338 $options{options} ||= {};
1340 my $new = new FS::cust_pkg ( \%hash );
1341 $error = $new->replace( $self, options => { $self->options,
1342 %{ $options{options} },
1346 $dbh->rollback if $oldAutoCommit;
1351 # credit remaining time if appropriate
1352 if ( $self->part_pkg->option('unused_credit_suspend', 1) ) {
1353 my $error = $self->credit_remaining('suspend', $suspend_time);
1355 $dbh->rollback if $oldAutoCommit;
1362 foreach my $cust_svc (
1363 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
1365 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
1367 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
1368 $dbh->rollback if $oldAutoCommit;
1369 return "Illegal svcdb value in part_svc!";
1372 require "FS/$svcdb.pm";
1374 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
1376 $error = $svc->suspend;
1378 $dbh->rollback if $oldAutoCommit;
1381 my( $label, $value ) = $cust_svc->label;
1382 push @labels, "$label: $value";
1386 my $conf = new FS::Conf;
1387 if ( $conf->config('suspend_email_admin') ) {
1389 my $error = send_email(
1390 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
1391 #invoice_from ??? well as good as any
1392 'to' => $conf->config('suspend_email_admin'),
1393 'subject' => 'FREESIDE NOTIFICATION: Customer package suspended',
1395 "This is an automatic message from your Freeside installation\n",
1396 "informing you that the following customer package has been suspended:\n",
1398 'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
1399 'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
1400 ( map { "Service : $_\n" } @labels ),
1402 'custnum' => $self->custnum,
1403 'msgtype' => 'admin'
1407 warn "WARNING: can't send suspension admin email (suspending anyway): ".
1415 foreach my $supp_pkg ( $self->supplemental_pkgs ) {
1416 $error = $supp_pkg->suspend(%options, 'from_main' => 1);
1418 $dbh->rollback if $oldAutoCommit;
1419 return "suspending supplemental pkg#".$supp_pkg->pkgnum.": $error";
1423 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1428 =item credit_remaining MODE TIME
1430 Generate a credit for this package for the time remaining in the current
1431 billing period. MODE is either "suspend" or "cancel" (determines the
1432 credit type). TIME is the time of suspension/cancellation. Both arguments
1437 sub credit_remaining {
1438 # Add a credit for remaining service
1439 my ($self, $mode, $time) = @_;
1440 die 'credit_remaining requires suspend or cancel'
1441 unless $mode eq 'suspend' or $mode eq 'cancel';
1442 die 'no suspend/cancel time' unless $time > 0;
1444 my $conf = FS::Conf->new;
1445 my $reason_type = $conf->config($mode.'_credit_type');
1447 my $last_bill = $self->getfield('last_bill') || 0;
1448 my $next_bill = $self->getfield('bill') || 0;
1449 if ( $last_bill > 0 # the package has been billed
1450 and $next_bill > 0 # the package has a next bill date
1451 and $next_bill >= $time # which is in the future
1453 my $remaining_value = $self->calc_remain('time' => $time);
1454 if ( $remaining_value > 0 ) {
1455 warn "Crediting for $remaining_value on package ".$self->pkgnum."\n"
1457 my $error = $self->cust_main->credit(
1459 'Credit for unused time on '. $self->part_pkg->pkg,
1460 'reason_type' => $reason_type,
1462 return "Error crediting customer \$$remaining_value for unused time".
1463 " on ". $self->part_pkg->pkg. ": $error"
1465 } #if $remaining_value
1466 } #if $last_bill, etc.
1470 =item unsuspend [ OPTION => VALUE ... ]
1472 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
1473 package, then unsuspends the package itself (clears the susp field and the
1474 adjourn field if it is in the past). If the suspend reason includes an
1475 unsuspension package, that package will be ordered.
1477 Available options are:
1483 Can be set to a date to unsuspend the package in the future (the 'resume'
1486 =item adjust_next_bill
1488 Can be set true to adjust the next bill date forward by
1489 the amount of time the account was inactive. This was set true by default
1490 in the past (from 1.4.2 and 1.5.0pre6 through 1.7.0), but now needs to be
1491 explicitly requested with this option or in the price plan.
1495 If there is an error, returns the error, otherwise returns false.
1500 my( $self, %opt ) = @_;
1503 # pass all suspend/cancel actions to the main package
1504 if ( $self->main_pkgnum and !$opt{'from_main'} ) {
1505 return $self->main_pkg->unsuspend(%opt);
1508 local $SIG{HUP} = 'IGNORE';
1509 local $SIG{INT} = 'IGNORE';
1510 local $SIG{QUIT} = 'IGNORE';
1511 local $SIG{TERM} = 'IGNORE';
1512 local $SIG{TSTP} = 'IGNORE';
1513 local $SIG{PIPE} = 'IGNORE';
1515 my $oldAutoCommit = $FS::UID::AutoCommit;
1516 local $FS::UID::AutoCommit = 0;
1519 my $old = $self->select_for_update;
1521 my $pkgnum = $old->pkgnum;
1522 if ( $old->get('cancel') || $self->get('cancel') ) {
1523 $dbh->rollback if $oldAutoCommit;
1524 return "Can't unsuspend cancelled package $pkgnum";
1527 unless ( $old->get('susp') && $self->get('susp') ) {
1528 $dbh->rollback if $oldAutoCommit;
1529 return ""; # no error # complain instead?
1532 # handle the case of setting a future unsuspend (resume) date
1533 # and do not continue to actually unsuspend the package
1534 my $date = $opt{'date'};
1535 if ( $date and $date > time ) { # return an error if $date <= time?
1537 if ( $old->get('expire') && $old->get('expire') < $date ) {
1538 $dbh->rollback if $oldAutoCommit;
1539 return "Package $pkgnum expires before it would be unsuspended.";
1542 my $new = new FS::cust_pkg { $self->hash };
1543 $new->set('resume', $date);
1544 $error = $new->replace($self, options => $self->options);
1547 $dbh->rollback if $oldAutoCommit;
1551 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1557 if (!$self->setup) {
1558 # then this package is being released from on-hold status
1559 $self->set_initial_timers;
1564 foreach my $cust_svc (
1565 qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
1567 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
1569 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
1570 $dbh->rollback if $oldAutoCommit;
1571 return "Illegal svcdb value in part_svc!";
1574 require "FS/$svcdb.pm";
1576 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
1578 $error = $svc->unsuspend;
1580 $dbh->rollback if $oldAutoCommit;
1583 my( $label, $value ) = $cust_svc->label;
1584 push @labels, "$label: $value";
1589 my $cust_pkg_reason = $self->last_cust_pkg_reason('susp');
1590 my $reason = $cust_pkg_reason ? $cust_pkg_reason->reason : '';
1592 my %hash = $self->hash;
1593 my $inactive = time - $hash{'susp'};
1595 my $conf = new FS::Conf;
1597 $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive
1599 && ( $hash{'bill'} || $hash{'setup'} )
1600 && ( $opt{'adjust_next_bill'}
1601 || $conf->exists('unsuspend-always_adjust_next_bill_date')
1602 || $self->part_pkg->option('unsuspend_adjust_bill', 1)
1604 && ! $self->option('suspend_bill',1)
1605 && ( ! $self->part_pkg->option('suspend_bill',1)
1606 || $self->option('no_suspend_bill',1)
1608 && $hash{'order_date'} != $hash{'susp'}
1612 $hash{'adjourn'} = '' if $hash{'adjourn'} and $hash{'adjourn'} < time;
1613 $hash{'resume'} = '' if !$hash{'adjourn'};
1614 my $new = new FS::cust_pkg ( \%hash );
1615 $error = $new->replace( $self, options => { $self->options } );
1617 $dbh->rollback if $oldAutoCommit;
1623 if ( $reason && $reason->unsuspend_pkgpart ) {
1624 my $part_pkg = FS::part_pkg->by_key($reason->unsuspend_pkgpart)
1625 or $error = "Unsuspend package definition ".$reason->unsuspend_pkgpart.
1627 my $start_date = $self->cust_main->next_bill_date
1628 if $reason->unsuspend_hold;
1631 $unsusp_pkg = FS::cust_pkg->new({
1632 'custnum' => $self->custnum,
1633 'pkgpart' => $reason->unsuspend_pkgpart,
1634 'start_date' => $start_date,
1635 'locationnum' => $self->locationnum,
1636 # discount? probably not...
1639 $error ||= $self->cust_main->order_pkg( 'cust_pkg' => $unsusp_pkg );
1643 $dbh->rollback if $oldAutoCommit;
1648 if ( $conf->config('unsuspend_email_admin') ) {
1650 my $error = send_email(
1651 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
1652 #invoice_from ??? well as good as any
1653 'to' => $conf->config('unsuspend_email_admin'),
1654 'subject' => 'FREESIDE NOTIFICATION: Customer package unsuspended', 'body' => [
1655 "This is an automatic message from your Freeside installation\n",
1656 "informing you that the following customer package has been unsuspended:\n",
1658 'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
1659 'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
1660 ( map { "Service : $_\n" } @labels ),
1662 "An unsuspension fee was charged: ".
1663 $unsusp_pkg->part_pkg->pkg_comment."\n"
1667 'custnum' => $self->custnum,
1668 'msgtype' => 'admin',
1672 warn "WARNING: can't send unsuspension admin email (unsuspending anyway): ".
1678 foreach my $supp_pkg ( $self->supplemental_pkgs ) {
1679 $error = $supp_pkg->unsuspend(%opt, 'from_main' => 1);
1681 $dbh->rollback if $oldAutoCommit;
1682 return "unsuspending supplemental pkg#".$supp_pkg->pkgnum.": $error";
1686 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1693 Cancels any pending suspension (sets the adjourn field to null).
1695 If there is an error, returns the error, otherwise returns false.
1700 my( $self, %options ) = @_;
1703 local $SIG{HUP} = 'IGNORE';
1704 local $SIG{INT} = 'IGNORE';
1705 local $SIG{QUIT} = 'IGNORE';
1706 local $SIG{TERM} = 'IGNORE';
1707 local $SIG{TSTP} = 'IGNORE';
1708 local $SIG{PIPE} = 'IGNORE';
1710 my $oldAutoCommit = $FS::UID::AutoCommit;
1711 local $FS::UID::AutoCommit = 0;
1714 my $old = $self->select_for_update;
1716 my $pkgnum = $old->pkgnum;
1717 if ( $old->get('cancel') || $self->get('cancel') ) {
1718 dbh->rollback if $oldAutoCommit;
1719 return "Can't unadjourn cancelled package $pkgnum";
1720 # or at least it's pointless
1723 if ( $old->get('susp') || $self->get('susp') ) {
1724 dbh->rollback if $oldAutoCommit;
1725 return "Can't unadjourn suspended package $pkgnum";
1726 # perhaps this is arbitrary
1729 unless ( $old->get('adjourn') && $self->get('adjourn') ) {
1730 dbh->rollback if $oldAutoCommit;
1731 return ""; # no error
1734 my %hash = $self->hash;
1735 $hash{'adjourn'} = '';
1736 $hash{'resume'} = '';
1737 my $new = new FS::cust_pkg ( \%hash );
1738 $error = $new->replace( $self, options => { $self->options } );
1740 $dbh->rollback if $oldAutoCommit;
1744 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1751 =item change HASHREF | OPTION => VALUE ...
1753 Changes this package: cancels it and creates a new one, with a different
1754 pkgpart or locationnum or both. All services are transferred to the new
1755 package (no change will be made if this is not possible).
1757 Options may be passed as a list of key/value pairs or as a hash reference.
1764 New locationnum, to change the location for this package.
1768 New FS::cust_location object, to create a new location and assign it
1773 New FS::cust_main object, to create a new customer and assign the new package
1778 New pkgpart (see L<FS::part_pkg>).
1782 New refnum (see L<FS::part_referral>).
1786 New quantity; if unspecified, the new package will have the same quantity
1791 "New" (existing) FS::cust_pkg object. The package's services and other
1792 attributes will be transferred to this package.
1796 Set to true to transfer billing dates (start_date, setup, last_bill, bill,
1797 susp, adjourn, cancel, expire, and contract_end) to the new package.
1799 =item unprotect_svcs
1801 Normally, change() will rollback and return an error if some services
1802 can't be transferred (also see the I<cust_pkg-change_svcpart> config option).
1803 If unprotect_svcs is true, this method will transfer as many services as
1804 it can and then unconditionally cancel the old package.
1808 At least one of locationnum, cust_location, pkgpart, refnum, cust_main, or
1809 cust_pkg must be specified (otherwise, what's the point?)
1811 Returns either the new FS::cust_pkg object or a scalar error.
1815 my $err_or_new_cust_pkg = $old_cust_pkg->change
1819 #some false laziness w/order
1822 my $opt = ref($_[0]) ? shift : { @_ };
1824 my $conf = new FS::Conf;
1826 # Transactionize this whole mess
1827 local $SIG{HUP} = 'IGNORE';
1828 local $SIG{INT} = 'IGNORE';
1829 local $SIG{QUIT} = 'IGNORE';
1830 local $SIG{TERM} = 'IGNORE';
1831 local $SIG{TSTP} = 'IGNORE';
1832 local $SIG{PIPE} = 'IGNORE';
1834 my $oldAutoCommit = $FS::UID::AutoCommit;
1835 local $FS::UID::AutoCommit = 0;
1844 $hash{'setup'} = $time if $self->setup;
1846 $hash{'change_date'} = $time;
1847 $hash{"change_$_"} = $self->$_()
1848 foreach qw( pkgnum pkgpart locationnum );
1850 if ( $opt->{'cust_location'} ) {
1851 $error = $opt->{'cust_location'}->find_or_insert;
1853 $dbh->rollback if $oldAutoCommit;
1854 return "creating location record: $error";
1856 $opt->{'locationnum'} = $opt->{'cust_location'}->locationnum;
1859 if ( $opt->{'cust_pkg'} ) {
1860 # treat changing to a package with a different pkgpart as a
1861 # pkgpart change (because it is)
1862 $opt->{'pkgpart'} = $opt->{'cust_pkg'}->pkgpart;
1865 # whether to override pkgpart checking on the new package
1866 my $same_pkgpart = 1;
1867 if ( $opt->{'pkgpart'} and ( $opt->{'pkgpart'} != $self->pkgpart ) ) {
1871 my $unused_credit = 0;
1872 my $keep_dates = $opt->{'keep_dates'};
1873 # Special case. If the pkgpart is changing, and the customer is
1874 # going to be credited for remaining time, don't keep setup, bill,
1875 # or last_bill dates, and DO pass the flag to cancel() to credit
1877 if ( $opt->{'pkgpart'}
1878 and $opt->{'pkgpart'} != $self->pkgpart
1879 and $self->part_pkg->option('unused_credit_change', 1) ) {
1882 $hash{$_} = '' foreach qw(setup bill last_bill);
1885 if ( $keep_dates ) {
1886 foreach my $date ( qw(setup bill last_bill susp adjourn cancel expire
1887 resume start_date contract_end ) ) {
1888 $hash{$date} = $self->getfield($date);
1891 # always keep this date, regardless of anything
1892 # (the date of the package change is in a different field)
1893 $hash{'order_date'} = $self->getfield('order_date');
1895 # allow $opt->{'locationnum'} = '' to specifically set it to null
1896 # (i.e. customer default location)
1897 $opt->{'locationnum'} = $self->locationnum if !exists($opt->{'locationnum'});
1899 # usually this doesn't matter. the two cases where it does are:
1900 # 1. unused_credit_change + pkgpart change + setup fee on the new package
1902 # 2. (more importantly) changing a package before it's billed
1903 $hash{'waive_setup'} = $self->waive_setup;
1905 my $custnum = $self->custnum;
1906 if ( $opt->{cust_main} ) {
1907 my $cust_main = $opt->{cust_main};
1908 unless ( $cust_main->custnum ) {
1909 my $error = $cust_main->insert( @{ $opt->{cust_main_insert_args}||[] } );
1911 $dbh->rollback if $oldAutoCommit;
1912 return "inserting customer record: $error";
1915 $custnum = $cust_main->custnum;
1918 $hash{'contactnum'} = $opt->{'contactnum'} if $opt->{'contactnum'};
1921 if ( $opt->{'cust_pkg'} ) {
1922 # The target package already exists; update it to show that it was
1923 # changed from this package.
1924 $cust_pkg = $opt->{'cust_pkg'};
1926 foreach ( qw( pkgnum pkgpart locationnum ) ) {
1927 $cust_pkg->set("change_$_", $self->get($_));
1929 $cust_pkg->set('change_date', $time);
1930 $error = $cust_pkg->replace;
1933 # Create the new package.
1934 $cust_pkg = new FS::cust_pkg {
1935 custnum => $custnum,
1936 locationnum => $opt->{'locationnum'},
1937 ( map { $_ => ( $opt->{$_} || $self->$_() ) }
1938 qw( pkgpart quantity refnum salesnum )
1942 $error = $cust_pkg->insert( 'change' => 1,
1943 'allow_pkgpart' => $same_pkgpart );
1946 $dbh->rollback if $oldAutoCommit;
1947 return "inserting new package: $error";
1950 # Transfer services and cancel old package.
1952 $error = $self->transfer($cust_pkg);
1953 if ($error and $error == 0) {
1954 # $old_pkg->transfer failed.
1955 $dbh->rollback if $oldAutoCommit;
1956 return "transferring $error";
1959 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1960 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1961 $error = $self->transfer($cust_pkg, 'change_svcpart'=>1 );
1962 if ($error and $error == 0) {
1963 # $old_pkg->transfer failed.
1964 $dbh->rollback if $oldAutoCommit;
1965 return "converting $error";
1969 # We set unprotect_svcs when executing a "future package change". It's
1970 # not a user-interactive operation, so returning an error means the
1971 # package change will just fail. Rather than have that happen, we'll
1972 # let leftover services be deleted.
1973 if ($error > 0 and !$opt->{'unprotect_svcs'}) {
1974 # Transfers were successful, but we still had services left on the old
1975 # package. We can't change the package under this circumstances, so abort.
1976 $dbh->rollback if $oldAutoCommit;
1977 return "unable to transfer all services";
1980 #reset usage if changing pkgpart
1981 # AND usage rollover is off (otherwise adds twice, now and at package bill)
1982 if ($self->pkgpart != $cust_pkg->pkgpart) {
1983 my $part_pkg = $cust_pkg->part_pkg;
1984 $error = $part_pkg->reset_usage($cust_pkg, $part_pkg->is_prepaid
1988 if $part_pkg->can('reset_usage') && ! $part_pkg->option('usage_rollover',1);
1991 $dbh->rollback if $oldAutoCommit;
1992 return "setting usage values: $error";
1995 # if NOT changing pkgpart, transfer any usage pools over
1996 foreach my $usage ($self->cust_pkg_usage) {
1997 $usage->set('pkgnum', $cust_pkg->pkgnum);
1998 $error = $usage->replace;
2000 $dbh->rollback if $oldAutoCommit;
2001 return "transferring usage pools: $error";
2006 # transfer discounts, if we're not changing pkgpart
2007 if ( $same_pkgpart ) {
2008 foreach my $old_discount ($self->cust_pkg_discount_active) {
2009 # don't remove the old discount, we may still need to bill that package.
2010 my $new_discount = new FS::cust_pkg_discount {
2011 'pkgnum' => $cust_pkg->pkgnum,
2012 'discountnum' => $old_discount->discountnum,
2013 'months_used' => $old_discount->months_used,
2015 $error = $new_discount->insert;
2017 $dbh->rollback if $oldAutoCommit;
2018 return "transferring discounts: $error";
2023 # transfer (copy) invoice details
2024 foreach my $detail ($self->cust_pkg_detail) {
2025 my $new_detail = FS::cust_pkg_detail->new({ $detail->hash });
2026 $new_detail->set('pkgdetailnum', '');
2027 $new_detail->set('pkgnum', $cust_pkg->pkgnum);
2028 $error = $new_detail->insert;
2030 $dbh->rollback if $oldAutoCommit;
2031 return "transferring package notes: $error";
2037 if ( !$opt->{'cust_pkg'} ) {
2038 # Order any supplemental packages.
2039 my $part_pkg = $cust_pkg->part_pkg;
2040 my @old_supp_pkgs = $self->supplemental_pkgs;
2041 foreach my $link ($part_pkg->supp_part_pkg_link) {
2043 foreach (@old_supp_pkgs) {
2044 if ($_->pkgpart == $link->dst_pkgpart) {
2046 $_->pkgpart(0); # so that it can't match more than once
2050 # false laziness with FS::cust_main::Packages::order_pkg
2051 my $new = FS::cust_pkg->new({
2052 pkgpart => $link->dst_pkgpart,
2053 pkglinknum => $link->pkglinknum,
2054 custnum => $custnum,
2055 main_pkgnum => $cust_pkg->pkgnum,
2056 locationnum => $cust_pkg->locationnum,
2057 start_date => $cust_pkg->start_date,
2058 order_date => $cust_pkg->order_date,
2059 expire => $cust_pkg->expire,
2060 adjourn => $cust_pkg->adjourn,
2061 contract_end => $cust_pkg->contract_end,
2062 refnum => $cust_pkg->refnum,
2063 discountnum => $cust_pkg->discountnum,
2064 waive_setup => $cust_pkg->waive_setup,
2066 if ( $old and $opt->{'keep_dates'} ) {
2067 foreach (qw(setup bill last_bill)) {
2068 $new->set($_, $old->get($_));
2071 $error = $new->insert( allow_pkgpart => $same_pkgpart );
2074 $error ||= $old->transfer($new);
2076 if ( $error and $error > 0 ) {
2077 # no reason why this should ever fail, but still...
2078 $error = "Unable to transfer all services from supplemental package ".
2082 $dbh->rollback if $oldAutoCommit;
2085 push @new_supp_pkgs, $new;
2087 } # if !$opt->{'cust_pkg'}
2088 # because if there is one, then supplemental packages would already
2089 # have been created for it.
2091 #Good to go, cancel old package. Notify 'cancel' of whether to credit
2093 #Don't allow billing the package (preceding period packages and/or
2094 #outstanding usage) if we are keeping dates (i.e. location changing),
2095 #because the new package will be billed for the same date range.
2096 #Supplemental packages are also canceled here.
2098 # during scheduled changes, avoid canceling the package we just
2100 $self->set('change_to_pkgnum' => '');
2102 $error = $self->cancel(
2104 unused_credit => $unused_credit,
2105 nobill => $keep_dates,
2106 change_custnum => ( $self->custnum != $custnum ? $custnum : '' ),
2109 $dbh->rollback if $oldAutoCommit;
2110 return "canceling old package: $error";
2113 if ( $conf->exists('cust_pkg-change_pkgpart-bill_now') ) {
2115 my $error = $cust_pkg->cust_main->bill(
2116 'pkg_list' => [ $cust_pkg, @new_supp_pkgs ]
2119 $dbh->rollback if $oldAutoCommit;
2120 return "billing new package: $error";
2124 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2130 =item change_later OPTION => VALUE...
2132 Schedule a package change for a later date. This actually orders the new
2133 package immediately, but sets its start date for a future date, and sets
2134 the current package to expire on the same date.
2136 If the package is already scheduled for a change, this can be called with
2137 'start_date' to change the scheduled date, or with pkgpart and/or
2138 locationnum to modify the package change. To cancel the scheduled change
2139 entirely, see C<abort_change>.
2147 The date for the package change. Required, and must be in the future.
2155 The pkgpart. locationnum, and quantity of the new package, with the same
2156 meaning as in C<change>.
2164 my $opt = ref($_[0]) ? shift : { @_ };
2166 my $oldAutoCommit = $FS::UID::AutoCommit;
2167 local $FS::UID::AutoCommit = 0;
2170 my $cust_main = $self->cust_main;
2172 my $date = delete $opt->{'start_date'} or return 'start_date required';
2174 if ( $date <= time ) {
2175 $dbh->rollback if $oldAutoCommit;
2176 return "start_date $date is in the past";
2181 if ( $self->change_to_pkgnum ) {
2182 my $change_to = FS::cust_pkg->by_key($self->change_to_pkgnum);
2183 my $new_pkgpart = $opt->{'pkgpart'}
2184 if $opt->{'pkgpart'} and $opt->{'pkgpart'} != $change_to->pkgpart;
2185 my $new_locationnum = $opt->{'locationnum'}
2186 if $opt->{'locationnum'} and $opt->{'locationnum'} != $change_to->locationnum;
2187 my $new_quantity = $opt->{'quantity'}
2188 if $opt->{'quantity'} and $opt->{'quantity'} != $change_to->quantity;
2189 if ( $new_pkgpart or $new_locationnum or $new_quantity ) {
2190 # it hasn't been billed yet, so in principle we could just edit
2191 # it in place (w/o a package change), but that's bad form.
2192 # So change the package according to the new options...
2193 my $err_or_pkg = $change_to->change(%$opt);
2194 if ( ref $err_or_pkg ) {
2195 # Then set that package up for a future start.
2196 $self->set('change_to_pkgnum', $err_or_pkg->pkgnum);
2197 $self->set('expire', $date); # in case it's different
2198 $err_or_pkg->set('start_date', $date);
2199 $err_or_pkg->set('change_date', '');
2200 $err_or_pkg->set('change_pkgnum', '');
2202 $error = $self->replace ||
2203 $err_or_pkg->replace ||
2204 $change_to->cancel ||
2207 $error = $err_or_pkg;
2209 } else { # change the start date only.
2210 $self->set('expire', $date);
2211 $change_to->set('start_date', $date);
2212 $error = $self->replace || $change_to->replace;
2215 $dbh->rollback if $oldAutoCommit;
2218 $dbh->commit if $oldAutoCommit;
2221 } # if $self->change_to_pkgnum
2223 my $new_pkgpart = $opt->{'pkgpart'}
2224 if $opt->{'pkgpart'} and $opt->{'pkgpart'} != $self->pkgpart;
2225 my $new_locationnum = $opt->{'locationnum'}
2226 if $opt->{'locationnum'} and $opt->{'locationnum'} != $self->locationnum;
2227 my $new_quantity = $opt->{'quantity'}
2228 if $opt->{'quantity'} and $opt->{'quantity'} != $self->quantity;
2230 return '' unless $new_pkgpart or $new_locationnum or $new_quantity; # wouldn't do anything
2232 # allow $opt->{'locationnum'} = '' to specifically set it to null
2233 # (i.e. customer default location)
2234 $opt->{'locationnum'} = $self->locationnum if !exists($opt->{'locationnum'});
2236 my $new = FS::cust_pkg->new( {
2237 custnum => $self->custnum,
2238 locationnum => $opt->{'locationnum'},
2239 start_date => $date,
2240 map { $_ => ( $opt->{$_} || $self->$_() ) }
2241 qw( pkgpart quantity refnum salesnum )
2243 $error = $new->insert('change' => 1,
2244 'allow_pkgpart' => ($new_pkgpart ? 0 : 1));
2246 $self->set('change_to_pkgnum', $new->pkgnum);
2247 $self->set('expire', $date);
2248 $error = $self->replace;
2251 $dbh->rollback if $oldAutoCommit;
2253 $dbh->commit if $oldAutoCommit;
2261 Cancels a future package change scheduled by C<change_later>.
2267 my $pkgnum = $self->change_to_pkgnum;
2268 my $change_to = FS::cust_pkg->by_key($pkgnum) if $pkgnum;
2271 $error = $change_to->cancel || $change_to->delete;
2272 return $error if $error;
2274 $self->set('change_to_pkgnum', '');
2275 $self->set('expire', '');
2279 =item set_quantity QUANTITY
2281 Change the package's quantity field. This is one of the few package properties
2282 that can safely be changed without canceling and reordering the package
2283 (because it doesn't affect tax eligibility). Returns an error or an
2290 $self = $self->replace_old; # just to make sure
2291 $self->quantity(shift);
2295 =item set_salesnum SALESNUM
2297 Change the package's salesnum (sales person) field. This is one of the few
2298 package properties that can safely be changed without canceling and reordering
2299 the package (because it doesn't affect tax eligibility). Returns an error or
2306 $self = $self->replace_old; # just to make sure
2307 $self->salesnum(shift);
2309 # XXX this should probably reassign any credit that's already been given
2312 =item modify_charge OPTIONS
2314 Change the properties of a one-time charge. The following properties can
2315 be changed this way:
2316 - pkg: the package description
2317 - classnum: the package class
2318 - additional: arrayref of additional invoice details to add to this package
2320 and, I<if the charge has not yet been billed>:
2321 - start_date: the date when it will be billed
2322 - amount: the setup fee to be charged
2323 - quantity: the multiplier for the setup fee
2325 If you pass 'adjust_commission' => 1, and the classnum changes, and there are
2326 commission credits linked to this charge, they will be recalculated.
2333 my $part_pkg = $self->part_pkg;
2334 my $pkgnum = $self->pkgnum;
2337 my $oldAutoCommit = $FS::UID::AutoCommit;
2338 local $FS::UID::AutoCommit = 0;
2340 return "Can't use modify_charge except on one-time charges"
2341 unless $part_pkg->freq eq '0';
2343 if ( length($opt{'pkg'}) and $part_pkg->pkg ne $opt{'pkg'} ) {
2344 $part_pkg->set('pkg', $opt{'pkg'});
2347 my %pkg_opt = $part_pkg->options;
2348 my $pkg_opt_modified = 0;
2350 $opt{'additional'} ||= [];
2353 foreach (grep /^additional/, keys %pkg_opt) {
2354 ($i) = ($_ =~ /^additional_info(\d+)$/);
2355 $old_additional[$i] = $pkg_opt{$_} if $i;
2356 delete $pkg_opt{$_};
2359 for ( $i = 0; exists($opt{'additional'}->[$i]); $i++ ) {
2360 $pkg_opt{ "additional_info$i" } = $opt{'additional'}->[$i];
2361 if (!exists($old_additional[$i])
2362 or $old_additional[$i] ne $opt{'additional'}->[$i])
2364 $pkg_opt_modified = 1;
2367 $pkg_opt_modified = 1 if (scalar(@old_additional) - 1) != $i;
2368 $pkg_opt{'additional_count'} = $i if $i > 0;
2371 if ( exists($opt{'classnum'}) and $part_pkg->classnum ne $opt{'classnum'} )
2374 $old_classnum = $part_pkg->classnum;
2375 $part_pkg->set('classnum', $opt{'classnum'});
2378 if ( !$self->get('setup') ) {
2379 # not yet billed, so allow amount and quantity
2380 if ( exists($opt{'quantity'})
2381 and $opt{'quantity'} != $self->quantity
2382 and $opt{'quantity'} > 0 ) {
2384 $self->set('quantity', $opt{'quantity'});
2386 if ( exists($opt{'start_date'})
2387 and $opt{'start_date'} != $self->start_date ) {
2389 $self->set('start_date', $opt{'start_date'});
2392 if ( exists($opt{'amount'})
2393 and $part_pkg->option('setup_fee') != $opt{'amount'}
2394 and $opt{'amount'} > 0 ) {
2396 $pkg_opt{'setup_fee'} = $opt{'amount'};
2397 $pkg_opt_modified = 1;
2400 } # else simply ignore them; the UI shouldn't allow editing the fields
2403 if ( $part_pkg->modified or $pkg_opt_modified ) {
2404 # can we safely modify the package def?
2405 # Yes, if it's not available for purchase, and this is the only instance
2407 if ( $part_pkg->disabled
2408 and FS::cust_pkg->count('pkgpart = '.$part_pkg->pkgpart) == 1
2409 and FS::quotation_pkg->count('pkgpart = '.$part_pkg->pkgpart) == 0
2411 $error = $part_pkg->replace( options => \%pkg_opt );
2414 $part_pkg = $part_pkg->clone;
2415 $part_pkg->set('disabled' => 'Y');
2416 $error = $part_pkg->insert( options => \%pkg_opt );
2417 # and associate this as yet-unbilled package to the new package def
2418 $self->set('pkgpart' => $part_pkg->pkgpart);
2421 $dbh->rollback if $oldAutoCommit;
2426 if ($self->modified) { # for quantity or start_date change, or if we had
2427 # to clone the existing package def
2428 my $error = $self->replace;
2429 return $error if $error;
2431 if (defined $old_classnum) {
2432 # fix invoice grouping records
2433 my $old_catname = $old_classnum
2434 ? FS::pkg_class->by_key($old_classnum)->categoryname
2436 my $new_catname = $opt{'classnum'}
2437 ? $part_pkg->pkg_class->categoryname
2439 if ( $old_catname ne $new_catname ) {
2440 foreach my $cust_bill_pkg ($self->cust_bill_pkg) {
2441 # (there should only be one...)
2442 my @display = qsearch( 'cust_bill_pkg_display', {
2443 'billpkgnum' => $cust_bill_pkg->billpkgnum,
2444 'section' => $old_catname,
2446 foreach (@display) {
2447 $_->set('section', $new_catname);
2448 $error = $_->replace;
2450 $dbh->rollback if $oldAutoCommit;
2454 } # foreach $cust_bill_pkg
2457 if ( $opt{'adjust_commission'} ) {
2458 # fix commission credits...tricky.
2459 foreach my $cust_event ($self->cust_event) {
2460 my $part_event = $cust_event->part_event;
2461 foreach my $table (qw(sales agent)) {
2463 "FS::part_event::Action::Mixin::credit_${table}_pkg_class";
2464 my $credit = qsearchs('cust_credit', {
2465 'eventnum' => $cust_event->eventnum,
2467 if ( $part_event->isa($class) ) {
2468 # Yes, this results in current commission rates being applied
2469 # retroactively to a one-time charge. For accounting purposes
2470 # there ought to be some kind of time limit on doing this.
2471 my $amount = $part_event->_calc_credit($self);
2472 if ( $credit and $credit->amount ne $amount ) {
2473 # Void the old credit.
2474 $error = $credit->void('Package class changed');
2476 $dbh->rollback if $oldAutoCommit;
2477 return "$error (adjusting commission credit)";
2480 # redo the event action to recreate the credit.
2482 eval { $part_event->do_action( $self, $cust_event ) };
2484 $dbh->rollback if $oldAutoCommit;
2487 } # if $part_event->isa($class)
2489 } # foreach $cust_event
2490 } # if $opt{'adjust_commission'}
2491 } # if defined $old_classnum
2493 $dbh->commit if $oldAutoCommit;
2499 use Storable 'thaw';
2502 sub process_bulk_cust_pkg {
2504 my $param = thaw(decode_base64(shift));
2505 warn Dumper($param) if $DEBUG;
2507 my $old_part_pkg = qsearchs('part_pkg',
2508 { pkgpart => $param->{'old_pkgpart'} });
2509 my $new_part_pkg = qsearchs('part_pkg',
2510 { pkgpart => $param->{'new_pkgpart'} });
2511 die "Must select a new package type\n" unless $new_part_pkg;
2512 #my $keep_dates = $param->{'keep_dates'} || 0;
2513 my $keep_dates = 1; # there is no good reason to turn this off
2515 local $SIG{HUP} = 'IGNORE';
2516 local $SIG{INT} = 'IGNORE';
2517 local $SIG{QUIT} = 'IGNORE';
2518 local $SIG{TERM} = 'IGNORE';
2519 local $SIG{TSTP} = 'IGNORE';
2520 local $SIG{PIPE} = 'IGNORE';
2522 my $oldAutoCommit = $FS::UID::AutoCommit;
2523 local $FS::UID::AutoCommit = 0;
2526 my @cust_pkgs = qsearch('cust_pkg', { 'pkgpart' => $param->{'old_pkgpart'} } );
2529 foreach my $old_cust_pkg ( @cust_pkgs ) {
2531 $job->update_statustext(int(100*$i/(scalar @cust_pkgs)));
2532 if ( $old_cust_pkg->getfield('cancel') ) {
2533 warn '[process_bulk_cust_pkg ] skipping canceled pkgnum '.
2534 $old_cust_pkg->pkgnum."\n"
2538 warn '[process_bulk_cust_pkg] changing pkgnum '.$old_cust_pkg->pkgnum."\n"
2540 my $error = $old_cust_pkg->change(
2541 'pkgpart' => $param->{'new_pkgpart'},
2542 'keep_dates' => $keep_dates
2544 if ( !ref($error) ) { # change returns the cust_pkg on success
2546 die "Error changing pkgnum ".$old_cust_pkg->pkgnum.": '$error'\n";
2549 $dbh->commit if $oldAutoCommit;
2555 Returns the last bill date, or if there is no last bill date, the setup date.
2556 Useful for billing metered services.
2562 return $self->setfield('last_bill', $_[0]) if @_;
2563 return $self->getfield('last_bill') if $self->getfield('last_bill');
2564 my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
2565 'edate' => $self->bill, } );
2566 $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
2569 =item last_cust_pkg_reason ACTION
2571 Returns the most recent ACTION FS::cust_pkg_reason associated with the package.
2572 Returns false if there is no reason or the package is not currenly ACTION'd
2573 ACTION is one of adjourn, susp, cancel, or expire.
2577 sub last_cust_pkg_reason {
2578 my ( $self, $action ) = ( shift, shift );
2579 my $date = $self->get($action);
2581 'table' => 'cust_pkg_reason',
2582 'hashref' => { 'pkgnum' => $self->pkgnum,
2583 'action' => substr(uc($action), 0, 1),
2586 'order_by' => 'ORDER BY num DESC LIMIT 1',
2590 =item last_reason ACTION
2592 Returns the most recent ACTION FS::reason associated with the package.
2593 Returns false if there is no reason or the package is not currenly ACTION'd
2594 ACTION is one of adjourn, susp, cancel, or expire.
2599 my $cust_pkg_reason = shift->last_cust_pkg_reason(@_);
2600 $cust_pkg_reason->reason
2601 if $cust_pkg_reason;
2606 Returns the definition for this billing item, as an FS::part_pkg object (see
2613 return $self->{'_pkgpart'} if $self->{'_pkgpart'};
2614 cluck "cust_pkg->part_pkg called" if $DEBUG > 1;
2615 qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
2620 Returns the cancelled package this package was changed from, if any.
2626 return '' unless $self->change_pkgnum;
2627 qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
2630 =item change_cust_main
2632 Returns the customter this package was detached to, if any.
2636 sub change_cust_main {
2638 return '' unless $self->change_custnum;
2639 qsearchs('cust_main', { 'custnum' => $self->change_custnum } );
2644 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
2651 $self->part_pkg->calc_setup($self, @_);
2656 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
2663 $self->part_pkg->calc_recur($self, @_);
2668 Calls the I<base_recur> of the FS::part_pkg object associated with this billing
2675 $self->part_pkg->base_recur($self, @_);
2680 Calls the I<calc_remain> of the FS::part_pkg object associated with this
2687 $self->part_pkg->calc_remain($self, @_);
2692 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
2699 $self->part_pkg->calc_cancel($self, @_);
2704 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
2710 qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
2713 =item cust_pkg_detail [ DETAILTYPE ]
2715 Returns any customer package details for this package (see
2716 L<FS::cust_pkg_detail>).
2718 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
2722 sub cust_pkg_detail {
2724 my %hash = ( 'pkgnum' => $self->pkgnum );
2725 $hash{detailtype} = shift if @_;
2727 'table' => 'cust_pkg_detail',
2728 'hashref' => \%hash,
2729 'order_by' => 'ORDER BY weight, pkgdetailnum',
2733 =item set_cust_pkg_detail DETAILTYPE [ DETAIL, DETAIL, ... ]
2735 Sets customer package details for this package (see L<FS::cust_pkg_detail>).
2737 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
2739 If there is an error, returns the error, otherwise returns false.
2743 sub set_cust_pkg_detail {
2744 my( $self, $detailtype, @details ) = @_;
2746 local $SIG{HUP} = 'IGNORE';
2747 local $SIG{INT} = 'IGNORE';
2748 local $SIG{QUIT} = 'IGNORE';
2749 local $SIG{TERM} = 'IGNORE';
2750 local $SIG{TSTP} = 'IGNORE';
2751 local $SIG{PIPE} = 'IGNORE';
2753 my $oldAutoCommit = $FS::UID::AutoCommit;
2754 local $FS::UID::AutoCommit = 0;
2757 foreach my $current ( $self->cust_pkg_detail($detailtype) ) {
2758 my $error = $current->delete;
2760 $dbh->rollback if $oldAutoCommit;
2761 return "error removing old detail: $error";
2765 foreach my $detail ( @details ) {
2766 my $cust_pkg_detail = new FS::cust_pkg_detail {
2767 'pkgnum' => $self->pkgnum,
2768 'detailtype' => $detailtype,
2769 'detail' => $detail,
2771 my $error = $cust_pkg_detail->insert;
2773 $dbh->rollback if $oldAutoCommit;
2774 return "error adding new detail: $error";
2779 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2786 Returns the customer billing events (see L<FS::cust_event>) for this invoice.
2790 #false laziness w/cust_bill.pm
2794 'table' => 'cust_event',
2795 'addl_from' => 'JOIN part_event USING ( eventpart )',
2796 'hashref' => { 'tablenum' => $self->pkgnum },
2797 'extra_sql' => " AND eventtable = 'cust_pkg' ",
2801 =item num_cust_event
2803 Returns the number of customer billing events (see L<FS::cust_event>) for this package.
2807 #false laziness w/cust_bill.pm
2808 sub num_cust_event {
2810 my $sql = "SELECT COUNT(*) ". $self->_from_cust_event_where;
2811 $self->_prep_ex($sql, $self->pkgnum)->fetchrow_arrayref->[0];
2814 =item exists_cust_event
2816 Returns true if there are customer billing events (see L<FS::cust_event>) for this package. More efficient than using num_cust_event.
2820 sub exists_cust_event {
2822 my $sql = "SELECT 1 ". $self->_from_cust_event_where. " LIMIT 1";
2823 my $row = $self->_prep_ex($sql, $self->pkgnum)->fetchrow_arrayref;
2824 $row ? $row->[0] : '';
2827 sub _from_cust_event_where {
2829 " FROM cust_event JOIN part_event USING ( eventpart ) ".
2830 " WHERE tablenum = ? AND eventtable = 'cust_pkg' ";
2834 my( $self, $sql, @args ) = @_;
2835 my $sth = dbh->prepare($sql) or die dbh->errstr. " preparing $sql";
2836 $sth->execute(@args) or die $sth->errstr. " executing $sql";
2840 =item cust_svc [ SVCPART ] (old, deprecated usage)
2842 =item cust_svc [ OPTION => VALUE ... ] (current usage)
2844 =item cust_svc_unsorted [ OPTION => VALUE ... ]
2846 Returns the services for this package, as FS::cust_svc objects (see
2847 L<FS::cust_svc>). Available options are svcpart and svcdb. If either is
2848 spcififed, returns only the matching services.
2850 As an optimization, use the cust_svc_unsorted version if you are not displaying
2857 cluck "cust_pkg->cust_svc called" if $DEBUG > 2;
2858 $self->_sort_cust_svc( $self->cust_svc_unsorted_arrayref(@_) );
2861 sub cust_svc_unsorted {
2863 @{ $self->cust_svc_unsorted_arrayref(@_) };
2866 sub cust_svc_unsorted_arrayref {
2869 return [] unless $self->num_cust_svc(@_);
2872 if ( @_ && $_[0] =~ /^\d+/ ) {
2873 $opt{svcpart} = shift;
2874 } elsif ( @_ && ref($_[0]) eq 'HASH' ) {
2881 'table' => 'cust_svc',
2882 'hashref' => { 'pkgnum' => $self->pkgnum },
2884 if ( $opt{svcpart} ) {
2885 $search{hashref}->{svcpart} = $opt{'svcpart'};
2887 if ( $opt{'svcdb'} ) {
2888 $search{addl_from} = ' LEFT JOIN part_svc USING ( svcpart ) ';
2889 $search{extra_sql} = ' AND svcdb = '. dbh->quote( $opt{'svcdb'} );
2892 [ qsearch(\%search) ];
2896 =item overlimit [ SVCPART ]
2898 Returns the services for this package which have exceeded their
2899 usage limit as FS::cust_svc objects (see L<FS::cust_svc>). If a svcpart
2900 is specified, return only the matching services.
2906 return () unless $self->num_cust_svc(@_);
2907 grep { $_->overlimit } $self->cust_svc(@_);
2910 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
2912 Returns historical services for this package created before END TIMESTAMP and
2913 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
2914 (see L<FS::h_cust_svc>). If MODE is 'I' (for 'invoice'), services with the
2915 I<pkg_svc.hidden> flag will be omitted.
2921 warn "$me _h_cust_svc called on $self\n"
2924 my ($end, $start, $mode) = @_;
2925 my @cust_svc = $self->_sort_cust_svc(
2926 [ qsearch( 'h_cust_svc',
2927 { 'pkgnum' => $self->pkgnum, },
2928 FS::h_cust_svc->sql_h_search(@_),
2931 if ( defined($mode) && $mode eq 'I' ) {
2932 my %hidden_svcpart = map { $_->svcpart => $_->hidden } $self->part_svc;
2933 return grep { !$hidden_svcpart{$_->svcpart} } @cust_svc;
2939 sub _sort_cust_svc {
2940 my( $self, $arrayref ) = @_;
2943 sub ($$) { my ($a, $b) = @_; $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] };
2945 my %pkg_svc = map { $_->svcpart => $_ }
2946 qsearch( 'pkg_svc', { 'pkgpart' => $self->pkgpart } );
2951 my $pkg_svc = $pkg_svc{ $_->svcpart } || '';
2953 $pkg_svc ? $pkg_svc->primary_svc : '',
2954 $pkg_svc ? $pkg_svc->quantity : 0,
2961 =item num_cust_svc [ SVCPART ] (old, deprecated usage)
2963 =item num_cust_svc [ OPTION => VALUE ... ] (current usage)
2965 Returns the number of services for this package. Available options are svcpart
2966 and svcdb. If either is spcififed, returns only the matching services.
2973 return $self->{'_num_cust_svc'}
2975 && exists($self->{'_num_cust_svc'})
2976 && $self->{'_num_cust_svc'} =~ /\d/;
2978 cluck "cust_pkg->num_cust_svc called, _num_cust_svc:".$self->{'_num_cust_svc'}
2982 if ( @_ && $_[0] =~ /^\d+/ ) {
2983 $opt{svcpart} = shift;
2984 } elsif ( @_ && ref($_[0]) eq 'HASH' ) {
2990 my $select = 'SELECT COUNT(*) FROM cust_svc ';
2991 my $where = ' WHERE pkgnum = ? ';
2992 my @param = ($self->pkgnum);
2994 if ( $opt{'svcpart'} ) {
2995 $where .= ' AND svcpart = ? ';
2996 push @param, $opt{'svcpart'};
2998 if ( $opt{'svcdb'} ) {
2999 $select .= ' LEFT JOIN part_svc USING ( svcpart ) ';
3000 $where .= ' AND svcdb = ? ';
3001 push @param, $opt{'svcdb'};
3004 my $sth = dbh->prepare("$select $where") or die dbh->errstr;
3005 $sth->execute(@param) or die $sth->errstr;
3006 $sth->fetchrow_arrayref->[0];
3009 =item available_part_svc
3011 Returns a list of FS::part_svc objects representing services included in this
3012 package but not yet provisioned. Each FS::part_svc object also has an extra
3013 field, I<num_avail>, which specifies the number of available services.
3017 sub available_part_svc {
3020 my $pkg_quantity = $self->quantity || 1;
3022 grep { $_->num_avail > 0 }
3024 my $part_svc = $_->part_svc;
3025 $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
3026 $pkg_quantity * $_->quantity - $self->num_cust_svc($_->svcpart);
3028 # more evil encapsulation breakage
3029 if($part_svc->{'Hash'}{'num_avail'} > 0) {
3030 my @exports = $part_svc->part_export_did;
3031 $part_svc->{'Hash'}{'can_get_dids'} = scalar(@exports);
3036 $self->part_pkg->pkg_svc;
3039 =item part_svc [ OPTION => VALUE ... ]
3041 Returns a list of FS::part_svc objects representing provisioned and available
3042 services included in this package. Each FS::part_svc object also has the
3043 following extra fields:
3057 (services) - array reference containing the provisioned services, as cust_svc objects
3061 Accepts two options:
3065 =item summarize_size
3067 If true, will omit the extra cust_pkg_svc option for objects where num_cust_svc
3068 is this size or greater.
3070 =item hide_discontinued
3072 If true, will omit looking for services that are no longer avaialble in the
3080 #label -> ($cust_svc->label)[1]
3086 my $pkg_quantity = $self->quantity || 1;
3088 #XXX some sort of sort order besides numeric by svcpart...
3089 my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
3091 my $part_svc = $pkg_svc->part_svc;
3092 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
3093 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
3094 $part_svc->{'Hash'}{'num_avail'} =
3095 max( 0, $pkg_quantity * $pkg_svc->quantity - $num_cust_svc );
3096 $part_svc->{'Hash'}{'cust_pkg_svc'} =
3097 $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : []
3098 unless exists($opt{summarize_size}) && $opt{summarize_size} > 0
3099 && $num_cust_svc >= $opt{summarize_size};
3100 $part_svc->{'Hash'}{'hidden'} = $pkg_svc->hidden;
3102 } $self->part_pkg->pkg_svc;
3104 unless ( $opt{hide_discontinued} ) {
3106 push @part_svc, map {
3108 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
3109 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
3110 $part_svc->{'Hash'}{'num_avail'} = 0; #0-$num_cust_svc ?
3111 $part_svc->{'Hash'}{'cust_pkg_svc'} =
3112 $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
3114 } $self->extra_part_svc;
3121 =item extra_part_svc
3123 Returns a list of FS::part_svc objects corresponding to services in this
3124 package which are still provisioned but not (any longer) available in the
3129 sub extra_part_svc {
3132 my $pkgnum = $self->pkgnum;
3133 #my $pkgpart = $self->pkgpart;
3136 # 'table' => 'part_svc',
3139 # "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
3140 # WHERE pkg_svc.svcpart = part_svc.svcpart
3141 # AND pkg_svc.pkgpart = ?
3144 # AND 0 < ( SELECT COUNT(*) FROM cust_svc
3145 # LEFT JOIN cust_pkg USING ( pkgnum )
3146 # WHERE cust_svc.svcpart = part_svc.svcpart
3149 # 'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
3152 #seems to benchmark slightly faster... (or did?)
3154 my @pkgparts = map $_->pkgpart, $self->part_pkg->self_and_svc_linked;
3155 my $pkgparts = join(',', @pkgparts);
3158 #'select' => 'DISTINCT ON (svcpart) part_svc.*',
3159 #MySQL doesn't grok DISINCT ON
3160 'select' => 'DISTINCT part_svc.*',
3161 'table' => 'part_svc',
3163 "LEFT JOIN pkg_svc ON ( pkg_svc.svcpart = part_svc.svcpart
3164 AND pkg_svc.pkgpart IN ($pkgparts)
3167 LEFT JOIN cust_svc ON ( cust_svc.svcpart = part_svc.svcpart )
3168 LEFT JOIN cust_pkg USING ( pkgnum )
3171 'extra_sql' => "WHERE pkgsvcnum IS NULL AND cust_pkg.pkgnum = ? ",
3172 'extra_param' => [ [$self->pkgnum=>'int'] ],
3178 Returns a short status string for this package, currently:
3184 =item not yet billed
3186 =item one-time charge
3201 my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
3203 return 'cancelled' if $self->get('cancel');
3204 return 'on hold' if $self->susp && ! $self->setup;
3205 return 'suspended' if $self->susp;
3206 return 'not yet billed' unless $self->setup;
3207 return 'one-time charge' if $freq =~ /^(0|$)/;
3211 =item ucfirst_status
3213 Returns the status with the first character capitalized.
3217 sub ucfirst_status {
3218 ucfirst(shift->status);
3223 Class method that returns the list of possible status strings for packages
3224 (see L<the status method|/status>). For example:
3226 @statuses = FS::cust_pkg->statuses();
3230 tie my %statuscolor, 'Tie::IxHash',
3231 'on hold' => '7E0079', #purple!
3232 'not yet billed' => '009999', #teal? cyan?
3233 'one-time charge' => '0000CC', #blue #'000000',
3234 'active' => '00CC00',
3235 'suspended' => 'FF9900',
3236 'cancelled' => 'FF0000',
3240 my $self = shift; #could be class...
3241 #grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
3242 # # mayble split btw one-time vs. recur
3253 Returns a hex triplet color string for this package's status.
3259 $statuscolor{$self->status};
3264 Returns a label for this package. (Currently "pkgnum: pkg - comment" or
3265 "pkg - comment" depending on user preference).
3271 my $label = $self->part_pkg->pkg_comment( 'nopkgpart' => 1 );
3272 $label = $self->pkgnum. ": $label"
3273 if $FS::CurrentUser::CurrentUser->option('show_pkgnum');
3277 =item pkg_label_long
3279 Returns a long label for this package, adding the primary service's label to
3284 sub pkg_label_long {
3286 my $label = $self->pkg_label;
3287 my $cust_svc = $self->primary_cust_svc;
3288 $label .= ' ('. ($cust_svc->label)[1]. ')' if $cust_svc;
3294 Returns a customer-localized label for this package.
3300 $self->part_pkg->pkg_locale( $self->cust_main->locale );
3303 =item primary_cust_svc
3305 Returns a primary service (as FS::cust_svc object) if one can be identified.
3309 #for labeling purposes - might not 100% match up with part_pkg->svcpart's idea
3311 sub primary_cust_svc {
3314 my @cust_svc = $self->cust_svc;
3316 return '' unless @cust_svc; #no serivces - irrelevant then
3318 return $cust_svc[0] if scalar(@cust_svc) == 1; #always return a single service
3320 # primary service as specified in the package definition
3321 # or exactly one service definition with quantity one
3322 my $svcpart = $self->part_pkg->svcpart;
3323 @cust_svc = grep { $_->svcpart == $svcpart } @cust_svc;
3324 return $cust_svc[0] if scalar(@cust_svc) == 1;
3326 #couldn't identify one thing..
3332 Returns a list of lists, calling the label method for all services
3333 (see L<FS::cust_svc>) of this billing item.
3339 map { [ $_->label ] } $self->cust_svc;
3342 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
3344 Like the labels method, but returns historical information on services that
3345 were active as of END_TIMESTAMP and (optionally) not cancelled before
3346 START_TIMESTAMP. If MODE is 'I' (for 'invoice'), services with the
3347 I<pkg_svc.hidden> flag will be omitted.
3349 Returns a list of lists, calling the label method for all (historical) services
3350 (see L<FS::h_cust_svc>) of this billing item.
3356 warn "$me _h_labels called on $self\n"
3358 map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
3363 Like labels, except returns a simple flat list, and shortens long
3364 (currently >5 or the cust_bill-max_same_services configuration value) lists of
3365 identical services to one line that lists the service label and the number of
3366 individual services rather than individual items.
3371 shift->_labels_short( 'labels', @_ );
3374 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
3376 Like h_labels, except returns a simple flat list, and shortens long
3377 (currently >5 or the cust_bill-max_same_services configuration value) lists of
3378 identical services to one line that lists the service label and the number of
3379 individual services rather than individual items.
3383 sub h_labels_short {
3384 shift->_labels_short( 'h_labels', @_ );
3388 my( $self, $method ) = ( shift, shift );
3390 warn "$me _labels_short called on $self with $method method\n"
3393 my $conf = new FS::Conf;
3394 my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
3396 warn "$me _labels_short populating \%labels\n"
3400 #tie %labels, 'Tie::IxHash';
3401 push @{ $labels{$_->[0]} }, $_->[1]
3402 foreach $self->$method(@_);
3404 warn "$me _labels_short populating \@labels\n"
3408 foreach my $label ( keys %labels ) {
3410 my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
3411 my $num = scalar(@values);
3412 warn "$me _labels_short $num items for $label\n"
3415 if ( $num > $max_same_services ) {
3416 warn "$me _labels_short more than $max_same_services, so summarizing\n"
3418 push @labels, "$label ($num)";
3420 if ( $conf->exists('cust_bill-consolidate_services') ) {
3421 warn "$me _labels_short consolidating services\n"
3423 # push @labels, "$label: ". join(', ', @values);
3425 my $detail = "$label: ";
3426 $detail .= shift(@values). ', '
3428 && ( length($detail.$values[0]) < 78 || $detail eq "$label: " );
3430 push @labels, $detail;
3432 warn "$me _labels_short done consolidating services\n"
3435 warn "$me _labels_short adding service data\n"
3437 push @labels, map { "$label: $_" } @values;
3448 Returns the parent customer object (see L<FS::cust_main>).
3454 qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
3459 Returns the balance for this specific package, when using
3460 experimental package balance.
3466 $self->cust_main->balance_pkgnum( $self->pkgnum );
3469 #these subs are in location_Mixin.pm now... unfortunately the POD doesn't mixin
3473 Returns the location object, if any (see L<FS::cust_location>).
3475 =item cust_location_or_main
3477 If this package is associated with a location, returns the locaiton (see
3478 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
3480 =item location_label [ OPTION => VALUE ... ]
3482 Returns the label of the location object (see L<FS::cust_location>).
3486 #end of subs in location_Mixin.pm now... unfortunately the POD doesn't mixin
3488 =item tax_locationnum
3490 Returns the foreign key to a L<FS::cust_location> object for calculating
3491 tax on this package, as determined by the C<tax-pkg_address> and
3492 C<tax-ship_address> configuration flags.
3496 sub tax_locationnum {
3498 my $conf = FS::Conf->new;
3499 if ( $conf->exists('tax-pkg_address') ) {
3500 return $self->locationnum;
3502 elsif ( $conf->exists('tax-ship_address') ) {
3503 return $self->cust_main->ship_locationnum;
3506 return $self->cust_main->bill_locationnum;
3512 Returns the L<FS::cust_location> object for tax_locationnum.
3518 my $conf = FS::Conf->new;
3519 if ( $conf->exists('tax-pkg_address') and $self->locationnum ) {
3520 return FS::cust_location->by_key($self->locationnum);
3522 elsif ( $conf->exists('tax-ship_address') ) {
3523 return $self->cust_main->ship_location;
3526 return $self->cust_main->bill_location;
3530 =item seconds_since TIMESTAMP
3532 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
3533 package have been online since TIMESTAMP, according to the session monitor.
3535 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
3536 L<Time::Local> and L<Date::Parse> for conversion functions.
3541 my($self, $since) = @_;
3544 foreach my $cust_svc (
3545 grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
3547 $seconds += $cust_svc->seconds_since($since);
3554 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
3556 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
3557 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
3560 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
3561 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
3567 sub seconds_since_sqlradacct {
3568 my($self, $start, $end) = @_;
3572 foreach my $cust_svc (
3574 my $part_svc = $_->part_svc;
3575 $part_svc->svcdb eq 'svc_acct'
3576 && scalar($part_svc->part_export_usage);
3579 $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
3586 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
3588 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
3589 in this package for sessions ending between TIMESTAMP_START (inclusive) and
3593 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
3594 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
3599 sub attribute_since_sqlradacct {
3600 my($self, $start, $end, $attrib) = @_;
3604 foreach my $cust_svc (
3606 my $part_svc = $_->part_svc;
3607 scalar($part_svc->part_export_usage);
3610 $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
3622 my( $self, $value ) = @_;
3623 if ( defined($value) ) {
3624 $self->setfield('quantity', $value);
3626 $self->getfield('quantity') || 1;
3629 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
3631 Transfers as many services as possible from this package to another package.
3633 The destination package can be specified by pkgnum by passing an FS::cust_pkg
3634 object. The destination package must already exist.
3636 Services are moved only if the destination allows services with the correct
3637 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true. Use
3638 this option with caution! No provision is made for export differences
3639 between the old and new service definitions. Probably only should be used
3640 when your exports for all service definitions of a given svcdb are identical.
3641 (attempt a transfer without it first, to move all possible svcpart-matching
3644 Any services that can't be moved remain in the original package.
3646 Returns an error, if there is one; otherwise, returns the number of services
3647 that couldn't be moved.
3652 my ($self, $dest_pkgnum, %opt) = @_;
3658 if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
3659 $dest = $dest_pkgnum;
3660 $dest_pkgnum = $dest->pkgnum;
3662 $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
3665 return ('Package does not exist: '.$dest_pkgnum) unless $dest;
3667 foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
3668 $target{$pkg_svc->svcpart} = $pkg_svc->quantity * ( $dest->quantity || 1 );
3671 foreach my $cust_svc ($dest->cust_svc) {
3672 $target{$cust_svc->svcpart}--;
3675 my %svcpart2svcparts = ();
3676 if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
3677 warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
3678 foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
3679 next if exists $svcpart2svcparts{$svcpart};
3680 my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
3681 $svcpart2svcparts{$svcpart} = [
3683 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
3685 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
3686 'svcpart' => $_ } );
3688 $pkg_svc ? $pkg_svc->primary_svc : '',
3689 $pkg_svc ? $pkg_svc->quantity : 0,
3693 grep { $_ != $svcpart }
3695 qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
3697 warn "alternates for svcpart $svcpart: ".
3698 join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
3704 foreach my $cust_svc ($self->cust_svc) {
3705 my $svcnum = $cust_svc->svcnum;
3706 if($target{$cust_svc->svcpart} > 0
3707 or $FS::cust_svc::ignore_quantity) { # maybe should be a 'force' option
3708 $target{$cust_svc->svcpart}--;
3709 my $new = new FS::cust_svc { $cust_svc->hash };
3710 $new->pkgnum($dest_pkgnum);
3711 $error = $new->replace($cust_svc);
3712 } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
3714 warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
3715 warn "alternates to consider: ".
3716 join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
3718 my @alternate = grep {
3719 warn "considering alternate svcpart $_: ".
3720 "$target{$_} available in new package\n"
3723 } @{$svcpart2svcparts{$cust_svc->svcpart}};
3725 warn "alternate(s) found\n" if $DEBUG;
3726 my $change_svcpart = $alternate[0];
3727 $target{$change_svcpart}--;
3728 my $new = new FS::cust_svc { $cust_svc->hash };
3729 $new->svcpart($change_svcpart);
3730 $new->pkgnum($dest_pkgnum);
3731 $error = $new->replace($cust_svc);
3739 my @label = $cust_svc->label;
3740 return "service $label[1]: $error";
3746 =item grab_svcnums SVCNUM, SVCNUM ...
3748 Change the pkgnum for the provided services to this packages. If there is an
3749 error, returns the error, otherwise returns false.
3757 local $SIG{HUP} = 'IGNORE';
3758 local $SIG{INT} = 'IGNORE';
3759 local $SIG{QUIT} = 'IGNORE';
3760 local $SIG{TERM} = 'IGNORE';
3761 local $SIG{TSTP} = 'IGNORE';
3762 local $SIG{PIPE} = 'IGNORE';
3764 my $oldAutoCommit = $FS::UID::AutoCommit;
3765 local $FS::UID::AutoCommit = 0;
3768 foreach my $svcnum (@svcnum) {
3769 my $cust_svc = qsearchs('cust_svc', { svcnum=>$svcnum } ) or do {
3770 $dbh->rollback if $oldAutoCommit;
3771 return "unknown svcnum $svcnum";
3773 $cust_svc->pkgnum( $self->pkgnum );
3774 my $error = $cust_svc->replace;
3776 $dbh->rollback if $oldAutoCommit;
3781 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3788 This method is deprecated. See the I<depend_jobnum> option to the insert and
3789 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
3796 local $SIG{HUP} = 'IGNORE';
3797 local $SIG{INT} = 'IGNORE';
3798 local $SIG{QUIT} = 'IGNORE';
3799 local $SIG{TERM} = 'IGNORE';
3800 local $SIG{TSTP} = 'IGNORE';
3801 local $SIG{PIPE} = 'IGNORE';
3803 my $oldAutoCommit = $FS::UID::AutoCommit;
3804 local $FS::UID::AutoCommit = 0;
3807 foreach my $cust_svc ( $self->cust_svc ) {
3808 #false laziness w/svc_Common::insert
3809 my $svc_x = $cust_svc->svc_x;
3810 foreach my $part_export ( $cust_svc->part_svc->part_export ) {
3811 my $error = $part_export->export_insert($svc_x);
3813 $dbh->rollback if $oldAutoCommit;
3819 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3824 =item export_pkg_change OLD_CUST_PKG
3826 Calls the "pkg_change" export action for all services attached to this package.
3830 sub export_pkg_change {
3831 my( $self, $old ) = ( shift, shift );
3833 local $SIG{HUP} = 'IGNORE';
3834 local $SIG{INT} = 'IGNORE';
3835 local $SIG{QUIT} = 'IGNORE';
3836 local $SIG{TERM} = 'IGNORE';
3837 local $SIG{TSTP} = 'IGNORE';
3838 local $SIG{PIPE} = 'IGNORE';
3840 my $oldAutoCommit = $FS::UID::AutoCommit;
3841 local $FS::UID::AutoCommit = 0;
3844 foreach my $svc_x ( map $_->svc_x, $self->cust_svc ) {
3845 my $error = $svc_x->export('pkg_change', $self, $old);
3847 $dbh->rollback if $oldAutoCommit;
3852 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3859 Associates this package with a (suspension or cancellation) reason (see
3860 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
3863 Available options are:
3869 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.
3873 the access_user (see L<FS::access_user>) providing the reason
3881 the action (cancel, susp, adjourn, expire) associated with the reason
3885 If there is an error, returns the error, otherwise returns false.
3890 my ($self, %options) = @_;
3892 my $otaker = $options{reason_otaker} ||
3893 $FS::CurrentUser::CurrentUser->username;
3896 if ( $options{'reason'} =~ /^(\d+)$/ ) {
3900 } elsif ( ref($options{'reason'}) ) {
3902 return 'Enter a new reason (or select an existing one)'
3903 unless $options{'reason'}->{'reason'} !~ /^\s*$/;
3905 my $reason = new FS::reason({
3906 'reason_type' => $options{'reason'}->{'typenum'},
3907 'reason' => $options{'reason'}->{'reason'},
3909 my $error = $reason->insert;
3910 return $error if $error;
3912 $reasonnum = $reason->reasonnum;
3915 return "Unparsable reason: ". $options{'reason'};
3918 my $cust_pkg_reason =
3919 new FS::cust_pkg_reason({ 'pkgnum' => $self->pkgnum,
3920 'reasonnum' => $reasonnum,
3921 'otaker' => $otaker,
3922 'action' => substr(uc($options{'action'}),0,1),
3923 'date' => $options{'date'}
3928 $cust_pkg_reason->insert;
3931 =item insert_discount
3933 Associates this package with a discount (see L<FS::cust_pkg_discount>, possibly
3934 inserting a new discount on the fly (see L<FS::discount>).
3936 Available options are:
3944 If there is an error, returns the error, otherwise returns false.
3948 sub insert_discount {
3949 #my ($self, %options) = @_;
3952 my $cust_pkg_discount = new FS::cust_pkg_discount {
3953 'pkgnum' => $self->pkgnum,
3954 'discountnum' => $self->discountnum,
3956 'end_date' => '', #XXX
3957 #for the create a new discount case
3958 '_type' => $self->discountnum__type,
3959 'amount' => $self->discountnum_amount,
3960 'percent' => $self->discountnum_percent,
3961 'months' => $self->discountnum_months,
3962 'setup' => $self->discountnum_setup,
3963 #'disabled' => $self->discountnum_disabled,
3966 $cust_pkg_discount->insert;
3969 =item set_usage USAGE_VALUE_HASHREF
3971 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
3972 to which they should be set (see L<FS::svc_acct>). Currently seconds,
3973 upbytes, downbytes, and totalbytes are appropriate keys.
3975 All svc_accts which are part of this package have their values reset.
3980 my ($self, $valueref, %opt) = @_;
3982 #only svc_acct can set_usage for now
3983 foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
3984 my $svc_x = $cust_svc->svc_x;
3985 $svc_x->set_usage($valueref, %opt)
3986 if $svc_x->can("set_usage");
3990 =item recharge USAGE_VALUE_HASHREF
3992 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
3993 to which they should be set (see L<FS::svc_acct>). Currently seconds,
3994 upbytes, downbytes, and totalbytes are appropriate keys.
3996 All svc_accts which are part of this package have their values incremented.
4001 my ($self, $valueref) = @_;
4003 #only svc_acct can set_usage for now
4004 foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
4005 my $svc_x = $cust_svc->svc_x;
4006 $svc_x->recharge($valueref)
4007 if $svc_x->can("recharge");
4011 =item cust_pkg_discount
4015 sub cust_pkg_discount {
4017 qsearch('cust_pkg_discount', { 'pkgnum' => $self->pkgnum } );
4020 =item cust_pkg_discount_active
4024 sub cust_pkg_discount_active {
4026 grep { $_->status eq 'active' } $self->cust_pkg_discount;
4029 =item cust_pkg_usage
4031 Returns a list of all voice usage counters attached to this package.
4035 sub cust_pkg_usage {
4037 qsearch('cust_pkg_usage', { pkgnum => $self->pkgnum });
4040 =item apply_usage OPTIONS
4042 Takes the following options:
4043 - cdr: a call detail record (L<FS::cdr>)
4044 - rate_detail: the rate determined for this call (L<FS::rate_detail>)
4045 - minutes: the maximum number of minutes to be charged
4047 Finds available usage minutes for a call of this class, and subtracts
4048 up to that many minutes from the usage pool. If the usage pool is empty,
4049 and the C<cdr-minutes_priority> global config option is set, minutes may
4050 be taken from other calls as well. Either way, an allocation record will
4051 be created (L<FS::cdr_cust_pkg_usage>) and this method will return the
4052 number of minutes of usage applied to the call.
4057 my ($self, %opt) = @_;
4058 my $cdr = $opt{cdr};
4059 my $rate_detail = $opt{rate_detail};
4060 my $minutes = $opt{minutes};
4061 my $classnum = $rate_detail->classnum;
4062 my $pkgnum = $self->pkgnum;
4063 my $custnum = $self->custnum;
4065 local $SIG{HUP} = 'IGNORE';
4066 local $SIG{INT} = 'IGNORE';
4067 local $SIG{QUIT} = 'IGNORE';
4068 local $SIG{TERM} = 'IGNORE';
4069 local $SIG{TSTP} = 'IGNORE';
4070 local $SIG{PIPE} = 'IGNORE';
4072 my $oldAutoCommit = $FS::UID::AutoCommit;
4073 local $FS::UID::AutoCommit = 0;
4075 my $order = FS::Conf->new->config('cdr-minutes_priority');
4079 $is_classnum = ' part_pkg_usage_class.classnum = '.$classnum;
4081 $is_classnum = ' part_pkg_usage_class.classnum IS NULL';
4083 my @usage_recs = qsearch({
4084 'table' => 'cust_pkg_usage',
4085 'addl_from' => ' JOIN part_pkg_usage USING (pkgusagepart)'.
4086 ' JOIN cust_pkg USING (pkgnum)'.
4087 ' JOIN part_pkg_usage_class USING (pkgusagepart)',
4088 'select' => 'cust_pkg_usage.*',
4089 'extra_sql' => " WHERE ( cust_pkg.pkgnum = $pkgnum OR ".
4090 " ( cust_pkg.custnum = $custnum AND ".
4091 " part_pkg_usage.shared IS NOT NULL ) ) AND ".
4092 $is_classnum . ' AND '.
4093 " cust_pkg_usage.minutes > 0",
4094 'order_by' => " ORDER BY priority ASC",
4097 my $orig_minutes = $minutes;
4099 while (!$error and $minutes > 0 and @usage_recs) {
4100 my $cust_pkg_usage = shift @usage_recs;
4101 $cust_pkg_usage->select_for_update;
4102 my $cdr_cust_pkg_usage = FS::cdr_cust_pkg_usage->new({
4103 pkgusagenum => $cust_pkg_usage->pkgusagenum,
4104 acctid => $cdr->acctid,
4105 minutes => min($cust_pkg_usage->minutes, $minutes),
4107 $cust_pkg_usage->set('minutes',
4108 $cust_pkg_usage->minutes - $cdr_cust_pkg_usage->minutes
4110 $error = $cust_pkg_usage->replace || $cdr_cust_pkg_usage->insert;
4111 $minutes -= $cdr_cust_pkg_usage->minutes;
4113 if ( $order and $minutes > 0 and !$error ) {
4114 # then try to steal minutes from another call
4116 'table' => 'cdr_cust_pkg_usage',
4117 'addl_from' => ' JOIN cust_pkg_usage USING (pkgusagenum)'.
4118 ' JOIN part_pkg_usage USING (pkgusagepart)'.
4119 ' JOIN cust_pkg USING (pkgnum)'.
4120 ' JOIN part_pkg_usage_class USING (pkgusagepart)'.
4121 ' JOIN cdr USING (acctid)',
4122 'select' => 'cdr_cust_pkg_usage.*',
4123 'extra_sql' => " WHERE cdr.freesidestatus = 'rated' AND ".
4124 " ( cust_pkg.pkgnum = $pkgnum OR ".
4125 " ( cust_pkg.custnum = $custnum AND ".
4126 " part_pkg_usage.shared IS NOT NULL ) ) AND ".
4127 " part_pkg_usage_class.classnum = $classnum",
4128 'order_by' => ' ORDER BY part_pkg_usage.priority ASC',
4130 if ( $order eq 'time' ) {
4131 # find CDRs that are using minutes, but have a later startdate
4133 my $startdate = $cdr->startdate;
4134 if ($startdate !~ /^\d+$/) {
4135 die "bad cdr startdate '$startdate'";
4137 $search{'extra_sql'} .= " AND cdr.startdate > $startdate";
4138 # minimize needless reshuffling
4139 $search{'order_by'} .= ', cdr.startdate DESC';
4141 # XXX may not work correctly with rate_time schedules. Could
4142 # fix this by storing ratedetailnum in cdr_cust_pkg_usage, I
4144 $search{'addl_from'} .=
4145 ' JOIN rate_detail'.
4146 ' ON (cdr.rated_ratedetailnum = rate_detail.ratedetailnum)';
4147 if ( $order eq 'rate_high' ) {
4148 $search{'extra_sql'} .= ' AND rate_detail.min_charge < '.
4149 $rate_detail->min_charge;
4150 $search{'order_by'} .= ', rate_detail.min_charge ASC';
4151 } elsif ( $order eq 'rate_low' ) {
4152 $search{'extra_sql'} .= ' AND rate_detail.min_charge > '.
4153 $rate_detail->min_charge;
4154 $search{'order_by'} .= ', rate_detail.min_charge DESC';
4156 # this should really never happen
4157 die "invalid cdr-minutes_priority value '$order'\n";
4160 my @cdr_usage_recs = qsearch(\%search);
4162 while (!$error and @cdr_usage_recs and $minutes > 0) {
4163 my $cdr_cust_pkg_usage = shift @cdr_usage_recs;
4164 my $cust_pkg_usage = $cdr_cust_pkg_usage->cust_pkg_usage;
4165 my $old_cdr = $cdr_cust_pkg_usage->cdr;
4166 $reproc_cdrs{$old_cdr->acctid} = $old_cdr;
4167 $cdr_cust_pkg_usage->select_for_update;
4168 $old_cdr->select_for_update;
4169 $cust_pkg_usage->select_for_update;
4170 # in case someone else stole the usage from this CDR
4171 # while waiting for the lock...
4172 next if $old_cdr->acctid != $cdr_cust_pkg_usage->acctid;
4173 # steal the usage allocation and flag the old CDR for reprocessing
4174 $cdr_cust_pkg_usage->set('acctid', $cdr->acctid);
4175 # if the allocation is more minutes than we need, adjust it...
4176 my $delta = $cdr_cust_pkg_usage->minutes - $minutes;
4178 $cdr_cust_pkg_usage->set('minutes', $minutes);
4179 $cust_pkg_usage->set('minutes', $cust_pkg_usage->minutes + $delta);
4180 $error = $cust_pkg_usage->replace;
4182 #warn 'CDR '.$cdr->acctid . ' stealing allocation '.$cdr_cust_pkg_usage->cdrusagenum.' from CDR '.$old_cdr->acctid."\n";
4183 $error ||= $cdr_cust_pkg_usage->replace;
4184 # deduct the stolen minutes
4185 $minutes -= $cdr_cust_pkg_usage->minutes;
4187 # after all minute-stealing is done, reset the affected CDRs
4188 foreach (values %reproc_cdrs) {
4189 $error ||= $_->set_status('');
4190 # XXX or should we just call $cdr->rate right here?
4191 # it's not like we can create a loop this way, since the min_charge
4192 # or call time has to go monotonically in one direction.
4193 # we COULD get some very deep recursions going, though...
4195 } # if $order and $minutes
4198 die "error applying included minutes\npkgnum ".$self->pkgnum.", class $classnum, acctid ".$cdr->acctid."\n$error\n"
4200 $dbh->commit if $oldAutoCommit;
4201 return $orig_minutes - $minutes;
4205 =item supplemental_pkgs
4207 Returns a list of all packages supplemental to this one.
4211 sub supplemental_pkgs {
4213 qsearch('cust_pkg', { 'main_pkgnum' => $self->pkgnum });
4218 Returns the package that this one is supplemental to, if any.
4224 if ( $self->main_pkgnum ) {
4225 return FS::cust_pkg->by_key($self->main_pkgnum);
4232 =head1 CLASS METHODS
4238 Returns an SQL expression identifying recurring packages.
4242 sub recurring_sql { "
4243 '0' != ( select freq from part_pkg
4244 where cust_pkg.pkgpart = part_pkg.pkgpart )
4249 Returns an SQL expression identifying one-time packages.
4254 '0' = ( select freq from part_pkg
4255 where cust_pkg.pkgpart = part_pkg.pkgpart )
4260 Returns an SQL expression identifying ordered packages (recurring packages not
4266 $_[0]->recurring_sql. " AND ". $_[0]->not_yet_billed_sql;
4271 Returns an SQL expression identifying active packages.
4276 $_[0]->recurring_sql. "
4277 AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
4278 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4279 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
4282 =item not_yet_billed_sql
4284 Returns an SQL expression identifying packages which have not yet been billed.
4288 sub not_yet_billed_sql { "
4289 ( cust_pkg.setup IS NULL OR cust_pkg.setup = 0 )
4290 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4291 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
4296 Returns an SQL expression identifying inactive packages (one-time packages
4297 that are otherwise unsuspended/uncancelled).
4301 sub inactive_sql { "
4302 ". $_[0]->onetime_sql(). "
4303 AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
4304 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4305 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
4310 Returns an SQL expression identifying on-hold packages.
4315 #$_[0]->recurring_sql(). ' AND '.
4317 ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4318 AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0
4319 AND ( cust_pkg.setup IS NULL OR cust_pkg.setup = 0 )
4326 Returns an SQL expression identifying suspended packages.
4330 sub suspended_sql { susp_sql(@_); }
4332 #$_[0]->recurring_sql(). ' AND '.
4334 ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4335 AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0
4336 AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
4343 Returns an SQL exprression identifying cancelled packages.
4347 sub cancelled_sql { cancel_sql(@_); }
4349 #$_[0]->recurring_sql(). ' AND '.
4350 "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
4355 Returns an SQL expression to give the package status as a string.
4361 WHEN cust_pkg.cancel IS NOT NULL THEN 'cancelled'
4362 WHEN ( cust_pkg.susp IS NOT NULL AND cust_pkg.setup IS NULL ) THEN 'on hold'
4363 WHEN cust_pkg.susp IS NOT NULL THEN 'suspended'
4364 WHEN cust_pkg.setup IS NULL THEN 'not yet billed'
4365 WHEN ".onetime_sql()." THEN 'one-time charge'
4370 =item search HASHREF
4374 Returns a qsearch hash expression to search for parameters specified in HASHREF.
4375 Valid parameters are
4383 on hold, active, inactive (or one-time charge), suspended, canceled (or cancelled)
4387 Equivalent to "status", except that "canceled"/"cancelled" will exclude
4388 packages that were changed into a new package with the same pkgpart (i.e.
4389 location or quantity changes).
4393 boolean selects custom packages
4399 pkgpart or arrayref or hashref of pkgparts
4403 arrayref of beginning and ending epoch date
4407 arrayref of beginning and ending epoch date
4411 arrayref of beginning and ending epoch date
4415 arrayref of beginning and ending epoch date
4419 arrayref of beginning and ending epoch date
4423 arrayref of beginning and ending epoch date
4427 arrayref of beginning and ending epoch date
4431 pkgnum or APKG_pkgnum
4435 a value suited to passing to FS::UI::Web::cust_header
4439 specifies the user for agent virtualization
4443 boolean; if true, returns only packages with more than 0 FCC phone lines.
4445 =item state, country
4447 Limit to packages with a service location in the specified state and country.
4448 For FCC 477 reporting, mostly.
4452 Limit to packages whose service locations are the same as the customer's
4453 default service location.
4455 =item location_nocust
4457 Limit to packages whose service locations are not the customer's default
4460 =item location_census
4462 Limit to packages whose service locations have census tracts.
4464 =item location_nocensus
4466 Limit to packages whose service locations do not have a census tract.
4468 =item location_geocode
4470 Limit to packages whose locations have geocodes.
4472 =item location_geocode
4474 Limit to packages whose locations do not have geocodes.
4478 Limit to packages associated with a svc_broadband, associated with a sector,
4479 associated with this towernum (or any of these, if it's an arrayref) (or NO
4480 towernum, if it's zero). This is an extreme niche case.
4482 =item 477part, 477rownum, date
4484 Limit to packages included in a specific row of one of the FCC 477 reports.
4485 '477part' is the section name (see L<FS::Report::FCC_477> methods), 'date'
4486 is the report as-of date (completely unrelated to the package setup/bill/
4487 other date fields), and '477rownum' is the row number of the report starting
4488 with zero. Row numbers have no inherent meaning, so this is useful only
4489 for explaining a 477 report you've already run.
4496 my ($class, $params) = @_;
4503 if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
4505 "cust_main.agentnum = $1";
4512 if ( $params->{'cust_status'} =~ /^([a-z]+)$/ ) {
4513 push @where, FS::cust_main->cust_status_sql . " = '$1' ";
4517 # parse customer sales person
4520 if ( $params->{'cust_main_salesnum'} =~ /^(\d+)$/ ) {
4521 push @where, ($1 > 0) ? "cust_main.salesnum = $1"
4522 : 'cust_main.salesnum IS NULL';
4527 # parse sales person
4530 if ( $params->{'salesnum'} =~ /^(\d+)$/ ) {
4531 push @where, ($1 > 0) ? "cust_pkg.salesnum = $1"
4532 : 'cust_pkg.salesnum IS NULL';
4539 if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
4541 "cust_pkg.custnum = $1";
4548 if ( $params->{'pkgbatch'} =~ /^([\w\/\-\:\.]+)$/ and $1 ) {
4550 "cust_pkg.pkgbatch = '$1'";
4557 if ( $params->{'magic'} eq 'active'
4558 || $params->{'status'} eq 'active' ) {
4560 push @where, FS::cust_pkg->active_sql();
4562 } elsif ( $params->{'magic'} =~ /^not[ _]yet[ _]billed$/
4563 || $params->{'status'} =~ /^not[ _]yet[ _]billed$/ ) {
4565 push @where, FS::cust_pkg->not_yet_billed_sql();
4567 } elsif ( $params->{'magic'} =~ /^(one-time charge|inactive)/
4568 || $params->{'status'} =~ /^(one-time charge|inactive)/ ) {
4570 push @where, FS::cust_pkg->inactive_sql();
4572 } elsif ( $params->{'magic'} =~ /^on[ _]hold$/
4573 || $params->{'status'} =~ /^on[ _]hold$/ ) {
4575 push @where, FS::cust_pkg->on_hold_sql();
4578 } elsif ( $params->{'magic'} eq 'suspended'
4579 || $params->{'status'} eq 'suspended' ) {
4581 push @where, FS::cust_pkg->suspended_sql();
4583 } elsif ( $params->{'magic'} =~ /^cancell?ed$/
4584 || $params->{'status'} =~ /^cancell?ed$/ ) {
4586 push @where, FS::cust_pkg->cancelled_sql();
4590 ### special case: "magic" is used in detail links from browse/part_pkg,
4591 # where "cancelled" has the restriction "and not replaced with a package
4592 # of the same pkgpart". Be consistent with that.
4595 if ( $params->{'magic'} =~ /^cancell?ed$/ ) {
4596 my $new_pkgpart = "SELECT pkgpart FROM cust_pkg AS cust_pkg_next ".
4597 "WHERE cust_pkg_next.change_pkgnum = cust_pkg.pkgnum";
4598 # ...may not exist, if this was just canceled and not changed; in that
4599 # case give it a "new pkgpart" that never equals the old pkgpart
4600 push @where, "COALESCE(($new_pkgpart), 0) != cust_pkg.pkgpart";
4604 # parse package class
4607 if ( exists($params->{'classnum'}) ) {
4610 if ( ref($params->{'classnum'}) ) {
4612 if ( ref($params->{'classnum'}) eq 'HASH' ) {
4613 @classnum = grep $params->{'classnum'}{$_}, keys %{ $params->{'classnum'} };
4614 } elsif ( ref($params->{'classnum'}) eq 'ARRAY' ) {
4615 @classnum = @{ $params->{'classnum'} };
4617 die 'unhandled classnum ref '. $params->{'classnum'};
4621 } elsif ( $params->{'classnum'} =~ /^(\d*)$/ && $1 ne '0' ) {
4628 my @nums = grep $_, @classnum;
4629 push @c_where, 'part_pkg.classnum IN ('. join(',',@nums). ')' if @nums;
4630 my $null = scalar( grep { $_ eq '' } @classnum );
4631 push @c_where, 'part_pkg.classnum IS NULL' if $null;
4633 if ( scalar(@c_where) == 1 ) {
4634 push @where, @c_where;
4635 } elsif ( @c_where ) {
4636 push @where, ' ( '. join(' OR ', @c_where). ' ) ';
4645 # parse package report options
4648 my @report_option = ();
4649 if ( exists($params->{'report_option'}) ) {
4650 if ( ref($params->{'report_option'}) eq 'ARRAY' ) {
4651 @report_option = @{ $params->{'report_option'} };
4652 } elsif ( $params->{'report_option'} =~ /^([,\d]*)$/ ) {
4653 @report_option = split(',', $1);
4658 if (@report_option) {
4659 # this will result in the empty set for the dangling comma case as it should
4661 map{ "0 < ( SELECT count(*) FROM part_pkg_option
4662 WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
4663 AND optionname = 'report_option_$_'
4664 AND optionvalue = '1' )"
4668 foreach my $any ( grep /^report_option_any/, keys %$params ) {
4670 my @report_option_any = ();
4671 if ( ref($params->{$any}) eq 'ARRAY' ) {
4672 @report_option_any = @{ $params->{$any} };
4673 } elsif ( $params->{$any} =~ /^([,\d]*)$/ ) {
4674 @report_option_any = split(',', $1);
4677 if (@report_option_any) {
4678 # this will result in the empty set for the dangling comma case as it should
4679 push @where, ' ( '. join(' OR ',
4680 map{ "0 < ( SELECT count(*) FROM part_pkg_option
4681 WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
4682 AND optionname = 'report_option_$_'
4683 AND optionvalue = '1' )"
4684 } @report_option_any
4694 push @where, "part_pkg.custom = 'Y'" if $params->{custom};
4700 push @where, "(part_pkg.fcc_ds0s > 0 OR pkg_class.fcc_ds0s > 0)"
4701 if $params->{fcc_line};
4707 if ( exists($params->{'censustract'}) ) {
4708 $params->{'censustract'} =~ /^([.\d]*)$/;
4709 my $censustract = "cust_location.censustract = '$1'";
4710 $censustract .= ' OR cust_location.censustract is NULL' unless $1;
4711 push @where, "( $censustract )";
4715 # parse censustract2
4717 if ( exists($params->{'censustract2'})
4718 && $params->{'censustract2'} =~ /^(\d*)$/
4722 push @where, "cust_location.censustract LIKE '$1%'";
4725 "( cust_location.censustract = '' OR cust_location.censustract IS NULL )";
4730 # parse country/state/zip
4732 for (qw(state country)) { # parsing rules are the same for these
4733 if ( exists($params->{$_})
4734 && uc($params->{$_}) =~ /^([A-Z]{2})$/ )
4736 # XXX post-2.3 only--before that, state/country may be in cust_main
4737 push @where, "cust_location.$_ = '$1'";
4740 if ( exists($params->{zip}) ) {
4741 push @where, "cust_location.zip = " . dbh->quote($params->{zip});
4747 if ( $params->{location_cust} xor $params->{location_nocust} ) {
4748 my $op = $params->{location_cust} ? '=' : '!=';
4749 push @where, "cust_location.locationnum $op cust_main.ship_locationnum";
4751 if ( $params->{location_census} xor $params->{location_nocensus} ) {
4752 my $op = $params->{location_census} ? "IS NOT NULL" : "IS NULL";
4753 push @where, "cust_location.censustract $op";
4755 if ( $params->{location_geocode} xor $params->{location_nogeocode} ) {
4756 my $op = $params->{location_geocode} ? "IS NOT NULL" : "IS NULL";
4757 push @where, "cust_location.geocode $op";
4764 if ( ref($params->{'pkgpart'}) ) {
4767 if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
4768 @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
4769 } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
4770 @pkgpart = @{ $params->{'pkgpart'} };
4772 die 'unhandled pkgpart ref '. $params->{'pkgpart'};
4775 @pkgpart = grep /^(\d+)$/, @pkgpart;
4777 push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
4779 } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
4780 push @where, "pkgpart = $1";
4789 #false laziness w/report_cust_pkg.html
4792 'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
4793 'active' => { 'susp'=>1, 'cancel'=>1 },
4794 'suspended' => { 'cancel' => 1 },
4799 if( exists($params->{'active'} ) ) {
4800 # This overrides all the other date-related fields, and includes packages
4801 # that were active at some time during the interval. It excludes:
4802 # - packages that were set up after the end of the interval
4803 # - packages that were canceled before the start of the interval
4804 # - packages that were suspended before the start of the interval
4805 # and are still suspended now
4806 my($beginning, $ending) = @{$params->{'active'}};
4808 "cust_pkg.setup IS NOT NULL",
4809 "cust_pkg.setup <= $ending",
4810 "(cust_pkg.cancel IS NULL OR cust_pkg.cancel >= $beginning )",
4811 "(cust_pkg.susp IS NULL OR cust_pkg.susp >= $beginning )",
4812 "NOT (".FS::cust_pkg->onetime_sql . ")";
4815 my $exclude_change_from = 0;
4816 my $exclude_change_to = 0;
4818 foreach my $field (qw( setup last_bill bill adjourn susp expire contract_end change_date cancel )) {
4820 next unless exists($params->{$field});
4822 my($beginning, $ending) = @{$params->{$field}};
4824 next if $beginning == 0 && $ending == 4294967295;
4827 "cust_pkg.$field IS NOT NULL",
4828 "cust_pkg.$field >= $beginning",
4829 "cust_pkg.$field <= $ending";
4831 $orderby ||= "ORDER BY cust_pkg.$field";
4833 if ( $field eq 'setup' ) {
4834 $exclude_change_from = 1;
4835 } elsif ( $field eq 'cancel' ) {
4836 $exclude_change_to = 1;
4837 } elsif ( $field eq 'change_date' ) {
4838 # if we are given setup and change_date ranges, and the setup date
4839 # falls in _both_ ranges, then include the package whether it was
4841 $exclude_change_from = 0;
4845 if ($exclude_change_from) {
4846 push @where, "change_pkgnum IS NULL";
4848 if ($exclude_change_to) {
4849 # a join might be more efficient here
4850 push @where, "NOT EXISTS(
4851 SELECT 1 FROM cust_pkg AS changed_to_pkg
4852 WHERE cust_pkg.pkgnum = changed_to_pkg.change_pkgnum
4857 $orderby ||= 'ORDER BY bill';
4860 # parse magic, legacy, etc.
4863 if ( $params->{'magic'} &&
4864 $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
4867 $orderby = 'ORDER BY pkgnum';
4869 if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
4870 push @where, "pkgpart = $1";
4873 } elsif ( $params->{'query'} eq 'pkgnum' ) {
4875 $orderby = 'ORDER BY pkgnum';
4877 } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
4879 $orderby = 'ORDER BY pkgnum';
4882 SELECT count(*) FROM pkg_svc
4883 WHERE pkg_svc.pkgpart = cust_pkg.pkgpart
4884 AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
4885 WHERE cust_svc.pkgnum = cust_pkg.pkgnum
4886 AND cust_svc.svcpart = pkg_svc.svcpart
4893 # parse the extremely weird 'towernum' param
4896 if ($params->{towernum}) {
4897 my $towernum = $params->{towernum};
4898 $towernum = [ $towernum ] if !ref($towernum);
4899 my $in = join(',', grep /^\d+$/, @$towernum);
4901 # inefficient, but this is an obscure feature
4902 eval "use FS::Report::Table";
4903 FS::Report::Table->_init_tower_pkg_cache; # probably does nothing
4904 push @where, "EXISTS(
4905 SELECT 1 FROM tower_pkg_cache
4906 WHERE tower_pkg_cache.pkgnum = cust_pkg.pkgnum
4907 AND tower_pkg_cache.towernum IN ($in)
4913 # parse the 477 report drill-down options
4916 if ($params->{'477part'} =~ /^([a-z]+)$/) {
4918 my ($date, $rownum, $agentnum);
4919 if ($params->{'date'} =~ /^(\d+)$/) {
4922 if ($params->{'477rownum'} =~ /^(\d+)$/) {
4925 if ($params->{'agentnum'} =~ /^(\d+)$/) {
4928 if ($date and defined($rownum)) {
4929 my $report = FS::Report::FCC_477->report($section,
4931 'agentnum' => $agentnum,
4934 my $row = $report->[$rownum]
4935 or die "row $rownum is past the end of the report";
4936 my $pkgnums = $row->[-1] || '0';
4937 # '0' so that if there are no pkgnums (empty string) it will create
4938 # a valid query that returns nothing
4939 warn "PKGNUMS:\n$pkgnums\n\n"; # XXX debug
4941 # and this overrides everything
4942 @where = ( "cust_pkg.pkgnum IN($pkgnums)" );
4943 } # else we're missing some params, ignore the whole business
4947 # setup queries, links, subs, etc. for the search
4950 # here is the agent virtualization
4951 if ($params->{CurrentUser}) {
4953 qsearchs('access_user', { username => $params->{CurrentUser} });
4956 push @where, $access_user->agentnums_sql('table'=>'cust_main');
4961 push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
4964 my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
4966 my $addl_from = 'LEFT JOIN part_pkg USING ( pkgpart ) '.
4967 'LEFT JOIN pkg_class ON ( part_pkg.classnum = pkg_class.classnum ) '.
4968 'LEFT JOIN cust_location USING ( locationnum ) '.
4969 FS::UI::Web::join_cust_main('cust_pkg', 'cust_pkg');
4973 if ( $params->{'select_zip5'} ) {
4974 my $zip = 'cust_location.zip';
4976 $select = "DISTINCT substr($zip,1,5) as zip";
4977 $orderby = "ORDER BY substr($zip,1,5)";
4978 $count_query = "SELECT COUNT( DISTINCT substr($zip,1,5) )";
4980 $select = join(', ',
4982 ( map "part_pkg.$_", qw( pkg freq ) ),
4983 'pkg_class.classname',
4984 'cust_main.custnum AS cust_main_custnum',
4985 FS::UI::Web::cust_sql_fields(
4986 $params->{'cust_fields'}
4989 $count_query = 'SELECT COUNT(*)';
4992 $count_query .= " FROM cust_pkg $addl_from $extra_sql";
4995 'table' => 'cust_pkg',
4997 'select' => $select,
4998 'extra_sql' => $extra_sql,
4999 'order_by' => $orderby,
5000 'addl_from' => $addl_from,
5001 'count_query' => $count_query,
5008 Returns a list of two package counts. The first is a count of packages
5009 based on the supplied criteria and the second is the count of residential
5010 packages with those same criteria. Criteria are specified as in the search
5016 my ($class, $params) = @_;
5018 my $sql_query = $class->search( $params );
5020 my $count_sql = delete($sql_query->{'count_query'});
5021 $count_sql =~ s/ FROM/,count(CASE WHEN cust_main.company IS NULL OR cust_main.company = '' THEN 1 END) FROM/
5022 or die "couldn't parse count_sql";
5024 my $count_sth = dbh->prepare($count_sql)
5025 or die "Error preparing $count_sql: ". dbh->errstr;
5027 or die "Error executing $count_sql: ". $count_sth->errstr;
5028 my $count_arrayref = $count_sth->fetchrow_arrayref;
5030 return ( @$count_arrayref );
5034 =item tax_locationnum_sql
5036 Returns an SQL expression for the tax location for a package, based
5037 on the settings of 'tax-pkg_address' and 'tax-ship_address'.
5041 sub tax_locationnum_sql {
5042 my $conf = FS::Conf->new;
5043 if ( $conf->exists('tax-pkg_address') ) {
5044 'cust_pkg.locationnum';
5046 elsif ( $conf->exists('tax-ship_address') ) {
5047 'cust_main.ship_locationnum';
5050 'cust_main.bill_locationnum';
5056 Returns a list: the first item is an SQL fragment identifying matching
5057 packages/customers via location (taking into account shipping and package
5058 address taxation, if enabled), and subsequent items are the parameters to
5059 substitute for the placeholders in that fragment.
5064 my($class, %opt) = @_;
5065 my $ornull = $opt{'ornull'};
5067 my $conf = new FS::Conf;
5069 # '?' placeholders in _location_sql_where
5070 my $x = $ornull ? 3 : 2;
5081 if ( $conf->exists('tax-ship_address') ) {
5084 ( ( ship_last IS NULL OR ship_last = '' )
5085 AND ". _location_sql_where('cust_main', '', $ornull ). "
5087 OR ( ship_last IS NOT NULL AND ship_last != ''
5088 AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
5091 # AND payby != 'COMP'
5093 @main_param = ( @bill_param, @bill_param );
5097 $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
5098 @main_param = @bill_param;
5104 if ( $conf->exists('tax-pkg_address') ) {
5106 my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
5109 ( cust_pkg.locationnum IS NULL AND $main_where )
5110 OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where )
5113 @param = ( @main_param, @bill_param );
5117 $where = $main_where;
5118 @param = @main_param;
5126 #subroutine, helper for location_sql
5127 sub _location_sql_where {
5129 my $prefix = @_ ? shift : '';
5130 my $ornull = @_ ? shift : '';
5132 # $ornull = $ornull ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
5134 $ornull = $ornull ? ' OR ? IS NULL ' : '';
5136 my $or_empty_city = " OR ( ? = '' AND $table.${prefix}city IS NULL )";
5137 my $or_empty_county = " OR ( ? = '' AND $table.${prefix}county IS NULL )";
5138 my $or_empty_state = " OR ( ? = '' AND $table.${prefix}state IS NULL )";
5140 my $text = (driver_name =~ /^mysql/i) ? 'char' : 'text';
5142 # ( $table.${prefix}city = ? $or_empty_city $ornull )
5144 ( $table.district = ? OR ? = '' OR CAST(? AS $text) IS NULL )
5145 AND ( $table.${prefix}city = ? OR ? = '' OR CAST(? AS $text) IS NULL )
5146 AND ( $table.${prefix}county = ? $or_empty_county $ornull )
5147 AND ( $table.${prefix}state = ? $or_empty_state $ornull )
5148 AND $table.${prefix}country = ?
5153 my( $self, $what ) = @_;
5155 my $what_show_zero = $what. '_show_zero';
5156 length($self->$what_show_zero())
5157 ? ($self->$what_show_zero() eq 'Y')
5158 : $self->part_pkg->$what_show_zero();
5165 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
5167 CUSTNUM is a customer (see L<FS::cust_main>)
5169 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
5170 L<FS::part_pkg>) to order for this customer. Duplicates are of course
5173 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
5174 remove for this customer. The services (see L<FS::cust_svc>) are moved to the
5175 new billing items. An error is returned if this is not possible (see
5176 L<FS::pkg_svc>). An empty arrayref is equivalent to not specifying this
5179 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
5180 newly-created cust_pkg objects.
5182 REFNUM, if specified, will specify the FS::pkg_referral record to be created
5183 and inserted. Multiple FS::pkg_referral records can be created by
5184 setting I<refnum> to an array reference of refnums or a hash reference with
5185 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
5186 record will be created corresponding to cust_main.refnum.
5191 my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
5193 my $conf = new FS::Conf;
5195 # Transactionize this whole mess
5196 local $SIG{HUP} = 'IGNORE';
5197 local $SIG{INT} = 'IGNORE';
5198 local $SIG{QUIT} = 'IGNORE';
5199 local $SIG{TERM} = 'IGNORE';
5200 local $SIG{TSTP} = 'IGNORE';
5201 local $SIG{PIPE} = 'IGNORE';
5203 my $oldAutoCommit = $FS::UID::AutoCommit;
5204 local $FS::UID::AutoCommit = 0;
5208 # my $cust_main = qsearchs('cust_main', { custnum => $custnum });
5209 # return "Customer not found: $custnum" unless $cust_main;
5211 warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
5214 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
5217 my $change = scalar(@old_cust_pkg) != 0;
5220 if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
5222 warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
5223 " to pkgpart ". $pkgparts->[0]. "\n"
5226 my $err_or_cust_pkg =
5227 $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
5228 'refnum' => $refnum,
5231 unless (ref($err_or_cust_pkg)) {
5232 $dbh->rollback if $oldAutoCommit;
5233 return $err_or_cust_pkg;
5236 push @$return_cust_pkg, $err_or_cust_pkg;
5237 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
5242 # Create the new packages.
5243 foreach my $pkgpart (@$pkgparts) {
5245 warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
5247 my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
5248 pkgpart => $pkgpart,
5252 $error = $cust_pkg->insert( 'change' => $change );
5253 push @$return_cust_pkg, $cust_pkg;
5255 foreach my $link ($cust_pkg->part_pkg->supp_part_pkg_link) {
5256 my $supp_pkg = FS::cust_pkg->new({
5257 custnum => $custnum,
5258 pkgpart => $link->dst_pkgpart,
5260 main_pkgnum => $cust_pkg->pkgnum,
5263 $error ||= $supp_pkg->insert( 'change' => $change );
5264 push @$return_cust_pkg, $supp_pkg;
5268 $dbh->rollback if $oldAutoCommit;
5273 # $return_cust_pkg now contains refs to all of the newly
5276 # Transfer services and cancel old packages.
5277 foreach my $old_pkg (@old_cust_pkg) {
5279 warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
5282 foreach my $new_pkg (@$return_cust_pkg) {
5283 $error = $old_pkg->transfer($new_pkg);
5284 if ($error and $error == 0) {
5285 # $old_pkg->transfer failed.
5286 $dbh->rollback if $oldAutoCommit;
5291 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
5292 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
5293 foreach my $new_pkg (@$return_cust_pkg) {
5294 $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
5295 if ($error and $error == 0) {
5296 # $old_pkg->transfer failed.
5297 $dbh->rollback if $oldAutoCommit;
5304 # Transfers were successful, but we went through all of the
5305 # new packages and still had services left on the old package.
5306 # We can't cancel the package under the circumstances, so abort.
5307 $dbh->rollback if $oldAutoCommit;
5308 return "Unable to transfer all services from package ".$old_pkg->pkgnum;
5310 $error = $old_pkg->cancel( quiet=>1 );
5316 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
5320 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
5322 A bulk change method to change packages for multiple customers.
5324 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
5325 L<FS::part_pkg>) to order for each customer. Duplicates are of course
5328 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
5329 replace. The services (see L<FS::cust_svc>) are moved to the
5330 new billing items. An error is returned if this is not possible (see
5333 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
5334 newly-created cust_pkg objects.
5339 my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
5341 # Transactionize this whole mess
5342 local $SIG{HUP} = 'IGNORE';
5343 local $SIG{INT} = 'IGNORE';
5344 local $SIG{QUIT} = 'IGNORE';
5345 local $SIG{TERM} = 'IGNORE';
5346 local $SIG{TSTP} = 'IGNORE';
5347 local $SIG{PIPE} = 'IGNORE';
5349 my $oldAutoCommit = $FS::UID::AutoCommit;
5350 local $FS::UID::AutoCommit = 0;
5354 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
5357 while(scalar(@old_cust_pkg)) {
5359 my $custnum = $old_cust_pkg[0]->custnum;
5360 my (@remove) = map { $_->pkgnum }
5361 grep { $_->custnum == $custnum } @old_cust_pkg;
5362 @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
5364 my $error = order $custnum, $pkgparts, \@remove, \@return;
5366 push @errors, $error
5368 push @$return_cust_pkg, @return;
5371 if (scalar(@errors)) {
5372 $dbh->rollback if $oldAutoCommit;
5373 return join(' / ', @errors);
5376 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
5380 # Used by FS::Upgrade to migrate to a new database.
5381 sub _upgrade_data { # class method
5382 my ($class, %opts) = @_;
5383 $class->_upgrade_otaker(%opts);
5385 # RT#10139, bug resulting in contract_end being set when it shouldn't
5386 'UPDATE cust_pkg SET contract_end = NULL WHERE contract_end = -1',
5387 # RT#10830, bad calculation of prorate date near end of year
5388 # the date range for bill is December 2009, and we move it forward
5389 # one year if it's before the previous bill date (which it should
5391 'UPDATE cust_pkg SET bill = bill + (365*24*60*60) WHERE bill < last_bill
5392 AND bill > 1259654400 AND bill < 1262332800 AND (SELECT plan FROM part_pkg
5393 WHERE part_pkg.pkgpart = cust_pkg.pkgpart) = \'prorate\'',
5394 # RT6628, add order_date to cust_pkg
5395 'update cust_pkg set order_date = (select history_date from h_cust_pkg
5396 where h_cust_pkg.pkgnum = cust_pkg.pkgnum and
5397 history_action = \'insert\') where order_date is null',
5399 foreach my $sql (@statements) {
5400 my $sth = dbh->prepare($sql);
5401 $sth->execute or die $sth->errstr;
5409 sub order is not OO. Perhaps it should be moved to FS::cust_main and made so?
5411 In sub order, the @pkgparts array (passed by reference) is clobbered.
5413 Also in sub order, no money is adjusted. Once FS::part_pkg defines a standard
5414 method to pass dates to the recur_prog expression, it should do so.
5416 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
5417 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
5418 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
5419 configuration values. Probably need a subroutine which decides what to do
5420 based on whether or not we've fetched the user yet, rather than a hash. See
5421 FS::UID and the TODO.
5423 Now that things are transactional should the check in the insert method be
5428 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
5429 L<FS::pkg_svc>, schema.html from the base documentation