2 use base qw( FS::cust_pkg::API 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 sum);
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
59 our $cache_enabled = 0;
62 my( $self, $hashref ) = @_;
63 if ( $cache_enabled && $hashref->{'pkg'} && $hashref->{'plan'} ) {
64 $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
70 my ( $hashref, $cache ) = @_;
71 # #if ( $hashref->{'pkgpart'} ) {
72 # if ( $hashref->{'pkg'} ) {
73 # # #@{ $self->{'_pkgnum'} } = ();
74 # # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
75 # # $self->{'_pkgpart'} = $subcache;
76 # # #push @{ $self->{'_pkgnum'} },
77 # # FS::part_pkg->new_or_cached($hashref, $subcache);
78 # $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
80 if ( exists $hashref->{'svcnum'} ) {
81 #@{ $self->{'_pkgnum'} } = ();
82 my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
83 $self->{'_svcnum'} = $subcache;
84 #push @{ $self->{'_pkgnum'} },
85 FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
91 FS::cust_pkg - Object methods for cust_pkg objects
97 $record = new FS::cust_pkg \%hash;
98 $record = new FS::cust_pkg { 'column' => 'value' };
100 $error = $record->insert;
102 $error = $new_record->replace($old_record);
104 $error = $record->delete;
106 $error = $record->check;
108 $error = $record->cancel;
110 $error = $record->suspend;
112 $error = $record->unsuspend;
114 $part_pkg = $record->part_pkg;
116 @labels = $record->labels;
118 $seconds = $record->seconds_since($timestamp);
120 #bulk cancel+order... perhaps slightly deprecated, only used by the bulk
121 # cancel+order in the web UI and nowhere else (edit/process/cust_pkg.cgi)
122 $error = FS::cust_pkg::order( $custnum, \@pkgparts );
123 $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
127 An FS::cust_pkg object represents a customer billing item. FS::cust_pkg
128 inherits from FS::Record. The following fields are currently supported:
134 Primary key (assigned automatically for new billing items)
138 Customer (see L<FS::cust_main>)
142 Billing item definition (see L<FS::part_pkg>)
146 Optional link to package location (see L<FS::location>)
150 date package was ordered (also remains same on changes)
162 date (next bill date)
190 order taker (see L<FS::access_user>)
194 If not set, defaults to 1
198 Date of change from previous package
208 =item change_locationnum
216 The pkgnum of the package that this package is supplemental to, if any.
220 The package link (L<FS::part_pkg_link>) that defines this supplemental
221 package, if it is one.
223 =item change_to_pkgnum
225 The pkgnum of the package this one will be "changed to" in the future
226 (on its expiration date).
230 Note: setup, last_bill, bill, adjourn, susp, expire, cancel and change_date
231 are specified as UNIX timestamps; see L<perlfunc/"time">. Also see
232 L<Time::Local> and L<Date::Parse> for conversion functions.
240 Create a new billing item. To add the item to the database, see L<"insert">.
244 sub table { 'cust_pkg'; }
245 sub cust_linked { $_[0]->cust_main_custnum || $_[0]->custnum }
246 sub cust_unlinked_msg {
248 "WARNING: can't find cust_main.custnum ". $self->custnum.
249 ' (cust_pkg.pkgnum '. $self->pkgnum. ')';
252 =item set_initial_timers
254 If required by the package definition, sets any automatic expire, adjourn,
255 or contract_end timers to some number of months after the start date
256 (or setup date, if the package has already been setup). If the package has
257 a delayed setup fee after a period of "free days", will also set the
258 start date to the end of that period.
262 sub set_initial_timers {
264 my $part_pkg = $self->part_pkg;
265 foreach my $action ( qw(expire adjourn contract_end) ) {
266 my $months = $part_pkg->option("${action}_months",1);
267 if($months and !$self->get($action)) {
268 my $start = $self->start_date || $self->setup || time;
269 $self->set($action, $part_pkg->add_freq($start, $months) );
273 # if this package has "free days" and delayed setup fee, then
274 # set start date that many days in the future.
275 # (this should have been set in the UI, but enforce it here)
276 if ( $part_pkg->option('free_days',1)
277 && $part_pkg->option('delay_setup',1)
280 $self->start_date( $part_pkg->default_start_date );
285 =item insert [ OPTION => VALUE ... ]
287 Adds this billing item to the database ("Orders" the item). If there is an
288 error, returns the error, otherwise returns false.
290 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
291 will be used to look up the package definition and agent restrictions will be
294 If the additional field I<refnum> is defined, an FS::pkg_referral record will
295 be created and inserted. Multiple FS::pkg_referral records can be created by
296 setting I<refnum> to an array reference of refnums or a hash reference with
297 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
298 record will be created corresponding to cust_main.refnum.
300 The following options are available:
306 If set true, supresses actions that should only be taken for new package
307 orders. (Currently this includes: intro periods when delay_setup is on,
308 auto-adding a 1st start date, auto-adding expiration/adjourn/contract_end dates)
312 cust_pkg_option records will be created
316 a ticket will be added to this customer with this subject
320 an optional queue name for ticket additions
324 Don't check the legality of the package definition. This should be used
325 when performing a package change that doesn't change the pkgpart (i.e.
333 my( $self, %options ) = @_;
336 $error = $self->check_pkgpart unless $options{'allow_pkgpart'};
337 return $error if $error;
339 my $part_pkg = $self->part_pkg;
341 if ( ! $options{'change'} ) {
343 # set order date to now
344 $self->order_date(time);
346 # if the package def says to start only on the first of the month:
347 if ( $part_pkg->option('start_1st', 1) && !$self->start_date ) {
348 my ($sec,$min,$hour,$mday,$mon,$year) = (localtime(time) )[0,1,2,3,4,5];
349 $mon += 1 unless $mday == 1;
350 until ( $mon < 12 ) { $mon -= 12; $year++; }
351 $self->start_date( timelocal_nocheck(0,0,0,1,$mon,$year) );
354 if ($self->susp eq 'now' or $part_pkg->start_on_hold) {
355 # if the package was ordered on hold:
357 # - don't set the start date (it will be started manually)
358 $self->set('susp', $self->order_date);
359 $self->set('start_date', '');
361 # set expire/adjourn/contract_end timers, and free days, if appropriate
362 $self->set_initial_timers;
364 } # else this is a package change, and shouldn't have "new package" behavior
366 local $SIG{HUP} = 'IGNORE';
367 local $SIG{INT} = 'IGNORE';
368 local $SIG{QUIT} = 'IGNORE';
369 local $SIG{TERM} = 'IGNORE';
370 local $SIG{TSTP} = 'IGNORE';
371 local $SIG{PIPE} = 'IGNORE';
373 my $oldAutoCommit = $FS::UID::AutoCommit;
374 local $FS::UID::AutoCommit = 0;
377 $error = $self->SUPER::insert($options{options} ? %{$options{options}} : ());
379 $dbh->rollback if $oldAutoCommit;
383 $self->refnum($self->cust_main->refnum) unless $self->refnum;
384 $self->refnum( [ $self->refnum ] ) unless ref($self->refnum);
385 $self->process_m2m( 'link_table' => 'pkg_referral',
386 'target_table' => 'part_referral',
387 'params' => $self->refnum,
390 if ( $self->discountnum ) {
391 my $error = $self->insert_discount();
393 $dbh->rollback if $oldAutoCommit;
398 my $conf = new FS::Conf;
400 if ($self->locationnum) {
402 map qsearch( 'part_export', {exportnum=>$_} ),
403 $conf->config('cust_location-exports'); #, $agentnum
405 foreach my $part_export ( @part_export ) {
406 my $error = $part_export->export_pkg_location($self); #, @$export_args);
408 $dbh->rollback if $oldAutoCommit;
409 return "exporting to ". $part_export->exporttype.
410 " (transaction rolled back): $error";
415 if ( $conf->config('ticket_system') && $options{ticket_subject} ) {
417 #this init stuff is still inefficient, but at least its limited to
418 # the small number (any?) folks using ticket emailing on pkg order
421 # use lib ( "/opt/rt3/local/lib", "/opt/rt3/lib" );
428 use FS::TicketSystem;
429 FS::TicketSystem->init();
431 my $q = new RT::Queue($RT::SystemUser);
432 $q->Load($options{ticket_queue}) if $options{ticket_queue};
433 my $t = new RT::Ticket($RT::SystemUser);
434 my $mime = new MIME::Entity;
435 $mime->build( Type => 'text/plain', Data => $options{ticket_subject} );
436 $t->Create( $options{ticket_queue} ? (Queue => $q) : (),
437 Subject => $options{ticket_subject},
440 $t->AddLink( Type => 'MemberOf',
441 Target => 'freeside://freeside/cust_main/'. $self->custnum,
445 if ($conf->config('welcome_letter') && $self->cust_main->num_pkgs == 1) {
446 my $queue = new FS::queue {
447 'job' => 'FS::cust_main::queueable_print',
449 $error = $queue->insert(
450 'custnum' => $self->custnum,
451 'template' => 'welcome_letter',
455 warn "can't send welcome letter: $error";
460 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
467 This method now works but you probably shouldn't use it.
469 You don't want to delete packages, because there would then be no record
470 the customer ever purchased the package. Instead, see the cancel method and
471 hide cancelled packages.
478 local $SIG{HUP} = 'IGNORE';
479 local $SIG{INT} = 'IGNORE';
480 local $SIG{QUIT} = 'IGNORE';
481 local $SIG{TERM} = 'IGNORE';
482 local $SIG{TSTP} = 'IGNORE';
483 local $SIG{PIPE} = 'IGNORE';
485 my $oldAutoCommit = $FS::UID::AutoCommit;
486 local $FS::UID::AutoCommit = 0;
489 foreach my $cust_pkg_discount ($self->cust_pkg_discount) {
490 my $error = $cust_pkg_discount->delete;
492 $dbh->rollback if $oldAutoCommit;
496 #cust_bill_pkg_discount?
498 foreach my $cust_pkg_detail ($self->cust_pkg_detail) {
499 my $error = $cust_pkg_detail->delete;
501 $dbh->rollback if $oldAutoCommit;
506 foreach my $cust_pkg_reason (
508 'table' => 'cust_pkg_reason',
509 'hashref' => { 'pkgnum' => $self->pkgnum },
513 my $error = $cust_pkg_reason->delete;
515 $dbh->rollback if $oldAutoCommit;
522 my $error = $self->SUPER::delete(@_);
524 $dbh->rollback if $oldAutoCommit;
528 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
534 =item replace [ OLD_RECORD ] [ HASHREF | OPTION => VALUE ... ]
536 Replaces the OLD_RECORD with this one in the database. If there is an error,
537 returns the error, otherwise returns false.
539 Currently, custnum, setup, bill, adjourn, susp, expire, and cancel may be changed.
541 Changing pkgpart may have disasterous effects. See the order subroutine.
543 setup and bill are normally updated by calling the bill method of a customer
544 object (see L<FS::cust_main>).
546 suspend is normally updated by the suspend and unsuspend methods.
548 cancel is normally updated by the cancel method (and also the order subroutine
551 Available options are:
557 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.
561 the access_user (see L<FS::access_user>) providing the reason
565 hashref of keys and values - cust_pkg_option records will be created, updated or removed as appopriate
574 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
579 ( ref($_[0]) eq 'HASH' )
583 #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
584 #return "Can't change otaker!" if $old->otaker ne $new->otaker;
587 #return "Can't change setup once it exists!"
588 # if $old->getfield('setup') &&
589 # $old->getfield('setup') != $new->getfield('setup');
591 #some logic for bill, susp, cancel?
593 local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
595 local $SIG{HUP} = 'IGNORE';
596 local $SIG{INT} = 'IGNORE';
597 local $SIG{QUIT} = 'IGNORE';
598 local $SIG{TERM} = 'IGNORE';
599 local $SIG{TSTP} = 'IGNORE';
600 local $SIG{PIPE} = 'IGNORE';
602 my $oldAutoCommit = $FS::UID::AutoCommit;
603 local $FS::UID::AutoCommit = 0;
606 foreach my $method ( qw(adjourn expire) ) { # How many reasons?
607 if ($options->{'reason'} && $new->$method && $old->$method ne $new->$method) {
608 my $error = $new->insert_reason(
609 'reason' => $options->{'reason'},
610 'date' => $new->$method,
612 'reason_otaker' => $options->{'reason_otaker'},
615 dbh->rollback if $oldAutoCommit;
616 return "Error inserting cust_pkg_reason: $error";
621 #save off and freeze RADIUS attributes for any associated svc_acct records
623 if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
625 #also check for specific exports?
626 # to avoid spurious modify export events
627 @svc_acct = map { $_->svc_x }
628 grep { $_->part_svc->svcdb eq 'svc_acct' }
631 $_->snapshot foreach @svc_acct;
635 my $error = $new->export_pkg_change($old)
636 || $new->SUPER::replace( $old,
638 ? $options->{options}
642 $dbh->rollback if $oldAutoCommit;
646 #for prepaid packages,
647 #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
648 foreach my $old_svc_acct ( @svc_acct ) {
649 my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
651 $new_svc_acct->replace( $old_svc_acct,
652 'depend_jobnum' => $options->{depend_jobnum},
655 $dbh->rollback if $oldAutoCommit;
660 # also run exports if removing locationnum?
661 # doesn't seem to happen, and we don't export blank locationnum on insert...
662 if ($new->locationnum and ($new->locationnum != $old->locationnum)) {
663 my $conf = new FS::Conf;
665 map qsearch( 'part_export', {exportnum=>$_} ),
666 $conf->config('cust_location-exports'); #, $agentnum
668 foreach my $part_export ( @part_export ) {
669 my $error = $part_export->export_pkg_location($new); #, @$export_args);
671 $dbh->rollback if $oldAutoCommit;
672 return "exporting to ". $part_export->exporttype.
673 " (transaction rolled back): $error";
678 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
685 Checks all fields to make sure this is a valid billing item. If there is an
686 error, returns the error, otherwise returns false. Called by the insert and
694 if ( !$self->locationnum or $self->locationnum == -1 ) {
695 $self->set('locationnum', $self->cust_main->ship_locationnum);
699 $self->ut_numbern('pkgnum')
700 || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
701 || $self->ut_numbern('pkgpart')
702 || $self->ut_foreign_keyn('contactnum', 'contact', 'contactnum' )
703 || $self->ut_foreign_keyn('locationnum', 'cust_location', 'locationnum')
704 || $self->ut_foreign_keyn('salesnum', 'sales', 'salesnum')
705 || $self->ut_numbern('quantity')
706 || $self->ut_numbern('start_date')
707 || $self->ut_numbern('setup')
708 || $self->ut_numbern('bill')
709 || $self->ut_numbern('susp')
710 || $self->ut_numbern('cancel')
711 || $self->ut_numbern('adjourn')
712 || $self->ut_numbern('resume')
713 || $self->ut_numbern('expire')
714 || $self->ut_numbern('dundate')
715 || $self->ut_flag('no_auto', [ '', 'Y' ])
716 || $self->ut_flag('waive_setup', [ '', 'Y' ])
717 || $self->ut_flag('separate_bill')
718 || $self->ut_textn('agent_pkgid')
719 || $self->ut_enum('recur_show_zero', [ '', 'Y', 'N', ])
720 || $self->ut_enum('setup_show_zero', [ '', 'Y', 'N', ])
721 || $self->ut_foreign_keyn('main_pkgnum', 'cust_pkg', 'pkgnum')
722 || $self->ut_foreign_keyn('pkglinknum', 'part_pkg_link', 'pkglinknum')
723 || $self->ut_foreign_keyn('change_to_pkgnum', 'cust_pkg', 'pkgnum')
725 return $error if $error;
727 return "A package with both start date (future start) and setup date (already started) will never bill"
728 if $self->start_date && $self->setup && ! $upgrade;
730 return "A future unsuspend date can only be set for a package with a suspend date"
731 if $self->resume and !$self->susp and !$self->adjourn;
733 $self->usernum($FS::CurrentUser::CurrentUser->usernum) unless $self->usernum;
735 if ( $self->dbdef_table->column('manual_flag') ) {
736 $self->manual_flag('') if $self->manual_flag eq ' ';
737 $self->manual_flag =~ /^([01]?)$/
738 or return "Illegal manual_flag ". $self->manual_flag;
739 $self->manual_flag($1);
747 Check the pkgpart to make sure it's allowed with the reg_code and/or
748 promo_code of the package (if present) and with the customer's agent.
749 Called from C<insert>, unless we are doing a package change that doesn't
757 # my $error = $self->ut_numbern('pkgpart'); # already done
760 if ( $self->reg_code ) {
762 unless ( grep { $self->pkgpart == $_->pkgpart }
763 map { $_->reg_code_pkg }
764 qsearchs( 'reg_code', { 'code' => $self->reg_code,
765 'agentnum' => $self->cust_main->agentnum })
767 return "Unknown registration code";
770 } elsif ( $self->promo_code ) {
773 qsearchs('part_pkg', {
774 'pkgpart' => $self->pkgpart,
775 'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
777 return 'Unknown promotional code' unless $promo_part_pkg;
781 unless ( $disable_agentcheck ) {
783 qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
784 return "agent ". $agent->agentnum. ':'. $agent->agent.
785 " can't purchase pkgpart ". $self->pkgpart
786 unless $agent->pkgpart_hashref->{ $self->pkgpart }
787 || $agent->agentnum == $self->part_pkg->agentnum;
790 $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
791 return $error if $error;
799 =item cancel [ OPTION => VALUE ... ]
801 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
802 in this package, then cancels the package itself (sets the cancel field to
805 Available options are:
809 =item quiet - can be set true to supress email cancellation notices.
811 =item time - can be set to cancel the package based on a specific future or
812 historical date. Using time ensures that the remaining amount is calculated
813 correctly. Note however that this is an immediate cancel and just changes
814 the date. You are PROBABLY looking to expire the account instead of using
817 =item reason - can be set to a cancellation reason (see L<FS:reason>),
818 either a reasonnum of an existing reason, or a hashref to create
819 a new reason. The hashref should have the following keys:
820 typenum - Reason type (see L<FS::reason_type>
821 reason - Text of the new reason.
823 If this argument isn't given or is a false value, then the package will be
824 canceled with no reason.
826 =item date - can be set to a unix style timestamp to specify when to
829 =item nobill - can be set true to skip billing if it might otherwise be done.
831 =item unused_credit - can be set to 1 to credit the remaining time, or 0 to
832 not credit it. This must be set (by change()) when changing the package
833 to a different pkgpart or location, and probably shouldn't be in any other
834 case. If it's not set, the 'unused_credit_cancel' part_pkg option will
837 =item no_delay_cancel - prevents delay_cancel behavior
838 no matter what other options say, for use when changing packages (or any
839 other time you're really sure you want an immediate cancel)
843 If there is an error, returns the error, otherwise returns false.
847 #NOT DOCUMENTING - this should only be used when calling recursively
848 #=item delay_cancel - for internal use, to allow proper handling of
849 #supplemental packages when the main package is flagged to suspend
850 #before cancelling, probably shouldn't be used otherwise (set the
851 #corresponding package option instead)
854 my( $self, %options ) = @_;
857 # pass all suspend/cancel actions to the main package
858 # (unless the pkglinknum has been removed, then the link is defunct and
859 # this package can be canceled on its own)
860 if ( $self->main_pkgnum and $self->pkglinknum and !$options{'from_main'} ) {
861 return $self->main_pkg->cancel(%options);
864 my $conf = new FS::Conf;
866 warn "cust_pkg::cancel called with options".
867 join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
870 local $SIG{HUP} = 'IGNORE';
871 local $SIG{INT} = 'IGNORE';
872 local $SIG{QUIT} = 'IGNORE';
873 local $SIG{TERM} = 'IGNORE';
874 local $SIG{TSTP} = 'IGNORE';
875 local $SIG{PIPE} = 'IGNORE';
877 my $oldAutoCommit = $FS::UID::AutoCommit;
878 local $FS::UID::AutoCommit = 0;
881 my $old = $self->select_for_update;
883 if ( $old->get('cancel') || $self->get('cancel') ) {
884 dbh->rollback if $oldAutoCommit;
885 return ""; # no error
888 # XXX possibly set cancel_time to the expire date?
889 my $cancel_time = $options{'time'} || time;
890 my $date = $options{'date'} if $options{'date'}; # expire/cancel later
891 $date = '' if ($date && $date <= $cancel_time); # complain instead?
893 my $delay_cancel = $options{'no_delay_cancel'} ? 0 : $options{'delay_cancel'};
894 if ( !$date && $self->part_pkg->option('delay_cancel',1)
895 && (($self->status eq 'active') || ($self->status eq 'suspended'))
896 && !$options{'no_delay_cancel'}
898 my $expdays = $conf->config('part_pkg-delay_cancel-days') || 1;
899 my $expsecs = 60*60*24*$expdays;
900 my $suspfor = $self->susp ? $cancel_time - $self->susp : 0;
901 $expsecs = $expsecs - $suspfor if $suspfor;
902 unless ($expsecs <= 0) { #if it's already been suspended long enough, don't re-suspend
904 $date = $cancel_time + $expsecs;
908 #race condition: usage could be ongoing until unprovisioned
909 #resolved by performing a change package instead (which unprovisions) and
911 if ( !$options{nobill} && !$date ) {
912 # && $conf->exists('bill_usage_on_cancel') ) { #calc_cancel checks this
913 my $copy = $self->new({$self->hash});
915 $copy->cust_main->bill( 'pkg_list' => [ $copy ],
917 'time' => $cancel_time );
918 warn "Error billing during cancel, custnum ".
919 #$self->cust_main->custnum. ": $error"
924 if ( $options{'reason'} ) {
925 $error = $self->insert_reason( 'reason' => $options{'reason'},
926 'action' => $date ? 'expire' : 'cancel',
927 'date' => $date ? $date : $cancel_time,
928 'reason_otaker' => $options{'reason_otaker'},
931 dbh->rollback if $oldAutoCommit;
932 return "Error inserting cust_pkg_reason: $error";
936 my %svc_cancel_opt = ();
937 $svc_cancel_opt{'date'} = $date if $date;
938 foreach my $cust_svc (
941 sort { $a->[1] <=> $b->[1] }
942 map { [ $_, $_->svc_x ? $_->svc_x->table_info->{'cancel_weight'} : -1 ]; }
943 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
945 my $part_svc = $cust_svc->part_svc;
946 next if ( defined($part_svc) and $part_svc->preserve );
947 my $error = $cust_svc->cancel( %svc_cancel_opt );
950 $dbh->rollback if $oldAutoCommit;
951 return 'Error '. ($svc_cancel_opt{'date'} ? 'expiring' : 'canceling' ).
956 # if a reasonnum was passed, get the actual reason object so we can check
960 if ($options{'reason'} =~ /^\d+$/) {
961 $reason = FS::reason->by_key($options{'reason'});
965 # credit remaining time if any of these are true:
966 # - unused_credit => 1 was passed (this happens when canceling a package
967 # for a package change when unused_credit_change is set)
968 # - no unused_credit option, and there is a cancel reason, and the cancel
969 # reason says to credit the package
970 # - no unused_credit option, and the package definition says to credit the
971 # package on cancellation
973 if ( exists($options{'unused_credit'}) ) {
974 $do_credit = $options{'unused_credit'};
975 } elsif ( defined($reason) && $reason->unused_credit ) {
978 $do_credit = $self->part_pkg->option('unused_credit_cancel', 1);
981 my $error = $self->credit_remaining('cancel', $cancel_time);
983 $dbh->rollback if $oldAutoCommit;
989 my %hash = $self->hash;
991 $hash{'expire'} = $date;
993 # just to be sure these are clear
994 $hash{'adjourn'} = undef;
995 $hash{'resume'} = undef;
998 $hash{'cancel'} = $cancel_time;
1000 $hash{'change_custnum'} = $options{'change_custnum'};
1002 # if this is a supplemental package that's lost its part_pkg_link, and it's
1003 # being canceled for real, unlink it completely
1004 if ( !$date and ! $self->pkglinknum ) {
1005 $hash{main_pkgnum} = '';
1008 my $new = new FS::cust_pkg ( \%hash );
1009 $error = $new->replace( $self, options => { $self->options } );
1010 if ( $self->change_to_pkgnum ) {
1011 my $change_to = FS::cust_pkg->by_key($self->change_to_pkgnum);
1012 $error ||= $change_to->cancel('no_delay_cancel' => 1) || $change_to->delete;
1015 $dbh->rollback if $oldAutoCommit;
1019 foreach my $supp_pkg ( $self->supplemental_pkgs ) {
1020 $error = $supp_pkg->cancel(%options,
1022 'date' => $date, #in case it got changed by delay_cancel
1023 'delay_cancel' => $delay_cancel,
1026 $dbh->rollback if $oldAutoCommit;
1027 return "canceling supplemental pkg#".$supp_pkg->pkgnum.": $error";
1031 if ($delay_cancel && !$options{'from_main'}) {
1032 $error = $new->suspend(
1034 'time' => $cancel_time
1039 foreach my $usage ( $self->cust_pkg_usage ) {
1040 $error = $usage->delete;
1042 $dbh->rollback if $oldAutoCommit;
1043 return "deleting usage pools: $error";
1048 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1049 return '' if $date; #no errors
1051 my $cust_main = $self->cust_main;
1053 my @invoicing_list = $cust_main->invoicing_list_emailonly;
1054 if ( !$options{'quiet'}
1055 && $conf->config_bool('emailcancel', $cust_main->agentnum)
1059 my $msgnum = $conf->config('cancel_msgnum', $cust_main->agentnum);
1061 my $msg_template = qsearchs('msg_template', { msgnum => $msgnum });
1062 my $error = $msg_template->send(
1063 'cust_main' => $cust_main,
1067 $error = send_email(
1068 'from' => $conf->invoice_from_full( $self->cust_main->agentnum ),
1069 'to' => \@invoicing_list,
1070 'subject' => ( $conf->config('cancelsubject') || 'Cancellation Notice' ),
1071 'body' => [ map "$_\n", $conf->config('cancelmessage') ],
1072 'custnum' => $self->custnum,
1073 'msgtype' => '', #admin?
1076 #should this do something on errors?
1079 my %pkg_class = map { $_=>1 }
1080 $conf->config('cancel_msgnum-referring_cust-pkg_class');
1081 my $ref_msgnum = $conf->config('cancel_msgnum-referring_cust');
1082 if ( !$options{'quiet'}
1083 && $cust_main->referral_custnum
1084 && $pkg_class{ $self->classnum }
1088 my $msg_template = qsearchs('msg_template', { msgnum => $ref_msgnum });
1089 my $error = $msg_template->send(
1090 'cust_main' => $cust_main->referring_cust_main,
1093 #should this do something on errors?
1100 =item cancel_if_expired [ NOW_TIMESTAMP ]
1102 Cancels this package if its expire date has been reached.
1106 # XXX should look for an expire reason
1107 # but seems to be unused; this is now handled more holistically in
1108 # cust_main::Billing
1110 sub cancel_if_expired {
1112 my $time = shift || time;
1113 return '' unless $self->expire && $self->expire <= $time;
1114 my $error = $self->cancel;
1116 return "Error cancelling expired pkg ". $self->pkgnum. " for custnum ".
1117 $self->custnum. ": $error";
1122 =item uncancel_svc_x
1124 For cancelled cust_pkg, returns a list of new, uninserted FS::svc_X records
1125 for services that would be inserted by L</uncancel>. Returned objects also
1126 include the field _h_svc_x, which contains the service history object.
1128 Set pkgnum before inserting.
1130 Accepts the following options:
1132 only_svcnum - arrayref of svcnum, only returns objects for these svcnum
1133 (and only if they would otherwise be returned by this)
1137 sub uncancel_svc_x {
1138 my ($self, %opt) = @_;
1140 die 'uncancel_svc_x called on a non-cancelled cust_pkg' unless $self->get('cancel');
1142 #find historical services within this timeframe before the package cancel
1143 # (incompatible with "time" option to cust_pkg->cancel?)
1144 my $fuzz = 2 * 60; #2 minutes? too much? (might catch separate unprovision)
1145 # too little? (unprovisioing export delay?)
1146 my($end, $start) = ( $self->get('cancel'), $self->get('cancel') - $fuzz );
1147 my @h_cust_svc = $self->h_cust_svc( $end, $start );
1150 foreach my $h_cust_svc (@h_cust_svc) {
1151 next if $opt{'only_svcnum'} && !(grep { $_ == $h_cust_svc->svcnum } @{$opt{'only_svcnum'}});
1152 # filter out services that still exist on this package (ie preserved svcs)
1153 # but keep services that have since been provisioned on another package (for informational purposes)
1154 next if qsearchs('cust_svc',{ 'svcnum' => $h_cust_svc->svcnum, 'pkgnum' => $self->pkgnum });
1155 my $h_svc_x = $h_cust_svc->h_svc_x( $end, $start );
1156 next unless $h_svc_x; # this probably doesn't happen, but just in case
1157 (my $table = $h_svc_x->table) =~ s/^h_//;
1158 require "FS/$table.pm";
1159 my $class = "FS::$table";
1160 my $svc_x = $class->new( {
1161 'svcpart' => $h_cust_svc->svcpart,
1162 '_h_svc_x' => $h_svc_x,
1163 map { $_ => $h_svc_x->get($_) } fields($table)
1167 if ( $h_svc_x->isa('FS::h_svc_Radius_Mixin') ) {
1168 $svc_x->usergroup( [ $h_svc_x->h_usergroup($end, $start) ] );
1171 #these are pretty rare, but should handle them
1172 # - dsl_device (mac addresses)
1173 # - phone_device (mac addresses)
1174 # - dsl_note (ikano notes)
1175 # - domain_record (i.e. restore DNS information w/domains)
1176 # - inventory_item(?) (inventory w/un-cancelling service?)
1177 # - nas (svc_broaband nas stuff)
1178 #this stuff is unused in the wild afaik
1179 # - mailinglistmember
1181 # - svc_domain.parent_svcnum?
1182 # - acct_snarf (ancient mail fetching config)
1183 # - cgp_rule (communigate)
1184 # - cust_svc_option (used by our Tron stuff)
1185 # - acct_rt_transaction (used by our time worked stuff)
1187 push @svc_x, $svc_x;
1192 =item uncancel_svc_summary
1194 Returns an array of hashrefs, one for each service that could
1195 potentially be reprovisioned by L</uncancel>, with the following keys:
1203 label - from history table if not currently calculable, undefined if it can't be loaded
1205 reprovisionable - 1 if test reprovision succeeded, otherwise 0
1207 num_cust_svc - number of svcs for this svcpart, only if summarizing (see below)
1209 Cannot be run from within a transaction. Performs inserts
1210 to test the results, and then rolls back the transaction.
1211 Does not perform exports, so does not catch if export would fail.
1213 Also accepts the following options:
1215 no_test_reprovision - skip the test inserts (reprovisionable field will not exist)
1217 summarize_size - if true, returns a single summary record for svcparts with at
1218 least this many svcs, will have key num_cust_svc but not uncancel_svcnum, label or reprovisionable
1222 sub uncancel_svc_summary {
1223 my ($self, %opt) = @_;
1225 die 'uncancel_svc_summary called on a non-cancelled cust_pkg' unless $self->get('cancel');
1226 die 'uncancel_svc_summary called from within a transaction' unless $FS::UID::AutoCommit;
1228 local $FS::svc_Common::noexport_hack = 1; # very important not to run exports!!!
1229 local $FS::UID::AutoCommit = 0;
1231 # sort by svcpart, to check summarize_size
1232 my $uncancel_svc_x = {};
1233 foreach my $svc_x (sort { $a->{'svcpart'} <=> $b->{'svcpart'} } $self->uncancel_svc_x) {
1234 $uncancel_svc_x->{$svc_x->svcpart} = [] unless $uncancel_svc_x->{$svc_x->svcpart};
1235 push @{$uncancel_svc_x->{$svc_x->svcpart}}, $svc_x;
1239 foreach my $svcpart (keys %$uncancel_svc_x) {
1240 my @svcpart_svc_x = @{$uncancel_svc_x->{$svcpart}};
1241 if ($opt{'summarize_size'} && (@svcpart_svc_x >= $opt{'summarize_size'})) {
1242 my $svc_x = $svcpart_svc_x[0]; #grab first one for access to $part_svc
1243 my $part_svc = $svc_x->part_svc;
1245 'svcpart' => $part_svc->svcpart,
1246 'svc' => $part_svc->svc,
1247 'num_cust_svc' => scalar(@svcpart_svc_x),
1250 foreach my $svc_x (@svcpart_svc_x) {
1251 my $part_svc = $svc_x->part_svc;
1253 'svcpart' => $part_svc->svcpart,
1254 'svc' => $part_svc->svc,
1255 'uncancel_svcnum' => $svc_x->get('_h_svc_x')->svcnum,
1257 $svc_x->pkgnum($self->pkgnum); # provisioning services on a canceled package, will be rolled back
1259 unless ($opt{'no_test_reprovision'}) {
1260 # avoid possibly fatal errors from missing linked records
1261 eval { $insert_error = $svc_x->insert };
1262 $insert_error ||= $@;
1264 if ($opt{'no_test_reprovision'} or $insert_error) {
1265 # avoid possibly fatal errors from missing linked records
1266 eval { $out->{'label'} = $svc_x->label };
1267 eval { $out->{'label'} = $svc_x->get('_h_svc_x')->label } unless defined($out->{'label'});
1268 $out->{'reprovisionable'} = 0 unless $opt{'no_test_reprovision'};
1270 $out->{'label'} = $svc_x->label;
1271 $out->{'reprovisionable'} = 1;
1284 "Un-cancels" this package: Orders a new package with the same custnum, pkgpart,
1285 locationnum, (other fields?). Attempts to re-provision cancelled services
1286 using history information (errors at this stage are not fatal).
1288 cust_pkg: pass a scalar reference, will be filled in with the new cust_pkg object
1290 svc_fatal: service provisioning errors are fatal
1292 svc_errors: pass an array reference, will be filled in with any provisioning errors
1294 only_svcnum: arrayref, only attempt to re-provision these cancelled services
1296 main_pkgnum: link the package as a supplemental package of this one. For
1302 my( $self, %options ) = @_;
1304 #in case you try do do $uncancel-date = $cust_pkg->uncacel
1305 return '' unless $self->get('cancel');
1307 if ( $self->main_pkgnum and !$options{'main_pkgnum'} ) {
1308 return $self->main_pkg->uncancel(%options);
1315 local $SIG{HUP} = 'IGNORE';
1316 local $SIG{INT} = 'IGNORE';
1317 local $SIG{QUIT} = 'IGNORE';
1318 local $SIG{TERM} = 'IGNORE';
1319 local $SIG{TSTP} = 'IGNORE';
1320 local $SIG{PIPE} = 'IGNORE';
1322 my $oldAutoCommit = $FS::UID::AutoCommit;
1323 local $FS::UID::AutoCommit = 0;
1327 # insert the new package
1330 my $cust_pkg = new FS::cust_pkg {
1331 last_bill => ( $options{'last_bill'} || $self->get('last_bill') ),
1332 bill => ( $options{'bill'} || $self->get('bill') ),
1334 uncancel_pkgnum => $self->pkgnum,
1335 main_pkgnum => ($options{'main_pkgnum'} || ''),
1336 map { $_ => $self->get($_) } qw(
1337 custnum pkgpart locationnum
1339 susp adjourn resume expire start_date contract_end dundate
1340 change_date change_pkgpart change_locationnum
1341 manual_flag no_auto separate_bill quantity agent_pkgid
1342 recur_show_zero setup_show_zero
1346 my $error = $cust_pkg->insert(
1347 'change' => 1, #supresses any referral credit to a referring customer
1348 'allow_pkgpart' => 1, # allow this even if the package def is disabled
1351 $dbh->rollback if $oldAutoCommit;
1360 foreach my $svc_x ($self->uncancel_svc_x('only_svcnum' => $options{'only_svcnum'})) {
1362 $svc_x->pkgnum($cust_pkg->pkgnum);
1363 my $svc_error = $svc_x->insert;
1366 if ( $options{svc_fatal} ) {
1367 $dbh->rollback if $oldAutoCommit;
1370 # if we've failed to insert the svc_x object, svc_Common->insert
1371 # will have removed the cust_svc already. if not, then both records
1372 # were inserted but we failed for some other reason (export, most
1373 # likely). in that case, report the error and delete the records.
1374 push @svc_errors, $svc_error;
1375 my $cust_svc = qsearchs('cust_svc', { 'svcnum' => $svc_x->svcnum });
1377 # except if export_insert failed, export_delete probably won't be
1379 local $FS::svc_Common::noexport_hack = 1;
1380 my $cleanup_error = $svc_x->delete; # also deletes cust_svc
1381 if ( $cleanup_error ) { # and if THAT fails, then run away
1382 $dbh->rollback if $oldAutoCommit;
1383 return $cleanup_error;
1388 } #foreach uncancel_svc_x
1391 # also move over any services that didn't unprovision at cancellation
1394 foreach my $cust_svc ( qsearch('cust_svc', { pkgnum => $self->pkgnum } ) ) {
1395 $cust_svc->pkgnum( $cust_pkg->pkgnum );
1396 my $error = $cust_svc->replace;
1398 $dbh->rollback if $oldAutoCommit;
1404 # Uncancel any supplemental packages, and make them supplemental to the
1408 foreach my $supp_pkg ( $self->supplemental_pkgs ) {
1410 $error = $supp_pkg->uncancel(%options, 'main_pkgnum' => $cust_pkg->pkgnum);
1412 $dbh->rollback if $oldAutoCommit;
1413 return "canceling supplemental pkg#".$supp_pkg->pkgnum.": $error";
1421 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1423 ${ $options{cust_pkg} } = $cust_pkg if ref($options{cust_pkg});
1424 @{ $options{svc_errors} } = @svc_errors if ref($options{svc_errors});
1431 Cancels any pending expiration (sets the expire field to null)
1432 for this package and any supplemental packages.
1434 If there is an error, returns the error, otherwise returns false.
1442 local $SIG{HUP} = 'IGNORE';
1443 local $SIG{INT} = 'IGNORE';
1444 local $SIG{QUIT} = 'IGNORE';
1445 local $SIG{TERM} = 'IGNORE';
1446 local $SIG{TSTP} = 'IGNORE';
1447 local $SIG{PIPE} = 'IGNORE';
1449 my $oldAutoCommit = $FS::UID::AutoCommit;
1450 local $FS::UID::AutoCommit = 0;
1453 my $old = $self->select_for_update;
1455 my $pkgnum = $old->pkgnum;
1456 if ( $old->get('cancel') || $self->get('cancel') ) {
1457 dbh->rollback if $oldAutoCommit;
1458 return "Can't unexpire cancelled package $pkgnum";
1459 # or at least it's pointless
1462 unless ( $old->get('expire') && $self->get('expire') ) {
1463 dbh->rollback if $oldAutoCommit;
1464 return ""; # no error
1467 my %hash = $self->hash;
1468 $hash{'expire'} = '';
1469 my $new = new FS::cust_pkg ( \%hash );
1470 $error = $new->replace( $self, options => { $self->options } );
1472 $dbh->rollback if $oldAutoCommit;
1476 foreach my $supp_pkg ( $self->supplemental_pkgs ) {
1477 $error = $supp_pkg->unexpire;
1479 $dbh->rollback if $oldAutoCommit;
1480 return "unexpiring supplemental pkg#".$supp_pkg->pkgnum.": $error";
1484 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1490 =item suspend [ OPTION => VALUE ... ]
1492 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
1493 package, then suspends the package itself (sets the susp field to now).
1495 Available options are:
1499 =item reason - can be set to a cancellation reason (see L<FS:reason>),
1500 either a reasonnum of an existing reason, or passing a hashref will create
1501 a new reason. The hashref should have the following keys:
1502 - typenum - Reason type (see L<FS::reason_type>
1503 - reason - Text of the new reason.
1505 =item date - can be set to a unix style timestamp to specify when to
1508 =item time - can be set to override the current time, for calculation
1509 of final invoices or unused-time credits
1511 =item resume_date - can be set to a time when the package should be
1512 unsuspended. This may be more convenient than calling C<unsuspend()>
1515 =item from_main - allows a supplemental package to be suspended, rather
1516 than redirecting the method call to its main package. For internal use.
1518 =item from_cancel - used when suspending from the cancel method, forces
1519 this to skip everything besides basic suspension. For internal use.
1523 If there is an error, returns the error, otherwise returns false.
1528 my( $self, %options ) = @_;
1531 # pass all suspend/cancel actions to the main package
1532 if ( $self->main_pkgnum and !$options{'from_main'} ) {
1533 return $self->main_pkg->suspend(%options);
1536 local $SIG{HUP} = 'IGNORE';
1537 local $SIG{INT} = 'IGNORE';
1538 local $SIG{QUIT} = 'IGNORE';
1539 local $SIG{TERM} = 'IGNORE';
1540 local $SIG{TSTP} = 'IGNORE';
1541 local $SIG{PIPE} = 'IGNORE';
1543 my $oldAutoCommit = $FS::UID::AutoCommit;
1544 local $FS::UID::AutoCommit = 0;
1547 my $old = $self->select_for_update;
1549 my $pkgnum = $old->pkgnum;
1550 if ( $old->get('cancel') || $self->get('cancel') ) {
1551 dbh->rollback if $oldAutoCommit;
1552 return "Can't suspend cancelled package $pkgnum";
1555 if ( $old->get('susp') || $self->get('susp') ) {
1556 dbh->rollback if $oldAutoCommit;
1557 return ""; # no error # complain on adjourn?
1560 my $suspend_time = $options{'time'} || time;
1561 my $date = $options{date} if $options{date}; # adjourn/suspend later
1562 $date = '' if ($date && $date <= $suspend_time); # complain instead?
1564 if ( $date && $old->get('expire') && $old->get('expire') < $date ) {
1565 dbh->rollback if $oldAutoCommit;
1566 return "Package $pkgnum expires before it would be suspended.";
1569 # some false laziness with sub cancel
1570 if ( !$options{nobill} && !$date && !$options{'from_cancel'} &&
1571 $self->part_pkg->option('bill_suspend_as_cancel',1) ) {
1572 # kind of a kludge--'bill_suspend_as_cancel' to avoid having to
1573 # make the entire cust_main->bill path recognize 'suspend' and
1574 # 'cancel' separately.
1575 warn "Billing $pkgnum on suspension (at $suspend_time)\n" if $DEBUG;
1576 my $copy = $self->new({$self->hash});
1578 $copy->cust_main->bill( 'pkg_list' => [ $copy ],
1580 'time' => $suspend_time );
1581 warn "Error billing during suspend, custnum ".
1582 #$self->cust_main->custnum. ": $error"
1587 my $cust_pkg_reason;
1588 if ( $options{'reason'} ) {
1589 $error = $self->insert_reason( 'reason' => $options{'reason'},
1590 'action' => $date ? 'adjourn' : 'suspend',
1591 'date' => $date ? $date : $suspend_time,
1592 'reason_otaker' => $options{'reason_otaker'},
1595 dbh->rollback if $oldAutoCommit;
1596 return "Error inserting cust_pkg_reason: $error";
1598 $cust_pkg_reason = qsearchs('cust_pkg_reason', {
1599 'date' => $date ? $date : $suspend_time,
1600 'action' => $date ? 'A' : 'S',
1601 'pkgnum' => $self->pkgnum,
1605 # if a reasonnum was passed, get the actual reason object so we can check
1607 # (passing a reason hashref is still allowed, but it can't be used with
1608 # the fancy behavioral options.)
1611 if ($options{'reason'} =~ /^\d+$/) {
1612 $reason = FS::reason->by_key($options{'reason'});
1615 my %hash = $self->hash;
1617 $hash{'adjourn'} = $date;
1619 $hash{'susp'} = $suspend_time;
1622 my $resume_date = $options{'resume_date'} || 0;
1623 if ( $resume_date > ($date || $suspend_time) ) {
1624 $hash{'resume'} = $resume_date;
1627 $options{options} ||= {};
1629 my $new = new FS::cust_pkg ( \%hash );
1630 $error = $new->replace( $self, options => { $self->options,
1631 %{ $options{options} },
1635 $dbh->rollback if $oldAutoCommit;
1639 unless ( $date ) { # then we are suspending now
1641 unless ($options{'from_cancel'}) {
1642 # credit remaining time if appropriate
1643 # (if required by the package def, or the suspend reason)
1644 my $unused_credit = $self->part_pkg->option('unused_credit_suspend',1)
1645 || ( defined($reason) && $reason->unused_credit );
1647 if ( $unused_credit ) {
1648 warn "crediting unused time on pkg#".$self->pkgnum."\n" if $DEBUG;
1649 my $error = $self->credit_remaining('suspend', $suspend_time);
1651 $dbh->rollback if $oldAutoCommit;
1659 foreach my $cust_svc (
1660 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
1662 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
1664 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
1665 $dbh->rollback if $oldAutoCommit;
1666 return "Illegal svcdb value in part_svc!";
1669 require "FS/$svcdb.pm";
1671 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
1673 $error = $svc->suspend;
1675 $dbh->rollback if $oldAutoCommit;
1678 my( $label, $value ) = $cust_svc->label;
1679 push @labels, "$label: $value";
1683 # suspension fees: if there is a feepart, and it's not an unsuspend fee,
1684 # and this is not a suspend-before-cancel
1685 if ( $cust_pkg_reason ) {
1686 my $reason_obj = $cust_pkg_reason->reason;
1687 if ( $reason_obj->feepart and
1688 ! $reason_obj->fee_on_unsuspend and
1689 ! $options{'from_cancel'} ) {
1691 # register the need to charge a fee, cust_main->bill will do the rest
1692 warn "registering suspend fee: pkgnum ".$self->pkgnum.", feepart ".$reason->feepart."\n"
1694 my $cust_pkg_reason_fee = FS::cust_pkg_reason_fee->new({
1695 'pkgreasonnum' => $cust_pkg_reason->num,
1696 'pkgnum' => $self->pkgnum,
1697 'feepart' => $reason->feepart,
1698 'nextbill' => $reason->fee_hold,
1700 $error ||= $cust_pkg_reason_fee->insert;
1704 my $conf = new FS::Conf;
1705 if ( $conf->config('suspend_email_admin') && !$options{'from_cancel'} ) {
1707 my $error = send_email(
1708 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
1709 #invoice_from ??? well as good as any
1710 'to' => $conf->config('suspend_email_admin'),
1711 'subject' => 'FREESIDE NOTIFICATION: Customer package suspended',
1713 "This is an automatic message from your Freeside installation\n",
1714 "informing you that the following customer package has been suspended:\n",
1716 'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
1717 'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
1718 ( map { "Service : $_\n" } @labels ),
1720 'custnum' => $self->custnum,
1721 'msgtype' => 'admin'
1725 warn "WARNING: can't send suspension admin email (suspending anyway): ".
1733 foreach my $supp_pkg ( $self->supplemental_pkgs ) {
1734 $error = $supp_pkg->suspend(%options, 'from_main' => 1);
1736 $dbh->rollback if $oldAutoCommit;
1737 return "suspending supplemental pkg#".$supp_pkg->pkgnum.": $error";
1741 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1746 =item credit_remaining MODE TIME
1748 Generate a credit for this package for the time remaining in the current
1749 billing period. MODE is either "suspend" or "cancel" (determines the
1750 credit type). TIME is the time of suspension/cancellation. Both arguments
1755 # Implementation note:
1757 # If you pkgpart-change a package that has been billed, and it's set to give
1758 # credit on package change, then this method gets called and then the new
1759 # package will have no last_bill date. Therefore the customer will be credited
1760 # only once (per billing period) even if there are multiple package changes.
1762 # If you location-change a package that has been billed, this method will NOT
1763 # be called and the new package WILL have the last bill date of the old
1766 # If the new package is then canceled within the same billing cycle,
1767 # credit_remaining needs to run calc_remain on the OLD package to determine
1768 # the amount of unused time to credit.
1770 sub credit_remaining {
1771 # Add a credit for remaining service
1772 my ($self, $mode, $time) = @_;
1773 die 'credit_remaining requires suspend or cancel'
1774 unless $mode eq 'suspend' or $mode eq 'cancel';
1775 die 'no suspend/cancel time' unless $time > 0;
1777 my $conf = FS::Conf->new;
1778 my $reason_type = $conf->config($mode.'_credit_type');
1782 my $remain_pkg = $self;
1783 my (@billpkgnums, @amounts, @setuprecurs);
1785 # we may have to walk back past some package changes to get to the
1786 # one that actually has unused time. loop until that happens, or we
1787 # reach the first package in the chain.
1789 my $last_bill = $remain_pkg->get('last_bill') || 0;
1790 my $next_bill = $remain_pkg->get('bill') || 0;
1791 if ( $last_bill > 0 # the package has been billed
1792 and $next_bill > 0 # the package has a next bill date
1793 and $next_bill >= $time # which is in the future
1796 # Find actual charges for the period ending on or after the cancel
1798 my @charges = qsearch('cust_bill_pkg', {
1799 pkgnum => $remain_pkg->pkgnum,
1800 edate => {op => '>=', value => $time},
1801 recur => {op => '>' , value => 0},
1804 foreach my $cust_bill_pkg (@charges) {
1805 # hack to deal with the weird behavior of edate on package
1807 my $edate = $cust_bill_pkg->edate;
1808 if ( $self->recur_temporality eq 'preceding' ) {
1809 $edate = $self->add_freq($cust_bill_pkg->sdate);
1812 # this will also get any package charges that are _entirely_ after
1813 # the cancellation date (can happen with advance billing). in that
1814 # case, use the entire recurring charge:
1815 my $amount = $cust_bill_pkg->recur - $cust_bill_pkg->usage;
1816 my $max_credit = $amount
1817 - $cust_bill_pkg->credited('', '', setuprecur => 'recur') || 0;
1819 # but if the cancellation happens during the interval, prorate it:
1820 # (XXX obey prorate_round_day here?)
1821 if ( $cust_bill_pkg->sdate < $time ) {
1823 ($edate - $time) / ($edate - $cust_bill_pkg->sdate);
1826 # if there are existing credits, don't let the sum of credits exceed
1827 # the recurring charge
1828 $amount = $max_credit if $amount > $max_credit;
1830 $amount = sprintf('%.2f', $amount);
1832 # if no time has been used and/or there are existing line item
1833 # credits, we may end up not needing to credit anything.
1834 if ( $amount > 0 ) {
1836 push @billpkgnums, $cust_bill_pkg->billpkgnum;
1837 push @amounts, $amount;
1838 push @setuprecurs, 'recur';
1840 warn "Crediting for $amount on package ".$remain_pkg->pkgnum."\n"
1849 if ( my $changed_from_pkgnum = $remain_pkg->change_pkgnum ) {
1850 $remain_pkg = FS::cust_pkg->by_key($changed_from_pkgnum);
1852 # the package has really never been billed
1857 # keep traditional behavior here.
1859 my $reason = FS::reason->new_or_existing(
1860 reason => 'Credit for unused time on '. $self->part_pkg->pkg,
1861 type => $reason_type,
1865 return "failed to set credit reason: $@";
1868 my $error = FS::cust_credit->credit_lineitems(
1869 'billpkgnums' => \@billpkgnums,
1870 'setuprecurs' => \@setuprecurs,
1871 'amounts' => \@amounts,
1872 'custnum' => $self->custnum,
1874 'reasonnum' => $reason->reasonnum,
1881 =item unsuspend [ OPTION => VALUE ... ]
1883 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
1884 package, then unsuspends the package itself (clears the susp field and the
1885 adjourn field if it is in the past). If the suspend reason includes an
1886 unsuspension package, that package will be ordered.
1888 Available options are:
1894 Can be set to a date to unsuspend the package in the future (the 'resume'
1897 =item adjust_next_bill
1899 Can be set true to adjust the next bill date forward by
1900 the amount of time the account was inactive. This was set true by default
1901 in the past (from 1.4.2 and 1.5.0pre6 through 1.7.0), but now needs to be
1902 explicitly requested with this option or in the price plan.
1906 If there is an error, returns the error, otherwise returns false.
1911 my( $self, %opt ) = @_;
1914 # pass all suspend/cancel actions to the main package
1915 if ( $self->main_pkgnum and !$opt{'from_main'} ) {
1916 return $self->main_pkg->unsuspend(%opt);
1919 local $SIG{HUP} = 'IGNORE';
1920 local $SIG{INT} = 'IGNORE';
1921 local $SIG{QUIT} = 'IGNORE';
1922 local $SIG{TERM} = 'IGNORE';
1923 local $SIG{TSTP} = 'IGNORE';
1924 local $SIG{PIPE} = 'IGNORE';
1926 my $oldAutoCommit = $FS::UID::AutoCommit;
1927 local $FS::UID::AutoCommit = 0;
1930 my $old = $self->select_for_update;
1932 my $pkgnum = $old->pkgnum;
1933 if ( $old->get('cancel') || $self->get('cancel') ) {
1934 $dbh->rollback if $oldAutoCommit;
1935 return "Can't unsuspend cancelled package $pkgnum";
1938 unless ( $old->get('susp') && $self->get('susp') ) {
1939 $dbh->rollback if $oldAutoCommit;
1940 return ""; # no error # complain instead?
1943 # handle the case of setting a future unsuspend (resume) date
1944 # and do not continue to actually unsuspend the package
1945 my $date = $opt{'date'};
1946 if ( $date and $date > time ) { # return an error if $date <= time?
1948 if ( $old->get('expire') && $old->get('expire') < $date ) {
1949 $dbh->rollback if $oldAutoCommit;
1950 return "Package $pkgnum expires before it would be unsuspended.";
1953 my $new = new FS::cust_pkg { $self->hash };
1954 $new->set('resume', $date);
1955 $error = $new->replace($self, options => $self->options);
1958 $dbh->rollback if $oldAutoCommit;
1962 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1968 if (!$self->setup) {
1969 # then this package is being released from on-hold status
1970 $self->set_initial_timers;
1975 foreach my $cust_svc (
1976 qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
1978 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
1980 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
1981 $dbh->rollback if $oldAutoCommit;
1982 return "Illegal svcdb value in part_svc!";
1985 require "FS/$svcdb.pm";
1987 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
1989 $error = $svc->unsuspend;
1991 $dbh->rollback if $oldAutoCommit;
1994 my( $label, $value ) = $cust_svc->label;
1995 push @labels, "$label: $value";
2000 my $cust_pkg_reason = $self->last_cust_pkg_reason('susp');
2001 my $reason = $cust_pkg_reason ? $cust_pkg_reason->reason : '';
2003 my %hash = $self->hash;
2004 my $inactive = time - $hash{'susp'};
2006 my $conf = new FS::Conf;
2008 # increment next bill date if certain conditions are met:
2009 # - it was due to be billed at some point
2010 # - either the global or local config says to do this
2011 my $adjust_bill = 0;
2014 && ( $hash{'bill'} || $hash{'setup'} )
2015 && ( $opt{'adjust_next_bill'}
2016 || $conf->exists('unsuspend-always_adjust_next_bill_date')
2017 || $self->part_pkg->option('unsuspend_adjust_bill', 1)
2024 # - the package billed during suspension
2025 # - or it was ordered on hold
2026 # - or the customer was credited for the unused time
2028 if ( $self->option('suspend_bill',1)
2029 or ( $self->part_pkg->option('suspend_bill',1)
2030 and ! $self->option('no_suspend_bill',1)
2032 or $hash{'order_date'} == $hash{'susp'}
2037 if ( $adjust_bill ) {
2038 if ( $self->part_pkg->option('unused_credit_suspend')
2039 or ( $reason and $reason->unused_credit ) ) {
2040 # then the customer was credited for the unused time before suspending,
2041 # so their next bill should be immediate.
2042 $hash{'bill'} = time;
2044 # add the length of time suspended to the bill date
2045 $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive;
2050 $hash{'adjourn'} = '' if $hash{'adjourn'} and $hash{'adjourn'} < time;
2051 $hash{'resume'} = '' if !$hash{'adjourn'};
2052 my $new = new FS::cust_pkg ( \%hash );
2053 $error = $new->replace( $self, options => { $self->options } );
2055 $dbh->rollback if $oldAutoCommit;
2062 if ( $reason->unsuspend_pkgpart ) {
2063 #warn "Suspend reason '".$reason->reason."' uses deprecated unsuspend_pkgpart feature.\n"; # in 4.x
2064 my $part_pkg = FS::part_pkg->by_key($reason->unsuspend_pkgpart)
2065 or $error = "Unsuspend package definition ".$reason->unsuspend_pkgpart.
2067 my $start_date = $self->cust_main->next_bill_date
2068 if $reason->unsuspend_hold;
2071 $unsusp_pkg = FS::cust_pkg->new({
2072 'custnum' => $self->custnum,
2073 'pkgpart' => $reason->unsuspend_pkgpart,
2074 'start_date' => $start_date,
2075 'locationnum' => $self->locationnum,
2076 # discount? probably not...
2079 $error ||= $self->cust_main->order_pkg( 'cust_pkg' => $unsusp_pkg );
2082 # new way, using fees
2083 if ( $reason->feepart and $reason->fee_on_unsuspend ) {
2084 # register the need to charge a fee, cust_main->bill will do the rest
2085 warn "registering unsuspend fee: pkgnum ".$self->pkgnum.", feepart ".$reason->feepart."\n"
2087 my $cust_pkg_reason_fee = FS::cust_pkg_reason_fee->new({
2088 'pkgreasonnum' => $cust_pkg_reason->num,
2089 'pkgnum' => $self->pkgnum,
2090 'feepart' => $reason->feepart,
2091 'nextbill' => $reason->fee_hold,
2093 $error ||= $cust_pkg_reason_fee->insert;
2097 $dbh->rollback if $oldAutoCommit;
2102 if ( $conf->config('unsuspend_email_admin') ) {
2104 my $error = send_email(
2105 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
2106 #invoice_from ??? well as good as any
2107 'to' => $conf->config('unsuspend_email_admin'),
2108 'subject' => 'FREESIDE NOTIFICATION: Customer package unsuspended', 'body' => [
2109 "This is an automatic message from your Freeside installation\n",
2110 "informing you that the following customer package has been unsuspended:\n",
2112 'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
2113 'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
2114 ( map { "Service : $_\n" } @labels ),
2116 "An unsuspension fee was charged: ".
2117 $unsusp_pkg->part_pkg->pkg_comment."\n"
2121 'custnum' => $self->custnum,
2122 'msgtype' => 'admin',
2126 warn "WARNING: can't send unsuspension admin email (unsuspending anyway): ".
2132 foreach my $supp_pkg ( $self->supplemental_pkgs ) {
2133 $error = $supp_pkg->unsuspend(%opt, 'from_main' => 1);
2135 $dbh->rollback if $oldAutoCommit;
2136 return "unsuspending supplemental pkg#".$supp_pkg->pkgnum.": $error";
2140 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2147 Cancels any pending suspension (sets the adjourn field to null)
2148 for this package and any supplemental packages.
2150 If there is an error, returns the error, otherwise returns false.
2158 local $SIG{HUP} = 'IGNORE';
2159 local $SIG{INT} = 'IGNORE';
2160 local $SIG{QUIT} = 'IGNORE';
2161 local $SIG{TERM} = 'IGNORE';
2162 local $SIG{TSTP} = 'IGNORE';
2163 local $SIG{PIPE} = 'IGNORE';
2165 my $oldAutoCommit = $FS::UID::AutoCommit;
2166 local $FS::UID::AutoCommit = 0;
2169 my $old = $self->select_for_update;
2171 my $pkgnum = $old->pkgnum;
2172 if ( $old->get('cancel') || $self->get('cancel') ) {
2173 dbh->rollback if $oldAutoCommit;
2174 return "Can't unadjourn cancelled package $pkgnum";
2175 # or at least it's pointless
2178 if ( $old->get('susp') || $self->get('susp') ) {
2179 dbh->rollback if $oldAutoCommit;
2180 return "Can't unadjourn suspended package $pkgnum";
2181 # perhaps this is arbitrary
2184 unless ( $old->get('adjourn') && $self->get('adjourn') ) {
2185 dbh->rollback if $oldAutoCommit;
2186 return ""; # no error
2189 my %hash = $self->hash;
2190 $hash{'adjourn'} = '';
2191 $hash{'resume'} = '';
2192 my $new = new FS::cust_pkg ( \%hash );
2193 $error = $new->replace( $self, options => { $self->options } );
2195 $dbh->rollback if $oldAutoCommit;
2199 foreach my $supp_pkg ( $self->supplemental_pkgs ) {
2200 $error = $supp_pkg->unadjourn;
2202 $dbh->rollback if $oldAutoCommit;
2203 return "unadjourning supplemental pkg#".$supp_pkg->pkgnum.": $error";
2207 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2214 =item change HASHREF | OPTION => VALUE ...
2216 Changes this package: cancels it and creates a new one, with a different
2217 pkgpart or locationnum or both. All services are transferred to the new
2218 package (no change will be made if this is not possible).
2220 Options may be passed as a list of key/value pairs or as a hash reference.
2227 New locationnum, to change the location for this package.
2231 New FS::cust_location object, to create a new location and assign it
2236 New FS::cust_main object, to create a new customer and assign the new package
2241 New pkgpart (see L<FS::part_pkg>).
2245 New refnum (see L<FS::part_referral>).
2249 New quantity; if unspecified, the new package will have the same quantity
2254 "New" (existing) FS::cust_pkg object. The package's services and other
2255 attributes will be transferred to this package.
2259 Set to true to transfer billing dates (start_date, setup, last_bill, bill,
2260 susp, adjourn, cancel, expire, and contract_end) to the new package.
2262 =item unprotect_svcs
2264 Normally, change() will rollback and return an error if some services
2265 can't be transferred (also see the I<cust_pkg-change_svcpart> config option).
2266 If unprotect_svcs is true, this method will transfer as many services as
2267 it can and then unconditionally cancel the old package.
2271 If specified, sets this value for the contract_end date on the new package
2272 (without regard for keep_dates or the usual date-preservation behavior.)
2273 Will throw an error if defined but false; the UI doesn't allow editing
2274 this unless it already exists, making removal impossible to undo.
2278 At least one of locationnum, cust_location, pkgpart, refnum, cust_main, or
2279 cust_pkg must be specified (otherwise, what's the point?)
2281 Returns either the new FS::cust_pkg object or a scalar error.
2285 my $err_or_new_cust_pkg = $old_cust_pkg->change
2289 #used by change and change_later
2290 #didn't put with documented check methods because it depends on change-specific opts
2291 #and it also possibly edits the value of opts
2295 if ( defined($opt->{'contract_end'}) ) {
2296 my $current_contract_end = $self->get('contract_end');
2297 unless ($opt->{'contract_end'}) {
2298 if ($current_contract_end) {
2299 return "Cannot remove contract end date when changing packages";
2301 #shouldn't even pass this option if there's not a current value
2302 #but can be handled gracefully if the option is empty
2303 warn "Contract end date passed unexpectedly";
2304 delete $opt->{'contract_end'};
2308 unless ($current_contract_end) {
2309 #option shouldn't be passed, throw error if it's non-empty
2310 return "Cannot add contract end date when changing packages " . $self->pkgnum;
2316 #some false laziness w/order
2319 my $opt = ref($_[0]) ? shift : { @_ };
2321 my $conf = new FS::Conf;
2323 # handle contract_end on cust_pkg same as passed option
2324 if ( $opt->{'cust_pkg'} ) {
2325 $opt->{'contract_end'} = $opt->{'cust_pkg'}->contract_end;
2326 delete $opt->{'contract_end'} unless $opt->{'contract_end'};
2329 # check contract_end, prevent adding/removing
2330 my $error = $self->_check_change($opt);
2331 return $error if $error;
2333 # Transactionize this whole mess
2334 local $SIG{HUP} = 'IGNORE';
2335 local $SIG{INT} = 'IGNORE';
2336 local $SIG{QUIT} = 'IGNORE';
2337 local $SIG{TERM} = 'IGNORE';
2338 local $SIG{TSTP} = 'IGNORE';
2339 local $SIG{PIPE} = 'IGNORE';
2341 my $oldAutoCommit = $FS::UID::AutoCommit;
2342 local $FS::UID::AutoCommit = 0;
2345 if ( $opt->{'cust_location'} ) {
2346 $error = $opt->{'cust_location'}->find_or_insert;
2348 $dbh->rollback if $oldAutoCommit;
2349 return "creating location record: $error";
2351 $opt->{'locationnum'} = $opt->{'cust_location'}->locationnum;
2354 # figure out if we're changing pkgpart
2355 if ( $opt->{'cust_pkg'} ) {
2356 $opt->{'pkgpart'} = $opt->{'cust_pkg'}->pkgpart;
2359 # whether to override pkgpart checking on the new package
2360 my $same_pkgpart = 1;
2361 if ( $opt->{'pkgpart'} and ( $opt->{'pkgpart'} != $self->pkgpart ) ) {
2365 # Before going any further here: if the package is still in the pre-setup
2366 # state, it's safe to modify it in place. No need to charge/credit for
2367 # partial period, transfer usage pools, copy invoice details, or change any
2368 # dates. We DO need to "transfer" services (from the package to itself) to
2369 # check their validity on the new pkgpart.
2370 if ( ! $self->setup and ! $opt->{cust_pkg} and ! $opt->{cust_main} ) {
2371 foreach ( qw( locationnum pkgpart quantity refnum salesnum ) ) {
2372 if ( length($opt->{$_}) ) {
2373 $self->set($_, $opt->{$_});
2376 # almost. if the new pkgpart specifies start/adjourn/expire timers,
2378 if ( !$same_pkgpart ) {
2379 $self->set_initial_timers;
2381 # but if contract_end was explicitly specified, that overrides all else
2382 $self->set('contract_end', $opt->{'contract_end'})
2383 if $opt->{'contract_end'};
2385 $error = $self->replace;
2387 $dbh->rollback if $oldAutoCommit;
2388 return "modifying package: $error";
2391 # check/convert services (only on pkgpart change, to avoid surprises
2392 # when editing locations)
2393 # (maybe do this if changing quantity?)
2394 if ( !$same_pkgpart ) {
2396 $error = $self->transfer($self);
2398 if ( $error and $error == 0 ) {
2399 $error = "transferring $error";
2400 } elsif ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
2401 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
2402 $error = $self->transfer($self, 'change_svcpart'=>1 );
2403 if ($error and $error == 0) {
2404 $error = "converting $error";
2409 $error = "unable to transfer all services";
2413 $dbh->rollback if $oldAutoCommit;
2417 } # done transferring services
2419 $dbh->commit if $oldAutoCommit;
2428 $hash{'setup'} = $time if $self->get('setup');
2430 $hash{'change_date'} = $time;
2431 $hash{"change_$_"} = $self->$_()
2432 foreach qw( pkgnum pkgpart locationnum );
2434 my $unused_credit = 0;
2435 my $keep_dates = $opt->{'keep_dates'};
2437 # Special case. If the pkgpart is changing, and the customer is going to be
2438 # credited for remaining time, don't keep setup, bill, or last_bill dates,
2439 # and DO pass the flag to cancel() to credit the customer. If the old
2440 # package had a setup date, set the new package's setup to the package
2441 # change date so that it has the same status as before.
2442 if ( $opt->{'pkgpart'}
2443 and $opt->{'pkgpart'} != $self->pkgpart
2444 and $self->part_pkg->option('unused_credit_change', 1) ) {
2447 $hash{'last_bill'} = '';
2451 if ( $keep_dates ) {
2452 foreach my $date ( qw(setup bill last_bill) ) {
2453 $hash{$date} = $self->getfield($date);
2456 # always keep the following dates
2457 foreach my $date (qw(order_date susp adjourn cancel expire resume
2458 start_date contract_end)) {
2459 $hash{$date} = $self->getfield($date);
2461 # but if contract_end was explicitly specified, that overrides all else
2462 $hash{'contract_end'} = $opt->{'contract_end'}
2463 if $opt->{'contract_end'};
2465 # allow $opt->{'locationnum'} = '' to specifically set it to null
2466 # (i.e. customer default location)
2467 $opt->{'locationnum'} = $self->locationnum if !exists($opt->{'locationnum'});
2469 # usually this doesn't matter. the two cases where it does are:
2470 # 1. unused_credit_change + pkgpart change + setup fee on the new package
2472 # 2. (more importantly) changing a package before it's billed
2473 $hash{'waive_setup'} = $self->waive_setup;
2475 # if this package is scheduled for a future package change, preserve that
2476 $hash{'change_to_pkgnum'} = $self->change_to_pkgnum;
2478 my $custnum = $self->custnum;
2479 if ( $opt->{cust_main} ) {
2480 my $cust_main = $opt->{cust_main};
2481 unless ( $cust_main->custnum ) {
2482 my $error = $cust_main->insert( @{ $opt->{cust_main_insert_args}||[] } );
2484 $dbh->rollback if $oldAutoCommit;
2485 return "inserting customer record: $error";
2488 $custnum = $cust_main->custnum;
2491 $hash{'contactnum'} = $opt->{'contactnum'} if $opt->{'contactnum'};
2494 if ( $opt->{'cust_pkg'} ) {
2495 # The target package already exists; update it to show that it was
2496 # changed from this package.
2497 $cust_pkg = $opt->{'cust_pkg'};
2499 # follow all the above rules for date changes, etc.
2500 foreach (keys %hash) {
2501 $cust_pkg->set($_, $hash{$_});
2503 # except those that implement the future package change behavior
2504 foreach (qw(change_to_pkgnum start_date expire)) {
2505 $cust_pkg->set($_, '');
2508 $error = $cust_pkg->replace;
2511 # Create the new package.
2512 $cust_pkg = new FS::cust_pkg {
2513 custnum => $custnum,
2514 locationnum => $opt->{'locationnum'},
2515 ( map { $_ => ( $opt->{$_} || $self->$_() ) }
2516 qw( pkgpart quantity refnum salesnum )
2520 $error = $cust_pkg->insert( 'change' => 1,
2521 'allow_pkgpart' => $same_pkgpart );
2524 $dbh->rollback if $oldAutoCommit;
2525 return "inserting new package: $error";
2528 # Transfer services and cancel old package.
2529 # Enforce service limits only if this is a pkgpart change.
2530 local $FS::cust_svc::ignore_quantity;
2531 $FS::cust_svc::ignore_quantity = 1 if $same_pkgpart;
2532 $error = $self->transfer($cust_pkg);
2533 if ($error and $error == 0) {
2534 # $old_pkg->transfer failed.
2535 $dbh->rollback if $oldAutoCommit;
2536 return "transferring $error";
2539 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
2540 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
2541 $error = $self->transfer($cust_pkg, 'change_svcpart'=>1 );
2542 if ($error and $error == 0) {
2543 # $old_pkg->transfer failed.
2544 $dbh->rollback if $oldAutoCommit;
2545 return "converting $error";
2549 # We set unprotect_svcs when executing a "future package change". It's
2550 # not a user-interactive operation, so returning an error means the
2551 # package change will just fail. Rather than have that happen, we'll
2552 # let leftover services be deleted.
2553 if ($error > 0 and !$opt->{'unprotect_svcs'}) {
2554 # Transfers were successful, but we still had services left on the old
2555 # package. We can't change the package under this circumstances, so abort.
2556 $dbh->rollback if $oldAutoCommit;
2557 return "unable to transfer all services";
2560 #reset usage if changing pkgpart
2561 # AND usage rollover is off (otherwise adds twice, now and at package bill)
2562 if ($self->pkgpart != $cust_pkg->pkgpart) {
2563 my $part_pkg = $cust_pkg->part_pkg;
2564 $error = $part_pkg->reset_usage($cust_pkg, $part_pkg->is_prepaid
2568 if $part_pkg->can('reset_usage') && ! $part_pkg->option('usage_rollover',1);
2571 $dbh->rollback if $oldAutoCommit;
2572 return "setting usage values: $error";
2575 # if NOT changing pkgpart, transfer any usage pools over
2576 foreach my $usage ($self->cust_pkg_usage) {
2577 $usage->set('pkgnum', $cust_pkg->pkgnum);
2578 $error = $usage->replace;
2580 $dbh->rollback if $oldAutoCommit;
2581 return "transferring usage pools: $error";
2586 # transfer discounts, if we're not changing pkgpart
2587 if ( $same_pkgpart ) {
2588 foreach my $old_discount ($self->cust_pkg_discount_active) {
2589 # don't remove the old discount, we may still need to bill that package.
2590 my $new_discount = new FS::cust_pkg_discount {
2591 'pkgnum' => $cust_pkg->pkgnum,
2592 'discountnum' => $old_discount->discountnum,
2593 'months_used' => $old_discount->months_used,
2595 $error = $new_discount->insert;
2597 $dbh->rollback if $oldAutoCommit;
2598 return "transferring discounts: $error";
2603 # transfer (copy) invoice details
2604 foreach my $detail ($self->cust_pkg_detail) {
2605 my $new_detail = FS::cust_pkg_detail->new({ $detail->hash });
2606 $new_detail->set('pkgdetailnum', '');
2607 $new_detail->set('pkgnum', $cust_pkg->pkgnum);
2608 $error = $new_detail->insert;
2610 $dbh->rollback if $oldAutoCommit;
2611 return "transferring package notes: $error";
2615 # transfer scheduled expire/adjourn reasons
2616 foreach my $action ('expire', 'adjourn') {
2617 if ( $cust_pkg->get($action) ) {
2618 my $reason = $self->last_cust_pkg_reason($action);
2620 $reason->set('pkgnum', $cust_pkg->pkgnum);
2621 $error = $reason->replace;
2623 $dbh->rollback if $oldAutoCommit;
2624 return "transferring $action reason: $error";
2632 if ( !$opt->{'cust_pkg'} ) {
2633 # Order any supplemental packages.
2634 my $part_pkg = $cust_pkg->part_pkg;
2635 my @old_supp_pkgs = $self->supplemental_pkgs;
2636 foreach my $link ($part_pkg->supp_part_pkg_link) {
2638 foreach (@old_supp_pkgs) {
2639 if ($_->pkgpart == $link->dst_pkgpart) {
2641 $_->pkgpart(0); # so that it can't match more than once
2645 # false laziness with FS::cust_main::Packages::order_pkg
2646 my $new = FS::cust_pkg->new({
2647 pkgpart => $link->dst_pkgpart,
2648 pkglinknum => $link->pkglinknum,
2649 custnum => $custnum,
2650 main_pkgnum => $cust_pkg->pkgnum,
2651 locationnum => $cust_pkg->locationnum,
2652 start_date => $cust_pkg->start_date,
2653 order_date => $cust_pkg->order_date,
2654 expire => $cust_pkg->expire,
2655 adjourn => $cust_pkg->adjourn,
2656 contract_end => $cust_pkg->contract_end,
2657 refnum => $cust_pkg->refnum,
2658 discountnum => $cust_pkg->discountnum,
2659 waive_setup => $cust_pkg->waive_setup,
2661 if ( $old and $opt->{'keep_dates'} ) {
2662 foreach (qw(setup bill last_bill)) {
2663 $new->set($_, $old->get($_));
2666 $error = $new->insert( allow_pkgpart => $same_pkgpart );
2669 $error ||= $old->transfer($new);
2671 if ( $error and $error > 0 ) {
2672 # no reason why this should ever fail, but still...
2673 $error = "Unable to transfer all services from supplemental package ".
2677 $dbh->rollback if $oldAutoCommit;
2680 push @new_supp_pkgs, $new;
2682 } # if !$opt->{'cust_pkg'}
2683 # because if there is one, then supplemental packages would already
2684 # have been created for it.
2686 #Good to go, cancel old package. Notify 'cancel' of whether to credit
2688 #Don't allow billing the package (preceding period packages and/or
2689 #outstanding usage) if we are keeping dates (i.e. location changing),
2690 #because the new package will be billed for the same date range.
2691 #Supplemental packages are also canceled here.
2693 # during scheduled changes, avoid canceling the package we just
2695 $self->set('change_to_pkgnum' => '');
2697 $error = $self->cancel(
2699 unused_credit => $unused_credit,
2700 nobill => $keep_dates,
2701 change_custnum => ( $self->custnum != $custnum ? $custnum : '' ),
2702 no_delay_cancel => 1,
2705 $dbh->rollback if $oldAutoCommit;
2706 return "canceling old package: $error";
2709 # transfer rt_field_charge, if we're not changing pkgpart
2710 # after billing of old package, before billing of new package
2711 if ( $same_pkgpart ) {
2712 foreach my $rt_field_charge ($self->rt_field_charge) {
2713 $rt_field_charge->set('pkgnum', $cust_pkg->pkgnum);
2714 $error = $rt_field_charge->replace;
2716 $dbh->rollback if $oldAutoCommit;
2717 return "transferring rt_field_charge: $error";
2722 if ( $conf->exists('cust_pkg-change_pkgpart-bill_now') ) {
2724 my $error = $cust_pkg->cust_main->bill(
2725 'pkg_list' => [ $cust_pkg, @new_supp_pkgs ]
2728 $dbh->rollback if $oldAutoCommit;
2729 return "billing new package: $error";
2733 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2739 =item change_later OPTION => VALUE...
2741 Schedule a package change for a later date. This actually orders the new
2742 package immediately, but sets its start date for a future date, and sets
2743 the current package to expire on the same date.
2745 If the package is already scheduled for a change, this can be called with
2746 'start_date' to change the scheduled date, or with pkgpart and/or
2747 locationnum to modify the package change. To cancel the scheduled change
2748 entirely, see C<abort_change>.
2756 The date for the package change. Required, and must be in the future.
2766 The pkgpart, locationnum, quantity and optional contract_end of the new
2767 package, with the same meaning as in C<change>.
2775 my $opt = ref($_[0]) ? shift : { @_ };
2777 # check contract_end, prevent adding/removing
2778 my $error = $self->_check_change($opt);
2779 return $error if $error;
2781 my $oldAutoCommit = $FS::UID::AutoCommit;
2782 local $FS::UID::AutoCommit = 0;
2785 my $cust_main = $self->cust_main;
2787 my $date = delete $opt->{'start_date'} or return 'start_date required';
2789 if ( $date <= time ) {
2790 $dbh->rollback if $oldAutoCommit;
2791 return "start_date $date is in the past";
2794 # If the user entered a new location, set it up now.
2795 if ( $opt->{'cust_location'} ) {
2796 $error = $opt->{'cust_location'}->find_or_insert;
2798 $dbh->rollback if $oldAutoCommit;
2799 return "creating location record: $error";
2801 $opt->{'locationnum'} = $opt->{'cust_location'}->locationnum;
2804 if ( $self->change_to_pkgnum ) {
2805 my $change_to = FS::cust_pkg->by_key($self->change_to_pkgnum);
2806 my $new_pkgpart = $opt->{'pkgpart'}
2807 if $opt->{'pkgpart'} and $opt->{'pkgpart'} != $change_to->pkgpart;
2808 my $new_locationnum = $opt->{'locationnum'}
2809 if $opt->{'locationnum'} and $opt->{'locationnum'} != $change_to->locationnum;
2810 my $new_quantity = $opt->{'quantity'}
2811 if $opt->{'quantity'} and $opt->{'quantity'} != $change_to->quantity;
2812 my $new_contract_end = $opt->{'contract_end'}
2813 if $opt->{'contract_end'} and $opt->{'contract_end'} != $change_to->contract_end;
2814 if ( $new_pkgpart or $new_locationnum or $new_quantity or $new_contract_end ) {
2815 # it hasn't been billed yet, so in principle we could just edit
2816 # it in place (w/o a package change), but that's bad form.
2817 # So change the package according to the new options...
2818 my $err_or_pkg = $change_to->change(%$opt);
2819 if ( ref $err_or_pkg ) {
2820 # Then set that package up for a future start.
2821 $self->set('change_to_pkgnum', $err_or_pkg->pkgnum);
2822 $self->set('expire', $date); # in case it's different
2823 $err_or_pkg->set('start_date', $date);
2824 $err_or_pkg->set('change_date', '');
2825 $err_or_pkg->set('change_pkgnum', '');
2827 $error = $self->replace ||
2828 $err_or_pkg->replace ||
2829 #because change() might've edited existing scheduled change in place
2830 (($err_or_pkg->pkgnum == $change_to->pkgnum) ? '' :
2831 $change_to->cancel('no_delay_cancel' => 1) ||
2832 $change_to->delete);
2834 $error = $err_or_pkg;
2836 } else { # change the start date only.
2837 $self->set('expire', $date);
2838 $change_to->set('start_date', $date);
2839 $error = $self->replace || $change_to->replace;
2842 $dbh->rollback if $oldAutoCommit;
2845 $dbh->commit if $oldAutoCommit;
2848 } # if $self->change_to_pkgnum
2850 my $new_pkgpart = $opt->{'pkgpart'}
2851 if $opt->{'pkgpart'} and $opt->{'pkgpart'} != $self->pkgpart;
2852 my $new_locationnum = $opt->{'locationnum'}
2853 if $opt->{'locationnum'} and $opt->{'locationnum'} != $self->locationnum;
2854 my $new_quantity = $opt->{'quantity'}
2855 if $opt->{'quantity'} and $opt->{'quantity'} != $self->quantity;
2856 my $new_contract_end = $opt->{'contract_end'}
2857 if $opt->{'contract_end'} and $opt->{'contract_end'} != $self->contract_end;
2859 return '' unless $new_pkgpart or $new_locationnum or $new_quantity or $new_contract_end; # wouldn't do anything
2861 # allow $opt->{'locationnum'} = '' to specifically set it to null
2862 # (i.e. customer default location)
2863 $opt->{'locationnum'} = $self->locationnum if !exists($opt->{'locationnum'});
2865 my $new = FS::cust_pkg->new( {
2866 custnum => $self->custnum,
2867 locationnum => $opt->{'locationnum'},
2868 start_date => $date,
2869 map { $_ => ( $opt->{$_} || $self->$_() ) }
2870 qw( pkgpart quantity refnum salesnum contract_end )
2872 $error = $new->insert('change' => 1,
2873 'allow_pkgpart' => ($new_pkgpart ? 0 : 1));
2875 $self->set('change_to_pkgnum', $new->pkgnum);
2876 $self->set('expire', $date);
2877 $error = $self->replace;
2880 $dbh->rollback if $oldAutoCommit;
2882 $dbh->commit if $oldAutoCommit;
2890 Cancels a future package change scheduled by C<change_later>.
2896 my $pkgnum = $self->change_to_pkgnum;
2897 my $change_to = FS::cust_pkg->by_key($pkgnum) if $pkgnum;
2900 $error = $change_to->cancel || $change_to->delete;
2901 return $error if $error;
2903 $self->set('change_to_pkgnum', '');
2904 $self->set('expire', '');
2908 =item set_quantity QUANTITY
2910 Change the package's quantity field. This is one of the few package properties
2911 that can safely be changed without canceling and reordering the package
2912 (because it doesn't affect tax eligibility). Returns an error or an
2919 $self = $self->replace_old; # just to make sure
2920 $self->quantity(shift);
2924 =item set_salesnum SALESNUM
2926 Change the package's salesnum (sales person) field. This is one of the few
2927 package properties that can safely be changed without canceling and reordering
2928 the package (because it doesn't affect tax eligibility). Returns an error or
2935 $self = $self->replace_old; # just to make sure
2936 $self->salesnum(shift);
2938 # XXX this should probably reassign any credit that's already been given
2941 =item modify_charge OPTIONS
2943 Change the properties of a one-time charge. The following properties can
2944 be changed this way:
2945 - pkg: the package description
2946 - classnum: the package class
2947 - additional: arrayref of additional invoice details to add to this package
2949 and, I<if the charge has not yet been billed>:
2950 - start_date: the date when it will be billed
2951 - amount: the setup fee to be charged
2952 - quantity: the multiplier for the setup fee
2953 - separate_bill: whether to put the charge on a separate invoice
2955 If you pass 'adjust_commission' => 1, and the classnum changes, and there are
2956 commission credits linked to this charge, they will be recalculated.
2963 my $part_pkg = $self->part_pkg;
2964 my $pkgnum = $self->pkgnum;
2967 my $oldAutoCommit = $FS::UID::AutoCommit;
2968 local $FS::UID::AutoCommit = 0;
2970 return "Can't use modify_charge except on one-time charges"
2971 unless $part_pkg->freq eq '0';
2973 if ( length($opt{'pkg'}) and $part_pkg->pkg ne $opt{'pkg'} ) {
2974 $part_pkg->set('pkg', $opt{'pkg'});
2977 my %pkg_opt = $part_pkg->options;
2978 my $pkg_opt_modified = 0;
2980 $opt{'additional'} ||= [];
2983 foreach (grep /^additional/, keys %pkg_opt) {
2984 ($i) = ($_ =~ /^additional_info(\d+)$/);
2985 $old_additional[$i] = $pkg_opt{$_} if $i;
2986 delete $pkg_opt{$_};
2989 for ( $i = 0; exists($opt{'additional'}->[$i]); $i++ ) {
2990 $pkg_opt{ "additional_info$i" } = $opt{'additional'}->[$i];
2991 if (!exists($old_additional[$i])
2992 or $old_additional[$i] ne $opt{'additional'}->[$i])
2994 $pkg_opt_modified = 1;
2997 $pkg_opt_modified = 1 if scalar(@old_additional) != $i;
2998 $pkg_opt{'additional_count'} = $i if $i > 0;
3001 if ( exists($opt{'classnum'}) and $part_pkg->classnum ne $opt{'classnum'} )
3004 $old_classnum = $part_pkg->classnum;
3005 $part_pkg->set('classnum', $opt{'classnum'});
3008 if ( !$self->get('setup') ) {
3009 # not yet billed, so allow amount, setup_cost, quantity, start_date,
3012 if ( exists($opt{'amount'})
3013 and $part_pkg->option('setup_fee') != $opt{'amount'}
3014 and $opt{'amount'} > 0 ) {
3016 $pkg_opt{'setup_fee'} = $opt{'amount'};
3017 $pkg_opt_modified = 1;
3020 if ( exists($opt{'setup_cost'})
3021 and $part_pkg->setup_cost != $opt{'setup_cost'}
3022 and $opt{'setup_cost'} > 0 ) {
3024 $part_pkg->set('setup_cost', $opt{'setup_cost'});
3027 if ( exists($opt{'quantity'})
3028 and $opt{'quantity'} != $self->quantity
3029 and $opt{'quantity'} > 0 ) {
3031 $self->set('quantity', $opt{'quantity'});
3034 if ( exists($opt{'start_date'})
3035 and $opt{'start_date'} != $self->start_date ) {
3037 $self->set('start_date', $opt{'start_date'});
3040 if ( exists($opt{'separate_bill'})
3041 and $opt{'separate_bill'} ne $self->separate_bill ) {
3043 $self->set('separate_bill', $opt{'separate_bill'});
3047 } # else simply ignore them; the UI shouldn't allow editing the fields
3049 if ( exists($opt{'taxclass'})
3050 and $part_pkg->taxclass ne $opt{'taxclass'}) {
3052 $part_pkg->set('taxclass', $opt{'taxclass'});
3056 if ( $part_pkg->modified or $pkg_opt_modified ) {
3057 # can we safely modify the package def?
3058 # Yes, if it's not available for purchase, and this is the only instance
3060 if ( $part_pkg->disabled
3061 and FS::cust_pkg->count('pkgpart = '.$part_pkg->pkgpart) == 1
3062 and FS::quotation_pkg->count('pkgpart = '.$part_pkg->pkgpart) == 0
3064 $error = $part_pkg->replace( options => \%pkg_opt );
3067 $part_pkg = $part_pkg->clone;
3068 $part_pkg->set('disabled' => 'Y');
3069 $error = $part_pkg->insert( options => \%pkg_opt );
3070 # and associate this as yet-unbilled package to the new package def
3071 $self->set('pkgpart' => $part_pkg->pkgpart);
3074 $dbh->rollback if $oldAutoCommit;
3079 if ($self->modified) { # for quantity or start_date change, or if we had
3080 # to clone the existing package def
3081 my $error = $self->replace;
3082 return $error if $error;
3084 if (defined $old_classnum) {
3085 # fix invoice grouping records
3086 my $old_catname = $old_classnum
3087 ? FS::pkg_class->by_key($old_classnum)->categoryname
3089 my $new_catname = $opt{'classnum'}
3090 ? $part_pkg->pkg_class->categoryname
3092 if ( $old_catname ne $new_catname ) {
3093 foreach my $cust_bill_pkg ($self->cust_bill_pkg) {
3094 # (there should only be one...)
3095 my @display = qsearch( 'cust_bill_pkg_display', {
3096 'billpkgnum' => $cust_bill_pkg->billpkgnum,
3097 'section' => $old_catname,
3099 foreach (@display) {
3100 $_->set('section', $new_catname);
3101 $error = $_->replace;
3103 $dbh->rollback if $oldAutoCommit;
3107 } # foreach $cust_bill_pkg
3110 if ( $opt{'adjust_commission'} ) {
3111 # fix commission credits...tricky.
3112 foreach my $cust_event ($self->cust_event) {
3113 my $part_event = $cust_event->part_event;
3114 foreach my $table (qw(sales agent)) {
3116 "FS::part_event::Action::Mixin::credit_${table}_pkg_class";
3117 my $credit = qsearchs('cust_credit', {
3118 'eventnum' => $cust_event->eventnum,
3120 if ( $part_event->isa($class) ) {
3121 # Yes, this results in current commission rates being applied
3122 # retroactively to a one-time charge. For accounting purposes
3123 # there ought to be some kind of time limit on doing this.
3124 my $amount = $part_event->_calc_credit($self);
3125 if ( $credit and $credit->amount ne $amount ) {
3126 # Void the old credit.
3127 $error = $credit->void('Package class changed');
3129 $dbh->rollback if $oldAutoCommit;
3130 return "$error (adjusting commission credit)";
3133 # redo the event action to recreate the credit.
3135 eval { $part_event->do_action( $self, $cust_event ) };
3137 $dbh->rollback if $oldAutoCommit;
3140 } # if $part_event->isa($class)
3142 } # foreach $cust_event
3143 } # if $opt{'adjust_commission'}
3144 } # if defined $old_classnum
3146 $dbh->commit if $oldAutoCommit;
3150 use Storable 'thaw';
3153 sub process_bulk_cust_pkg {
3155 my $param = thaw(decode_base64(shift));
3156 warn Dumper($param) if $DEBUG;
3158 my $old_part_pkg = qsearchs('part_pkg',
3159 { pkgpart => $param->{'old_pkgpart'} });
3160 my $new_part_pkg = qsearchs('part_pkg',
3161 { pkgpart => $param->{'new_pkgpart'} });
3162 die "Must select a new package type\n" unless $new_part_pkg;
3163 #my $keep_dates = $param->{'keep_dates'} || 0;
3164 my $keep_dates = 1; # there is no good reason to turn this off
3166 local $SIG{HUP} = 'IGNORE';
3167 local $SIG{INT} = 'IGNORE';
3168 local $SIG{QUIT} = 'IGNORE';
3169 local $SIG{TERM} = 'IGNORE';
3170 local $SIG{TSTP} = 'IGNORE';
3171 local $SIG{PIPE} = 'IGNORE';
3173 my $oldAutoCommit = $FS::UID::AutoCommit;
3174 local $FS::UID::AutoCommit = 0;
3177 my @cust_pkgs = qsearch('cust_pkg', { 'pkgpart' => $param->{'old_pkgpart'} } );
3180 foreach my $old_cust_pkg ( @cust_pkgs ) {
3182 $job->update_statustext(int(100*$i/(scalar @cust_pkgs)));
3183 if ( $old_cust_pkg->getfield('cancel') ) {
3184 warn '[process_bulk_cust_pkg ] skipping canceled pkgnum '.
3185 $old_cust_pkg->pkgnum."\n"
3189 warn '[process_bulk_cust_pkg] changing pkgnum '.$old_cust_pkg->pkgnum."\n"
3191 my $error = $old_cust_pkg->change(
3192 'pkgpart' => $param->{'new_pkgpart'},
3193 'keep_dates' => $keep_dates
3195 if ( !ref($error) ) { # change returns the cust_pkg on success
3197 die "Error changing pkgnum ".$old_cust_pkg->pkgnum.": '$error'\n";
3200 $dbh->commit if $oldAutoCommit;
3206 Returns the last bill date, or if there is no last bill date, the setup date.
3207 Useful for billing metered services.
3213 return $self->setfield('last_bill', $_[0]) if @_;
3214 return $self->getfield('last_bill') if $self->getfield('last_bill');
3215 my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
3216 'edate' => $self->bill, } );
3217 $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
3220 =item last_cust_pkg_reason ACTION
3222 Returns the most recent ACTION FS::cust_pkg_reason associated with the package.
3223 Returns false if there is no reason or the package is not currenly ACTION'd
3224 ACTION is one of adjourn, susp, cancel, or expire.
3228 sub last_cust_pkg_reason {
3229 my ( $self, $action ) = ( shift, shift );
3230 my $date = $self->get($action);
3232 'table' => 'cust_pkg_reason',
3233 'hashref' => { 'pkgnum' => $self->pkgnum,
3234 'action' => substr(uc($action), 0, 1),
3237 'order_by' => 'ORDER BY num DESC LIMIT 1',
3241 =item last_reason ACTION
3243 Returns the most recent ACTION FS::reason associated with the package.
3244 Returns false if there is no reason or the package is not currenly ACTION'd
3245 ACTION is one of adjourn, susp, cancel, or expire.
3250 my $cust_pkg_reason = shift->last_cust_pkg_reason(@_);
3251 $cust_pkg_reason->reason
3252 if $cust_pkg_reason;
3257 Returns the definition for this billing item, as an FS::part_pkg object (see
3264 return $self->{'_pkgpart'} if $self->{'_pkgpart'};
3265 cluck "cust_pkg->part_pkg called" if $DEBUG > 1;
3266 qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
3271 Returns the cancelled package this package was changed from, if any.
3277 return '' unless $self->change_pkgnum;
3278 qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
3281 =item change_cust_main
3283 Returns the customter this package was detached to, if any.
3287 sub change_cust_main {
3289 return '' unless $self->change_custnum;
3290 qsearchs('cust_main', { 'custnum' => $self->change_custnum } );
3295 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
3302 $self->part_pkg->calc_setup($self, @_);
3307 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
3314 $self->part_pkg->calc_recur($self, @_);
3319 Returns the base setup fee (per unit) of this package, from the package
3324 # minimal version for 3.x; in 4.x this can invoke currency conversion
3328 $self->part_pkg->unit_setup($self);
3333 Calls the I<base_recur> of the FS::part_pkg object associated with this billing
3340 $self->part_pkg->base_recur($self, @_);
3345 Calls the I<calc_remain> of the FS::part_pkg object associated with this
3352 $self->part_pkg->calc_remain($self, @_);
3357 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
3364 $self->part_pkg->calc_cancel($self, @_);
3369 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
3375 qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
3378 =item cust_pkg_detail [ DETAILTYPE ]
3380 Returns any customer package details for this package (see
3381 L<FS::cust_pkg_detail>).
3383 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
3387 sub cust_pkg_detail {
3389 my %hash = ( 'pkgnum' => $self->pkgnum );
3390 $hash{detailtype} = shift if @_;
3392 'table' => 'cust_pkg_detail',
3393 'hashref' => \%hash,
3394 'order_by' => 'ORDER BY weight, pkgdetailnum',
3398 =item set_cust_pkg_detail DETAILTYPE [ DETAIL, DETAIL, ... ]
3400 Sets customer package details for this package (see L<FS::cust_pkg_detail>).
3402 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
3404 If there is an error, returns the error, otherwise returns false.
3408 sub set_cust_pkg_detail {
3409 my( $self, $detailtype, @details ) = @_;
3411 local $SIG{HUP} = 'IGNORE';
3412 local $SIG{INT} = 'IGNORE';
3413 local $SIG{QUIT} = 'IGNORE';
3414 local $SIG{TERM} = 'IGNORE';
3415 local $SIG{TSTP} = 'IGNORE';
3416 local $SIG{PIPE} = 'IGNORE';
3418 my $oldAutoCommit = $FS::UID::AutoCommit;
3419 local $FS::UID::AutoCommit = 0;
3422 foreach my $current ( $self->cust_pkg_detail($detailtype) ) {
3423 my $error = $current->delete;
3425 $dbh->rollback if $oldAutoCommit;
3426 return "error removing old detail: $error";
3430 foreach my $detail ( @details ) {
3431 my $cust_pkg_detail = new FS::cust_pkg_detail {
3432 'pkgnum' => $self->pkgnum,
3433 'detailtype' => $detailtype,
3434 'detail' => $detail,
3436 my $error = $cust_pkg_detail->insert;
3438 $dbh->rollback if $oldAutoCommit;
3439 return "error adding new detail: $error";
3444 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3451 Returns the customer billing events (see L<FS::cust_event>) for this invoice.
3455 #false laziness w/cust_bill.pm
3459 'table' => 'cust_event',
3460 'addl_from' => 'JOIN part_event USING ( eventpart )',
3461 'hashref' => { 'tablenum' => $self->pkgnum },
3462 'extra_sql' => " AND eventtable = 'cust_pkg' ",
3466 =item num_cust_event
3468 Returns the number of customer billing events (see L<FS::cust_event>) for this package.
3472 #false laziness w/cust_bill.pm
3473 sub num_cust_event {
3475 my $sql = "SELECT COUNT(*) ". $self->_from_cust_event_where;
3476 $self->_prep_ex($sql, $self->pkgnum)->fetchrow_arrayref->[0];
3479 =item exists_cust_event
3481 Returns true if there are customer billing events (see L<FS::cust_event>) for this package. More efficient than using num_cust_event.
3485 sub exists_cust_event {
3487 my $sql = "SELECT 1 ". $self->_from_cust_event_where. " LIMIT 1";
3488 my $row = $self->_prep_ex($sql, $self->pkgnum)->fetchrow_arrayref;
3489 $row ? $row->[0] : '';
3492 sub _from_cust_event_where {
3494 " FROM cust_event JOIN part_event USING ( eventpart ) ".
3495 " WHERE tablenum = ? AND eventtable = 'cust_pkg' ";
3499 my( $self, $sql, @args ) = @_;
3500 my $sth = dbh->prepare($sql) or die dbh->errstr. " preparing $sql";
3501 $sth->execute(@args) or die $sth->errstr. " executing $sql";
3505 =item cust_svc [ SVCPART ] (old, deprecated usage)
3507 =item cust_svc [ OPTION => VALUE ... ] (current usage)
3509 =item cust_svc_unsorted [ OPTION => VALUE ... ]
3511 Returns the services for this package, as FS::cust_svc objects (see
3512 L<FS::cust_svc>). Available options are svcpart and svcdb. If either is
3513 spcififed, returns only the matching services.
3515 As an optimization, use the cust_svc_unsorted version if you are not displaying
3522 cluck "cust_pkg->cust_svc called" if $DEBUG > 2;
3523 $self->_sort_cust_svc( $self->cust_svc_unsorted_arrayref(@_) );
3526 sub cust_svc_unsorted {
3528 @{ $self->cust_svc_unsorted_arrayref(@_) };
3531 sub cust_svc_unsorted_arrayref {
3534 return [] unless $self->num_cust_svc(@_);
3537 if ( @_ && $_[0] =~ /^\d+/ ) {
3538 $opt{svcpart} = shift;
3539 } elsif ( @_ && ref($_[0]) eq 'HASH' ) {
3546 'select' => 'cust_svc.*, part_svc.*',
3547 'table' => 'cust_svc',
3548 'hashref' => { 'pkgnum' => $self->pkgnum },
3549 'addl_from' => 'LEFT JOIN part_svc USING ( svcpart )',
3551 $search{hashref}->{svcpart} = $opt{svcpart}
3553 $search{extra_sql} = ' AND svcdb = '. dbh->quote( $opt{svcdb} )
3556 [ qsearch(\%search) ];
3560 =item overlimit [ SVCPART ]
3562 Returns the services for this package which have exceeded their
3563 usage limit as FS::cust_svc objects (see L<FS::cust_svc>). If a svcpart
3564 is specified, return only the matching services.
3570 return () unless $self->num_cust_svc(@_);
3571 grep { $_->overlimit } $self->cust_svc(@_);
3574 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
3576 Returns historical services for this package created before END TIMESTAMP and
3577 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
3578 (see L<FS::h_cust_svc>). If MODE is 'I' (for 'invoice'), services with the
3579 I<pkg_svc.hidden> flag will be omitted.
3585 warn "$me _h_cust_svc called on $self\n"
3588 my ($end, $start, $mode) = @_;
3589 my @cust_svc = $self->_sort_cust_svc(
3590 [ qsearch( 'h_cust_svc',
3591 { 'pkgnum' => $self->pkgnum, },
3592 FS::h_cust_svc->sql_h_search(@_),
3595 if ( defined($mode) && $mode eq 'I' ) {
3596 my %hidden_svcpart = map { $_->svcpart => $_->hidden } $self->part_svc;
3597 return grep { !$hidden_svcpart{$_->svcpart} } @cust_svc;
3603 sub _sort_cust_svc {
3604 my( $self, $arrayref ) = @_;
3607 sub ($$) { my ($a, $b) = @_; $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] };
3609 my %pkg_svc = map { $_->svcpart => $_ }
3610 qsearch( 'pkg_svc', { 'pkgpart' => $self->pkgpart } );
3615 my $pkg_svc = $pkg_svc{ $_->svcpart } || '';
3617 $pkg_svc ? $pkg_svc->primary_svc : '',
3618 $pkg_svc ? $pkg_svc->quantity : 0,
3625 =item num_cust_svc [ SVCPART ] (old, deprecated usage)
3627 =item num_cust_svc [ OPTION => VALUE ... ] (current usage)
3629 Returns the number of services for this package. Available options are svcpart
3630 and svcdb. If either is spcififed, returns only the matching services.
3637 return $self->{'_num_cust_svc'}
3639 && exists($self->{'_num_cust_svc'})
3640 && $self->{'_num_cust_svc'} =~ /\d/;
3642 cluck "cust_pkg->num_cust_svc called, _num_cust_svc:".$self->{'_num_cust_svc'}
3646 if ( @_ && $_[0] =~ /^\d+/ ) {
3647 $opt{svcpart} = shift;
3648 } elsif ( @_ && ref($_[0]) eq 'HASH' ) {
3654 my $select = 'SELECT COUNT(*) FROM cust_svc ';
3655 my $where = ' WHERE pkgnum = ? ';
3656 my @param = ($self->pkgnum);
3658 if ( $opt{'svcpart'} ) {
3659 $where .= ' AND svcpart = ? ';
3660 push @param, $opt{'svcpart'};
3662 if ( $opt{'svcdb'} ) {
3663 $select .= ' LEFT JOIN part_svc USING ( svcpart ) ';
3664 $where .= ' AND svcdb = ? ';
3665 push @param, $opt{'svcdb'};
3668 my $sth = dbh->prepare("$select $where") or die dbh->errstr;
3669 $sth->execute(@param) or die $sth->errstr;
3670 $sth->fetchrow_arrayref->[0];
3673 =item available_part_svc
3675 Returns a list of FS::part_svc objects representing services included in this
3676 package but not yet provisioned. Each FS::part_svc object also has an extra
3677 field, I<num_avail>, which specifies the number of available services.
3679 Accepts option I<provision_hold>; if true, only returns part_svc for which the
3680 associated pkg_svc has the provision_hold flag set.
3684 sub available_part_svc {
3688 my $pkg_quantity = $self->quantity || 1;
3690 grep { $_->num_avail > 0 }
3692 my $part_svc = $_->part_svc;
3693 $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
3694 $pkg_quantity * $_->quantity - $self->num_cust_svc($_->svcpart);
3696 # more evil encapsulation breakage
3697 if ($part_svc->{'Hash'}{'num_avail'} > 0) {
3698 my @exports = $part_svc->part_export_did;
3699 $part_svc->{'Hash'}{'can_get_dids'} = scalar(@exports);
3704 grep { $opt{'provision_hold'} ? $_->provision_hold : 1 }
3705 $self->part_pkg->pkg_svc;
3708 =item part_svc [ OPTION => VALUE ... ]
3710 Returns a list of FS::part_svc objects representing provisioned and available
3711 services included in this package. Each FS::part_svc object also has the
3712 following extra fields:
3726 (services) - array reference containing the provisioned services, as cust_svc objects
3730 Accepts two options:
3734 =item summarize_size
3736 If true, will omit the extra cust_pkg_svc option for objects where num_cust_svc
3737 is this size or greater.
3739 =item hide_discontinued
3741 If true, will omit looking for services that are no longer avaialble in the
3749 #label -> ($cust_svc->label)[1]
3755 my $pkg_quantity = $self->quantity || 1;
3757 #XXX some sort of sort order besides numeric by svcpart...
3758 my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
3760 my $part_svc = $pkg_svc->part_svc;
3761 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
3762 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
3763 $part_svc->{'Hash'}{'num_avail'} =
3764 max( 0, $pkg_quantity * $pkg_svc->quantity - $num_cust_svc );
3765 $part_svc->{'Hash'}{'cust_pkg_svc'} =
3766 $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : []
3767 unless exists($opt{summarize_size}) && $opt{summarize_size} > 0
3768 && $num_cust_svc >= $opt{summarize_size};
3769 $part_svc->{'Hash'}{'hidden'} = $pkg_svc->hidden;
3771 } $self->part_pkg->pkg_svc;
3773 unless ( $opt{hide_discontinued} ) {
3775 push @part_svc, map {
3777 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
3778 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
3779 $part_svc->{'Hash'}{'num_avail'} = 0; #0-$num_cust_svc ?
3780 $part_svc->{'Hash'}{'cust_pkg_svc'} =
3781 $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
3783 } $self->extra_part_svc;
3790 =item extra_part_svc
3792 Returns a list of FS::part_svc objects corresponding to services in this
3793 package which are still provisioned but not (any longer) available in the
3798 sub extra_part_svc {
3801 my $pkgnum = $self->pkgnum;
3802 #my $pkgpart = $self->pkgpart;
3805 # 'table' => 'part_svc',
3808 # "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
3809 # WHERE pkg_svc.svcpart = part_svc.svcpart
3810 # AND pkg_svc.pkgpart = ?
3813 # AND 0 < ( SELECT COUNT(*) FROM cust_svc
3814 # LEFT JOIN cust_pkg USING ( pkgnum )
3815 # WHERE cust_svc.svcpart = part_svc.svcpart
3818 # 'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
3821 #seems to benchmark slightly faster... (or did?)
3823 my @pkgparts = map $_->pkgpart, $self->part_pkg->self_and_svc_linked;
3824 my $pkgparts = join(',', @pkgparts);
3827 #'select' => 'DISTINCT ON (svcpart) part_svc.*',
3828 #MySQL doesn't grok DISINCT ON
3829 'select' => 'DISTINCT part_svc.*',
3830 'table' => 'part_svc',
3832 "LEFT JOIN pkg_svc ON ( pkg_svc.svcpart = part_svc.svcpart
3833 AND pkg_svc.pkgpart IN ($pkgparts)
3836 LEFT JOIN cust_svc ON ( cust_svc.svcpart = part_svc.svcpart )
3837 LEFT JOIN cust_pkg USING ( pkgnum )
3840 'extra_sql' => "WHERE pkgsvcnum IS NULL AND cust_pkg.pkgnum = ? ",
3841 'extra_param' => [ [$self->pkgnum=>'int'] ],
3847 Returns a short status string for this package, currently:
3853 =item not yet billed
3855 =item one-time charge
3870 my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
3872 return 'cancelled' if $self->get('cancel');
3873 return 'on hold' if $self->susp && ! $self->setup;
3874 return 'suspended' if $self->susp;
3875 return 'not yet billed' unless $self->setup;
3876 return 'one-time charge' if $freq =~ /^(0|$)/;
3880 =item ucfirst_status
3882 Returns the status with the first character capitalized.
3886 sub ucfirst_status {
3887 ucfirst(shift->status);
3892 Class method that returns the list of possible status strings for packages
3893 (see L<the status method|/status>). For example:
3895 @statuses = FS::cust_pkg->statuses();
3899 tie my %statuscolor, 'Tie::IxHash',
3900 'on hold' => 'FF00F5', #brighter purple!
3901 'not yet billed' => '009999', #teal? cyan?
3902 'one-time charge' => '0000CC', #blue #'000000',
3903 'active' => '00CC00',
3904 'suspended' => 'FF9900',
3905 'cancelled' => 'FF0000',
3909 my $self = shift; #could be class...
3910 #grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
3911 # # mayble split btw one-time vs. recur
3922 Returns a hex triplet color string for this package's status.
3928 $statuscolor{$self->status};
3931 =item is_status_delay_cancel
3933 Returns true if part_pkg has option delay_cancel,
3934 cust_pkg status is 'suspended' and expire is set
3935 to cancel package within the next day (or however
3936 many days are set in global config part_pkg-delay_cancel-days.
3938 Accepts option I<part_pkg-delay_cancel-days> which should be
3939 the value of the config setting, to avoid looking it up again.
3941 This is not a real status, this only meant for hacking display
3942 values, because otherwise treating the package as suspended is
3943 really the whole point of the delay_cancel option.
3947 sub is_status_delay_cancel {
3948 my ($self,%opt) = @_;
3949 if ( $self->main_pkgnum and $self->pkglinknum ) {
3950 return $self->main_pkg->is_status_delay_cancel;
3952 return 0 unless $self->part_pkg->option('delay_cancel',1);
3953 return 0 unless $self->status eq 'suspended';
3954 return 0 unless $self->expire;
3955 my $expdays = $opt{'part_pkg-delay_cancel-days'};
3957 my $conf = new FS::Conf;
3958 $expdays = $conf->config('part_pkg-delay_cancel-days') || 1;
3960 my $expsecs = 60*60*24*$expdays;
3961 return 0 unless $self->expire < time + $expsecs;
3967 Returns a label for this package. (Currently "pkgnum: pkg - comment" or
3968 "pkg - comment" depending on user preference).
3974 my $label = $self->part_pkg->pkg_comment( 'nopkgpart' => 1 );
3975 $label = $self->pkgnum. ": $label"
3976 if $FS::CurrentUser::CurrentUser->option('show_pkgnum');
3980 =item pkg_label_long
3982 Returns a long label for this package, adding the primary service's label to
3987 sub pkg_label_long {
3989 my $label = $self->pkg_label;
3990 my $cust_svc = $self->primary_cust_svc;
3991 $label .= ' ('. ($cust_svc->label)[1]. ')' if $cust_svc;
3997 Returns a customer-localized label for this package.
4003 $self->part_pkg->pkg_locale( $self->cust_main->locale );
4006 =item primary_cust_svc
4008 Returns a primary service (as FS::cust_svc object) if one can be identified.
4012 #for labeling purposes - might not 100% match up with part_pkg->svcpart's idea
4014 sub primary_cust_svc {
4017 my @cust_svc = $self->cust_svc;
4019 return '' unless @cust_svc; #no serivces - irrelevant then
4021 return $cust_svc[0] if scalar(@cust_svc) == 1; #always return a single service
4023 # primary service as specified in the package definition
4024 # or exactly one service definition with quantity one
4025 my $svcpart = $self->part_pkg->svcpart;
4026 @cust_svc = grep { $_->svcpart == $svcpart } @cust_svc;
4027 return $cust_svc[0] if scalar(@cust_svc) == 1;
4029 #couldn't identify one thing..
4035 Returns a list of lists, calling the label method for all services
4036 (see L<FS::cust_svc>) of this billing item.
4042 map { [ $_->label ] } $self->cust_svc;
4045 =item h_labels END_TIMESTAMP [, START_TIMESTAMP [, MODE [, LOCALE ] ] ]
4047 Like the labels method, but returns historical information on services that
4048 were active as of END_TIMESTAMP and (optionally) not cancelled before
4049 START_TIMESTAMP. If MODE is 'I' (for 'invoice'), services with the
4050 I<pkg_svc.hidden> flag will be omitted.
4052 If LOCALE is passed, service definition names will be localized.
4054 Returns a list of lists, calling the label method for all (historical)
4055 services (see L<FS::h_cust_svc>) of this billing item.
4061 my ($end, $start, $mode, $locale) = @_;
4062 warn "$me h_labels\n"
4064 map { [ $_->label($end, $start, $locale) ] }
4065 $self->h_cust_svc($end, $start, $mode);
4070 Like labels, except returns a simple flat list, and shortens long
4071 (currently >5 or the cust_bill-max_same_services configuration value) lists of
4072 identical services to one line that lists the service label and the number of
4073 individual services rather than individual items.
4078 shift->_labels_short( 'labels' ); # 'labels' takes no further arguments
4081 =item h_labels_short END_TIMESTAMP [, START_TIMESTAMP [, MODE [, LOCALE ] ] ]
4083 Like h_labels, except returns a simple flat list, and shortens long
4084 (currently >5 or the cust_bill-max_same_services configuration value) lists
4085 of identical services to one line that lists the service label and the
4086 number of individual services rather than individual items.
4090 sub h_labels_short {
4091 shift->_labels_short( 'h_labels', @_ );
4094 # takes a method name ('labels' or 'h_labels') and all its arguments;
4095 # maybe should be "shorten($self->h_labels( ... ) )"
4098 my( $self, $method ) = ( shift, shift );
4100 warn "$me _labels_short called on $self with $method method\n"
4103 my $conf = new FS::Conf;
4104 my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
4106 warn "$me _labels_short populating \%labels\n"
4110 #tie %labels, 'Tie::IxHash';
4111 push @{ $labels{$_->[0]} }, $_->[1]
4112 foreach $self->$method(@_);
4114 warn "$me _labels_short populating \@labels\n"
4118 foreach my $label ( keys %labels ) {
4120 my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
4121 my $num = scalar(@values);
4122 warn "$me _labels_short $num items for $label\n"
4125 if ( $num > $max_same_services ) {
4126 warn "$me _labels_short more than $max_same_services, so summarizing\n"
4128 push @labels, "$label ($num)";
4130 if ( $conf->exists('cust_bill-consolidate_services') ) {
4131 warn "$me _labels_short consolidating services\n"
4133 # push @labels, "$label: ". join(', ', @values);
4135 my $detail = "$label: ";
4136 $detail .= shift(@values). ', '
4138 && ( length($detail.$values[0]) < 78 || $detail eq "$label: " );
4140 push @labels, $detail;
4142 warn "$me _labels_short done consolidating services\n"
4145 warn "$me _labels_short adding service data\n"
4147 push @labels, map { "$label: $_" } @values;
4158 Returns the parent customer object (see L<FS::cust_main>).
4164 cluck 'cust_pkg->cust_main called' if $DEBUG;
4165 qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
4170 Returns the balance for this specific package, when using
4171 experimental package balance.
4177 $self->cust_main->balance_pkgnum( $self->pkgnum );
4180 #these subs are in location_Mixin.pm now... unfortunately the POD doesn't mixin
4184 Returns the location object, if any (see L<FS::cust_location>).
4186 =item cust_location_or_main
4188 If this package is associated with a location, returns the locaiton (see
4189 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
4191 =item location_label [ OPTION => VALUE ... ]
4193 Returns the label of the location object (see L<FS::cust_location>).
4197 #end of subs in location_Mixin.pm now... unfortunately the POD doesn't mixin
4199 =item tax_locationnum
4201 Returns the foreign key to a L<FS::cust_location> object for calculating
4202 tax on this package, as determined by the C<tax-pkg_address> and
4203 C<tax-ship_address> configuration flags.
4207 sub tax_locationnum {
4209 my $conf = FS::Conf->new;
4210 if ( $conf->exists('tax-pkg_address') ) {
4211 return $self->locationnum;
4213 elsif ( $conf->exists('tax-ship_address') ) {
4214 return $self->cust_main->ship_locationnum;
4217 return $self->cust_main->bill_locationnum;
4223 Returns the L<FS::cust_location> object for tax_locationnum.
4229 my $conf = FS::Conf->new;
4230 if ( $conf->exists('tax-pkg_address') and $self->locationnum ) {
4231 return FS::cust_location->by_key($self->locationnum);
4233 elsif ( $conf->exists('tax-ship_address') ) {
4234 return $self->cust_main->ship_location;
4237 return $self->cust_main->bill_location;
4241 =item seconds_since TIMESTAMP
4243 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
4244 package have been online since TIMESTAMP, according to the session monitor.
4246 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
4247 L<Time::Local> and L<Date::Parse> for conversion functions.
4252 my($self, $since) = @_;
4255 foreach my $cust_svc (
4256 grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
4258 $seconds += $cust_svc->seconds_since($since);
4265 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
4267 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
4268 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
4271 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
4272 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
4278 sub seconds_since_sqlradacct {
4279 my($self, $start, $end) = @_;
4283 foreach my $cust_svc (
4285 my $part_svc = $_->part_svc;
4286 $part_svc->svcdb eq 'svc_acct'
4287 && scalar($part_svc->part_export_usage);
4290 $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
4297 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
4299 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
4300 in this package for sessions ending between TIMESTAMP_START (inclusive) and
4304 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
4305 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
4310 sub attribute_since_sqlradacct {
4311 my($self, $start, $end, $attrib) = @_;
4315 foreach my $cust_svc (
4317 my $part_svc = $_->part_svc;
4318 scalar($part_svc->part_export_usage);
4321 $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
4333 my( $self, $value ) = @_;
4334 if ( defined($value) ) {
4335 $self->setfield('quantity', $value);
4337 $self->getfield('quantity') || 1;
4340 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
4342 Transfers as many services as possible from this package to another package.
4344 The destination package can be specified by pkgnum by passing an FS::cust_pkg
4345 object. The destination package must already exist.
4347 Services are moved only if the destination allows services with the correct
4348 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true. Use
4349 this option with caution! No provision is made for export differences
4350 between the old and new service definitions. Probably only should be used
4351 when your exports for all service definitions of a given svcdb are identical.
4352 (attempt a transfer without it first, to move all possible svcpart-matching
4355 Any services that can't be moved remain in the original package.
4357 Returns an error, if there is one; otherwise, returns the number of services
4358 that couldn't be moved.
4363 my ($self, $dest_pkgnum, %opt) = @_;
4369 if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
4370 $dest = $dest_pkgnum;
4371 $dest_pkgnum = $dest->pkgnum;
4373 $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
4376 return ('Package does not exist: '.$dest_pkgnum) unless $dest;
4378 foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
4379 $target{$pkg_svc->svcpart} = $pkg_svc->quantity * ( $dest->quantity || 1 );
4382 unless ( $self->pkgnum == $dest->pkgnum ) {
4383 foreach my $cust_svc ($dest->cust_svc) {
4384 $target{$cust_svc->svcpart}--;
4388 my %svcpart2svcparts = ();
4389 if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
4390 warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
4391 foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
4392 next if exists $svcpart2svcparts{$svcpart};
4393 my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
4394 $svcpart2svcparts{$svcpart} = [
4396 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
4398 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
4399 'svcpart' => $_ } );
4401 $pkg_svc ? $pkg_svc->primary_svc : '',
4402 $pkg_svc ? $pkg_svc->quantity : 0,
4406 grep { $_ != $svcpart }
4408 qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
4410 warn "alternates for svcpart $svcpart: ".
4411 join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
4417 foreach my $cust_svc ($self->cust_svc) {
4418 my $svcnum = $cust_svc->svcnum;
4420 if ( $target{$cust_svc->svcpart} > 0
4421 or $FS::cust_svc::ignore_quantity # maybe should be a 'force' option
4424 $target{$cust_svc->svcpart}--;
4426 local $FS::cust_svc::ignore_quantity = 1
4427 if $self->pkgnum == $dest->pkgnum;
4429 #why run replace at all in the $self->pkgnum == $dest->pkgnum case?
4430 # we do want to trigger location and pkg_change exports, but
4431 # without pkgnum changing from an old to new package, cust_svc->replace
4432 # doesn't know how to trigger those. :/
4433 # does this mean we scrap the whole idea of "safe to modify it in place",
4434 # or do we special-case and pass the info needed to cust_svc->replace? :/
4436 my $new = new FS::cust_svc { $cust_svc->hash };
4437 $new->pkgnum($dest_pkgnum);
4438 $error = $new->replace($cust_svc);
4440 } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
4443 warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
4444 warn "alternates to consider: ".
4445 join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
4448 my @alternate = grep {
4449 warn "considering alternate svcpart $_: ".
4450 "$target{$_} available in new package\n"
4453 } @{$svcpart2svcparts{$cust_svc->svcpart}};
4456 warn "alternate(s) found\n" if $DEBUG;
4457 my $change_svcpart = $alternate[0];
4458 $target{$change_svcpart}--;
4459 my $new = new FS::cust_svc { $cust_svc->hash };
4460 $new->svcpart($change_svcpart);
4461 $new->pkgnum($dest_pkgnum);
4462 $error = $new->replace($cust_svc);
4472 my @label = $cust_svc->label;
4473 return "service $label[1]: $error";
4480 =item grab_svcnums SVCNUM, SVCNUM ...
4482 Change the pkgnum for the provided services to this packages. If there is an
4483 error, returns the error, otherwise returns false.
4491 local $SIG{HUP} = 'IGNORE';
4492 local $SIG{INT} = 'IGNORE';
4493 local $SIG{QUIT} = 'IGNORE';
4494 local $SIG{TERM} = 'IGNORE';
4495 local $SIG{TSTP} = 'IGNORE';
4496 local $SIG{PIPE} = 'IGNORE';
4498 my $oldAutoCommit = $FS::UID::AutoCommit;
4499 local $FS::UID::AutoCommit = 0;
4502 foreach my $svcnum (@svcnum) {
4503 my $cust_svc = qsearchs('cust_svc', { svcnum=>$svcnum } ) or do {
4504 $dbh->rollback if $oldAutoCommit;
4505 return "unknown svcnum $svcnum";
4507 $cust_svc->pkgnum( $self->pkgnum );
4508 my $error = $cust_svc->replace;
4510 $dbh->rollback if $oldAutoCommit;
4515 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4522 This method is deprecated. See the I<depend_jobnum> option to the insert and
4523 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
4530 local $SIG{HUP} = 'IGNORE';
4531 local $SIG{INT} = 'IGNORE';
4532 local $SIG{QUIT} = 'IGNORE';
4533 local $SIG{TERM} = 'IGNORE';
4534 local $SIG{TSTP} = 'IGNORE';
4535 local $SIG{PIPE} = 'IGNORE';
4537 my $oldAutoCommit = $FS::UID::AutoCommit;
4538 local $FS::UID::AutoCommit = 0;
4541 foreach my $cust_svc ( $self->cust_svc ) {
4542 #false laziness w/svc_Common::insert
4543 my $svc_x = $cust_svc->svc_x;
4544 foreach my $part_export ( $cust_svc->part_svc->part_export ) {
4545 my $error = $part_export->export_insert($svc_x);
4547 $dbh->rollback if $oldAutoCommit;
4553 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4558 =item export_pkg_change OLD_CUST_PKG
4560 Calls the "pkg_change" export action for all services attached to this package.
4564 sub export_pkg_change {
4565 my( $self, $old ) = ( shift, shift );
4567 local $SIG{HUP} = 'IGNORE';
4568 local $SIG{INT} = 'IGNORE';
4569 local $SIG{QUIT} = 'IGNORE';
4570 local $SIG{TERM} = 'IGNORE';
4571 local $SIG{TSTP} = 'IGNORE';
4572 local $SIG{PIPE} = 'IGNORE';
4574 my $oldAutoCommit = $FS::UID::AutoCommit;
4575 local $FS::UID::AutoCommit = 0;
4578 foreach my $svc_x ( map $_->svc_x, $self->cust_svc ) {
4579 my $error = $svc_x->export('pkg_change', $self, $old);
4581 $dbh->rollback if $oldAutoCommit;
4586 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4593 Associates this package with a (suspension or cancellation) reason (see
4594 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
4597 Available options are:
4603 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.
4607 the access_user (see L<FS::access_user>) providing the reason
4615 the action (cancel, susp, adjourn, expire) associated with the reason
4619 If there is an error, returns the error, otherwise returns false.
4624 my ($self, %options) = @_;
4626 my $otaker = $options{reason_otaker} ||
4627 $FS::CurrentUser::CurrentUser->username;
4630 if ( $options{'reason'} =~ /^(\d+)$/ ) {
4634 } elsif ( ref($options{'reason'}) ) {
4636 return 'Enter a new reason (or select an existing one)'
4637 unless $options{'reason'}->{'reason'} !~ /^\s*$/;
4639 my $reason = new FS::reason({
4640 'reason_type' => $options{'reason'}->{'typenum'},
4641 'reason' => $options{'reason'}->{'reason'},
4643 my $error = $reason->insert;
4644 return $error if $error;
4646 $reasonnum = $reason->reasonnum;
4649 return "Unparseable reason: ". $options{'reason'};
4652 my $cust_pkg_reason =
4653 new FS::cust_pkg_reason({ 'pkgnum' => $self->pkgnum,
4654 'reasonnum' => $reasonnum,
4655 'otaker' => $otaker,
4656 'action' => substr(uc($options{'action'}),0,1),
4657 'date' => $options{'date'}
4662 $cust_pkg_reason->insert;
4665 =item insert_discount
4667 Associates this package with a discount (see L<FS::cust_pkg_discount>, possibly
4668 inserting a new discount on the fly (see L<FS::discount>).
4670 Available options are:
4678 If there is an error, returns the error, otherwise returns false.
4682 sub insert_discount {
4683 #my ($self, %options) = @_;
4686 my $cust_pkg_discount = new FS::cust_pkg_discount {
4687 'pkgnum' => $self->pkgnum,
4688 'discountnum' => $self->discountnum,
4690 'end_date' => '', #XXX
4691 #for the create a new discount case
4692 '_type' => $self->discountnum__type,
4693 'amount' => $self->discountnum_amount,
4694 'percent' => $self->discountnum_percent,
4695 'months' => $self->discountnum_months,
4696 'setup' => $self->discountnum_setup,
4697 #'disabled' => $self->discountnum_disabled,
4700 $cust_pkg_discount->insert;
4703 =item set_usage USAGE_VALUE_HASHREF
4705 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
4706 to which they should be set (see L<FS::svc_acct>). Currently seconds,
4707 upbytes, downbytes, and totalbytes are appropriate keys.
4709 All svc_accts which are part of this package have their values reset.
4714 my ($self, $valueref, %opt) = @_;
4716 #only svc_acct can set_usage for now
4717 foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
4718 my $svc_x = $cust_svc->svc_x;
4719 $svc_x->set_usage($valueref, %opt)
4720 if $svc_x->can("set_usage");
4724 =item recharge USAGE_VALUE_HASHREF
4726 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
4727 to which they should be set (see L<FS::svc_acct>). Currently seconds,
4728 upbytes, downbytes, and totalbytes are appropriate keys.
4730 All svc_accts which are part of this package have their values incremented.
4735 my ($self, $valueref) = @_;
4737 #only svc_acct can set_usage for now
4738 foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
4739 my $svc_x = $cust_svc->svc_x;
4740 $svc_x->recharge($valueref)
4741 if $svc_x->can("recharge");
4745 =item cust_pkg_discount
4749 sub cust_pkg_discount {
4751 qsearch('cust_pkg_discount', { 'pkgnum' => $self->pkgnum } );
4754 =item cust_pkg_discount_active
4758 sub cust_pkg_discount_active {
4760 grep { $_->status eq 'active' } $self->cust_pkg_discount;
4763 =item cust_pkg_usage
4765 Returns a list of all voice usage counters attached to this package.
4769 sub cust_pkg_usage {
4771 qsearch('cust_pkg_usage', { pkgnum => $self->pkgnum });
4774 =item apply_usage OPTIONS
4776 Takes the following options:
4777 - cdr: a call detail record (L<FS::cdr>)
4778 - rate_detail: the rate determined for this call (L<FS::rate_detail>)
4779 - minutes: the maximum number of minutes to be charged
4781 Finds available usage minutes for a call of this class, and subtracts
4782 up to that many minutes from the usage pool. If the usage pool is empty,
4783 and the C<cdr-minutes_priority> global config option is set, minutes may
4784 be taken from other calls as well. Either way, an allocation record will
4785 be created (L<FS::cdr_cust_pkg_usage>) and this method will return the
4786 number of minutes of usage applied to the call.
4791 my ($self, %opt) = @_;
4792 my $cdr = $opt{cdr};
4793 my $rate_detail = $opt{rate_detail};
4794 my $minutes = $opt{minutes};
4795 my $classnum = $rate_detail->classnum;
4796 my $pkgnum = $self->pkgnum;
4797 my $custnum = $self->custnum;
4799 local $SIG{HUP} = 'IGNORE';
4800 local $SIG{INT} = 'IGNORE';
4801 local $SIG{QUIT} = 'IGNORE';
4802 local $SIG{TERM} = 'IGNORE';
4803 local $SIG{TSTP} = 'IGNORE';
4804 local $SIG{PIPE} = 'IGNORE';
4806 my $oldAutoCommit = $FS::UID::AutoCommit;
4807 local $FS::UID::AutoCommit = 0;
4809 my $order = FS::Conf->new->config('cdr-minutes_priority');
4813 $is_classnum = ' part_pkg_usage_class.classnum = '.$classnum;
4815 $is_classnum = ' part_pkg_usage_class.classnum IS NULL';
4817 my @usage_recs = qsearch({
4818 'table' => 'cust_pkg_usage',
4819 'addl_from' => ' JOIN part_pkg_usage USING (pkgusagepart)'.
4820 ' JOIN cust_pkg USING (pkgnum)'.
4821 ' JOIN part_pkg_usage_class USING (pkgusagepart)',
4822 'select' => 'cust_pkg_usage.*',
4823 'extra_sql' => " WHERE ( cust_pkg.pkgnum = $pkgnum OR ".
4824 " ( cust_pkg.custnum = $custnum AND ".
4825 " part_pkg_usage.shared IS NOT NULL ) ) AND ".
4826 $is_classnum . ' AND '.
4827 " cust_pkg_usage.minutes > 0",
4828 'order_by' => " ORDER BY priority ASC",
4831 my $orig_minutes = $minutes;
4833 while (!$error and $minutes > 0 and @usage_recs) {
4834 my $cust_pkg_usage = shift @usage_recs;
4835 $cust_pkg_usage->select_for_update;
4836 my $cdr_cust_pkg_usage = FS::cdr_cust_pkg_usage->new({
4837 pkgusagenum => $cust_pkg_usage->pkgusagenum,
4838 acctid => $cdr->acctid,
4839 minutes => min($cust_pkg_usage->minutes, $minutes),
4841 $cust_pkg_usage->set('minutes',
4842 $cust_pkg_usage->minutes - $cdr_cust_pkg_usage->minutes
4844 $error = $cust_pkg_usage->replace || $cdr_cust_pkg_usage->insert;
4845 $minutes -= $cdr_cust_pkg_usage->minutes;
4847 if ( $order and $minutes > 0 and !$error ) {
4848 # then try to steal minutes from another call
4850 'table' => 'cdr_cust_pkg_usage',
4851 'addl_from' => ' JOIN cust_pkg_usage USING (pkgusagenum)'.
4852 ' JOIN part_pkg_usage USING (pkgusagepart)'.
4853 ' JOIN cust_pkg USING (pkgnum)'.
4854 ' JOIN part_pkg_usage_class USING (pkgusagepart)'.
4855 ' JOIN cdr USING (acctid)',
4856 'select' => 'cdr_cust_pkg_usage.*',
4857 'extra_sql' => " WHERE cdr.freesidestatus = 'rated' AND ".
4858 " ( cust_pkg.pkgnum = $pkgnum OR ".
4859 " ( cust_pkg.custnum = $custnum AND ".
4860 " part_pkg_usage.shared IS NOT NULL ) ) AND ".
4861 " part_pkg_usage_class.classnum = $classnum",
4862 'order_by' => ' ORDER BY part_pkg_usage.priority ASC',
4864 if ( $order eq 'time' ) {
4865 # find CDRs that are using minutes, but have a later startdate
4867 my $startdate = $cdr->startdate;
4868 if ($startdate !~ /^\d+$/) {
4869 die "bad cdr startdate '$startdate'";
4871 $search{'extra_sql'} .= " AND cdr.startdate > $startdate";
4872 # minimize needless reshuffling
4873 $search{'order_by'} .= ', cdr.startdate DESC';
4875 # XXX may not work correctly with rate_time schedules. Could
4876 # fix this by storing ratedetailnum in cdr_cust_pkg_usage, I
4878 $search{'addl_from'} .=
4879 ' JOIN rate_detail'.
4880 ' ON (cdr.rated_ratedetailnum = rate_detail.ratedetailnum)';
4881 if ( $order eq 'rate_high' ) {
4882 $search{'extra_sql'} .= ' AND rate_detail.min_charge < '.
4883 $rate_detail->min_charge;
4884 $search{'order_by'} .= ', rate_detail.min_charge ASC';
4885 } elsif ( $order eq 'rate_low' ) {
4886 $search{'extra_sql'} .= ' AND rate_detail.min_charge > '.
4887 $rate_detail->min_charge;
4888 $search{'order_by'} .= ', rate_detail.min_charge DESC';
4890 # this should really never happen
4891 die "invalid cdr-minutes_priority value '$order'\n";
4894 my @cdr_usage_recs = qsearch(\%search);
4896 while (!$error and @cdr_usage_recs and $minutes > 0) {
4897 my $cdr_cust_pkg_usage = shift @cdr_usage_recs;
4898 my $cust_pkg_usage = $cdr_cust_pkg_usage->cust_pkg_usage;
4899 my $old_cdr = $cdr_cust_pkg_usage->cdr;
4900 $reproc_cdrs{$old_cdr->acctid} = $old_cdr;
4901 $cdr_cust_pkg_usage->select_for_update;
4902 $old_cdr->select_for_update;
4903 $cust_pkg_usage->select_for_update;
4904 # in case someone else stole the usage from this CDR
4905 # while waiting for the lock...
4906 next if $old_cdr->acctid != $cdr_cust_pkg_usage->acctid;
4907 # steal the usage allocation and flag the old CDR for reprocessing
4908 $cdr_cust_pkg_usage->set('acctid', $cdr->acctid);
4909 # if the allocation is more minutes than we need, adjust it...
4910 my $delta = $cdr_cust_pkg_usage->minutes - $minutes;
4912 $cdr_cust_pkg_usage->set('minutes', $minutes);
4913 $cust_pkg_usage->set('minutes', $cust_pkg_usage->minutes + $delta);
4914 $error = $cust_pkg_usage->replace;
4916 #warn 'CDR '.$cdr->acctid . ' stealing allocation '.$cdr_cust_pkg_usage->cdrusagenum.' from CDR '.$old_cdr->acctid."\n";
4917 $error ||= $cdr_cust_pkg_usage->replace;
4918 # deduct the stolen minutes
4919 $minutes -= $cdr_cust_pkg_usage->minutes;
4921 # after all minute-stealing is done, reset the affected CDRs
4922 foreach (values %reproc_cdrs) {
4923 $error ||= $_->set_status('');
4924 # XXX or should we just call $cdr->rate right here?
4925 # it's not like we can create a loop this way, since the min_charge
4926 # or call time has to go monotonically in one direction.
4927 # we COULD get some very deep recursions going, though...
4929 } # if $order and $minutes
4932 die "error applying included minutes\npkgnum ".$self->pkgnum.", class $classnum, acctid ".$cdr->acctid."\n$error\n"
4934 $dbh->commit if $oldAutoCommit;
4935 return $orig_minutes - $minutes;
4939 =item supplemental_pkgs
4941 Returns a list of all packages supplemental to this one.
4945 sub supplemental_pkgs {
4947 qsearch('cust_pkg', { 'main_pkgnum' => $self->pkgnum });
4952 Returns the package that this one is supplemental to, if any.
4958 if ( $self->main_pkgnum ) {
4959 return FS::cust_pkg->by_key($self->main_pkgnum);
4966 =head1 CLASS METHODS
4972 Returns an SQL expression identifying recurring packages.
4976 sub recurring_sql { "
4977 '0' != ( select freq from part_pkg
4978 where cust_pkg.pkgpart = part_pkg.pkgpart )
4983 Returns an SQL expression identifying one-time packages.
4988 '0' = ( select freq from part_pkg
4989 where cust_pkg.pkgpart = part_pkg.pkgpart )
4994 Returns an SQL expression identifying ordered packages (recurring packages not
5000 $_[0]->recurring_sql. " AND ". $_[0]->not_yet_billed_sql;
5005 Returns an SQL expression identifying active packages.
5010 $_[0]->recurring_sql. "
5011 AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
5012 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
5013 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
5016 =item not_yet_billed_sql
5018 Returns an SQL expression identifying packages which have not yet been billed.
5022 sub not_yet_billed_sql { "
5023 ( cust_pkg.setup IS NULL OR cust_pkg.setup = 0 )
5024 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
5025 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
5030 Returns an SQL expression identifying inactive packages (one-time packages
5031 that are otherwise unsuspended/uncancelled).
5035 sub inactive_sql { "
5036 ". $_[0]->onetime_sql(). "
5037 AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
5038 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
5039 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
5044 Returns an SQL expression identifying on-hold packages.
5049 #$_[0]->recurring_sql(). ' AND '.
5051 ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
5052 AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0
5053 AND ( cust_pkg.setup IS NULL OR cust_pkg.setup = 0 )
5060 Returns an SQL expression identifying suspended packages.
5064 sub suspended_sql { susp_sql(@_); }
5066 #$_[0]->recurring_sql(). ' AND '.
5068 ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
5069 AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0
5070 AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
5077 Returns an SQL exprression identifying cancelled packages.
5081 sub cancelled_sql { cancel_sql(@_); }
5083 #$_[0]->recurring_sql(). ' AND '.
5084 "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
5087 =item ncancelled_recurring_sql
5089 Returns an SQL expression identifying un-cancelled, recurring packages.
5093 sub ncancelled_recurring_sql {
5094 $_[0]->recurring_sql().
5095 " AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 ) ";
5100 Returns an SQL expression to give the package status as a string.
5106 WHEN cust_pkg.cancel IS NOT NULL THEN 'cancelled'
5107 WHEN ( cust_pkg.susp IS NOT NULL AND cust_pkg.setup IS NULL ) THEN 'on hold'
5108 WHEN cust_pkg.susp IS NOT NULL THEN 'suspended'
5109 WHEN cust_pkg.setup IS NULL THEN 'not yet billed'
5110 WHEN ".onetime_sql()." THEN 'one-time charge'
5115 =item search HASHREF
5119 Returns a qsearch hash expression to search for parameters specified in HASHREF.
5120 Valid parameters are
5128 on hold, active, inactive (or one-time charge), suspended, canceled (or cancelled)
5132 Equivalent to "status", except that "canceled"/"cancelled" will exclude
5133 packages that were changed into a new package with the same pkgpart (i.e.
5134 location or quantity changes).
5138 boolean selects custom packages
5144 pkgpart or arrayref or hashref of pkgparts
5148 arrayref of beginning and ending epoch date
5152 arrayref of beginning and ending epoch date
5156 arrayref of beginning and ending epoch date
5160 arrayref of beginning and ending epoch date
5164 arrayref of beginning and ending epoch date
5168 arrayref of beginning and ending epoch date
5172 arrayref of beginning and ending epoch date
5176 pkgnum or APKG_pkgnum
5180 a value suited to passing to FS::UI::Web::cust_header
5184 specifies the user for agent virtualization
5188 boolean; if true, returns only packages with more than 0 FCC phone lines.
5190 =item state, country
5192 Limit to packages with a service location in the specified state and country.
5193 For FCC 477 reporting, mostly.
5197 Limit to packages whose service locations are the same as the customer's
5198 default service location.
5200 =item location_nocust
5202 Limit to packages whose service locations are not the customer's default
5205 =item location_census
5207 Limit to packages whose service locations have census tracts.
5209 =item location_nocensus
5211 Limit to packages whose service locations do not have a census tract.
5213 =item location_geocode
5215 Limit to packages whose locations have geocodes.
5217 =item location_geocode
5219 Limit to packages whose locations do not have geocodes.
5223 Limit to packages associated with a svc_broadband, associated with a sector,
5224 associated with this towernum (or any of these, if it's an arrayref) (or NO
5225 towernum, if it's zero). This is an extreme niche case.
5227 =item 477part, 477rownum, date
5229 Limit to packages included in a specific row of one of the FCC 477 reports.
5230 '477part' is the section name (see L<FS::Report::FCC_477> methods), 'date'
5231 is the report as-of date (completely unrelated to the package setup/bill/
5232 other date fields), and '477rownum' is the row number of the report starting
5233 with zero. Row numbers have no inherent meaning, so this is useful only
5234 for explaining a 477 report you've already run.
5241 my ($class, $params) = @_;
5248 if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
5250 "cust_main.agentnum = $1";
5257 if ( $params->{'cust_status'} =~ /^([a-z]+)$/ ) {
5258 push @where, FS::cust_main->cust_status_sql . " = '$1' ";
5262 # parse customer sales person
5265 if ( $params->{'cust_main_salesnum'} =~ /^(\d+)$/ ) {
5266 push @where, ($1 > 0) ? "cust_main.salesnum = $1"
5267 : 'cust_main.salesnum IS NULL';
5272 # parse sales person
5275 if ( $params->{'salesnum'} =~ /^(\d+)$/ ) {
5276 push @where, ($1 > 0) ? "cust_pkg.salesnum = $1"
5277 : 'cust_pkg.salesnum IS NULL';
5284 if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
5286 "cust_pkg.custnum = $1";
5293 if ( $params->{'pkgbatch'} =~ /^([\w\/\-\:\.]+)$/ and $1 ) {
5295 "cust_pkg.pkgbatch = '$1'";
5302 if ( $params->{'magic'} eq 'active'
5303 || $params->{'status'} eq 'active' ) {
5305 push @where, FS::cust_pkg->active_sql();
5307 } elsif ( $params->{'magic'} =~ /^not[ _]yet[ _]billed$/
5308 || $params->{'status'} =~ /^not[ _]yet[ _]billed$/ ) {
5310 push @where, FS::cust_pkg->not_yet_billed_sql();
5312 } elsif ( $params->{'magic'} =~ /^(one-time charge|inactive)/
5313 || $params->{'status'} =~ /^(one-time charge|inactive)/ ) {
5315 push @where, FS::cust_pkg->inactive_sql();
5317 } elsif ( $params->{'magic'} =~ /^on[ _]hold$/
5318 || $params->{'status'} =~ /^on[ _]hold$/ ) {
5320 push @where, FS::cust_pkg->on_hold_sql();
5323 } elsif ( $params->{'magic'} eq 'suspended'
5324 || $params->{'status'} eq 'suspended' ) {
5326 push @where, FS::cust_pkg->suspended_sql();
5328 } elsif ( $params->{'magic'} =~ /^cancell?ed$/
5329 || $params->{'status'} =~ /^cancell?ed$/ ) {
5331 push @where, FS::cust_pkg->cancelled_sql();
5335 ### special case: "magic" is used in detail links from browse/part_pkg,
5336 # where "cancelled" has the restriction "and not replaced with a package
5337 # of the same pkgpart". Be consistent with that.
5340 if ( $params->{'magic'} =~ /^cancell?ed$/ ) {
5341 my $new_pkgpart = "SELECT pkgpart FROM cust_pkg AS cust_pkg_next ".
5342 "WHERE cust_pkg_next.change_pkgnum = cust_pkg.pkgnum";
5343 # ...may not exist, if this was just canceled and not changed; in that
5344 # case give it a "new pkgpart" that never equals the old pkgpart
5345 push @where, "COALESCE(($new_pkgpart), 0) != cust_pkg.pkgpart";
5349 # parse package class
5352 if ( exists($params->{'classnum'}) ) {
5355 if ( ref($params->{'classnum'}) ) {
5357 if ( ref($params->{'classnum'}) eq 'HASH' ) {
5358 @classnum = grep $params->{'classnum'}{$_}, keys %{ $params->{'classnum'} };
5359 } elsif ( ref($params->{'classnum'}) eq 'ARRAY' ) {
5360 @classnum = @{ $params->{'classnum'} };
5362 die 'unhandled classnum ref '. $params->{'classnum'};
5366 } elsif ( $params->{'classnum'} =~ /^(\d*)$/ && $1 ne '0' ) {
5373 my @nums = grep $_, @classnum;
5374 push @c_where, 'part_pkg.classnum IN ('. join(',',@nums). ')' if @nums;
5375 my $null = scalar( grep { $_ eq '' } @classnum );
5376 push @c_where, 'part_pkg.classnum IS NULL' if $null;
5378 if ( scalar(@c_where) == 1 ) {
5379 push @where, @c_where;
5380 } elsif ( @c_where ) {
5381 push @where, ' ( '. join(' OR ', @c_where). ' ) ';
5390 # parse (customer) refnum (advertising source)
5393 if ( exists($params->{'refnum'}) ) {
5395 if (ref $params->{'refnum'}) {
5396 @refnum = @{ $params->{'refnum'} };
5398 @refnum = ( $params->{'refnum'} );
5400 my $in = join(',', grep /^\d+$/, @refnum);
5401 push @where, "cust_main.refnum IN($in)" if length $in;
5405 # parse package report options
5408 my @report_option = ();
5409 if ( exists($params->{'report_option'}) ) {
5410 if ( ref($params->{'report_option'}) eq 'ARRAY' ) {
5411 @report_option = @{ $params->{'report_option'} };
5412 } elsif ( $params->{'report_option'} =~ /^([,\d]*)$/ ) {
5413 @report_option = split(',', $1);
5418 if (@report_option) {
5419 # this will result in the empty set for the dangling comma case as it should
5421 map{ "0 < ( SELECT count(*) FROM part_pkg_option
5422 WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
5423 AND optionname = 'report_option_$_'
5424 AND optionvalue = '1' )"
5428 foreach my $any ( grep /^report_option_any/, keys %$params ) {
5430 my @report_option_any = ();
5431 if ( ref($params->{$any}) eq 'ARRAY' ) {
5432 @report_option_any = @{ $params->{$any} };
5433 } elsif ( $params->{$any} =~ /^([,\d]*)$/ ) {
5434 @report_option_any = split(',', $1);
5437 if (@report_option_any) {
5438 # this will result in the empty set for the dangling comma case as it should
5439 push @where, ' ( '. join(' OR ',
5440 map{ "0 < ( SELECT count(*) FROM part_pkg_option
5441 WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
5442 AND optionname = 'report_option_$_'
5443 AND optionvalue = '1' )"
5444 } @report_option_any
5454 push @where, "part_pkg.custom = 'Y'" if $params->{custom};
5460 push @where, "(part_pkg.fcc_ds0s > 0 OR pkg_class.fcc_ds0s > 0)"
5461 if $params->{fcc_line};
5467 if ( exists($params->{'censustract'}) ) {
5468 $params->{'censustract'} =~ /^([.\d]*)$/;
5469 my $censustract = "cust_location.censustract = '$1'";
5470 $censustract .= ' OR cust_location.censustract is NULL' unless $1;
5471 push @where, "( $censustract )";
5475 # parse censustract2
5477 if ( exists($params->{'censustract2'})
5478 && $params->{'censustract2'} =~ /^(\d*)$/
5482 push @where, "cust_location.censustract LIKE '$1%'";
5485 "( cust_location.censustract = '' OR cust_location.censustract IS NULL )";
5490 # parse country/state/zip
5492 for (qw(state country)) { # parsing rules are the same for these
5493 if ( exists($params->{$_})
5494 && uc($params->{$_}) =~ /^([A-Z]{2})$/ )
5496 # XXX post-2.3 only--before that, state/country may be in cust_main
5497 push @where, "cust_location.$_ = '$1'";
5500 if ( exists($params->{zip}) ) {
5501 push @where, "cust_location.zip = " . dbh->quote($params->{zip});
5507 if ( $params->{location_cust} xor $params->{location_nocust} ) {
5508 my $op = $params->{location_cust} ? '=' : '!=';
5509 push @where, "cust_location.locationnum $op cust_main.ship_locationnum";
5511 if ( $params->{location_census} xor $params->{location_nocensus} ) {
5512 my $op = $params->{location_census} ? "IS NOT NULL" : "IS NULL";
5513 push @where, "cust_location.censustract $op";
5515 if ( $params->{location_geocode} xor $params->{location_nogeocode} ) {
5516 my $op = $params->{location_geocode} ? "IS NOT NULL" : "IS NULL";
5517 push @where, "cust_location.geocode $op";
5524 if ( ref($params->{'pkgpart'}) ) {
5527 if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
5528 @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
5529 } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
5530 @pkgpart = @{ $params->{'pkgpart'} };
5532 die 'unhandled pkgpart ref '. $params->{'pkgpart'};
5535 @pkgpart = grep /^(\d+)$/, @pkgpart;
5537 push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
5539 } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
5540 push @where, "pkgpart = $1";
5549 #false laziness w/report_cust_pkg.html
5552 'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
5553 'active' => { 'susp'=>1, 'cancel'=>1 },
5554 'suspended' => { 'cancel' => 1 },
5559 if( exists($params->{'active'} ) ) {
5560 # This overrides all the other date-related fields, and includes packages
5561 # that were active at some time during the interval. It excludes:
5562 # - packages that were set up after the end of the interval
5563 # - packages that were canceled before the start of the interval
5564 # - packages that were suspended before the start of the interval
5565 # and are still suspended now
5566 my($beginning, $ending) = @{$params->{'active'}};
5568 "cust_pkg.setup IS NOT NULL",
5569 "cust_pkg.setup <= $ending",
5570 "(cust_pkg.cancel IS NULL OR cust_pkg.cancel >= $beginning )",
5571 "(cust_pkg.susp IS NULL OR cust_pkg.susp >= $beginning )",
5572 "NOT (".FS::cust_pkg->onetime_sql . ")";
5575 my $exclude_change_from = 0;
5576 my $exclude_change_to = 0;
5578 foreach my $field (qw( setup last_bill bill adjourn susp expire contract_end change_date cancel )) {
5580 if ( $params->{$field.'_null'} ) {
5582 push @where, "cust_pkg.$field IS NULL";
5583 # this should surely be obsoleted by now: OR cust_pkg.$field == 0
5587 next unless exists($params->{$field});
5589 my($beginning, $ending) = @{$params->{$field}};
5591 next if $beginning == 0 && $ending == 4294967295;
5594 "cust_pkg.$field IS NOT NULL",
5595 "cust_pkg.$field >= $beginning",
5596 "cust_pkg.$field <= $ending";
5598 $orderby ||= "ORDER BY cust_pkg.$field";
5600 if ( $field eq 'setup' ) {
5601 $exclude_change_from = 1;
5602 } elsif ( $field eq 'cancel' ) {
5603 $exclude_change_to = 1;
5604 } elsif ( $field eq 'change_date' ) {
5605 # if we are given setup and change_date ranges, and the setup date
5606 # falls in _both_ ranges, then include the package whether it was
5608 $exclude_change_from = 0;
5614 if ($exclude_change_from) {
5615 push @where, "change_pkgnum IS NULL";
5617 if ($exclude_change_to) {
5618 # a join might be more efficient here
5619 push @where, "NOT EXISTS(
5620 SELECT 1 FROM cust_pkg AS changed_to_pkg
5621 WHERE cust_pkg.pkgnum = changed_to_pkg.change_pkgnum
5627 $orderby ||= 'ORDER BY bill';
5630 # parse magic, legacy, etc.
5633 if ( $params->{'magic'} &&
5634 $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
5637 $orderby = 'ORDER BY pkgnum';
5639 if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
5640 push @where, "pkgpart = $1";
5643 } elsif ( $params->{'query'} eq 'pkgnum' ) {
5645 $orderby = 'ORDER BY pkgnum';
5647 } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
5649 $orderby = 'ORDER BY pkgnum';
5652 SELECT count(*) FROM pkg_svc
5653 WHERE pkg_svc.pkgpart = cust_pkg.pkgpart
5654 AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
5655 WHERE cust_svc.pkgnum = cust_pkg.pkgnum
5656 AND cust_svc.svcpart = pkg_svc.svcpart
5663 # parse the extremely weird 'towernum' param
5666 if ($params->{towernum}) {
5667 my $towernum = $params->{towernum};
5668 $towernum = [ $towernum ] if !ref($towernum);
5669 my $in = join(',', grep /^\d+$/, @$towernum);
5671 # inefficient, but this is an obscure feature
5672 eval "use FS::Report::Table";
5673 FS::Report::Table->_init_tower_pkg_cache; # probably does nothing
5674 push @where, "EXISTS(
5675 SELECT 1 FROM tower_pkg_cache
5676 WHERE tower_pkg_cache.pkgnum = cust_pkg.pkgnum
5677 AND tower_pkg_cache.towernum IN ($in)
5683 # parse the 477 report drill-down options
5686 if ($params->{'477part'} =~ /^([a-z]+)$/) {
5688 my ($date, $rownum, $agentnum);
5689 if ($params->{'date'} =~ /^(\d+)$/) {
5692 if ($params->{'477rownum'} =~ /^(\d+)$/) {
5695 if ($params->{'agentnum'} =~ /^(\d+)$/) {
5698 if ($date and defined($rownum)) {
5699 my $report = FS::Report::FCC_477->report($section,
5701 'agentnum' => $agentnum,
5704 my $pkgnums = $report->{detail}->[$rownum]
5705 or die "row $rownum is past the end of the report";
5706 # '0' so that if there are no pkgnums (empty string) it will create
5707 # a valid query that returns nothing
5708 warn "PKGNUMS:\n$pkgnums\n\n"; # XXX debug
5710 # and this overrides everything
5711 @where = ( "cust_pkg.pkgnum IN($pkgnums)" );
5712 } # else we're missing some params, ignore the whole business
5716 # setup queries, links, subs, etc. for the search
5719 # here is the agent virtualization
5720 if ($params->{CurrentUser}) {
5722 qsearchs('access_user', { username => $params->{CurrentUser} });
5725 push @where, $access_user->agentnums_sql('table'=>'cust_main');
5730 push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
5733 my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
5735 my $addl_from = 'LEFT JOIN part_pkg USING ( pkgpart ) '.
5736 'LEFT JOIN pkg_class ON ( part_pkg.classnum = pkg_class.classnum ) '.
5737 'LEFT JOIN cust_location USING ( locationnum ) '.
5738 FS::UI::Web::join_cust_main('cust_pkg', 'cust_pkg');
5742 if ( $params->{'select_zip5'} ) {
5743 my $zip = 'cust_location.zip';
5745 $select = "DISTINCT substr($zip,1,5) as zip";
5746 $orderby = "ORDER BY substr($zip,1,5)";
5747 $count_query = "SELECT COUNT( DISTINCT substr($zip,1,5) )";
5749 $select = join(', ',
5751 ( map "part_pkg.$_", qw( pkg freq ) ),
5752 'pkg_class.classname',
5753 'cust_main.custnum AS cust_main_custnum',
5754 FS::UI::Web::cust_sql_fields(
5755 $params->{'cust_fields'}
5758 $count_query = 'SELECT COUNT(*)';
5761 $count_query .= " FROM cust_pkg $addl_from $extra_sql";
5764 'table' => 'cust_pkg',
5766 'select' => $select,
5767 'extra_sql' => $extra_sql,
5768 'order_by' => $orderby,
5769 'addl_from' => $addl_from,
5770 'count_query' => $count_query,
5777 Returns a list of two package counts. The first is a count of packages
5778 based on the supplied criteria and the second is the count of residential
5779 packages with those same criteria. Criteria are specified as in the search
5785 my ($class, $params) = @_;
5787 my $sql_query = $class->search( $params );
5789 my $count_sql = delete($sql_query->{'count_query'});
5790 $count_sql =~ s/ FROM/,count(CASE WHEN cust_main.company IS NULL OR cust_main.company = '' THEN 1 END) FROM/
5791 or die "couldn't parse count_sql";
5793 my $count_sth = dbh->prepare($count_sql)
5794 or die "Error preparing $count_sql: ". dbh->errstr;
5796 or die "Error executing $count_sql: ". $count_sth->errstr;
5797 my $count_arrayref = $count_sth->fetchrow_arrayref;
5799 return ( @$count_arrayref );
5803 =item tax_locationnum_sql
5805 Returns an SQL expression for the tax location for a package, based
5806 on the settings of 'tax-pkg_address' and 'tax-ship_address'.
5810 sub tax_locationnum_sql {
5811 my $conf = FS::Conf->new;
5812 if ( $conf->exists('tax-pkg_address') ) {
5813 'cust_pkg.locationnum';
5815 elsif ( $conf->exists('tax-ship_address') ) {
5816 'cust_main.ship_locationnum';
5819 'cust_main.bill_locationnum';
5825 Returns a list: the first item is an SQL fragment identifying matching
5826 packages/customers via location (taking into account shipping and package
5827 address taxation, if enabled), and subsequent items are the parameters to
5828 substitute for the placeholders in that fragment.
5833 my($class, %opt) = @_;
5834 my $ornull = $opt{'ornull'};
5836 my $conf = new FS::Conf;
5838 # '?' placeholders in _location_sql_where
5839 my $x = $ornull ? 3 : 2;
5850 if ( $conf->exists('tax-ship_address') ) {
5853 ( ( ship_last IS NULL OR ship_last = '' )
5854 AND ". _location_sql_where('cust_main', '', $ornull ). "
5856 OR ( ship_last IS NOT NULL AND ship_last != ''
5857 AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
5860 # AND payby != 'COMP'
5862 @main_param = ( @bill_param, @bill_param );
5866 $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
5867 @main_param = @bill_param;
5873 if ( $conf->exists('tax-pkg_address') ) {
5875 my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
5878 ( cust_pkg.locationnum IS NULL AND $main_where )
5879 OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where )
5882 @param = ( @main_param, @bill_param );
5886 $where = $main_where;
5887 @param = @main_param;
5895 #subroutine, helper for location_sql
5896 sub _location_sql_where {
5898 my $prefix = @_ ? shift : '';
5899 my $ornull = @_ ? shift : '';
5901 # $ornull = $ornull ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
5903 $ornull = $ornull ? ' OR ? IS NULL ' : '';
5905 my $or_empty_city = " OR ( ? = '' AND $table.${prefix}city IS NULL )";
5906 my $or_empty_county = " OR ( ? = '' AND $table.${prefix}county IS NULL )";
5907 my $or_empty_state = " OR ( ? = '' AND $table.${prefix}state IS NULL )";
5909 my $text = (driver_name =~ /^mysql/i) ? 'char' : 'text';
5911 # ( $table.${prefix}city = ? $or_empty_city $ornull )
5913 ( $table.district = ? OR ? = '' OR CAST(? AS $text) IS NULL )
5914 AND ( $table.${prefix}city = ? OR ? = '' OR CAST(? AS $text) IS NULL )
5915 AND ( $table.${prefix}county = ? $or_empty_county $ornull )
5916 AND ( $table.${prefix}state = ? $or_empty_state $ornull )
5917 AND $table.${prefix}country = ?
5922 my( $self, $what ) = @_;
5924 my $what_show_zero = $what. '_show_zero';
5925 length($self->$what_show_zero())
5926 ? ($self->$what_show_zero() eq 'Y')
5927 : $self->part_pkg->$what_show_zero();
5934 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
5936 Bulk cancel + order subroutine. Perhaps slightly deprecated, only used by the
5937 bulk cancel+order in the web UI and nowhere else (edit/process/cust_pkg.cgi)
5939 CUSTNUM is a customer (see L<FS::cust_main>)
5941 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
5942 L<FS::part_pkg>) to order for this customer. Duplicates are of course
5945 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
5946 remove for this customer. The services (see L<FS::cust_svc>) are moved to the
5947 new billing items. An error is returned if this is not possible (see
5948 L<FS::pkg_svc>). An empty arrayref is equivalent to not specifying this
5951 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
5952 newly-created cust_pkg objects.
5954 REFNUM, if specified, will specify the FS::pkg_referral record to be created
5955 and inserted. Multiple FS::pkg_referral records can be created by
5956 setting I<refnum> to an array reference of refnums or a hash reference with
5957 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
5958 record will be created corresponding to cust_main.refnum.
5963 my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
5965 my $conf = new FS::Conf;
5967 # Transactionize this whole mess
5968 local $SIG{HUP} = 'IGNORE';
5969 local $SIG{INT} = 'IGNORE';
5970 local $SIG{QUIT} = 'IGNORE';
5971 local $SIG{TERM} = 'IGNORE';
5972 local $SIG{TSTP} = 'IGNORE';
5973 local $SIG{PIPE} = 'IGNORE';
5975 my $oldAutoCommit = $FS::UID::AutoCommit;
5976 local $FS::UID::AutoCommit = 0;
5980 # my $cust_main = qsearchs('cust_main', { custnum => $custnum });
5981 # return "Customer not found: $custnum" unless $cust_main;
5983 warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
5986 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
5989 my $change = scalar(@old_cust_pkg) != 0;
5992 if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
5994 warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
5995 " to pkgpart ". $pkgparts->[0]. "\n"
5998 my $err_or_cust_pkg =
5999 $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
6000 'refnum' => $refnum,
6003 unless (ref($err_or_cust_pkg)) {
6004 $dbh->rollback if $oldAutoCommit;
6005 return $err_or_cust_pkg;
6008 push @$return_cust_pkg, $err_or_cust_pkg;
6009 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
6014 # Create the new packages.
6015 foreach my $pkgpart (@$pkgparts) {
6017 warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
6019 my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
6020 pkgpart => $pkgpart,
6024 $error = $cust_pkg->insert( 'change' => $change );
6025 push @$return_cust_pkg, $cust_pkg;
6027 foreach my $link ($cust_pkg->part_pkg->supp_part_pkg_link) {
6028 my $supp_pkg = FS::cust_pkg->new({
6029 custnum => $custnum,
6030 pkgpart => $link->dst_pkgpart,
6032 main_pkgnum => $cust_pkg->pkgnum,
6035 $error ||= $supp_pkg->insert( 'change' => $change );
6036 push @$return_cust_pkg, $supp_pkg;
6040 $dbh->rollback if $oldAutoCommit;
6045 # $return_cust_pkg now contains refs to all of the newly
6048 # Transfer services and cancel old packages.
6049 foreach my $old_pkg (@old_cust_pkg) {
6051 warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
6054 foreach my $new_pkg (@$return_cust_pkg) {
6055 $error = $old_pkg->transfer($new_pkg);
6056 if ($error and $error == 0) {
6057 # $old_pkg->transfer failed.
6058 $dbh->rollback if $oldAutoCommit;
6063 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
6064 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
6065 foreach my $new_pkg (@$return_cust_pkg) {
6066 $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
6067 if ($error and $error == 0) {
6068 # $old_pkg->transfer failed.
6069 $dbh->rollback if $oldAutoCommit;
6076 # Transfers were successful, but we went through all of the
6077 # new packages and still had services left on the old package.
6078 # We can't cancel the package under the circumstances, so abort.
6079 $dbh->rollback if $oldAutoCommit;
6080 return "Unable to transfer all services from package ".$old_pkg->pkgnum;
6082 $error = $old_pkg->cancel( quiet=>1, 'no_delay_cancel'=>1 );
6088 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
6092 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
6094 A bulk change method to change packages for multiple customers.
6096 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
6097 L<FS::part_pkg>) to order for each customer. Duplicates are of course
6100 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
6101 replace. The services (see L<FS::cust_svc>) are moved to the
6102 new billing items. An error is returned if this is not possible (see
6105 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
6106 newly-created cust_pkg objects.
6111 my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
6113 # Transactionize this whole mess
6114 local $SIG{HUP} = 'IGNORE';
6115 local $SIG{INT} = 'IGNORE';
6116 local $SIG{QUIT} = 'IGNORE';
6117 local $SIG{TERM} = 'IGNORE';
6118 local $SIG{TSTP} = 'IGNORE';
6119 local $SIG{PIPE} = 'IGNORE';
6121 my $oldAutoCommit = $FS::UID::AutoCommit;
6122 local $FS::UID::AutoCommit = 0;
6126 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
6129 while(scalar(@old_cust_pkg)) {
6131 my $custnum = $old_cust_pkg[0]->custnum;
6132 my (@remove) = map { $_->pkgnum }
6133 grep { $_->custnum == $custnum } @old_cust_pkg;
6134 @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
6136 my $error = order $custnum, $pkgparts, \@remove, \@return;
6138 push @errors, $error
6140 push @$return_cust_pkg, @return;
6143 if (scalar(@errors)) {
6144 $dbh->rollback if $oldAutoCommit;
6145 return join(' / ', @errors);
6148 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
6152 =item forward_emails
6154 Returns a hash of svcnums and corresponding email addresses
6155 for svc_acct services that can be used as source or dest
6156 for svc_forward services provisioned in this package.
6158 Accepts options I<svc_forward> OR I<svcnum> for a svc_forward
6159 service; if included, will ensure the current values of the
6160 specified service are included in the list, even if for some
6161 other reason they wouldn't be. If called as a class method
6162 with a specified service, returns only these current values.
6164 Caution: does not actually check if svc_forward services are
6165 available to be provisioned on this package.
6169 sub forward_emails {
6173 #load optional service, thoroughly validated
6174 die "Use svcnum or svc_forward, not both"
6175 if $opt{'svcnum'} && $opt{'svc_forward'};
6176 my $svc_forward = $opt{'svc_forward'};
6177 $svc_forward ||= qsearchs('svc_forward',{ 'svcnum' => $opt{'svcnum'} })
6179 die "Specified service is not a forward service"
6180 if $svc_forward && (ref($svc_forward) ne 'FS::svc_forward');
6181 die "Specified service not found"
6182 if ($opt{'svcnum'} || $opt{'svc_forward'}) && !$svc_forward;
6186 ## everything below was basically copied from httemplate/edit/svc_forward.cgi
6187 ## with minimal refactoring, not sure why we can't just load all svc_accts for this custnum
6189 #add current values from specified service, if there was one
6191 foreach my $method (qw( srcsvc_acct dstsvc_acct )) {
6192 my $svc_acct = $svc_forward->$method();
6193 $email{$svc_acct->svcnum} = $svc_acct->email if $svc_acct;
6197 if (ref($self) eq 'FS::cust_pkg') {
6199 #and including the rest for this customer
6200 my($u_part_svc,@u_acct_svcparts);
6201 foreach $u_part_svc ( qsearch('part_svc',{'svcdb'=>'svc_acct'}) ) {
6202 push @u_acct_svcparts,$u_part_svc->getfield('svcpart');
6205 my $custnum = $self->getfield('custnum');
6206 foreach my $i_cust_pkg ( qsearch('cust_pkg',{'custnum'=>$custnum}) ) {
6207 my $cust_pkgnum = $i_cust_pkg->getfield('pkgnum');
6208 #now find the corresponding record(s) in cust_svc (for this pkgnum!)
6209 foreach my $acct_svcpart (@u_acct_svcparts) {
6210 foreach my $i_cust_svc (
6211 qsearch( 'cust_svc', { 'pkgnum' => $cust_pkgnum,
6212 'svcpart' => $acct_svcpart } )
6214 my $svc_acct = qsearchs( 'svc_acct', { 'svcnum' => $i_cust_svc->svcnum } );
6215 $email{$svc_acct->svcnum} = $svc_acct->email;
6224 # Used by FS::Upgrade to migrate to a new database.
6225 sub _upgrade_data { # class method
6226 my ($class, %opts) = @_;
6227 $class->_upgrade_otaker(%opts);
6229 # RT#10139, bug resulting in contract_end being set when it shouldn't
6230 'UPDATE cust_pkg SET contract_end = NULL WHERE contract_end = -1',
6231 # RT#10830, bad calculation of prorate date near end of year
6232 # the date range for bill is December 2009, and we move it forward
6233 # one year if it's before the previous bill date (which it should
6235 'UPDATE cust_pkg SET bill = bill + (365*24*60*60) WHERE bill < last_bill
6236 AND bill > 1259654400 AND bill < 1262332800 AND (SELECT plan FROM part_pkg
6237 WHERE part_pkg.pkgpart = cust_pkg.pkgpart) = \'prorate\'',
6238 # RT6628, add order_date to cust_pkg
6239 'update cust_pkg set order_date = (select history_date from h_cust_pkg
6240 where h_cust_pkg.pkgnum = cust_pkg.pkgnum and
6241 history_action = \'insert\') where order_date is null',
6243 foreach my $sql (@statements) {
6244 my $sth = dbh->prepare($sql);
6245 $sth->execute or die $sth->errstr;
6248 # RT31194: supplemental package links that are deleted don't clean up
6250 my @pkglinknums = qsearch({
6251 'select' => 'DISTINCT cust_pkg.pkglinknum',
6252 'table' => 'cust_pkg',
6253 'addl_from' => ' LEFT JOIN part_pkg_link USING (pkglinknum) ',
6254 'extra_sql' => ' WHERE cust_pkg.pkglinknum IS NOT NULL
6255 AND part_pkg_link.pkglinknum IS NULL',
6257 foreach (@pkglinknums) {
6258 my $pkglinknum = $_->pkglinknum;
6259 warn "cleaning part_pkg_link #$pkglinknum\n";
6260 my $part_pkg_link = FS::part_pkg_link->new({pkglinknum => $pkglinknum});
6261 my $error = $part_pkg_link->remove_linked;
6262 die $error if $error;
6265 # RT#73607: canceling a package with billing addons sometimes changes its
6267 # Find records where the last replace_new record for the package before it
6268 # was canceled has a different pkgpart from the package itself.
6269 my @cust_pkg = qsearch({
6270 'table' => 'cust_pkg',
6271 'select' => 'cust_pkg.*, h_cust_pkg.pkgpart AS h_pkgpart',
6272 'addl_from' => ' JOIN (
6273 SELECT pkgnum, MAX(historynum) AS historynum FROM h_cust_pkg
6274 WHERE cancel IS NULL
6275 AND history_action = \'replace_new\'
6277 ) AS last_history USING (pkgnum)
6278 JOIN h_cust_pkg USING (historynum)',
6279 'extra_sql' => ' WHERE cust_pkg.cancel is not null
6280 AND cust_pkg.pkgpart != h_cust_pkg.pkgpart'
6282 foreach my $cust_pkg ( @cust_pkg ) {
6283 my $pkgnum = $cust_pkg->pkgnum;
6284 warn "fixing pkgpart on canceled pkg#$pkgnum\n";
6285 $cust_pkg->set('pkgpart', $cust_pkg->h_pkgpart);
6286 my $error = $cust_pkg->replace;
6287 die $error if $error;
6292 # will autoload in v4+
6293 sub rt_field_charge {
6295 qsearch('rt_field_charge',{ 'pkgnum' => $self->pkgnum });
6302 sub order is not OO. Perhaps it should be moved to FS::cust_main and made so?
6304 In sub order, the @pkgparts array (passed by reference) is clobbered.
6306 Also in sub order, no money is adjusted. Once FS::part_pkg defines a standard
6307 method to pass dates to the recur_prog expression, it should do so.
6309 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
6310 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
6311 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
6312 configuration values. Probably need a subroutine which decides what to do
6313 based on whether or not we've fetched the user yet, rather than a hash. See
6314 FS::UID and the TODO.
6316 Now that things are transactional should the check in the insert method be
6321 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
6322 L<FS::pkg_svc>, schema.html from the base documentation