2 use base qw( FS::otaker_Mixin FS::cust_main_Mixin FS::Sales_Mixin
3 FS::contact_Mixin FS::location_Mixin
4 FS::m2m_Common FS::option_Common );
8 use Scalar::Util qw( blessed );
9 use List::Util qw(min max);
11 use Time::Local qw( timelocal timelocal_nocheck );
13 use FS::UID qw( dbh driver_name );
14 use FS::Misc qw( send_email );
15 use FS::Record qw( qsearch qsearchs fields );
21 use FS::cust_location;
23 use FS::cust_bill_pkg;
24 use FS::cust_pkg_detail;
25 use FS::cust_pkg_usage;
26 use FS::cdr_cust_pkg_usage;
31 use FS::cust_pkg_reason;
33 use FS::cust_pkg_discount;
40 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
42 # because they load configuration by setting FS::UID::callback (see TODO)
48 # for sending cancel emails in sub cancel
51 our ($disable_agentcheck, $DEBUG, $me, $import) = (0, 0, '[FS::cust_pkg]', 0);
53 our $upgrade = 0; #go away after setup+start dates cleaned up for old customers
57 my ( $hashref, $cache ) = @_;
58 #if ( $hashref->{'pkgpart'} ) {
59 if ( $hashref->{'pkg'} ) {
60 # #@{ $self->{'_pkgnum'} } = ();
61 # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
62 # $self->{'_pkgpart'} = $subcache;
63 # #push @{ $self->{'_pkgnum'} },
64 # FS::part_pkg->new_or_cached($hashref, $subcache);
65 $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
67 if ( exists $hashref->{'svcnum'} ) {
68 #@{ $self->{'_pkgnum'} } = ();
69 my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
70 $self->{'_svcnum'} = $subcache;
71 #push @{ $self->{'_pkgnum'} },
72 FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
78 FS::cust_pkg - Object methods for cust_pkg objects
84 $record = new FS::cust_pkg \%hash;
85 $record = new FS::cust_pkg { 'column' => 'value' };
87 $error = $record->insert;
89 $error = $new_record->replace($old_record);
91 $error = $record->delete;
93 $error = $record->check;
95 $error = $record->cancel;
97 $error = $record->suspend;
99 $error = $record->unsuspend;
101 $part_pkg = $record->part_pkg;
103 @labels = $record->labels;
105 $seconds = $record->seconds_since($timestamp);
107 $error = FS::cust_pkg::order( $custnum, \@pkgparts );
108 $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
112 An FS::cust_pkg object represents a customer billing item. FS::cust_pkg
113 inherits from FS::Record. The following fields are currently supported:
119 Primary key (assigned automatically for new billing items)
123 Customer (see L<FS::cust_main>)
127 Billing item definition (see L<FS::part_pkg>)
131 Optional link to package location (see L<FS::location>)
135 date package was ordered (also remains same on changes)
147 date (next bill date)
175 order taker (see L<FS::access_user>)
179 If this field is set to 1, disables the automatic
180 unsuspension of this package when using the B<unsuspendauto> config option.
184 If not set, defaults to 1
188 Date of change from previous package
198 =item change_locationnum
206 The pkgnum of the package that this package is supplemental to, if any.
210 The package link (L<FS::part_pkg_link>) that defines this supplemental
211 package, if it is one.
213 =item change_to_pkgnum
215 The pkgnum of the package this one will be "changed to" in the future
216 (on its expiration date).
220 Note: setup, last_bill, bill, adjourn, susp, expire, cancel and change_date
221 are specified as UNIX timestamps; see L<perlfunc/"time">. Also see
222 L<Time::Local> and L<Date::Parse> for conversion functions.
230 Create a new billing item. To add the item to the database, see L<"insert">.
234 sub table { 'cust_pkg'; }
235 sub cust_linked { $_[0]->cust_main_custnum || $_[0]->custnum }
236 sub cust_unlinked_msg {
238 "WARNING: can't find cust_main.custnum ". $self->custnum.
239 ' (cust_pkg.pkgnum '. $self->pkgnum. ')';
242 =item insert [ OPTION => VALUE ... ]
244 Adds this billing item to the database ("Orders" the item). If there is an
245 error, returns the error, otherwise returns false.
247 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
248 will be used to look up the package definition and agent restrictions will be
251 If the additional field I<refnum> is defined, an FS::pkg_referral record will
252 be created and inserted. Multiple FS::pkg_referral records can be created by
253 setting I<refnum> to an array reference of refnums or a hash reference with
254 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
255 record will be created corresponding to cust_main.refnum.
257 If the additional field I<cust_pkg_usageprice> is defined, it will be treated
258 as an arrayref of FS::cust_pkg_usageprice objects, which will be inserted.
259 (Note that this field cannot be set with a usual ->cust_pkg_usageprice method.
260 It can be set as part of the hash when creating the object, or with the B<set>
263 The following options are available:
269 If set true, supresses actions that should only be taken for new package
270 orders. (Currently this includes: intro periods when delay_setup is on.)
274 cust_pkg_option records will be created
278 a ticket will be added to this customer with this subject
282 an optional queue name for ticket additions
286 Don't check the legality of the package definition. This should be used
287 when performing a package change that doesn't change the pkgpart (i.e.
295 my( $self, %options ) = @_;
298 $error = $self->check_pkgpart unless $options{'allow_pkgpart'};
299 return $error if $error;
301 my $part_pkg = $self->part_pkg;
304 # if the package def says to start only on the first of the month:
305 if ( $part_pkg->option('start_1st', 1) && !$self->start_date ) {
306 my ($sec,$min,$hour,$mday,$mon,$year) = (localtime(time) )[0,1,2,3,4,5];
307 $mon += 1 unless $mday == 1;
308 until ( $mon < 12 ) { $mon -= 12; $year++; }
309 $self->start_date( timelocal_nocheck(0,0,0,1,$mon,$year) );
312 # set up any automatic expire/adjourn/contract_end timers
313 # based on the start date
314 foreach my $action ( qw(expire adjourn contract_end) ) {
315 my $months = $part_pkg->option("${action}_months",1);
316 if($months and !$self->$action) {
317 my $start = $self->start_date || $self->setup || time;
318 $self->$action( $part_pkg->add_freq($start, $months) );
322 # if this package has "free days" and delayed setup fee, tehn
323 # set start date that many days in the future.
324 # (this should have been set in the UI, but enforce it here)
325 if ( ! $options{'change'}
326 && ( my $free_days = $part_pkg->option('free_days',1) )
327 && $part_pkg->option('delay_setup',1)
328 #&& ! $self->start_date
331 $self->start_date( $part_pkg->default_start_date );
335 # set order date unless it was specified as part of an import
336 $self->order_date(time) unless $import && $self->order_date;
338 local $SIG{HUP} = 'IGNORE';
339 local $SIG{INT} = 'IGNORE';
340 local $SIG{QUIT} = 'IGNORE';
341 local $SIG{TERM} = 'IGNORE';
342 local $SIG{TSTP} = 'IGNORE';
343 local $SIG{PIPE} = 'IGNORE';
345 my $oldAutoCommit = $FS::UID::AutoCommit;
346 local $FS::UID::AutoCommit = 0;
349 $error = $self->SUPER::insert($options{options} ? %{$options{options}} : ());
351 $dbh->rollback if $oldAutoCommit;
355 $self->refnum($self->cust_main->refnum) unless $self->refnum;
356 $self->refnum( [ $self->refnum ] ) unless ref($self->refnum);
357 $self->process_m2m( 'link_table' => 'pkg_referral',
358 'target_table' => 'part_referral',
359 'params' => $self->refnum,
362 if ( $self->hashref->{cust_pkg_usageprice} ) {
363 for my $cust_pkg_usageprice ( @{ $self->hashref->{cust_pkg_usageprice} } ) {
364 $cust_pkg_usageprice->pkgnum( $self->pkgnum );
365 my $error = $cust_pkg_usageprice->insert;
367 $dbh->rollback if $oldAutoCommit;
373 if ( $self->discountnum ) {
374 my $error = $self->insert_discount();
376 $dbh->rollback if $oldAutoCommit;
381 my $conf = new FS::Conf;
383 if ( ! $import && $conf->config('ticket_system') && $options{ticket_subject} ) {
385 #this init stuff is still inefficient, but at least its limited to
386 # the small number (any?) folks using ticket emailing on pkg order
389 # use lib ( "/opt/rt3/local/lib", "/opt/rt3/lib" );
396 use FS::TicketSystem;
397 FS::TicketSystem->init();
399 my $q = new RT::Queue($RT::SystemUser);
400 $q->Load($options{ticket_queue}) if $options{ticket_queue};
401 my $t = new RT::Ticket($RT::SystemUser);
402 my $mime = new MIME::Entity;
403 $mime->build( Type => 'text/plain', Data => $options{ticket_subject} );
404 $t->Create( $options{ticket_queue} ? (Queue => $q) : (),
405 Subject => $options{ticket_subject},
408 $t->AddLink( Type => 'MemberOf',
409 Target => 'freeside://freeside/cust_main/'. $self->custnum,
413 if (! $import && $conf->config('welcome_letter') && $self->cust_main->num_pkgs == 1) {
414 my $queue = new FS::queue {
415 'job' => 'FS::cust_main::queueable_print',
417 $error = $queue->insert(
418 'custnum' => $self->custnum,
419 'template' => 'welcome_letter',
423 warn "can't send welcome letter: $error";
428 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
435 This method now works but you probably shouldn't use it.
437 You don't want to delete packages, because there would then be no record
438 the customer ever purchased the package. Instead, see the cancel method and
439 hide cancelled packages.
446 local $SIG{HUP} = 'IGNORE';
447 local $SIG{INT} = 'IGNORE';
448 local $SIG{QUIT} = 'IGNORE';
449 local $SIG{TERM} = 'IGNORE';
450 local $SIG{TSTP} = 'IGNORE';
451 local $SIG{PIPE} = 'IGNORE';
453 my $oldAutoCommit = $FS::UID::AutoCommit;
454 local $FS::UID::AutoCommit = 0;
457 foreach my $cust_pkg_discount ($self->cust_pkg_discount) {
458 my $error = $cust_pkg_discount->delete;
460 $dbh->rollback if $oldAutoCommit;
464 #cust_bill_pkg_discount?
466 foreach my $cust_pkg_detail ($self->cust_pkg_detail) {
467 my $error = $cust_pkg_detail->delete;
469 $dbh->rollback if $oldAutoCommit;
474 foreach my $cust_pkg_reason (
476 'table' => 'cust_pkg_reason',
477 'hashref' => { 'pkgnum' => $self->pkgnum },
481 my $error = $cust_pkg_reason->delete;
483 $dbh->rollback if $oldAutoCommit;
490 my $error = $self->SUPER::delete(@_);
492 $dbh->rollback if $oldAutoCommit;
496 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
502 =item replace [ OLD_RECORD ] [ HASHREF | OPTION => VALUE ... ]
504 Replaces the OLD_RECORD with this one in the database. If there is an error,
505 returns the error, otherwise returns false.
507 Currently, custnum, setup, bill, adjourn, susp, expire, and cancel may be changed.
509 Changing pkgpart may have disasterous effects. See the order subroutine.
511 setup and bill are normally updated by calling the bill method of a customer
512 object (see L<FS::cust_main>).
514 suspend is normally updated by the suspend and unsuspend methods.
516 cancel is normally updated by the cancel method (and also the order subroutine
519 Available options are:
525 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.
529 the access_user (see L<FS::access_user>) providing the reason
533 hashref of keys and values - cust_pkg_option records will be created, updated or removed as appopriate
542 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
547 ( ref($_[0]) eq 'HASH' )
551 #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
552 #return "Can't change otaker!" if $old->otaker ne $new->otaker;
555 #return "Can't change setup once it exists!"
556 # if $old->getfield('setup') &&
557 # $old->getfield('setup') != $new->getfield('setup');
559 #some logic for bill, susp, cancel?
561 local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
563 local $SIG{HUP} = 'IGNORE';
564 local $SIG{INT} = 'IGNORE';
565 local $SIG{QUIT} = 'IGNORE';
566 local $SIG{TERM} = 'IGNORE';
567 local $SIG{TSTP} = 'IGNORE';
568 local $SIG{PIPE} = 'IGNORE';
570 my $oldAutoCommit = $FS::UID::AutoCommit;
571 local $FS::UID::AutoCommit = 0;
574 foreach my $method ( qw(adjourn expire) ) { # How many reasons?
575 if ($options->{'reason'} && $new->$method && $old->$method ne $new->$method) {
576 my $error = $new->insert_reason(
577 'reason' => $options->{'reason'},
578 'date' => $new->$method,
580 'reason_otaker' => $options->{'reason_otaker'},
583 dbh->rollback if $oldAutoCommit;
584 return "Error inserting cust_pkg_reason: $error";
589 #save off and freeze RADIUS attributes for any associated svc_acct records
591 if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
593 #also check for specific exports?
594 # to avoid spurious modify export events
595 @svc_acct = map { $_->svc_x }
596 grep { $_->part_svc->svcdb eq 'svc_acct' }
599 $_->snapshot foreach @svc_acct;
603 my $error = $new->export_pkg_change($old)
604 || $new->SUPER::replace( $old,
606 ? $options->{options}
610 $dbh->rollback if $oldAutoCommit;
614 #for prepaid packages,
615 #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
616 foreach my $old_svc_acct ( @svc_acct ) {
617 my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
619 $new_svc_acct->replace( $old_svc_acct,
620 'depend_jobnum' => $options->{depend_jobnum},
623 $dbh->rollback if $oldAutoCommit;
628 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
635 Checks all fields to make sure this is a valid billing item. If there is an
636 error, returns the error, otherwise returns false. Called by the insert and
644 if ( !$self->locationnum or $self->locationnum == -1 ) {
645 $self->set('locationnum', $self->cust_main->ship_locationnum);
649 $self->ut_numbern('pkgnum')
650 || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
651 || $self->ut_numbern('pkgpart')
652 || $self->ut_foreign_keyn('contactnum', 'contact', 'contactnum' )
653 || $self->ut_foreign_keyn('locationnum', 'cust_location', 'locationnum')
654 || $self->ut_foreign_keyn('salesnum', 'sales', 'salesnum')
655 || $self->ut_numbern('quantity')
656 || $self->ut_numbern('start_date')
657 || $self->ut_numbern('setup')
658 || $self->ut_numbern('bill')
659 || $self->ut_numbern('susp')
660 || $self->ut_numbern('cancel')
661 || $self->ut_numbern('adjourn')
662 || $self->ut_numbern('resume')
663 || $self->ut_numbern('expire')
664 || $self->ut_numbern('dundate')
665 || $self->ut_enum('no_auto', [ '', 'Y' ])
666 || $self->ut_enum('waive_setup', [ '', 'Y' ])
667 || $self->ut_numbern('agent_pkgid')
668 || $self->ut_enum('recur_show_zero', [ '', 'Y', 'N', ])
669 || $self->ut_enum('setup_show_zero', [ '', 'Y', 'N', ])
670 || $self->ut_foreign_keyn('main_pkgnum', 'cust_pkg', 'pkgnum')
671 || $self->ut_foreign_keyn('pkglinknum', 'part_pkg_link', 'pkglinknum')
672 || $self->ut_foreign_keyn('change_to_pkgnum', 'cust_pkg', 'pkgnum')
674 return $error if $error;
676 return "A package with both start date (future start) and setup date (already started) will never bill"
677 if $self->start_date && $self->setup && ! $upgrade;
679 return "A future unsuspend date can only be set for a package with a suspend date"
680 if $self->resume and !$self->susp and !$self->adjourn;
682 $self->usernum($FS::CurrentUser::CurrentUser->usernum) unless $self->usernum;
684 if ( $self->dbdef_table->column('manual_flag') ) {
685 $self->manual_flag('') if $self->manual_flag eq ' ';
686 $self->manual_flag =~ /^([01]?)$/
687 or return "Illegal manual_flag ". $self->manual_flag;
688 $self->manual_flag($1);
696 Check the pkgpart to make sure it's allowed with the reg_code and/or
697 promo_code of the package (if present) and with the customer's agent.
698 Called from C<insert>, unless we are doing a package change that doesn't
706 # my $error = $self->ut_numbern('pkgpart'); # already done
709 if ( $self->reg_code ) {
711 unless ( grep { $self->pkgpart == $_->pkgpart }
712 map { $_->reg_code_pkg }
713 qsearchs( 'reg_code', { 'code' => $self->reg_code,
714 'agentnum' => $self->cust_main->agentnum })
716 return "Unknown registration code";
719 } elsif ( $self->promo_code ) {
722 qsearchs('part_pkg', {
723 'pkgpart' => $self->pkgpart,
724 'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
726 return 'Unknown promotional code' unless $promo_part_pkg;
730 unless ( $disable_agentcheck ) {
732 qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
733 return "agent ". $agent->agentnum. ':'. $agent->agent.
734 " can't purchase pkgpart ". $self->pkgpart
735 unless $agent->pkgpart_hashref->{ $self->pkgpart }
736 || $agent->agentnum == $self->part_pkg->agentnum;
739 $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
740 return $error if $error;
748 =item cancel [ OPTION => VALUE ... ]
750 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
751 in this package, then cancels the package itself (sets the cancel field to
754 Available options are:
758 =item quiet - can be set true to supress email cancellation notices.
760 =item time - can be set to cancel the package based on a specific future or
761 historical date. Using time ensures that the remaining amount is calculated
762 correctly. Note however that this is an immediate cancel and just changes
763 the date. You are PROBABLY looking to expire the account instead of using
766 =item reason - can be set to a cancellation reason (see L<FS:reason>),
767 either a reasonnum of an existing reason, or passing a hashref will create
768 a new reason. The hashref should have the following keys: typenum - Reason
769 type (see L<FS::reason_type>, reason - Text of the new reason.
771 =item date - can be set to a unix style timestamp to specify when to
774 =item nobill - can be set true to skip billing if it might otherwise be done.
776 =item unused_credit - can be set to 1 to credit the remaining time, or 0 to
777 not credit it. This must be set (by change()) when changing the package
778 to a different pkgpart or location, and probably shouldn't be in any other
779 case. If it's not set, the 'unused_credit_cancel' part_pkg option will
784 If there is an error, returns the error, otherwise returns false.
789 my( $self, %options ) = @_;
792 # pass all suspend/cancel actions to the main package
793 if ( $self->main_pkgnum and !$options{'from_main'} ) {
794 return $self->main_pkg->cancel(%options);
797 my $conf = new FS::Conf;
799 warn "cust_pkg::cancel called with options".
800 join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
803 local $SIG{HUP} = 'IGNORE';
804 local $SIG{INT} = 'IGNORE';
805 local $SIG{QUIT} = 'IGNORE';
806 local $SIG{TERM} = 'IGNORE';
807 local $SIG{TSTP} = 'IGNORE';
808 local $SIG{PIPE} = 'IGNORE';
810 my $oldAutoCommit = $FS::UID::AutoCommit;
811 local $FS::UID::AutoCommit = 0;
814 my $old = $self->select_for_update;
816 if ( $old->get('cancel') || $self->get('cancel') ) {
817 dbh->rollback if $oldAutoCommit;
818 return ""; # no error
821 # XXX possibly set cancel_time to the expire date?
822 my $cancel_time = $options{'time'} || time;
823 my $date = $options{'date'} if $options{'date'}; # expire/cancel later
824 $date = '' if ($date && $date <= $cancel_time); # complain instead?
826 #race condition: usage could be ongoing until unprovisioned
827 #resolved by performing a change package instead (which unprovisions) and
829 if ( !$options{nobill} && !$date ) {
830 # && $conf->exists('bill_usage_on_cancel') ) { #calc_cancel checks this
831 my $copy = $self->new({$self->hash});
833 $copy->cust_main->bill( 'pkg_list' => [ $copy ],
835 'time' => $cancel_time );
836 warn "Error billing during cancel, custnum ".
837 #$self->cust_main->custnum. ": $error"
842 if ( $options{'reason'} ) {
843 $error = $self->insert_reason( 'reason' => $options{'reason'},
844 'action' => $date ? 'expire' : 'cancel',
845 'date' => $date ? $date : $cancel_time,
846 'reason_otaker' => $options{'reason_otaker'},
849 dbh->rollback if $oldAutoCommit;
850 return "Error inserting cust_pkg_reason: $error";
854 my %svc_cancel_opt = ();
855 $svc_cancel_opt{'date'} = $date if $date;
856 foreach my $cust_svc (
859 sort { $a->[1] <=> $b->[1] }
860 map { [ $_, $_->svc_x ? $_->svc_x->table_info->{'cancel_weight'} : -1 ]; }
861 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
863 my $part_svc = $cust_svc->part_svc;
864 next if ( defined($part_svc) and $part_svc->preserve );
865 my $error = $cust_svc->cancel( %svc_cancel_opt );
868 $dbh->rollback if $oldAutoCommit;
869 return 'Error '. ($svc_cancel_opt{'date'} ? 'expiring' : 'canceling' ).
875 # credit remaining time if appropriate
877 if ( exists($options{'unused_credit'}) ) {
878 $do_credit = $options{'unused_credit'};
881 $do_credit = $self->part_pkg->option('unused_credit_cancel', 1);
884 my $error = $self->credit_remaining('cancel', $cancel_time);
886 $dbh->rollback if $oldAutoCommit;
893 my %hash = $self->hash;
895 $hash{'expire'} = $date;
897 $hash{'cancel'} = $cancel_time;
899 $hash{'change_custnum'} = $options{'change_custnum'};
901 my $new = new FS::cust_pkg ( \%hash );
902 $error = $new->replace( $self, options => { $self->options } );
903 if ( $self->change_to_pkgnum ) {
904 my $change_to = FS::cust_pkg->by_key($self->change_to_pkgnum);
905 $error ||= $change_to->cancel || $change_to->delete;
908 $dbh->rollback if $oldAutoCommit;
912 foreach my $supp_pkg ( $self->supplemental_pkgs ) {
913 $error = $supp_pkg->cancel(%options, 'from_main' => 1);
915 $dbh->rollback if $oldAutoCommit;
916 return "canceling supplemental pkg#".$supp_pkg->pkgnum.": $error";
920 foreach my $usage ( $self->cust_pkg_usage ) {
921 $error = $usage->delete;
923 $dbh->rollback if $oldAutoCommit;
924 return "deleting usage pools: $error";
928 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
929 return '' if $date; #no errors
931 my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
932 if ( !$options{'quiet'} &&
933 $conf->exists('emailcancel', $self->cust_main->agentnum) &&
935 my $msgnum = $conf->config('cancel_msgnum', $self->cust_main->agentnum);
938 my $msg_template = qsearchs('msg_template', { msgnum => $msgnum });
939 $error = $msg_template->send( 'cust_main' => $self->cust_main,
944 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
945 'to' => \@invoicing_list,
946 'subject' => ( $conf->config('cancelsubject') || 'Cancellation Notice' ),
947 'body' => [ map "$_\n", $conf->config('cancelmessage') ],
950 #should this do something on errors?
957 =item cancel_if_expired [ NOW_TIMESTAMP ]
959 Cancels this package if its expire date has been reached.
963 sub cancel_if_expired {
965 my $time = shift || time;
966 return '' unless $self->expire && $self->expire <= $time;
967 my $error = $self->cancel;
969 return "Error cancelling expired pkg ". $self->pkgnum. " for custnum ".
970 $self->custnum. ": $error";
977 "Un-cancels" this package: Orders a new package with the same custnum, pkgpart,
978 locationnum, (other fields?). Attempts to re-provision cancelled services
979 using history information (errors at this stage are not fatal).
981 cust_pkg: pass a scalar reference, will be filled in with the new cust_pkg object
983 svc_fatal: service provisioning errors are fatal
985 svc_errors: pass an array reference, will be filled in with any provisioning errors
987 main_pkgnum: link the package as a supplemental package of this one. For
993 my( $self, %options ) = @_;
995 #in case you try do do $uncancel-date = $cust_pkg->uncacel
996 return '' unless $self->get('cancel');
998 if ( $self->main_pkgnum and !$options{'main_pkgnum'} ) {
999 return $self->main_pkg->uncancel(%options);
1006 local $SIG{HUP} = 'IGNORE';
1007 local $SIG{INT} = 'IGNORE';
1008 local $SIG{QUIT} = 'IGNORE';
1009 local $SIG{TERM} = 'IGNORE';
1010 local $SIG{TSTP} = 'IGNORE';
1011 local $SIG{PIPE} = 'IGNORE';
1013 my $oldAutoCommit = $FS::UID::AutoCommit;
1014 local $FS::UID::AutoCommit = 0;
1018 # insert the new package
1021 my $cust_pkg = new FS::cust_pkg {
1022 last_bill => ( $options{'last_bill'} || $self->get('last_bill') ),
1023 bill => ( $options{'bill'} || $self->get('bill') ),
1025 uncancel_pkgnum => $self->pkgnum,
1026 main_pkgnum => ($options{'main_pkgnum'} || ''),
1027 map { $_ => $self->get($_) } qw(
1028 custnum pkgpart locationnum
1030 susp adjourn resume expire start_date contract_end dundate
1031 change_date change_pkgpart change_locationnum
1032 manual_flag no_auto quantity agent_pkgid recur_show_zero setup_show_zero
1036 my $error = $cust_pkg->insert(
1037 'change' => 1, #supresses any referral credit to a referring customer
1038 'allow_pkgpart' => 1, # allow this even if the package def is disabled
1041 $dbh->rollback if $oldAutoCommit;
1049 #find historical services within this timeframe before the package cancel
1050 # (incompatible with "time" option to cust_pkg->cancel?)
1051 my $fuzz = 2 * 60; #2 minutes? too much? (might catch separate unprovision)
1052 # too little? (unprovisioing export delay?)
1053 my($end, $start) = ( $self->get('cancel'), $self->get('cancel') - $fuzz );
1054 my @h_cust_svc = $self->h_cust_svc( $end, $start );
1057 foreach my $h_cust_svc (@h_cust_svc) {
1058 my $h_svc_x = $h_cust_svc->h_svc_x( $end, $start );
1059 #next unless $h_svc_x; #should this happen?
1060 (my $table = $h_svc_x->table) =~ s/^h_//;
1061 require "FS/$table.pm";
1062 my $class = "FS::$table";
1063 my $svc_x = $class->new( {
1064 'pkgnum' => $cust_pkg->pkgnum,
1065 'svcpart' => $h_cust_svc->svcpart,
1066 map { $_ => $h_svc_x->get($_) } fields($table)
1070 if ( $h_svc_x->isa('FS::h_svc_Radius_Mixin') ) {
1071 $svc_x->usergroup( [ $h_svc_x->h_usergroup($end, $start) ] );
1074 my $svc_error = $svc_x->insert;
1076 if ( $options{svc_fatal} ) {
1077 $dbh->rollback if $oldAutoCommit;
1080 # if we've failed to insert the svc_x object, svc_Common->insert
1081 # will have removed the cust_svc already. if not, then both records
1082 # were inserted but we failed for some other reason (export, most
1083 # likely). in that case, report the error and delete the records.
1084 push @svc_errors, $svc_error;
1085 my $cust_svc = qsearchs('cust_svc', { 'svcnum' => $svc_x->svcnum });
1087 # except if export_insert failed, export_delete probably won't be
1089 local $FS::svc_Common::noexport_hack = 1;
1090 my $cleanup_error = $svc_x->delete; # also deletes cust_svc
1091 if ( $cleanup_error ) { # and if THAT fails, then run away
1092 $dbh->rollback if $oldAutoCommit;
1093 return $cleanup_error;
1098 } #foreach $h_cust_svc
1100 #these are pretty rare, but should handle them
1101 # - dsl_device (mac addresses)
1102 # - phone_device (mac addresses)
1103 # - dsl_note (ikano notes)
1104 # - domain_record (i.e. restore DNS information w/domains)
1105 # - inventory_item(?) (inventory w/un-cancelling service?)
1106 # - nas (svc_broaband nas stuff)
1107 #this stuff is unused in the wild afaik
1108 # - mailinglistmember
1110 # - svc_domain.parent_svcnum?
1111 # - acct_snarf (ancient mail fetching config)
1112 # - cgp_rule (communigate)
1113 # - cust_svc_option (used by our Tron stuff)
1114 # - acct_rt_transaction (used by our time worked stuff)
1117 # also move over any services that didn't unprovision at cancellation
1120 foreach my $cust_svc ( qsearch('cust_svc', { pkgnum => $self->pkgnum } ) ) {
1121 $cust_svc->pkgnum( $cust_pkg->pkgnum );
1122 my $error = $cust_svc->replace;
1124 $dbh->rollback if $oldAutoCommit;
1130 # Uncancel any supplemental packages, and make them supplemental to the
1134 foreach my $supp_pkg ( $self->supplemental_pkgs ) {
1136 $error = $supp_pkg->uncancel(%options, 'main_pkgnum' => $cust_pkg->pkgnum);
1138 $dbh->rollback if $oldAutoCommit;
1139 return "canceling supplemental pkg#".$supp_pkg->pkgnum.": $error";
1147 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1149 ${ $options{cust_pkg} } = $cust_pkg if ref($options{cust_pkg});
1150 @{ $options{svc_errors} } = @svc_errors if ref($options{svc_errors});
1157 Cancels any pending expiration (sets the expire field to null).
1159 If there is an error, returns the error, otherwise returns false.
1164 my( $self, %options ) = @_;
1167 local $SIG{HUP} = 'IGNORE';
1168 local $SIG{INT} = 'IGNORE';
1169 local $SIG{QUIT} = 'IGNORE';
1170 local $SIG{TERM} = 'IGNORE';
1171 local $SIG{TSTP} = 'IGNORE';
1172 local $SIG{PIPE} = 'IGNORE';
1174 my $oldAutoCommit = $FS::UID::AutoCommit;
1175 local $FS::UID::AutoCommit = 0;
1178 my $old = $self->select_for_update;
1180 my $pkgnum = $old->pkgnum;
1181 if ( $old->get('cancel') || $self->get('cancel') ) {
1182 dbh->rollback if $oldAutoCommit;
1183 return "Can't unexpire cancelled package $pkgnum";
1184 # or at least it's pointless
1187 unless ( $old->get('expire') && $self->get('expire') ) {
1188 dbh->rollback if $oldAutoCommit;
1189 return ""; # no error
1192 my %hash = $self->hash;
1193 $hash{'expire'} = '';
1194 my $new = new FS::cust_pkg ( \%hash );
1195 $error = $new->replace( $self, options => { $self->options } );
1197 $dbh->rollback if $oldAutoCommit;
1201 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1207 =item suspend [ OPTION => VALUE ... ]
1209 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
1210 package, then suspends the package itself (sets the susp field to now).
1212 Available options are:
1216 =item reason - can be set to a cancellation reason (see L<FS:reason>),
1217 either a reasonnum of an existing reason, or passing a hashref will create
1218 a new reason. The hashref should have the following keys:
1219 - typenum - Reason type (see L<FS::reason_type>
1220 - reason - Text of the new reason.
1222 =item date - can be set to a unix style timestamp to specify when to
1225 =item time - can be set to override the current time, for calculation
1226 of final invoices or unused-time credits
1228 =item resume_date - can be set to a time when the package should be
1229 unsuspended. This may be more convenient than calling C<unsuspend()>
1232 =item from_main - allows a supplemental package to be suspended, rather
1233 than redirecting the method call to its main package. For internal use.
1237 If there is an error, returns the error, otherwise returns false.
1242 my( $self, %options ) = @_;
1245 # pass all suspend/cancel actions to the main package
1246 if ( $self->main_pkgnum and !$options{'from_main'} ) {
1247 return $self->main_pkg->suspend(%options);
1250 local $SIG{HUP} = 'IGNORE';
1251 local $SIG{INT} = 'IGNORE';
1252 local $SIG{QUIT} = 'IGNORE';
1253 local $SIG{TERM} = 'IGNORE';
1254 local $SIG{TSTP} = 'IGNORE';
1255 local $SIG{PIPE} = 'IGNORE';
1257 my $oldAutoCommit = $FS::UID::AutoCommit;
1258 local $FS::UID::AutoCommit = 0;
1261 my $old = $self->select_for_update;
1263 my $pkgnum = $old->pkgnum;
1264 if ( $old->get('cancel') || $self->get('cancel') ) {
1265 dbh->rollback if $oldAutoCommit;
1266 return "Can't suspend cancelled package $pkgnum";
1269 if ( $old->get('susp') || $self->get('susp') ) {
1270 dbh->rollback if $oldAutoCommit;
1271 return ""; # no error # complain on adjourn?
1274 my $suspend_time = $options{'time'} || time;
1275 my $date = $options{date} if $options{date}; # adjourn/suspend later
1276 $date = '' if ($date && $date <= $suspend_time); # complain instead?
1278 if ( $date && $old->get('expire') && $old->get('expire') < $date ) {
1279 dbh->rollback if $oldAutoCommit;
1280 return "Package $pkgnum expires before it would be suspended.";
1283 # some false laziness with sub cancel
1284 if ( !$options{nobill} && !$date &&
1285 $self->part_pkg->option('bill_suspend_as_cancel',1) ) {
1286 # kind of a kludge--'bill_suspend_as_cancel' to avoid having to
1287 # make the entire cust_main->bill path recognize 'suspend' and
1288 # 'cancel' separately.
1289 warn "Billing $pkgnum on suspension (at $suspend_time)\n" if $DEBUG;
1290 my $copy = $self->new({$self->hash});
1292 $copy->cust_main->bill( 'pkg_list' => [ $copy ],
1294 'time' => $suspend_time );
1295 warn "Error billing during suspend, custnum ".
1296 #$self->cust_main->custnum. ": $error"
1301 if ( $options{'reason'} ) {
1302 $error = $self->insert_reason( 'reason' => $options{'reason'},
1303 'action' => $date ? 'adjourn' : 'suspend',
1304 'date' => $date ? $date : $suspend_time,
1305 'reason_otaker' => $options{'reason_otaker'},
1308 dbh->rollback if $oldAutoCommit;
1309 return "Error inserting cust_pkg_reason: $error";
1313 my %hash = $self->hash;
1315 $hash{'adjourn'} = $date;
1317 $hash{'susp'} = $suspend_time;
1320 my $resume_date = $options{'resume_date'} || 0;
1321 if ( $resume_date > ($date || $suspend_time) ) {
1322 $hash{'resume'} = $resume_date;
1325 $options{options} ||= {};
1327 my $new = new FS::cust_pkg ( \%hash );
1328 $error = $new->replace( $self, options => { $self->options,
1329 %{ $options{options} },
1333 $dbh->rollback if $oldAutoCommit;
1338 # credit remaining time if appropriate
1339 if ( $self->part_pkg->option('unused_credit_suspend', 1) ) {
1340 my $error = $self->credit_remaining('suspend', $suspend_time);
1342 $dbh->rollback if $oldAutoCommit;
1349 foreach my $cust_svc (
1350 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
1352 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
1354 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
1355 $dbh->rollback if $oldAutoCommit;
1356 return "Illegal svcdb value in part_svc!";
1359 require "FS/$svcdb.pm";
1361 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
1363 $error = $svc->suspend;
1365 $dbh->rollback if $oldAutoCommit;
1368 my( $label, $value ) = $cust_svc->label;
1369 push @labels, "$label: $value";
1373 my $conf = new FS::Conf;
1374 if ( $conf->config('suspend_email_admin') ) {
1376 my $error = send_email(
1377 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
1378 #invoice_from ??? well as good as any
1379 'to' => $conf->config('suspend_email_admin'),
1380 'subject' => 'FREESIDE NOTIFICATION: Customer package suspended',
1382 "This is an automatic message from your Freeside installation\n",
1383 "informing you that the following customer package has been suspended:\n",
1385 'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
1386 'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
1387 ( map { "Service : $_\n" } @labels ),
1392 warn "WARNING: can't send suspension admin email (suspending anyway): ".
1400 foreach my $supp_pkg ( $self->supplemental_pkgs ) {
1401 $error = $supp_pkg->suspend(%options, 'from_main' => 1);
1403 $dbh->rollback if $oldAutoCommit;
1404 return "suspending supplemental pkg#".$supp_pkg->pkgnum.": $error";
1408 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1413 =item credit_remaining MODE TIME
1415 Generate a credit for this package for the time remaining in the current
1416 billing period. MODE is either "suspend" or "cancel" (determines the
1417 credit type). TIME is the time of suspension/cancellation. Both arguments
1422 sub credit_remaining {
1423 # Add a credit for remaining service
1424 my ($self, $mode, $time) = @_;
1425 die 'credit_remaining requires suspend or cancel'
1426 unless $mode eq 'suspend' or $mode eq 'cancel';
1427 die 'no suspend/cancel time' unless $time > 0;
1429 my $conf = FS::Conf->new;
1430 my $reason_type = $conf->config($mode.'_credit_type');
1432 my $last_bill = $self->getfield('last_bill') || 0;
1433 my $next_bill = $self->getfield('bill') || 0;
1434 if ( $last_bill > 0 # the package has been billed
1435 and $next_bill > 0 # the package has a next bill date
1436 and $next_bill >= $time # which is in the future
1438 my $remaining_value = $self->calc_remain('time' => $time);
1439 if ( $remaining_value > 0 ) {
1440 warn "Crediting for $remaining_value on package ".$self->pkgnum."\n"
1442 my $error = $self->cust_main->credit(
1444 'Credit for unused time on '. $self->part_pkg->pkg,
1445 'reason_type' => $reason_type,
1447 return "Error crediting customer \$$remaining_value for unused time".
1448 " on ". $self->part_pkg->pkg. ": $error"
1450 } #if $remaining_value
1451 } #if $last_bill, etc.
1455 =item unsuspend [ OPTION => VALUE ... ]
1457 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
1458 package, then unsuspends the package itself (clears the susp field and the
1459 adjourn field if it is in the past). If the suspend reason includes an
1460 unsuspension package, that package will be ordered.
1462 Available options are:
1468 Can be set to a date to unsuspend the package in the future (the 'resume'
1471 =item adjust_next_bill
1473 Can be set true to adjust the next bill date forward by
1474 the amount of time the account was inactive. This was set true by default
1475 in the past (from 1.4.2 and 1.5.0pre6 through 1.7.0), but now needs to be
1476 explicitly requested with this option or in the price plan.
1480 If there is an error, returns the error, otherwise returns false.
1485 my( $self, %opt ) = @_;
1488 # pass all suspend/cancel actions to the main package
1489 if ( $self->main_pkgnum and !$opt{'from_main'} ) {
1490 return $self->main_pkg->unsuspend(%opt);
1493 local $SIG{HUP} = 'IGNORE';
1494 local $SIG{INT} = 'IGNORE';
1495 local $SIG{QUIT} = 'IGNORE';
1496 local $SIG{TERM} = 'IGNORE';
1497 local $SIG{TSTP} = 'IGNORE';
1498 local $SIG{PIPE} = 'IGNORE';
1500 my $oldAutoCommit = $FS::UID::AutoCommit;
1501 local $FS::UID::AutoCommit = 0;
1504 my $old = $self->select_for_update;
1506 my $pkgnum = $old->pkgnum;
1507 if ( $old->get('cancel') || $self->get('cancel') ) {
1508 $dbh->rollback if $oldAutoCommit;
1509 return "Can't unsuspend cancelled package $pkgnum";
1512 unless ( $old->get('susp') && $self->get('susp') ) {
1513 $dbh->rollback if $oldAutoCommit;
1514 return ""; # no error # complain instead?
1517 my $date = $opt{'date'};
1518 if ( $date and $date > time ) { # return an error if $date <= time?
1520 if ( $old->get('expire') && $old->get('expire') < $date ) {
1521 $dbh->rollback if $oldAutoCommit;
1522 return "Package $pkgnum expires before it would be unsuspended.";
1525 my $new = new FS::cust_pkg { $self->hash };
1526 $new->set('resume', $date);
1527 $error = $new->replace($self, options => $self->options);
1530 $dbh->rollback if $oldAutoCommit;
1534 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1542 foreach my $cust_svc (
1543 qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
1545 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
1547 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
1548 $dbh->rollback if $oldAutoCommit;
1549 return "Illegal svcdb value in part_svc!";
1552 require "FS/$svcdb.pm";
1554 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
1556 $error = $svc->unsuspend;
1558 $dbh->rollback if $oldAutoCommit;
1561 my( $label, $value ) = $cust_svc->label;
1562 push @labels, "$label: $value";
1567 my $cust_pkg_reason = $self->last_cust_pkg_reason('susp');
1568 my $reason = $cust_pkg_reason ? $cust_pkg_reason->reason : '';
1570 my %hash = $self->hash;
1571 my $inactive = time - $hash{'susp'};
1573 my $conf = new FS::Conf;
1575 if ( $inactive > 0 &&
1576 ( $hash{'bill'} || $hash{'setup'} ) &&
1577 ( $opt{'adjust_next_bill'} ||
1578 $conf->exists('unsuspend-always_adjust_next_bill_date') ||
1579 $self->part_pkg->option('unsuspend_adjust_bill', 1) )
1582 $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive;
1587 $hash{'adjourn'} = '' if $hash{'adjourn'} and $hash{'adjourn'} < time;
1588 $hash{'resume'} = '' if !$hash{'adjourn'};
1589 my $new = new FS::cust_pkg ( \%hash );
1590 $error = $new->replace( $self, options => { $self->options } );
1592 $dbh->rollback if $oldAutoCommit;
1598 if ( $reason && $reason->unsuspend_pkgpart ) {
1599 my $part_pkg = FS::part_pkg->by_key($reason->unsuspend_pkgpart)
1600 or $error = "Unsuspend package definition ".$reason->unsuspend_pkgpart.
1602 my $start_date = $self->cust_main->next_bill_date
1603 if $reason->unsuspend_hold;
1606 $unsusp_pkg = FS::cust_pkg->new({
1607 'custnum' => $self->custnum,
1608 'pkgpart' => $reason->unsuspend_pkgpart,
1609 'start_date' => $start_date,
1610 'locationnum' => $self->locationnum,
1611 # discount? probably not...
1614 $error ||= $self->cust_main->order_pkg( 'cust_pkg' => $unsusp_pkg );
1618 $dbh->rollback if $oldAutoCommit;
1623 if ( $conf->config('unsuspend_email_admin') ) {
1625 my $error = send_email(
1626 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
1627 #invoice_from ??? well as good as any
1628 'to' => $conf->config('unsuspend_email_admin'),
1629 'subject' => 'FREESIDE NOTIFICATION: Customer package unsuspended', 'body' => [
1630 "This is an automatic message from your Freeside installation\n",
1631 "informing you that the following customer package has been unsuspended:\n",
1633 'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
1634 'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
1635 ( map { "Service : $_\n" } @labels ),
1637 "An unsuspension fee was charged: ".
1638 $unsusp_pkg->part_pkg->pkg_comment."\n"
1645 warn "WARNING: can't send unsuspension admin email (unsuspending anyway): ".
1651 foreach my $supp_pkg ( $self->supplemental_pkgs ) {
1652 $error = $supp_pkg->unsuspend(%opt, 'from_main' => 1);
1654 $dbh->rollback if $oldAutoCommit;
1655 return "unsuspending supplemental pkg#".$supp_pkg->pkgnum.": $error";
1659 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1666 Cancels any pending suspension (sets the adjourn field to null).
1668 If there is an error, returns the error, otherwise returns false.
1673 my( $self, %options ) = @_;
1676 local $SIG{HUP} = 'IGNORE';
1677 local $SIG{INT} = 'IGNORE';
1678 local $SIG{QUIT} = 'IGNORE';
1679 local $SIG{TERM} = 'IGNORE';
1680 local $SIG{TSTP} = 'IGNORE';
1681 local $SIG{PIPE} = 'IGNORE';
1683 my $oldAutoCommit = $FS::UID::AutoCommit;
1684 local $FS::UID::AutoCommit = 0;
1687 my $old = $self->select_for_update;
1689 my $pkgnum = $old->pkgnum;
1690 if ( $old->get('cancel') || $self->get('cancel') ) {
1691 dbh->rollback if $oldAutoCommit;
1692 return "Can't unadjourn cancelled package $pkgnum";
1693 # or at least it's pointless
1696 if ( $old->get('susp') || $self->get('susp') ) {
1697 dbh->rollback if $oldAutoCommit;
1698 return "Can't unadjourn suspended package $pkgnum";
1699 # perhaps this is arbitrary
1702 unless ( $old->get('adjourn') && $self->get('adjourn') ) {
1703 dbh->rollback if $oldAutoCommit;
1704 return ""; # no error
1707 my %hash = $self->hash;
1708 $hash{'adjourn'} = '';
1709 $hash{'resume'} = '';
1710 my $new = new FS::cust_pkg ( \%hash );
1711 $error = $new->replace( $self, options => { $self->options } );
1713 $dbh->rollback if $oldAutoCommit;
1717 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1724 =item change HASHREF | OPTION => VALUE ...
1726 Changes this package: cancels it and creates a new one, with a different
1727 pkgpart or locationnum or both. All services are transferred to the new
1728 package (no change will be made if this is not possible).
1730 Options may be passed as a list of key/value pairs or as a hash reference.
1737 New locationnum, to change the location for this package.
1741 New FS::cust_location object, to create a new location and assign it
1746 New FS::cust_main object, to create a new customer and assign the new package
1751 New pkgpart (see L<FS::part_pkg>).
1755 New refnum (see L<FS::part_referral>).
1759 New quantity; if unspecified, the new package will have the same quantity
1764 "New" (existing) FS::cust_pkg object. The package's services and other
1765 attributes will be transferred to this package.
1769 Set to true to transfer billing dates (start_date, setup, last_bill, bill,
1770 susp, adjourn, cancel, expire, and contract_end) to the new package.
1772 =item unprotect_svcs
1774 Normally, change() will rollback and return an error if some services
1775 can't be transferred (also see the I<cust_pkg-change_svcpart> config option).
1776 If unprotect_svcs is true, this method will transfer as many services as
1777 it can and then unconditionally cancel the old package.
1781 At least one of locationnum, cust_location, pkgpart, refnum, cust_main, or
1782 cust_pkg must be specified (otherwise, what's the point?)
1784 Returns either the new FS::cust_pkg object or a scalar error.
1788 my $err_or_new_cust_pkg = $old_cust_pkg->change
1792 #some false laziness w/order
1795 my $opt = ref($_[0]) ? shift : { @_ };
1797 my $conf = new FS::Conf;
1799 # Transactionize this whole mess
1800 local $SIG{HUP} = 'IGNORE';
1801 local $SIG{INT} = 'IGNORE';
1802 local $SIG{QUIT} = 'IGNORE';
1803 local $SIG{TERM} = 'IGNORE';
1804 local $SIG{TSTP} = 'IGNORE';
1805 local $SIG{PIPE} = 'IGNORE';
1807 my $oldAutoCommit = $FS::UID::AutoCommit;
1808 local $FS::UID::AutoCommit = 0;
1817 $hash{'setup'} = $time if $self->setup;
1819 $hash{'change_date'} = $time;
1820 $hash{"change_$_"} = $self->$_()
1821 foreach qw( pkgnum pkgpart locationnum );
1823 if ( $opt->{'cust_location'} ) {
1824 $error = $opt->{'cust_location'}->find_or_insert;
1826 $dbh->rollback if $oldAutoCommit;
1827 return "inserting cust_location (transaction rolled back): $error";
1829 $opt->{'locationnum'} = $opt->{'cust_location'}->locationnum;
1832 if ( $opt->{'cust_pkg'} ) {
1833 # treat changing to a package with a different pkgpart as a
1834 # pkgpart change (because it is)
1835 $opt->{'pkgpart'} = $opt->{'cust_pkg'}->pkgpart;
1838 # whether to override pkgpart checking on the new package
1839 my $same_pkgpart = 1;
1840 if ( $opt->{'pkgpart'} and ( $opt->{'pkgpart'} != $self->pkgpart ) ) {
1844 my $unused_credit = 0;
1845 my $keep_dates = $opt->{'keep_dates'};
1846 # Special case. If the pkgpart is changing, and the customer is
1847 # going to be credited for remaining time, don't keep setup, bill,
1848 # or last_bill dates, and DO pass the flag to cancel() to credit
1850 if ( $opt->{'pkgpart'}
1851 and $opt->{'pkgpart'} != $self->pkgpart
1852 and $self->part_pkg->option('unused_credit_change', 1) ) {
1855 $hash{$_} = '' foreach qw(setup bill last_bill);
1858 if ( $keep_dates ) {
1859 foreach my $date ( qw(setup bill last_bill susp adjourn cancel expire
1860 resume start_date contract_end ) ) {
1861 $hash{$date} = $self->getfield($date);
1865 # allow $opt->{'locationnum'} = '' to specifically set it to null
1866 # (i.e. customer default location)
1867 $opt->{'locationnum'} = $self->locationnum if !exists($opt->{'locationnum'});
1869 # usually this doesn't matter. the two cases where it does are:
1870 # 1. unused_credit_change + pkgpart change + setup fee on the new package
1872 # 2. (more importantly) changing a package before it's billed
1873 $hash{'waive_setup'} = $self->waive_setup;
1875 my $custnum = $self->custnum;
1876 if ( $opt->{cust_main} ) {
1877 my $cust_main = $opt->{cust_main};
1878 unless ( $cust_main->custnum ) {
1879 my $error = $cust_main->insert( @{ $opt->{cust_main_insert_args}||[] } );
1881 $dbh->rollback if $oldAutoCommit;
1882 return "inserting cust_main (transaction rolled back): $error";
1885 $custnum = $cust_main->custnum;
1888 $hash{'contactnum'} = $opt->{'contactnum'} if $opt->{'contactnum'};
1891 if ( $opt->{'cust_pkg'} ) {
1892 # The target package already exists; update it to show that it was
1893 # changed from this package.
1894 $cust_pkg = $opt->{'cust_pkg'};
1896 foreach ( qw( pkgnum pkgpart locationnum ) ) {
1897 $cust_pkg->set("change_$_", $self->get($_));
1899 $cust_pkg->set('change_date', $time);
1900 $error = $cust_pkg->replace;
1903 # Create the new package.
1904 $cust_pkg = new FS::cust_pkg {
1905 custnum => $custnum,
1906 locationnum => $opt->{'locationnum'},
1907 ( map { $_ => ( $opt->{$_} || $self->$_() ) }
1908 qw( pkgpart quantity refnum salesnum )
1912 $error = $cust_pkg->insert( 'change' => 1,
1913 'allow_pkgpart' => $same_pkgpart );
1916 $dbh->rollback if $oldAutoCommit;
1920 # Transfer services and cancel old package.
1922 $error = $self->transfer($cust_pkg);
1923 if ($error and $error == 0) {
1924 # $old_pkg->transfer failed.
1925 $dbh->rollback if $oldAutoCommit;
1929 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1930 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1931 $error = $self->transfer($cust_pkg, 'change_svcpart'=>1 );
1932 if ($error and $error == 0) {
1933 # $old_pkg->transfer failed.
1934 $dbh->rollback if $oldAutoCommit;
1939 # We set unprotect_svcs when executing a "future package change". It's
1940 # not a user-interactive operation, so returning an error means the
1941 # package change will just fail. Rather than have that happen, we'll
1942 # let leftover services be deleted.
1943 if ($error > 0 and !$opt->{'unprotect_svcs'}) {
1944 # Transfers were successful, but we still had services left on the old
1945 # package. We can't change the package under this circumstances, so abort.
1946 $dbh->rollback if $oldAutoCommit;
1947 return "Unable to transfer all services from package ". $self->pkgnum;
1950 #reset usage if changing pkgpart
1951 # AND usage rollover is off (otherwise adds twice, now and at package bill)
1952 if ($self->pkgpart != $cust_pkg->pkgpart) {
1953 my $part_pkg = $cust_pkg->part_pkg;
1954 $error = $part_pkg->reset_usage($cust_pkg, $part_pkg->is_prepaid
1958 if $part_pkg->can('reset_usage') && ! $part_pkg->option('usage_rollover',1);
1961 $dbh->rollback if $oldAutoCommit;
1962 return "Error setting usage values: $error";
1965 # if NOT changing pkgpart, transfer any usage pools over
1966 foreach my $usage ($self->cust_pkg_usage) {
1967 $usage->set('pkgnum', $cust_pkg->pkgnum);
1968 $error = $usage->replace;
1970 $dbh->rollback if $oldAutoCommit;
1971 return "Error transferring usage pools: $error";
1976 # transfer discounts, if we're not changing pkgpart
1977 if ( $same_pkgpart ) {
1978 foreach my $old_discount ($self->cust_pkg_discount_active) {
1979 # don't remove the old discount, we may still need to bill that package.
1980 my $new_discount = new FS::cust_pkg_discount {
1981 'pkgnum' => $cust_pkg->pkgnum,
1982 'discountnum' => $old_discount->discountnum,
1983 'months_used' => $old_discount->months_used,
1985 $error = $new_discount->insert;
1987 $dbh->rollback if $oldAutoCommit;
1988 return "Error transferring discounts: $error";
1993 # transfer (copy) invoice details
1994 foreach my $detail ($self->cust_pkg_detail) {
1995 my $new_detail = FS::cust_pkg_detail->new({ $detail->hash });
1996 $new_detail->set('pkgdetailnum', '');
1997 $new_detail->set('pkgnum', $cust_pkg->pkgnum);
1998 $error = $new_detail->insert;
2000 $dbh->rollback if $oldAutoCommit;
2001 return "Error transferring package notes: $error";
2007 if ( !$opt->{'cust_pkg'} ) {
2008 # Order any supplemental packages.
2009 my $part_pkg = $cust_pkg->part_pkg;
2010 my @old_supp_pkgs = $self->supplemental_pkgs;
2011 foreach my $link ($part_pkg->supp_part_pkg_link) {
2013 foreach (@old_supp_pkgs) {
2014 if ($_->pkgpart == $link->dst_pkgpart) {
2016 $_->pkgpart(0); # so that it can't match more than once
2020 # false laziness with FS::cust_main::Packages::order_pkg
2021 my $new = FS::cust_pkg->new({
2022 pkgpart => $link->dst_pkgpart,
2023 pkglinknum => $link->pkglinknum,
2024 custnum => $custnum,
2025 main_pkgnum => $cust_pkg->pkgnum,
2026 locationnum => $cust_pkg->locationnum,
2027 start_date => $cust_pkg->start_date,
2028 order_date => $cust_pkg->order_date,
2029 expire => $cust_pkg->expire,
2030 adjourn => $cust_pkg->adjourn,
2031 contract_end => $cust_pkg->contract_end,
2032 refnum => $cust_pkg->refnum,
2033 discountnum => $cust_pkg->discountnum,
2034 waive_setup => $cust_pkg->waive_setup,
2036 if ( $old and $opt->{'keep_dates'} ) {
2037 foreach (qw(setup bill last_bill)) {
2038 $new->set($_, $old->get($_));
2041 $error = $new->insert( allow_pkgpart => $same_pkgpart );
2044 $error ||= $old->transfer($new);
2046 if ( $error and $error > 0 ) {
2047 # no reason why this should ever fail, but still...
2048 $error = "Unable to transfer all services from supplemental package ".
2052 $dbh->rollback if $oldAutoCommit;
2055 push @new_supp_pkgs, $new;
2057 } # if !$opt->{'cust_pkg'}
2058 # because if there is one, then supplemental packages would already
2059 # have been created for it.
2061 #Good to go, cancel old package. Notify 'cancel' of whether to credit
2063 #Don't allow billing the package (preceding period packages and/or
2064 #outstanding usage) if we are keeping dates (i.e. location changing),
2065 #because the new package will be billed for the same date range.
2066 #Supplemental packages are also canceled here.
2068 # during scheduled changes, avoid canceling the package we just
2070 $self->set('change_to_pkgnum' => '');
2072 $error = $self->cancel(
2074 unused_credit => $unused_credit,
2075 nobill => $keep_dates,
2076 change_custnum => ( $self->custnum != $custnum ? $custnum : '' ),
2079 $dbh->rollback if $oldAutoCommit;
2083 if ( $conf->exists('cust_pkg-change_pkgpart-bill_now') ) {
2085 my $error = $cust_pkg->cust_main->bill(
2086 'pkg_list' => [ $cust_pkg, @new_supp_pkgs ]
2089 $dbh->rollback if $oldAutoCommit;
2094 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2100 =item change_later OPTION => VALUE...
2102 Schedule a package change for a later date. This actually orders the new
2103 package immediately, but sets its start date for a future date, and sets
2104 the current package to expire on the same date.
2106 If the package is already scheduled for a change, this can be called with
2107 'start_date' to change the scheduled date, or with pkgpart and/or
2108 locationnum to modify the package change. To cancel the scheduled change
2109 entirely, see C<abort_change>.
2117 The date for the package change. Required, and must be in the future.
2125 The pkgpart. locationnum, and quantity of the new package, with the same
2126 meaning as in C<change>.
2134 my $opt = ref($_[0]) ? shift : { @_ };
2136 my $oldAutoCommit = $FS::UID::AutoCommit;
2137 local $FS::UID::AutoCommit = 0;
2140 my $cust_main = $self->cust_main;
2142 my $date = delete $opt->{'start_date'} or return 'start_date required';
2144 if ( $date <= time ) {
2145 $dbh->rollback if $oldAutoCommit;
2146 return "start_date $date is in the past";
2151 if ( $self->change_to_pkgnum ) {
2152 my $change_to = FS::cust_pkg->by_key($self->change_to_pkgnum);
2153 my $new_pkgpart = $opt->{'pkgpart'}
2154 if $opt->{'pkgpart'} and $opt->{'pkgpart'} != $change_to->pkgpart;
2155 my $new_locationnum = $opt->{'locationnum'}
2156 if $opt->{'locationnum'} and $opt->{'locationnum'} != $change_to->locationnum;
2157 my $new_quantity = $opt->{'quantity'}
2158 if $opt->{'quantity'} and $opt->{'quantity'} != $change_to->quantity;
2159 if ( $new_pkgpart or $new_locationnum or $new_quantity ) {
2160 # it hasn't been billed yet, so in principle we could just edit
2161 # it in place (w/o a package change), but that's bad form.
2162 # So change the package according to the new options...
2163 my $err_or_pkg = $change_to->change(%$opt);
2164 if ( ref $err_or_pkg ) {
2165 # Then set that package up for a future start.
2166 $self->set('change_to_pkgnum', $err_or_pkg->pkgnum);
2167 $self->set('expire', $date); # in case it's different
2168 $err_or_pkg->set('start_date', $date);
2169 $err_or_pkg->set('change_date', '');
2170 $err_or_pkg->set('change_pkgnum', '');
2172 $error = $self->replace ||
2173 $err_or_pkg->replace ||
2174 $change_to->cancel ||
2177 $error = $err_or_pkg;
2179 } else { # change the start date only.
2180 $self->set('expire', $date);
2181 $change_to->set('start_date', $date);
2182 $error = $self->replace || $change_to->replace;
2185 $dbh->rollback if $oldAutoCommit;
2188 $dbh->commit if $oldAutoCommit;
2191 } # if $self->change_to_pkgnum
2193 my $new_pkgpart = $opt->{'pkgpart'}
2194 if $opt->{'pkgpart'} and $opt->{'pkgpart'} != $self->pkgpart;
2195 my $new_locationnum = $opt->{'locationnum'}
2196 if $opt->{'locationnum'} and $opt->{'locationnum'} != $self->locationnum;
2197 my $new_quantity = $opt->{'quantity'}
2198 if $opt->{'quantity'} and $opt->{'quantity'} != $self->quantity;
2200 return '' unless $new_pkgpart or $new_locationnum or $new_quantity; # wouldn't do anything
2202 # allow $opt->{'locationnum'} = '' to specifically set it to null
2203 # (i.e. customer default location)
2204 $opt->{'locationnum'} = $self->locationnum if !exists($opt->{'locationnum'});
2206 my $new = FS::cust_pkg->new( {
2207 custnum => $self->custnum,
2208 locationnum => $opt->{'locationnum'},
2209 start_date => $date,
2210 map { $_ => ( $opt->{$_} || $self->$_() ) }
2211 qw( pkgpart quantity refnum salesnum )
2213 $error = $new->insert('change' => 1,
2214 'allow_pkgpart' => ($new_pkgpart ? 0 : 1));
2216 $self->set('change_to_pkgnum', $new->pkgnum);
2217 $self->set('expire', $date);
2218 $error = $self->replace;
2221 $dbh->rollback if $oldAutoCommit;
2223 $dbh->commit if $oldAutoCommit;
2231 Cancels a future package change scheduled by C<change_later>.
2237 my $pkgnum = $self->change_to_pkgnum;
2238 my $change_to = FS::cust_pkg->by_key($pkgnum) if $pkgnum;
2241 $error = $change_to->cancel || $change_to->delete;
2242 return $error if $error;
2244 $self->set('change_to_pkgnum', '');
2245 $self->set('expire', '');
2249 =item set_quantity QUANTITY
2251 Change the package's quantity field. This is one of the few package properties
2252 that can safely be changed without canceling and reordering the package
2253 (because it doesn't affect tax eligibility). Returns an error or an
2260 $self = $self->replace_old; # just to make sure
2261 $self->quantity(shift);
2265 =item set_salesnum SALESNUM
2267 Change the package's salesnum (sales person) field. This is one of the few
2268 package properties that can safely be changed without canceling and reordering
2269 the package (because it doesn't affect tax eligibility). Returns an error or
2276 $self = $self->replace_old; # just to make sure
2277 $self->salesnum(shift);
2279 # XXX this should probably reassign any credit that's already been given
2282 =item modify_charge OPTIONS
2284 Change the properties of a one-time charge. Currently the only properties
2285 that can be changed this way are those that have no impact on billing
2287 - pkg: the package description
2288 - classnum: the package class
2289 - additional: arrayref of additional invoice details to add to this package
2291 If you pass 'adjust_commission' => 1, and the classnum changes, and there are
2292 commission credits linked to this charge, they will be recalculated.
2299 my $part_pkg = $self->part_pkg;
2300 my $pkgnum = $self->pkgnum;
2303 my $oldAutoCommit = $FS::UID::AutoCommit;
2304 local $FS::UID::AutoCommit = 0;
2306 return "Can't use modify_charge except on one-time charges"
2307 unless $part_pkg->freq eq '0';
2309 if ( length($opt{'pkg'}) and $part_pkg->pkg ne $opt{'pkg'} ) {
2310 $part_pkg->set('pkg', $opt{'pkg'});
2313 my %pkg_opt = $part_pkg->options;
2314 if ( ref($opt{'additional'}) ) {
2315 delete $pkg_opt{$_} foreach grep /^additional/, keys %pkg_opt;
2317 for ( $i = 0; exists($opt{'additional'}->[$i]); $i++ ) {
2318 $pkg_opt{ "additional_info$i" } = $opt{'additional'}->[$i];
2320 $pkg_opt{'additional_count'} = $i if $i > 0;
2324 if ( exists($opt{'classnum'}) and $part_pkg->classnum ne $opt{'classnum'} ) {
2326 $old_classnum = $part_pkg->classnum;
2327 $part_pkg->set('classnum', $opt{'classnum'});
2330 my $error = $part_pkg->replace( options => \%pkg_opt );
2331 return $error if $error;
2333 if (defined $old_classnum) {
2334 # fix invoice grouping records
2335 my $old_catname = $old_classnum
2336 ? FS::pkg_class->by_key($old_classnum)->categoryname
2338 my $new_catname = $opt{'classnum'}
2339 ? $part_pkg->pkg_class->categoryname
2341 if ( $old_catname ne $new_catname ) {
2342 foreach my $cust_bill_pkg ($self->cust_bill_pkg) {
2343 # (there should only be one...)
2344 my @display = qsearch( 'cust_bill_pkg_display', {
2345 'billpkgnum' => $cust_bill_pkg->billpkgnum,
2346 'section' => $old_catname,
2348 foreach (@display) {
2349 $_->set('section', $new_catname);
2350 $error = $_->replace;
2352 $dbh->rollback if $oldAutoCommit;
2356 } # foreach $cust_bill_pkg
2359 if ( $opt{'adjust_commission'} ) {
2360 # fix commission credits...tricky.
2361 foreach my $cust_event ($self->cust_event) {
2362 my $part_event = $cust_event->part_event;
2363 foreach my $table (qw(sales agent)) {
2365 "FS::part_event::Action::Mixin::credit_${table}_pkg_class";
2366 my $credit = qsearchs('cust_credit', {
2367 'eventnum' => $cust_event->eventnum,
2369 if ( $part_event->isa($class) ) {
2370 # Yes, this results in current commission rates being applied
2371 # retroactively to a one-time charge. For accounting purposes
2372 # there ought to be some kind of time limit on doing this.
2373 my $amount = $part_event->_calc_credit($self);
2374 if ( $credit and $credit->amount ne $amount ) {
2375 # Void the old credit.
2376 $error = $credit->void('Package class changed');
2378 $dbh->rollback if $oldAutoCommit;
2379 return "$error (adjusting commission credit)";
2382 # redo the event action to recreate the credit.
2384 eval { $part_event->do_action( $self, $cust_event ) };
2386 $dbh->rollback if $oldAutoCommit;
2389 } # if $part_event->isa($class)
2391 } # foreach $cust_event
2392 } # if $opt{'adjust_commission'}
2393 } # if defined $old_classnum
2395 $dbh->commit if $oldAutoCommit;
2401 use Storable 'thaw';
2404 sub process_bulk_cust_pkg {
2406 my $param = thaw(decode_base64(shift));
2407 warn Dumper($param) if $DEBUG;
2409 my $old_part_pkg = qsearchs('part_pkg',
2410 { pkgpart => $param->{'old_pkgpart'} });
2411 my $new_part_pkg = qsearchs('part_pkg',
2412 { pkgpart => $param->{'new_pkgpart'} });
2413 die "Must select a new package type\n" unless $new_part_pkg;
2414 #my $keep_dates = $param->{'keep_dates'} || 0;
2415 my $keep_dates = 1; # there is no good reason to turn this off
2417 local $SIG{HUP} = 'IGNORE';
2418 local $SIG{INT} = 'IGNORE';
2419 local $SIG{QUIT} = 'IGNORE';
2420 local $SIG{TERM} = 'IGNORE';
2421 local $SIG{TSTP} = 'IGNORE';
2422 local $SIG{PIPE} = 'IGNORE';
2424 my $oldAutoCommit = $FS::UID::AutoCommit;
2425 local $FS::UID::AutoCommit = 0;
2428 my @cust_pkgs = qsearch('cust_pkg', { 'pkgpart' => $param->{'old_pkgpart'} } );
2431 foreach my $old_cust_pkg ( @cust_pkgs ) {
2433 $job->update_statustext(int(100*$i/(scalar @cust_pkgs)));
2434 if ( $old_cust_pkg->getfield('cancel') ) {
2435 warn '[process_bulk_cust_pkg ] skipping canceled pkgnum '.
2436 $old_cust_pkg->pkgnum."\n"
2440 warn '[process_bulk_cust_pkg] changing pkgnum '.$old_cust_pkg->pkgnum."\n"
2442 my $error = $old_cust_pkg->change(
2443 'pkgpart' => $param->{'new_pkgpart'},
2444 'keep_dates' => $keep_dates
2446 if ( !ref($error) ) { # change returns the cust_pkg on success
2448 die "Error changing pkgnum ".$old_cust_pkg->pkgnum.": '$error'\n";
2451 $dbh->commit if $oldAutoCommit;
2457 Returns the last bill date, or if there is no last bill date, the setup date.
2458 Useful for billing metered services.
2464 return $self->setfield('last_bill', $_[0]) if @_;
2465 return $self->getfield('last_bill') if $self->getfield('last_bill');
2466 my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
2467 'edate' => $self->bill, } );
2468 $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
2471 =item last_cust_pkg_reason ACTION
2473 Returns the most recent ACTION FS::cust_pkg_reason associated with the package.
2474 Returns false if there is no reason or the package is not currenly ACTION'd
2475 ACTION is one of adjourn, susp, cancel, or expire.
2479 sub last_cust_pkg_reason {
2480 my ( $self, $action ) = ( shift, shift );
2481 my $date = $self->get($action);
2483 'table' => 'cust_pkg_reason',
2484 'hashref' => { 'pkgnum' => $self->pkgnum,
2485 'action' => substr(uc($action), 0, 1),
2488 'order_by' => 'ORDER BY num DESC LIMIT 1',
2492 =item last_reason ACTION
2494 Returns the most recent ACTION FS::reason associated with the package.
2495 Returns false if there is no reason or the package is not currenly ACTION'd
2496 ACTION is one of adjourn, susp, cancel, or expire.
2501 my $cust_pkg_reason = shift->last_cust_pkg_reason(@_);
2502 $cust_pkg_reason->reason
2503 if $cust_pkg_reason;
2508 Returns the definition for this billing item, as an FS::part_pkg object (see
2515 return $self->{'_pkgpart'} if $self->{'_pkgpart'};
2516 cluck "cust_pkg->part_pkg called" if $DEBUG > 1;
2517 qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
2522 Returns the cancelled package this package was changed from, if any.
2528 return '' unless $self->change_pkgnum;
2529 qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
2532 =item change_cust_main
2534 Returns the customter this package was detached to, if any.
2538 sub change_cust_main {
2540 return '' unless $self->change_custnum;
2541 qsearchs('cust_main', { 'custnum' => $self->change_custnum } );
2546 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
2553 $self->part_pkg->calc_setup($self, @_);
2558 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
2565 $self->part_pkg->calc_recur($self, @_);
2570 Calls the I<base_setup> of the FS::part_pkg object associated with this billing
2577 $self->part_pkg->base_setup($self, @_);
2582 Calls the I<base_recur> of the FS::part_pkg object associated with this billing
2589 $self->part_pkg->base_recur($self, @_);
2594 Calls the I<calc_remain> of the FS::part_pkg object associated with this
2601 $self->part_pkg->calc_remain($self, @_);
2606 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
2613 $self->part_pkg->calc_cancel($self, @_);
2618 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
2624 qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
2627 =item cust_pkg_detail [ DETAILTYPE ]
2629 Returns any customer package details for this package (see
2630 L<FS::cust_pkg_detail>).
2632 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
2636 sub cust_pkg_detail {
2638 my %hash = ( 'pkgnum' => $self->pkgnum );
2639 $hash{detailtype} = shift if @_;
2641 'table' => 'cust_pkg_detail',
2642 'hashref' => \%hash,
2643 'order_by' => 'ORDER BY weight, pkgdetailnum',
2647 =item set_cust_pkg_detail DETAILTYPE [ DETAIL, DETAIL, ... ]
2649 Sets customer package details for this package (see L<FS::cust_pkg_detail>).
2651 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
2653 If there is an error, returns the error, otherwise returns false.
2657 sub set_cust_pkg_detail {
2658 my( $self, $detailtype, @details ) = @_;
2660 local $SIG{HUP} = 'IGNORE';
2661 local $SIG{INT} = 'IGNORE';
2662 local $SIG{QUIT} = 'IGNORE';
2663 local $SIG{TERM} = 'IGNORE';
2664 local $SIG{TSTP} = 'IGNORE';
2665 local $SIG{PIPE} = 'IGNORE';
2667 my $oldAutoCommit = $FS::UID::AutoCommit;
2668 local $FS::UID::AutoCommit = 0;
2671 foreach my $current ( $self->cust_pkg_detail($detailtype) ) {
2672 my $error = $current->delete;
2674 $dbh->rollback if $oldAutoCommit;
2675 return "error removing old detail: $error";
2679 foreach my $detail ( @details ) {
2680 my $cust_pkg_detail = new FS::cust_pkg_detail {
2681 'pkgnum' => $self->pkgnum,
2682 'detailtype' => $detailtype,
2683 'detail' => $detail,
2685 my $error = $cust_pkg_detail->insert;
2687 $dbh->rollback if $oldAutoCommit;
2688 return "error adding new detail: $error";
2693 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2700 Returns the new-style customer billing events (see L<FS::cust_event>) for this invoice.
2704 #false laziness w/cust_bill.pm
2708 'table' => 'cust_event',
2709 'addl_from' => 'JOIN part_event USING ( eventpart )',
2710 'hashref' => { 'tablenum' => $self->pkgnum },
2711 'extra_sql' => " AND eventtable = 'cust_pkg' ",
2715 =item num_cust_event
2717 Returns the number of new-style customer billing events (see L<FS::cust_event>) for this invoice.
2721 #false laziness w/cust_bill.pm
2722 sub num_cust_event {
2725 "SELECT COUNT(*) FROM cust_event JOIN part_event USING ( eventpart ) ".
2726 " WHERE tablenum = ? AND eventtable = 'cust_pkg'";
2727 my $sth = dbh->prepare($sql) or die dbh->errstr. " preparing $sql";
2728 $sth->execute($self->pkgnum) or die $sth->errstr. " executing $sql";
2729 $sth->fetchrow_arrayref->[0];
2732 =item part_pkg_currency_option OPTIONNAME
2734 Returns a two item list consisting of the currency of this customer, if any,
2735 and a value for the provided option. If the customer has a currency, the value
2736 is the option value the given name and the currency (see
2737 L<FS::part_pkg_currency>). Otherwise, if the customer has no currency, is the
2738 regular option value for the given name (see L<FS::part_pkg_option>).
2742 sub part_pkg_currency_option {
2743 my( $self, $optionname ) = @_;
2744 my $part_pkg = $self->part_pkg;
2745 if ( my $currency = $self->cust_main->currency ) {
2746 ($currency, $part_pkg->part_pkg_currency_option($currency, $optionname) );
2748 ('', $part_pkg->option($optionname) );
2752 =item cust_svc [ SVCPART ] (old, deprecated usage)
2754 =item cust_svc [ OPTION => VALUE ... ] (current usage)
2756 =item cust_svc_unsorted [ OPTION => VALUE ... ]
2758 Returns the services for this package, as FS::cust_svc objects (see
2759 L<FS::cust_svc>). Available options are svcpart and svcdb. If either is
2760 spcififed, returns only the matching services.
2762 As an optimization, use the cust_svc_unsorted version if you are not displaying
2769 cluck "cust_pkg->cust_svc called" if $DEBUG > 2;
2770 $self->_sort_cust_svc( $self->cust_svc_unsorted_arrayref(@_) );
2773 sub cust_svc_unsorted {
2775 @{ $self->cust_svc_unsorted_arrayref(@_) };
2778 sub cust_svc_unsorted_arrayref {
2781 return () unless $self->num_cust_svc(@_);
2784 if ( @_ && $_[0] =~ /^\d+/ ) {
2785 $opt{svcpart} = shift;
2786 } elsif ( @_ && ref($_[0]) eq 'HASH' ) {
2793 'table' => 'cust_svc',
2794 'hashref' => { 'pkgnum' => $self->pkgnum },
2796 if ( $opt{svcpart} ) {
2797 $search{hashref}->{svcpart} = $opt{'svcpart'};
2799 if ( $opt{'svcdb'} ) {
2800 $search{addl_from} = ' LEFT JOIN part_svc USING ( svcpart ) ';
2801 $search{extra_sql} = ' AND svcdb = '. dbh->quote( $opt{'svcdb'} );
2804 [ qsearch(\%search) ];
2808 =item overlimit [ SVCPART ]
2810 Returns the services for this package which have exceeded their
2811 usage limit as FS::cust_svc objects (see L<FS::cust_svc>). If a svcpart
2812 is specified, return only the matching services.
2818 return () unless $self->num_cust_svc(@_);
2819 grep { $_->overlimit } $self->cust_svc(@_);
2822 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
2824 Returns historical services for this package created before END TIMESTAMP and
2825 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
2826 (see L<FS::h_cust_svc>). If MODE is 'I' (for 'invoice'), services with the
2827 I<pkg_svc.hidden> flag will be omitted.
2833 warn "$me _h_cust_svc called on $self\n"
2836 my ($end, $start, $mode) = @_;
2837 my @cust_svc = $self->_sort_cust_svc(
2838 [ qsearch( 'h_cust_svc',
2839 { 'pkgnum' => $self->pkgnum, },
2840 FS::h_cust_svc->sql_h_search(@_),
2843 if ( defined($mode) && $mode eq 'I' ) {
2844 my %hidden_svcpart = map { $_->svcpart => $_->hidden } $self->part_svc;
2845 return grep { !$hidden_svcpart{$_->svcpart} } @cust_svc;
2851 sub _sort_cust_svc {
2852 my( $self, $arrayref ) = @_;
2855 sub ($$) { my ($a, $b) = @_; $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] };
2857 my %pkg_svc = map { $_->svcpart => $_ }
2858 qsearch( 'pkg_svc', { 'pkgpart' => $self->pkgpart } );
2863 my $pkg_svc = $pkg_svc{ $_->svcpart } || '';
2865 $pkg_svc ? $pkg_svc->primary_svc : '',
2866 $pkg_svc ? $pkg_svc->quantity : 0,
2873 =item num_cust_svc [ SVCPART ] (old, deprecated usage)
2875 =item num_cust_svc [ OPTION => VALUE ... ] (current usage)
2877 Returns the number of services for this package. Available options are svcpart
2878 and svcdb. If either is spcififed, returns only the matching services.
2885 return $self->{'_num_cust_svc'}
2887 && exists($self->{'_num_cust_svc'})
2888 && $self->{'_num_cust_svc'} =~ /\d/;
2890 cluck "cust_pkg->num_cust_svc called, _num_cust_svc:".$self->{'_num_cust_svc'}
2894 if ( @_ && $_[0] =~ /^\d+/ ) {
2895 $opt{svcpart} = shift;
2896 } elsif ( @_ && ref($_[0]) eq 'HASH' ) {
2902 my $select = 'SELECT COUNT(*) FROM cust_svc ';
2903 my $where = ' WHERE pkgnum = ? ';
2904 my @param = ($self->pkgnum);
2906 if ( $opt{'svcpart'} ) {
2907 $where .= ' AND svcpart = ? ';
2908 push @param, $opt{'svcpart'};
2910 if ( $opt{'svcdb'} ) {
2911 $select .= ' LEFT JOIN part_svc USING ( svcpart ) ';
2912 $where .= ' AND svcdb = ? ';
2913 push @param, $opt{'svcdb'};
2916 my $sth = dbh->prepare("$select $where") or die dbh->errstr;
2917 $sth->execute(@param) or die $sth->errstr;
2918 $sth->fetchrow_arrayref->[0];
2921 =item available_part_svc
2923 Returns a list of FS::part_svc objects representing services included in this
2924 package but not yet provisioned. Each FS::part_svc object also has an extra
2925 field, I<num_avail>, which specifies the number of available services.
2929 sub available_part_svc {
2932 my $pkg_quantity = $self->quantity || 1;
2934 grep { $_->num_avail > 0 }
2936 my $part_svc = $_->part_svc;
2937 $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
2938 $pkg_quantity * $_->quantity - $self->num_cust_svc($_->svcpart);
2940 # more evil encapsulation breakage
2941 if($part_svc->{'Hash'}{'num_avail'} > 0) {
2942 my @exports = $part_svc->part_export_did;
2943 $part_svc->{'Hash'}{'can_get_dids'} = scalar(@exports);
2948 $self->part_pkg->pkg_svc;
2951 =item part_svc [ OPTION => VALUE ... ]
2953 Returns a list of FS::part_svc objects representing provisioned and available
2954 services included in this package. Each FS::part_svc object also has the
2955 following extra fields:
2959 =item num_cust_svc (count)
2961 =item num_avail (quantity - count)
2963 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
2967 Accepts one option: summarize_size. If specified and non-zero, will omit the
2968 extra cust_pkg_svc option for objects where num_cust_svc is this size or
2974 #label -> ($cust_svc->label)[1]
2980 my $pkg_quantity = $self->quantity || 1;
2982 #XXX some sort of sort order besides numeric by svcpart...
2983 my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
2985 my $part_svc = $pkg_svc->part_svc;
2986 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
2987 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
2988 $part_svc->{'Hash'}{'num_avail'} =
2989 max( 0, $pkg_quantity * $pkg_svc->quantity - $num_cust_svc );
2990 $part_svc->{'Hash'}{'cust_pkg_svc'} =
2991 $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : []
2992 unless exists($opt{summarize_size}) && $opt{summarize_size} > 0
2993 && $num_cust_svc >= $opt{summarize_size};
2994 $part_svc->{'Hash'}{'hidden'} = $pkg_svc->hidden;
2996 } $self->part_pkg->pkg_svc;
2999 push @part_svc, map {
3001 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
3002 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
3003 $part_svc->{'Hash'}{'num_avail'} = 0; #0-$num_cust_svc ?
3004 $part_svc->{'Hash'}{'cust_pkg_svc'} =
3005 $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
3007 } $self->extra_part_svc;
3013 =item extra_part_svc
3015 Returns a list of FS::part_svc objects corresponding to services in this
3016 package which are still provisioned but not (any longer) available in the
3021 sub extra_part_svc {
3024 my $pkgnum = $self->pkgnum;
3025 #my $pkgpart = $self->pkgpart;
3028 # 'table' => 'part_svc',
3031 # "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
3032 # WHERE pkg_svc.svcpart = part_svc.svcpart
3033 # AND pkg_svc.pkgpart = ?
3036 # AND 0 < ( SELECT COUNT(*) FROM cust_svc
3037 # LEFT JOIN cust_pkg USING ( pkgnum )
3038 # WHERE cust_svc.svcpart = part_svc.svcpart
3041 # 'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
3044 #seems to benchmark slightly faster... (or did?)
3046 my @pkgparts = map $_->pkgpart, $self->part_pkg->self_and_svc_linked;
3047 my $pkgparts = join(',', @pkgparts);
3050 #'select' => 'DISTINCT ON (svcpart) part_svc.*',
3051 #MySQL doesn't grok DISINCT ON
3052 'select' => 'DISTINCT part_svc.*',
3053 'table' => 'part_svc',
3055 "LEFT JOIN pkg_svc ON ( pkg_svc.svcpart = part_svc.svcpart
3056 AND pkg_svc.pkgpart IN ($pkgparts)
3059 LEFT JOIN cust_svc ON ( cust_svc.svcpart = part_svc.svcpart )
3060 LEFT JOIN cust_pkg USING ( pkgnum )
3063 'extra_sql' => "WHERE pkgsvcnum IS NULL AND cust_pkg.pkgnum = ? ",
3064 'extra_param' => [ [$self->pkgnum=>'int'] ],
3070 Returns a short status string for this package, currently:
3074 =item not yet billed
3076 =item one-time charge
3091 my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
3093 return 'cancelled' if $self->get('cancel');
3094 return 'suspended' if $self->susp;
3095 return 'not yet billed' unless $self->setup;
3096 return 'one-time charge' if $freq =~ /^(0|$)/;
3100 =item ucfirst_status
3102 Returns the status with the first character capitalized.
3106 sub ucfirst_status {
3107 ucfirst(shift->status);
3112 Class method that returns the list of possible status strings for packages
3113 (see L<the status method|/status>). For example:
3115 @statuses = FS::cust_pkg->statuses();
3119 tie my %statuscolor, 'Tie::IxHash',
3120 'not yet billed' => '009999', #teal? cyan?
3121 'one-time charge' => '000000',
3122 'active' => '00CC00',
3123 'suspended' => 'FF9900',
3124 'cancelled' => 'FF0000',
3128 my $self = shift; #could be class...
3129 #grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
3130 # # mayble split btw one-time vs. recur
3136 Returns a hex triplet color string for this package's status.
3142 $statuscolor{$self->status};
3147 Returns a label for this package. (Currently "pkgnum: pkg - comment" or
3148 "pkg - comment" depending on user preference).
3154 my $label = $self->part_pkg->pkg_comment( 'nopkgpart' => 1 );
3155 $label = $self->pkgnum. ": $label"
3156 if $FS::CurrentUser::CurrentUser->option('show_pkgnum');
3160 =item pkg_label_long
3162 Returns a long label for this package, adding the primary service's label to
3167 sub pkg_label_long {
3169 my $label = $self->pkg_label;
3170 my $cust_svc = $self->primary_cust_svc;
3171 $label .= ' ('. ($cust_svc->label)[1]. ')' if $cust_svc;
3177 Returns a customer-localized label for this package.
3183 $self->part_pkg->pkg_locale( $self->cust_main->locale );
3186 =item primary_cust_svc
3188 Returns a primary service (as FS::cust_svc object) if one can be identified.
3192 #for labeling purposes - might not 100% match up with part_pkg->svcpart's idea
3194 sub primary_cust_svc {
3197 my @cust_svc = $self->cust_svc;
3199 return '' unless @cust_svc; #no serivces - irrelevant then
3201 return $cust_svc[0] if scalar(@cust_svc) == 1; #always return a single service
3203 # primary service as specified in the package definition
3204 # or exactly one service definition with quantity one
3205 my $svcpart = $self->part_pkg->svcpart;
3206 @cust_svc = grep { $_->svcpart == $svcpart } @cust_svc;
3207 return $cust_svc[0] if scalar(@cust_svc) == 1;
3209 #couldn't identify one thing..
3215 Returns a list of lists, calling the label method for all services
3216 (see L<FS::cust_svc>) of this billing item.
3222 map { [ $_->label ] } $self->cust_svc;
3225 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
3227 Like the labels method, but returns historical information on services that
3228 were active as of END_TIMESTAMP and (optionally) not cancelled before
3229 START_TIMESTAMP. If MODE is 'I' (for 'invoice'), services with the
3230 I<pkg_svc.hidden> flag will be omitted.
3232 Returns a list of lists, calling the label method for all (historical) services
3233 (see L<FS::h_cust_svc>) of this billing item.
3239 warn "$me _h_labels called on $self\n"
3241 map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
3246 Like labels, except returns a simple flat list, and shortens long
3247 (currently >5 or the cust_bill-max_same_services configuration value) lists of
3248 identical services to one line that lists the service label and the number of
3249 individual services rather than individual items.
3254 shift->_labels_short( 'labels', @_ );
3257 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
3259 Like h_labels, except returns a simple flat list, and shortens long
3260 (currently >5 or the cust_bill-max_same_services configuration value) lists of
3261 identical services to one line that lists the service label and the number of
3262 individual services rather than individual items.
3266 sub h_labels_short {
3267 shift->_labels_short( 'h_labels', @_ );
3271 my( $self, $method ) = ( shift, shift );
3273 warn "$me _labels_short called on $self with $method method\n"
3276 my $conf = new FS::Conf;
3277 my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
3279 warn "$me _labels_short populating \%labels\n"
3283 #tie %labels, 'Tie::IxHash';
3284 push @{ $labels{$_->[0]} }, $_->[1]
3285 foreach $self->$method(@_);
3287 warn "$me _labels_short populating \@labels\n"
3291 foreach my $label ( keys %labels ) {
3293 my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
3294 my $num = scalar(@values);
3295 warn "$me _labels_short $num items for $label\n"
3298 if ( $num > $max_same_services ) {
3299 warn "$me _labels_short more than $max_same_services, so summarizing\n"
3301 push @labels, "$label ($num)";
3303 if ( $conf->exists('cust_bill-consolidate_services') ) {
3304 warn "$me _labels_short consolidating services\n"
3306 # push @labels, "$label: ". join(', ', @values);
3308 my $detail = "$label: ";
3309 $detail .= shift(@values). ', '
3311 && ( length($detail.$values[0]) < 78 || $detail eq "$label: " );
3313 push @labels, $detail;
3315 warn "$me _labels_short done consolidating services\n"
3318 warn "$me _labels_short adding service data\n"
3320 push @labels, map { "$label: $_" } @values;
3331 Returns the parent customer object (see L<FS::cust_main>).
3335 Returns the balance for this specific package, when using
3336 experimental package balance.
3342 $self->cust_main->balance_pkgnum( $self->pkgnum );
3345 #these subs are in location_Mixin.pm now... unfortunately the POD doesn't mixin
3349 Returns the location object, if any (see L<FS::cust_location>).
3351 =item cust_location_or_main
3353 If this package is associated with a location, returns the locaiton (see
3354 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
3356 =item location_label [ OPTION => VALUE ... ]
3358 Returns the label of the location object (see L<FS::cust_location>).
3362 #end of subs in location_Mixin.pm now... unfortunately the POD doesn't mixin
3364 =item tax_locationnum
3366 Returns the foreign key to a L<FS::cust_location> object for calculating
3367 tax on this package, as determined by the C<tax-pkg_address> and
3368 C<tax-ship_address> configuration flags.
3372 sub tax_locationnum {
3374 my $conf = FS::Conf->new;
3375 if ( $conf->exists('tax-pkg_address') ) {
3376 return $self->locationnum;
3378 elsif ( $conf->exists('tax-ship_address') ) {
3379 return $self->cust_main->ship_locationnum;
3382 return $self->cust_main->bill_locationnum;
3388 Returns the L<FS::cust_location> object for tax_locationnum.
3394 FS::cust_location->by_key( $self->tax_locationnum )
3397 =item seconds_since TIMESTAMP
3399 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
3400 package have been online since TIMESTAMP, according to the session monitor.
3402 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
3403 L<Time::Local> and L<Date::Parse> for conversion functions.
3408 my($self, $since) = @_;
3411 foreach my $cust_svc (
3412 grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
3414 $seconds += $cust_svc->seconds_since($since);
3421 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
3423 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
3424 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
3427 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
3428 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
3434 sub seconds_since_sqlradacct {
3435 my($self, $start, $end) = @_;
3439 foreach my $cust_svc (
3441 my $part_svc = $_->part_svc;
3442 $part_svc->svcdb eq 'svc_acct'
3443 && scalar($part_svc->part_export_usage);
3446 $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
3453 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
3455 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
3456 in this package for sessions ending between TIMESTAMP_START (inclusive) and
3460 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
3461 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
3466 sub attribute_since_sqlradacct {
3467 my($self, $start, $end, $attrib) = @_;
3471 foreach my $cust_svc (
3473 my $part_svc = $_->part_svc;
3474 scalar($part_svc->part_export_usage);
3477 $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
3489 my( $self, $value ) = @_;
3490 if ( defined($value) ) {
3491 $self->setfield('quantity', $value);
3493 $self->getfield('quantity') || 1;
3496 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
3498 Transfers as many services as possible from this package to another package.
3500 The destination package can be specified by pkgnum by passing an FS::cust_pkg
3501 object. The destination package must already exist.
3503 Services are moved only if the destination allows services with the correct
3504 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true. Use
3505 this option with caution! No provision is made for export differences
3506 between the old and new service definitions. Probably only should be used
3507 when your exports for all service definitions of a given svcdb are identical.
3508 (attempt a transfer without it first, to move all possible svcpart-matching
3511 Any services that can't be moved remain in the original package.
3513 Returns an error, if there is one; otherwise, returns the number of services
3514 that couldn't be moved.
3519 my ($self, $dest_pkgnum, %opt) = @_;
3525 if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
3526 $dest = $dest_pkgnum;
3527 $dest_pkgnum = $dest->pkgnum;
3529 $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
3532 return ('Package does not exist: '.$dest_pkgnum) unless $dest;
3534 foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
3535 $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
3538 foreach my $cust_svc ($dest->cust_svc) {
3539 $target{$cust_svc->svcpart}--;
3542 my %svcpart2svcparts = ();
3543 if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
3544 warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
3545 foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
3546 next if exists $svcpart2svcparts{$svcpart};
3547 my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
3548 $svcpart2svcparts{$svcpart} = [
3550 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
3552 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
3553 'svcpart' => $_ } );
3555 $pkg_svc ? $pkg_svc->primary_svc : '',
3556 $pkg_svc ? $pkg_svc->quantity : 0,
3560 grep { $_ != $svcpart }
3562 qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
3564 warn "alternates for svcpart $svcpart: ".
3565 join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
3570 foreach my $cust_svc ($self->cust_svc) {
3571 if($target{$cust_svc->svcpart} > 0
3572 or $FS::cust_svc::ignore_quantity) { # maybe should be a 'force' option
3573 $target{$cust_svc->svcpart}--;
3574 my $new = new FS::cust_svc { $cust_svc->hash };
3575 $new->pkgnum($dest_pkgnum);
3576 my $error = $new->replace($cust_svc);
3577 return $error if $error;
3578 } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
3580 warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
3581 warn "alternates to consider: ".
3582 join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
3584 my @alternate = grep {
3585 warn "considering alternate svcpart $_: ".
3586 "$target{$_} available in new package\n"
3589 } @{$svcpart2svcparts{$cust_svc->svcpart}};
3591 warn "alternate(s) found\n" if $DEBUG;
3592 my $change_svcpart = $alternate[0];
3593 $target{$change_svcpart}--;
3594 my $new = new FS::cust_svc { $cust_svc->hash };
3595 $new->svcpart($change_svcpart);
3596 $new->pkgnum($dest_pkgnum);
3597 my $error = $new->replace($cust_svc);
3598 return $error if $error;
3609 =item grab_svcnums SVCNUM, SVCNUM ...
3611 Change the pkgnum for the provided services to this packages. If there is an
3612 error, returns the error, otherwise returns false.
3620 local $SIG{HUP} = 'IGNORE';
3621 local $SIG{INT} = 'IGNORE';
3622 local $SIG{QUIT} = 'IGNORE';
3623 local $SIG{TERM} = 'IGNORE';
3624 local $SIG{TSTP} = 'IGNORE';
3625 local $SIG{PIPE} = 'IGNORE';
3627 my $oldAutoCommit = $FS::UID::AutoCommit;
3628 local $FS::UID::AutoCommit = 0;
3631 foreach my $svcnum (@svcnum) {
3632 my $cust_svc = qsearchs('cust_svc', { svcnum=>$svcnum } ) or do {
3633 $dbh->rollback if $oldAutoCommit;
3634 return "unknown svcnum $svcnum";
3636 $cust_svc->pkgnum( $self->pkgnum );
3637 my $error = $cust_svc->replace;
3639 $dbh->rollback if $oldAutoCommit;
3644 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3651 This method is deprecated. See the I<depend_jobnum> option to the insert and
3652 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
3656 #looks like this is still used by the order_pkg and change_pkg methods in
3657 # ClientAPI/MyAccount, need to look into those before removing
3661 local $SIG{HUP} = 'IGNORE';
3662 local $SIG{INT} = 'IGNORE';
3663 local $SIG{QUIT} = 'IGNORE';
3664 local $SIG{TERM} = 'IGNORE';
3665 local $SIG{TSTP} = 'IGNORE';
3666 local $SIG{PIPE} = 'IGNORE';
3668 my $oldAutoCommit = $FS::UID::AutoCommit;
3669 local $FS::UID::AutoCommit = 0;
3672 foreach my $cust_svc ( $self->cust_svc ) {
3673 #false laziness w/svc_Common::insert
3674 my $svc_x = $cust_svc->svc_x;
3675 foreach my $part_export ( $cust_svc->part_svc->part_export ) {
3676 my $error = $part_export->export_insert($svc_x);
3678 $dbh->rollback if $oldAutoCommit;
3684 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3689 =item export_pkg_change OLD_CUST_PKG
3691 Calls the "pkg_change" export action for all services attached to this package.
3695 sub export_pkg_change {
3696 my( $self, $old ) = ( shift, shift );
3698 local $SIG{HUP} = 'IGNORE';
3699 local $SIG{INT} = 'IGNORE';
3700 local $SIG{QUIT} = 'IGNORE';
3701 local $SIG{TERM} = 'IGNORE';
3702 local $SIG{TSTP} = 'IGNORE';
3703 local $SIG{PIPE} = 'IGNORE';
3705 my $oldAutoCommit = $FS::UID::AutoCommit;
3706 local $FS::UID::AutoCommit = 0;
3709 foreach my $svc_x ( map $_->svc_x, $self->cust_svc ) {
3710 my $error = $svc_x->export('pkg_change', $self, $old);
3712 $dbh->rollback if $oldAutoCommit;
3717 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3724 Associates this package with a (suspension or cancellation) reason (see
3725 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
3728 Available options are:
3734 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.
3738 the access_user (see L<FS::access_user>) providing the reason
3746 the action (cancel, susp, adjourn, expire) associated with the reason
3750 If there is an error, returns the error, otherwise returns false.
3755 my ($self, %options) = @_;
3757 my $otaker = $options{reason_otaker} ||
3758 $FS::CurrentUser::CurrentUser->username;
3761 if ( $options{'reason'} =~ /^(\d+)$/ ) {
3765 } elsif ( ref($options{'reason'}) ) {
3767 return 'Enter a new reason (or select an existing one)'
3768 unless $options{'reason'}->{'reason'} !~ /^\s*$/;
3770 my $reason = new FS::reason({
3771 'reason_type' => $options{'reason'}->{'typenum'},
3772 'reason' => $options{'reason'}->{'reason'},
3774 my $error = $reason->insert;
3775 return $error if $error;
3777 $reasonnum = $reason->reasonnum;
3780 return "Unparsable reason: ". $options{'reason'};
3783 my $cust_pkg_reason =
3784 new FS::cust_pkg_reason({ 'pkgnum' => $self->pkgnum,
3785 'reasonnum' => $reasonnum,
3786 'otaker' => $otaker,
3787 'action' => substr(uc($options{'action'}),0,1),
3788 'date' => $options{'date'}
3793 $cust_pkg_reason->insert;
3796 =item insert_discount
3798 Associates this package with a discount (see L<FS::cust_pkg_discount>, possibly
3799 inserting a new discount on the fly (see L<FS::discount>).
3801 Available options are:
3809 If there is an error, returns the error, otherwise returns false.
3813 sub insert_discount {
3814 #my ($self, %options) = @_;
3817 my $cust_pkg_discount = new FS::cust_pkg_discount {
3818 'pkgnum' => $self->pkgnum,
3819 'discountnum' => $self->discountnum,
3821 'end_date' => '', #XXX
3822 #for the create a new discount case
3823 '_type' => $self->discountnum__type,
3824 'amount' => $self->discountnum_amount,
3825 'percent' => $self->discountnum_percent,
3826 'months' => $self->discountnum_months,
3827 'setup' => $self->discountnum_setup,
3828 #'disabled' => $self->discountnum_disabled,
3831 $cust_pkg_discount->insert;
3834 =item set_usage USAGE_VALUE_HASHREF
3836 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
3837 to which they should be set (see L<FS::svc_acct>). Currently seconds,
3838 upbytes, downbytes, and totalbytes are appropriate keys.
3840 All svc_accts which are part of this package have their values reset.
3845 my ($self, $valueref, %opt) = @_;
3847 #only svc_acct can set_usage for now
3848 foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
3849 my $svc_x = $cust_svc->svc_x;
3850 $svc_x->set_usage($valueref, %opt)
3851 if $svc_x->can("set_usage");
3855 =item recharge USAGE_VALUE_HASHREF
3857 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
3858 to which they should be set (see L<FS::svc_acct>). Currently seconds,
3859 upbytes, downbytes, and totalbytes are appropriate keys.
3861 All svc_accts which are part of this package have their values incremented.
3866 my ($self, $valueref) = @_;
3868 #only svc_acct can set_usage for now
3869 foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
3870 my $svc_x = $cust_svc->svc_x;
3871 $svc_x->recharge($valueref)
3872 if $svc_x->can("recharge");
3876 =item cust_pkg_discount
3878 =item cust_pkg_discount_active
3882 sub cust_pkg_discount_active {
3884 grep { $_->status eq 'active' } $self->cust_pkg_discount;
3887 =item cust_pkg_usage
3889 Returns a list of all voice usage counters attached to this package.
3891 =item apply_usage OPTIONS
3893 Takes the following options:
3894 - cdr: a call detail record (L<FS::cdr>)
3895 - rate_detail: the rate determined for this call (L<FS::rate_detail>)
3896 - minutes: the maximum number of minutes to be charged
3898 Finds available usage minutes for a call of this class, and subtracts
3899 up to that many minutes from the usage pool. If the usage pool is empty,
3900 and the C<cdr-minutes_priority> global config option is set, minutes may
3901 be taken from other calls as well. Either way, an allocation record will
3902 be created (L<FS::cdr_cust_pkg_usage>) and this method will return the
3903 number of minutes of usage applied to the call.
3908 my ($self, %opt) = @_;
3909 my $cdr = $opt{cdr};
3910 my $rate_detail = $opt{rate_detail};
3911 my $minutes = $opt{minutes};
3912 my $classnum = $rate_detail->classnum;
3913 my $pkgnum = $self->pkgnum;
3914 my $custnum = $self->custnum;
3916 local $SIG{HUP} = 'IGNORE';
3917 local $SIG{INT} = 'IGNORE';
3918 local $SIG{QUIT} = 'IGNORE';
3919 local $SIG{TERM} = 'IGNORE';
3920 local $SIG{TSTP} = 'IGNORE';
3921 local $SIG{PIPE} = 'IGNORE';
3923 my $oldAutoCommit = $FS::UID::AutoCommit;
3924 local $FS::UID::AutoCommit = 0;
3926 my $order = FS::Conf->new->config('cdr-minutes_priority');
3930 $is_classnum = ' part_pkg_usage_class.classnum = '.$classnum;
3932 $is_classnum = ' part_pkg_usage_class.classnum IS NULL';
3934 my @usage_recs = qsearch({
3935 'table' => 'cust_pkg_usage',
3936 'addl_from' => ' JOIN part_pkg_usage USING (pkgusagepart)'.
3937 ' JOIN cust_pkg USING (pkgnum)'.
3938 ' JOIN part_pkg_usage_class USING (pkgusagepart)',
3939 'select' => 'cust_pkg_usage.*',
3940 'extra_sql' => " WHERE ( cust_pkg.pkgnum = $pkgnum OR ".
3941 " ( cust_pkg.custnum = $custnum AND ".
3942 " part_pkg_usage.shared IS NOT NULL ) ) AND ".
3943 $is_classnum . ' AND '.
3944 " cust_pkg_usage.minutes > 0",
3945 'order_by' => " ORDER BY priority ASC",
3948 my $orig_minutes = $minutes;
3950 while (!$error and $minutes > 0 and @usage_recs) {
3951 my $cust_pkg_usage = shift @usage_recs;
3952 $cust_pkg_usage->select_for_update;
3953 my $cdr_cust_pkg_usage = FS::cdr_cust_pkg_usage->new({
3954 pkgusagenum => $cust_pkg_usage->pkgusagenum,
3955 acctid => $cdr->acctid,
3956 minutes => min($cust_pkg_usage->minutes, $minutes),
3958 $cust_pkg_usage->set('minutes',
3959 sprintf('%.0f', $cust_pkg_usage->minutes - $cdr_cust_pkg_usage->minutes)
3961 $error = $cust_pkg_usage->replace || $cdr_cust_pkg_usage->insert;
3962 $minutes -= $cdr_cust_pkg_usage->minutes;
3964 if ( $order and $minutes > 0 and !$error ) {
3965 # then try to steal minutes from another call
3967 'table' => 'cdr_cust_pkg_usage',
3968 'addl_from' => ' JOIN cust_pkg_usage USING (pkgusagenum)'.
3969 ' JOIN part_pkg_usage USING (pkgusagepart)'.
3970 ' JOIN cust_pkg USING (pkgnum)'.
3971 ' JOIN part_pkg_usage_class USING (pkgusagepart)'.
3972 ' JOIN cdr USING (acctid)',
3973 'select' => 'cdr_cust_pkg_usage.*',
3974 'extra_sql' => " WHERE cdr.freesidestatus = 'rated' AND ".
3975 " ( cust_pkg.pkgnum = $pkgnum OR ".
3976 " ( cust_pkg.custnum = $custnum AND ".
3977 " part_pkg_usage.shared IS NOT NULL ) ) AND ".
3978 " part_pkg_usage_class.classnum = $classnum",
3979 'order_by' => ' ORDER BY part_pkg_usage.priority ASC',
3981 if ( $order eq 'time' ) {
3982 # find CDRs that are using minutes, but have a later startdate
3984 my $startdate = $cdr->startdate;
3985 if ($startdate !~ /^\d+$/) {
3986 die "bad cdr startdate '$startdate'";
3988 $search{'extra_sql'} .= " AND cdr.startdate > $startdate";
3989 # minimize needless reshuffling
3990 $search{'order_by'} .= ', cdr.startdate DESC';
3992 # XXX may not work correctly with rate_time schedules. Could
3993 # fix this by storing ratedetailnum in cdr_cust_pkg_usage, I
3995 $search{'addl_from'} .=
3996 ' JOIN rate_detail'.
3997 ' ON (cdr.rated_ratedetailnum = rate_detail.ratedetailnum)';
3998 if ( $order eq 'rate_high' ) {
3999 $search{'extra_sql'} .= ' AND rate_detail.min_charge < '.
4000 $rate_detail->min_charge;
4001 $search{'order_by'} .= ', rate_detail.min_charge ASC';
4002 } elsif ( $order eq 'rate_low' ) {
4003 $search{'extra_sql'} .= ' AND rate_detail.min_charge > '.
4004 $rate_detail->min_charge;
4005 $search{'order_by'} .= ', rate_detail.min_charge DESC';
4007 # this should really never happen
4008 die "invalid cdr-minutes_priority value '$order'\n";
4011 my @cdr_usage_recs = qsearch(\%search);
4013 while (!$error and @cdr_usage_recs and $minutes > 0) {
4014 my $cdr_cust_pkg_usage = shift @cdr_usage_recs;
4015 my $cust_pkg_usage = $cdr_cust_pkg_usage->cust_pkg_usage;
4016 my $old_cdr = $cdr_cust_pkg_usage->cdr;
4017 $reproc_cdrs{$old_cdr->acctid} = $old_cdr;
4018 $cdr_cust_pkg_usage->select_for_update;
4019 $old_cdr->select_for_update;
4020 $cust_pkg_usage->select_for_update;
4021 # in case someone else stole the usage from this CDR
4022 # while waiting for the lock...
4023 next if $old_cdr->acctid != $cdr_cust_pkg_usage->acctid;
4024 # steal the usage allocation and flag the old CDR for reprocessing
4025 $cdr_cust_pkg_usage->set('acctid', $cdr->acctid);
4026 # if the allocation is more minutes than we need, adjust it...
4027 my $delta = $cdr_cust_pkg_usage->minutes - $minutes;
4029 $cdr_cust_pkg_usage->set('minutes', $minutes);
4030 $cust_pkg_usage->set('minutes', $cust_pkg_usage->minutes + $delta);
4031 $error = $cust_pkg_usage->replace;
4033 #warn 'CDR '.$cdr->acctid . ' stealing allocation '.$cdr_cust_pkg_usage->cdrusagenum.' from CDR '.$old_cdr->acctid."\n";
4034 $error ||= $cdr_cust_pkg_usage->replace;
4035 # deduct the stolen minutes
4036 $minutes -= $cdr_cust_pkg_usage->minutes;
4038 # after all minute-stealing is done, reset the affected CDRs
4039 foreach (values %reproc_cdrs) {
4040 $error ||= $_->set_status('');
4041 # XXX or should we just call $cdr->rate right here?
4042 # it's not like we can create a loop this way, since the min_charge
4043 # or call time has to go monotonically in one direction.
4044 # we COULD get some very deep recursions going, though...
4046 } # if $order and $minutes
4049 die "error applying included minutes\npkgnum ".$self->pkgnum.", class $classnum, acctid ".$cdr->acctid."\n$error\n"
4051 $dbh->commit if $oldAutoCommit;
4052 return $orig_minutes - $minutes;
4056 =item supplemental_pkgs
4058 Returns a list of all packages supplemental to this one.
4062 sub supplemental_pkgs {
4064 qsearch('cust_pkg', { 'main_pkgnum' => $self->pkgnum });
4069 Returns the package that this one is supplemental to, if any.
4075 if ( $self->main_pkgnum ) {
4076 return FS::cust_pkg->by_key($self->main_pkgnum);
4083 =head1 CLASS METHODS
4089 Returns an SQL expression identifying recurring packages.
4093 sub recurring_sql { "
4094 '0' != ( select freq from part_pkg
4095 where cust_pkg.pkgpart = part_pkg.pkgpart )
4100 Returns an SQL expression identifying one-time packages.
4105 '0' = ( select freq from part_pkg
4106 where cust_pkg.pkgpart = part_pkg.pkgpart )
4111 Returns an SQL expression identifying ordered packages (recurring packages not
4117 $_[0]->recurring_sql. " AND ". $_[0]->not_yet_billed_sql;
4122 Returns an SQL expression identifying active packages.
4127 $_[0]->recurring_sql. "
4128 AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
4129 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4130 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
4133 =item not_yet_billed_sql
4135 Returns an SQL expression identifying packages which have not yet been billed.
4139 sub not_yet_billed_sql { "
4140 ( cust_pkg.setup IS NULL OR cust_pkg.setup = 0 )
4141 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4142 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
4147 Returns an SQL expression identifying inactive packages (one-time packages
4148 that are otherwise unsuspended/uncancelled).
4152 sub inactive_sql { "
4153 ". $_[0]->onetime_sql(). "
4154 AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
4155 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4156 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
4162 Returns an SQL expression identifying suspended packages.
4166 sub suspended_sql { susp_sql(@_); }
4168 #$_[0]->recurring_sql(). ' AND '.
4170 ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4171 AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0
4178 Returns an SQL exprression identifying cancelled packages.
4182 sub cancelled_sql { cancel_sql(@_); }
4184 #$_[0]->recurring_sql(). ' AND '.
4185 "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
4190 Returns an SQL expression to give the package status as a string.
4196 WHEN cust_pkg.cancel IS NOT NULL THEN 'cancelled'
4197 WHEN cust_pkg.susp IS NOT NULL THEN 'suspended'
4198 WHEN cust_pkg.setup IS NULL THEN 'not yet billed'
4199 WHEN ".onetime_sql()." THEN 'one-time charge'
4204 =item search HASHREF
4208 Returns a qsearch hash expression to search for parameters specified in HASHREF.
4209 Valid parameters are
4217 active, inactive, suspended, cancel (or cancelled)
4221 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
4225 boolean selects custom packages
4231 pkgpart or arrayref or hashref of pkgparts
4235 arrayref of beginning and ending epoch date
4239 arrayref of beginning and ending epoch date
4243 arrayref of beginning and ending epoch date
4247 arrayref of beginning and ending epoch date
4251 arrayref of beginning and ending epoch date
4255 arrayref of beginning and ending epoch date
4259 arrayref of beginning and ending epoch date
4263 pkgnum or APKG_pkgnum
4267 a value suited to passing to FS::UI::Web::cust_header
4271 specifies the user for agent virtualization
4275 boolean; if true, returns only packages with more than 0 FCC phone lines.
4277 =item state, country
4279 Limit to packages with a service location in the specified state and country.
4280 For FCC 477 reporting, mostly.
4284 Limit to packages whose service locations are the same as the customer's
4285 default service location.
4287 =item location_nocust
4289 Limit to packages whose service locations are not the customer's default
4292 =item location_census
4294 Limit to packages whose service locations have census tracts.
4296 =item location_nocensus
4298 Limit to packages whose service locations do not have a census tract.
4300 =item location_geocode
4302 Limit to packages whose locations have geocodes.
4304 =item location_geocode
4306 Limit to packages whose locations do not have geocodes.
4313 my ($class, $params) = @_;
4320 if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
4322 "cust_main.agentnum = $1";
4329 if ( $params->{'cust_status'} =~ /^([a-z]+)$/ ) {
4330 push @where, FS::cust_main->cust_status_sql . " = '$1' ";
4334 # parse customer sales person
4337 if ( $params->{'cust_main_salesnum'} =~ /^(\d+)$/ ) {
4338 push @where, ($1 > 0) ? "cust_main.salesnum = $1"
4339 : 'cust_main.salesnum IS NULL';
4344 # parse sales person
4347 if ( $params->{'salesnum'} =~ /^(\d+)$/ ) {
4348 push @where, ($1 > 0) ? "cust_pkg.salesnum = $1"
4349 : 'cust_pkg.salesnum IS NULL';
4356 if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
4358 "cust_pkg.custnum = $1";
4365 if ( $params->{'pkgbatch'} =~ /^([\w\/\-\:\.]+)$/ and $1 ) {
4367 "cust_pkg.pkgbatch = '$1'";
4374 if ( $params->{'magic'} eq 'active'
4375 || $params->{'status'} eq 'active' ) {
4377 push @where, FS::cust_pkg->active_sql();
4379 } elsif ( $params->{'magic'} =~ /^not[ _]yet[ _]billed$/
4380 || $params->{'status'} =~ /^not[ _]yet[ _]billed$/ ) {
4382 push @where, FS::cust_pkg->not_yet_billed_sql();
4384 } elsif ( $params->{'magic'} =~ /^(one-time charge|inactive)/
4385 || $params->{'status'} =~ /^(one-time charge|inactive)/ ) {
4387 push @where, FS::cust_pkg->inactive_sql();
4389 } elsif ( $params->{'magic'} eq 'suspended'
4390 || $params->{'status'} eq 'suspended' ) {
4392 push @where, FS::cust_pkg->suspended_sql();
4394 } elsif ( $params->{'magic'} =~ /^cancell?ed$/
4395 || $params->{'status'} =~ /^cancell?ed$/ ) {
4397 push @where, FS::cust_pkg->cancelled_sql();
4402 # parse package class
4405 if ( exists($params->{'classnum'}) ) {
4408 if ( ref($params->{'classnum'}) ) {
4410 if ( ref($params->{'classnum'}) eq 'HASH' ) {
4411 @classnum = grep $params->{'classnum'}{$_}, keys %{ $params->{'classnum'} };
4412 } elsif ( ref($params->{'classnum'}) eq 'ARRAY' ) {
4413 @classnum = @{ $params->{'classnum'} };
4415 die 'unhandled classnum ref '. $params->{'classnum'};
4419 } elsif ( $params->{'classnum'} =~ /^(\d*)$/ && $1 ne '0' ) {
4426 my @nums = grep $_, @classnum;
4427 push @c_where, 'part_pkg.classnum IN ('. join(',',@nums). ')' if @nums;
4428 my $null = scalar( grep { $_ eq '' } @classnum );
4429 push @c_where, 'part_pkg.classnum IS NULL' if $null;
4431 if ( scalar(@c_where) == 1 ) {
4432 push @where, @c_where;
4433 } elsif ( @c_where ) {
4434 push @where, ' ( '. join(' OR ', @c_where). ' ) ';
4443 # parse package report options
4446 my @report_option = ();
4447 if ( exists($params->{'report_option'}) ) {
4448 if ( ref($params->{'report_option'}) eq 'ARRAY' ) {
4449 @report_option = @{ $params->{'report_option'} };
4450 } elsif ( $params->{'report_option'} =~ /^([,\d]*)$/ ) {
4451 @report_option = split(',', $1);
4456 if (@report_option) {
4457 # this will result in the empty set for the dangling comma case as it should
4459 map{ "0 < ( SELECT count(*) FROM part_pkg_option
4460 WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
4461 AND optionname = 'report_option_$_'
4462 AND optionvalue = '1' )"
4466 foreach my $any ( grep /^report_option_any/, keys %$params ) {
4468 my @report_option_any = ();
4469 if ( ref($params->{$any}) eq 'ARRAY' ) {
4470 @report_option_any = @{ $params->{$any} };
4471 } elsif ( $params->{$any} =~ /^([,\d]*)$/ ) {
4472 @report_option_any = split(',', $1);
4475 if (@report_option_any) {
4476 # this will result in the empty set for the dangling comma case as it should
4477 push @where, ' ( '. join(' OR ',
4478 map{ "0 < ( SELECT count(*) FROM part_pkg_option
4479 WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
4480 AND optionname = 'report_option_$_'
4481 AND optionvalue = '1' )"
4482 } @report_option_any
4492 push @where, "part_pkg.custom = 'Y'" if $params->{custom};
4498 push @where, "(part_pkg.fcc_ds0s > 0 OR pkg_class.fcc_ds0s > 0)"
4499 if $params->{fcc_line};
4505 if ( exists($params->{'censustract'}) ) {
4506 $params->{'censustract'} =~ /^([.\d]*)$/;
4507 my $censustract = "cust_location.censustract = '$1'";
4508 $censustract .= ' OR cust_location.censustract is NULL' unless $1;
4509 push @where, "( $censustract )";
4513 # parse censustract2
4515 if ( exists($params->{'censustract2'})
4516 && $params->{'censustract2'} =~ /^(\d*)$/
4520 push @where, "cust_location.censustract LIKE '$1%'";
4523 "( cust_location.censustract = '' OR cust_location.censustract IS NULL )";
4528 # parse country/state
4530 for (qw(state country)) { # parsing rules are the same for these
4531 if ( exists($params->{$_})
4532 && uc($params->{$_}) =~ /^([A-Z]{2})$/ )
4534 # XXX post-2.3 only--before that, state/country may be in cust_main
4535 push @where, "cust_location.$_ = '$1'";
4542 if ( $params->{location_cust} xor $params->{location_nocust} ) {
4543 my $op = $params->{location_cust} ? '=' : '!=';
4544 push @where, "cust_location.locationnum $op cust_main.ship_locationnum";
4546 if ( $params->{location_census} xor $params->{location_nocensus} ) {
4547 my $op = $params->{location_census} ? "IS NOT NULL" : "IS NULL";
4548 push @where, "cust_location.censustract $op";
4550 if ( $params->{location_geocode} xor $params->{location_nogeocode} ) {
4551 my $op = $params->{location_geocode} ? "IS NOT NULL" : "IS NULL";
4552 push @where, "cust_location.geocode $op";
4559 if ( ref($params->{'pkgpart'}) ) {
4562 if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
4563 @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
4564 } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
4565 @pkgpart = @{ $params->{'pkgpart'} };
4567 die 'unhandled pkgpart ref '. $params->{'pkgpart'};
4570 @pkgpart = grep /^(\d+)$/, @pkgpart;
4572 push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
4574 } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
4575 push @where, "pkgpart = $1";
4584 #false laziness w/report_cust_pkg.html
4587 'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
4588 'active' => { 'susp'=>1, 'cancel'=>1 },
4589 'suspended' => { 'cancel' => 1 },
4594 if( exists($params->{'active'} ) ) {
4595 # This overrides all the other date-related fields
4596 my($beginning, $ending) = @{$params->{'active'}};
4598 "cust_pkg.setup IS NOT NULL",
4599 "cust_pkg.setup <= $ending",
4600 "(cust_pkg.cancel IS NULL OR cust_pkg.cancel >= $beginning )",
4601 "NOT (".FS::cust_pkg->onetime_sql . ")";
4604 foreach my $field (qw( setup last_bill bill adjourn susp expire contract_end change_date cancel )) {
4606 next unless exists($params->{$field});
4608 my($beginning, $ending) = @{$params->{$field}};
4610 next if $beginning == 0 && $ending == 4294967295;
4613 "cust_pkg.$field IS NOT NULL",
4614 "cust_pkg.$field >= $beginning",
4615 "cust_pkg.$field <= $ending";
4617 $orderby ||= "ORDER BY cust_pkg.$field";
4622 $orderby ||= 'ORDER BY bill';
4625 # parse magic, legacy, etc.
4628 if ( $params->{'magic'} &&
4629 $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
4632 $orderby = 'ORDER BY pkgnum';
4634 if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
4635 push @where, "pkgpart = $1";
4638 } elsif ( $params->{'query'} eq 'pkgnum' ) {
4640 $orderby = 'ORDER BY pkgnum';
4642 } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
4644 $orderby = 'ORDER BY pkgnum';
4647 SELECT count(*) FROM pkg_svc
4648 WHERE pkg_svc.pkgpart = cust_pkg.pkgpart
4649 AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
4650 WHERE cust_svc.pkgnum = cust_pkg.pkgnum
4651 AND cust_svc.svcpart = pkg_svc.svcpart
4658 # setup queries, links, subs, etc. for the search
4661 # here is the agent virtualization
4662 if ($params->{CurrentUser}) {
4664 qsearchs('access_user', { username => $params->{CurrentUser} });
4667 push @where, $access_user->agentnums_sql('table'=>'cust_main');
4672 push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
4675 my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
4677 my $addl_from = 'LEFT JOIN part_pkg USING ( pkgpart ) '.
4678 'LEFT JOIN pkg_class ON ( part_pkg.classnum = pkg_class.classnum ) '.
4679 'LEFT JOIN cust_location USING ( locationnum ) '.
4680 FS::UI::Web::join_cust_main('cust_pkg', 'cust_pkg');
4684 if ( $params->{'select_zip5'} ) {
4685 my $zip = 'cust_location.zip';
4687 $select = "DISTINCT substr($zip,1,5) as zip";
4688 $orderby = "ORDER BY substr($zip,1,5)";
4689 $count_query = "SELECT COUNT( DISTINCT substr($zip,1,5) )";
4691 $select = join(', ',
4693 ( map "part_pkg.$_", qw( pkg freq ) ),
4694 'pkg_class.classname',
4695 'cust_main.custnum AS cust_main_custnum',
4696 FS::UI::Web::cust_sql_fields(
4697 $params->{'cust_fields'}
4700 $count_query = 'SELECT COUNT(*)';
4703 $count_query .= " FROM cust_pkg $addl_from $extra_sql";
4706 'table' => 'cust_pkg',
4708 'select' => $select,
4709 'extra_sql' => $extra_sql,
4710 'order_by' => $orderby,
4711 'addl_from' => $addl_from,
4712 'count_query' => $count_query,
4719 Returns a list of two package counts. The first is a count of packages
4720 based on the supplied criteria and the second is the count of residential
4721 packages with those same criteria. Criteria are specified as in the search
4727 my ($class, $params) = @_;
4729 my $sql_query = $class->search( $params );
4731 my $count_sql = delete($sql_query->{'count_query'});
4732 $count_sql =~ s/ FROM/,count(CASE WHEN cust_main.company IS NULL OR cust_main.company = '' THEN 1 END) FROM/
4733 or die "couldn't parse count_sql";
4735 my $count_sth = dbh->prepare($count_sql)
4736 or die "Error preparing $count_sql: ". dbh->errstr;
4738 or die "Error executing $count_sql: ". $count_sth->errstr;
4739 my $count_arrayref = $count_sth->fetchrow_arrayref;
4741 return ( @$count_arrayref );
4745 =item tax_locationnum_sql
4747 Returns an SQL expression for the tax location for a package, based
4748 on the settings of 'tax-pkg_address' and 'tax-ship_address'.
4752 sub tax_locationnum_sql {
4753 my $conf = FS::Conf->new;
4754 if ( $conf->exists('tax-pkg_address') ) {
4755 'cust_pkg.locationnum';
4757 elsif ( $conf->exists('tax-ship_address') ) {
4758 'cust_main.ship_locationnum';
4761 'cust_main.bill_locationnum';
4767 Returns a list: the first item is an SQL fragment identifying matching
4768 packages/customers via location (taking into account shipping and package
4769 address taxation, if enabled), and subsequent items are the parameters to
4770 substitute for the placeholders in that fragment.
4775 my($class, %opt) = @_;
4776 my $ornull = $opt{'ornull'};
4778 my $conf = new FS::Conf;
4780 # '?' placeholders in _location_sql_where
4781 my $x = $ornull ? 3 : 2;
4792 if ( $conf->exists('tax-ship_address') ) {
4795 ( ( ship_last IS NULL OR ship_last = '' )
4796 AND ". _location_sql_where('cust_main', '', $ornull ). "
4798 OR ( ship_last IS NOT NULL AND ship_last != ''
4799 AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
4802 # AND payby != 'COMP'
4804 @main_param = ( @bill_param, @bill_param );
4808 $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
4809 @main_param = @bill_param;
4815 if ( $conf->exists('tax-pkg_address') ) {
4817 my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
4820 ( cust_pkg.locationnum IS NULL AND $main_where )
4821 OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where )
4824 @param = ( @main_param, @bill_param );
4828 $where = $main_where;
4829 @param = @main_param;
4837 #subroutine, helper for location_sql
4838 sub _location_sql_where {
4840 my $prefix = @_ ? shift : '';
4841 my $ornull = @_ ? shift : '';
4843 # $ornull = $ornull ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
4845 $ornull = $ornull ? ' OR ? IS NULL ' : '';
4847 my $or_empty_city = " OR ( ? = '' AND $table.${prefix}city IS NULL )";
4848 my $or_empty_county = " OR ( ? = '' AND $table.${prefix}county IS NULL )";
4849 my $or_empty_state = " OR ( ? = '' AND $table.${prefix}state IS NULL )";
4851 my $text = (driver_name =~ /^mysql/i) ? 'char' : 'text';
4853 # ( $table.${prefix}city = ? $or_empty_city $ornull )
4855 ( $table.district = ? OR ? = '' OR CAST(? AS $text) IS NULL )
4856 AND ( $table.${prefix}city = ? OR ? = '' OR CAST(? AS $text) IS NULL )
4857 AND ( $table.${prefix}county = ? $or_empty_county $ornull )
4858 AND ( $table.${prefix}state = ? $or_empty_state $ornull )
4859 AND $table.${prefix}country = ?
4864 my( $self, $what ) = @_;
4866 my $what_show_zero = $what. '_show_zero';
4867 length($self->$what_show_zero())
4868 ? ($self->$what_show_zero() eq 'Y')
4869 : $self->part_pkg->$what_show_zero();
4876 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
4878 CUSTNUM is a customer (see L<FS::cust_main>)
4880 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
4881 L<FS::part_pkg>) to order for this customer. Duplicates are of course
4884 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
4885 remove for this customer. The services (see L<FS::cust_svc>) are moved to the
4886 new billing items. An error is returned if this is not possible (see
4887 L<FS::pkg_svc>). An empty arrayref is equivalent to not specifying this
4890 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
4891 newly-created cust_pkg objects.
4893 REFNUM, if specified, will specify the FS::pkg_referral record to be created
4894 and inserted. Multiple FS::pkg_referral records can be created by
4895 setting I<refnum> to an array reference of refnums or a hash reference with
4896 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
4897 record will be created corresponding to cust_main.refnum.
4902 my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
4904 my $conf = new FS::Conf;
4906 # Transactionize this whole mess
4907 local $SIG{HUP} = 'IGNORE';
4908 local $SIG{INT} = 'IGNORE';
4909 local $SIG{QUIT} = 'IGNORE';
4910 local $SIG{TERM} = 'IGNORE';
4911 local $SIG{TSTP} = 'IGNORE';
4912 local $SIG{PIPE} = 'IGNORE';
4914 my $oldAutoCommit = $FS::UID::AutoCommit;
4915 local $FS::UID::AutoCommit = 0;
4919 # my $cust_main = qsearchs('cust_main', { custnum => $custnum });
4920 # return "Customer not found: $custnum" unless $cust_main;
4922 warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
4925 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
4928 my $change = scalar(@old_cust_pkg) != 0;
4931 if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
4933 warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
4934 " to pkgpart ". $pkgparts->[0]. "\n"
4937 my $err_or_cust_pkg =
4938 $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
4939 'refnum' => $refnum,
4942 unless (ref($err_or_cust_pkg)) {
4943 $dbh->rollback if $oldAutoCommit;
4944 return $err_or_cust_pkg;
4947 push @$return_cust_pkg, $err_or_cust_pkg;
4948 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4953 # Create the new packages.
4954 foreach my $pkgpart (@$pkgparts) {
4956 warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
4958 my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
4959 pkgpart => $pkgpart,
4963 $error = $cust_pkg->insert( 'change' => $change );
4964 push @$return_cust_pkg, $cust_pkg;
4966 foreach my $link ($cust_pkg->part_pkg->supp_part_pkg_link) {
4967 my $supp_pkg = FS::cust_pkg->new({
4968 custnum => $custnum,
4969 pkgpart => $link->dst_pkgpart,
4971 main_pkgnum => $cust_pkg->pkgnum,
4974 $error ||= $supp_pkg->insert( 'change' => $change );
4975 push @$return_cust_pkg, $supp_pkg;
4979 $dbh->rollback if $oldAutoCommit;
4984 # $return_cust_pkg now contains refs to all of the newly
4987 # Transfer services and cancel old packages.
4988 foreach my $old_pkg (@old_cust_pkg) {
4990 warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
4993 foreach my $new_pkg (@$return_cust_pkg) {
4994 $error = $old_pkg->transfer($new_pkg);
4995 if ($error and $error == 0) {
4996 # $old_pkg->transfer failed.
4997 $dbh->rollback if $oldAutoCommit;
5002 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
5003 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
5004 foreach my $new_pkg (@$return_cust_pkg) {
5005 $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
5006 if ($error and $error == 0) {
5007 # $old_pkg->transfer failed.
5008 $dbh->rollback if $oldAutoCommit;
5015 # Transfers were successful, but we went through all of the
5016 # new packages and still had services left on the old package.
5017 # We can't cancel the package under the circumstances, so abort.
5018 $dbh->rollback if $oldAutoCommit;
5019 return "Unable to transfer all services from package ".$old_pkg->pkgnum;
5021 $error = $old_pkg->cancel( quiet=>1 );
5027 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
5031 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
5033 A bulk change method to change packages for multiple customers.
5035 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
5036 L<FS::part_pkg>) to order for each customer. Duplicates are of course
5039 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
5040 replace. The services (see L<FS::cust_svc>) are moved to the
5041 new billing items. An error is returned if this is not possible (see
5044 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
5045 newly-created cust_pkg objects.
5050 my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
5052 # Transactionize this whole mess
5053 local $SIG{HUP} = 'IGNORE';
5054 local $SIG{INT} = 'IGNORE';
5055 local $SIG{QUIT} = 'IGNORE';
5056 local $SIG{TERM} = 'IGNORE';
5057 local $SIG{TSTP} = 'IGNORE';
5058 local $SIG{PIPE} = 'IGNORE';
5060 my $oldAutoCommit = $FS::UID::AutoCommit;
5061 local $FS::UID::AutoCommit = 0;
5065 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
5068 while(scalar(@old_cust_pkg)) {
5070 my $custnum = $old_cust_pkg[0]->custnum;
5071 my (@remove) = map { $_->pkgnum }
5072 grep { $_->custnum == $custnum } @old_cust_pkg;
5073 @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
5075 my $error = order $custnum, $pkgparts, \@remove, \@return;
5077 push @errors, $error
5079 push @$return_cust_pkg, @return;
5082 if (scalar(@errors)) {
5083 $dbh->rollback if $oldAutoCommit;
5084 return join(' / ', @errors);
5087 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
5091 # Used by FS::Upgrade to migrate to a new database.
5092 sub _upgrade_data { # class method
5093 my ($class, %opts) = @_;
5094 $class->_upgrade_otaker(%opts);
5096 # RT#10139, bug resulting in contract_end being set when it shouldn't
5097 'UPDATE cust_pkg SET contract_end = NULL WHERE contract_end = -1',
5098 # RT#10830, bad calculation of prorate date near end of year
5099 # the date range for bill is December 2009, and we move it forward
5100 # one year if it's before the previous bill date (which it should
5102 'UPDATE cust_pkg SET bill = bill + (365*24*60*60) WHERE bill < last_bill
5103 AND bill > 1259654400 AND bill < 1262332800 AND (SELECT plan FROM part_pkg
5104 WHERE part_pkg.pkgpart = cust_pkg.pkgpart) = \'prorate\'',
5105 # RT6628, add order_date to cust_pkg
5106 'update cust_pkg set order_date = (select history_date from h_cust_pkg
5107 where h_cust_pkg.pkgnum = cust_pkg.pkgnum and
5108 history_action = \'insert\') where order_date is null',
5110 foreach my $sql (@statements) {
5111 my $sth = dbh->prepare($sql);
5112 $sth->execute or die $sth->errstr;
5120 sub order is not OO. Perhaps it should be moved to FS::cust_main and made so?
5122 In sub order, the @pkgparts array (passed by reference) is clobbered.
5124 Also in sub order, no money is adjusted. Once FS::part_pkg defines a standard
5125 method to pass dates to the recur_prog expression, it should do so.
5127 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
5128 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
5129 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
5130 configuration values. Probably need a subroutine which decides what to do
5131 based on whether or not we've fetched the user yet, rather than a hash. See
5132 FS::UID and the TODO.
5134 Now that things are transactional should the check in the insert method be
5139 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
5140 L<FS::pkg_svc>, schema.html from the base documentation