4 use base qw( FS::otaker_Mixin FS::cust_main_Mixin FS::location_Mixin
5 FS::m2m_Common FS::option_Common );
6 use vars qw($disable_agentcheck $DEBUG $me);
8 use Scalar::Util qw( blessed );
9 use List::Util qw(max);
11 use Time::Local qw( timelocal_nocheck );
13 use FS::UID qw( getotaker dbh );
14 use FS::Misc qw( send_email );
15 use FS::Record qw( qsearch qsearchs );
20 use FS::cust_location;
22 use FS::cust_bill_pkg;
23 use FS::cust_pkg_detail;
28 use FS::cust_pkg_reason;
30 use FS::cust_pkg_discount;
34 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
36 # because they load configuration by setting FS::UID::callback (see TODO)
42 # for sending cancel emails in sub cancel
46 $me = '[FS::cust_pkg]';
48 $disable_agentcheck = 0;
52 my ( $hashref, $cache ) = @_;
53 #if ( $hashref->{'pkgpart'} ) {
54 if ( $hashref->{'pkg'} ) {
55 # #@{ $self->{'_pkgnum'} } = ();
56 # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
57 # $self->{'_pkgpart'} = $subcache;
58 # #push @{ $self->{'_pkgnum'} },
59 # FS::part_pkg->new_or_cached($hashref, $subcache);
60 $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
62 if ( exists $hashref->{'svcnum'} ) {
63 #@{ $self->{'_pkgnum'} } = ();
64 my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
65 $self->{'_svcnum'} = $subcache;
66 #push @{ $self->{'_pkgnum'} },
67 FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
73 FS::cust_pkg - Object methods for cust_pkg objects
79 $record = new FS::cust_pkg \%hash;
80 $record = new FS::cust_pkg { 'column' => 'value' };
82 $error = $record->insert;
84 $error = $new_record->replace($old_record);
86 $error = $record->delete;
88 $error = $record->check;
90 $error = $record->cancel;
92 $error = $record->suspend;
94 $error = $record->unsuspend;
96 $part_pkg = $record->part_pkg;
98 @labels = $record->labels;
100 $seconds = $record->seconds_since($timestamp);
102 $error = FS::cust_pkg::order( $custnum, \@pkgparts );
103 $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
107 An FS::cust_pkg object represents a customer billing item. FS::cust_pkg
108 inherits from FS::Record. The following fields are currently supported:
114 Primary key (assigned automatically for new billing items)
118 Customer (see L<FS::cust_main>)
122 Billing item definition (see L<FS::part_pkg>)
126 Optional link to package location (see L<FS::location>)
138 date (next bill date)
166 order taker (see L<FS::access_user>)
170 If this field is set to 1, disables the automatic
171 unsuspension of this package when using the B<unsuspendauto> config option.
175 If not set, defaults to 1
179 Date of change from previous package
189 =item change_locationnum
195 Note: setup, last_bill, bill, adjourn, susp, expire, cancel and change_date
196 are specified as UNIX timestamps; see L<perlfunc/"time">. Also see
197 L<Time::Local> and L<Date::Parse> for conversion functions.
205 Create a new billing item. To add the item to the database, see L<"insert">.
209 sub table { 'cust_pkg'; }
210 sub cust_linked { $_[0]->cust_main_custnum; }
211 sub cust_unlinked_msg {
213 "WARNING: can't find cust_main.custnum ". $self->custnum.
214 ' (cust_pkg.pkgnum '. $self->pkgnum. ')';
217 =item insert [ OPTION => VALUE ... ]
219 Adds this billing item to the database ("Orders" the item). If there is an
220 error, returns the error, otherwise returns false.
222 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
223 will be used to look up the package definition and agent restrictions will be
226 If the additional field I<refnum> is defined, an FS::pkg_referral record will
227 be created and inserted. Multiple FS::pkg_referral records can be created by
228 setting I<refnum> to an array reference of refnums or a hash reference with
229 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
230 record will be created corresponding to cust_main.refnum.
232 The following options are available:
238 If set true, supresses any referral credit to a referring customer.
242 cust_pkg_option records will be created
246 a ticket will be added to this customer with this subject
250 an optional queue name for ticket additions
257 my( $self, %options ) = @_;
259 if ( $self->part_pkg->option('start_1st', 1) && !$self->start_date ) {
260 my ($sec,$min,$hour,$mday,$mon,$year) = (localtime(time) )[0,1,2,3,4,5];
261 $mon += 1 unless $mday == 1;
262 until ( $mon < 12 ) { $mon -= 12; $year++; }
263 $self->start_date( timelocal_nocheck(0,0,0,1,$mon,$year) );
266 foreach my $action ( qw(expire adjourn contract_end) ) {
267 my $months = $self->part_pkg->option("${action}_months",1);
268 if($months and !$self->$action) {
269 my $start = $self->start_date || $self->setup || time;
270 $self->$action( $self->part_pkg->add_freq($start, $months) );
274 local $SIG{HUP} = 'IGNORE';
275 local $SIG{INT} = 'IGNORE';
276 local $SIG{QUIT} = 'IGNORE';
277 local $SIG{TERM} = 'IGNORE';
278 local $SIG{TSTP} = 'IGNORE';
279 local $SIG{PIPE} = 'IGNORE';
281 my $oldAutoCommit = $FS::UID::AutoCommit;
282 local $FS::UID::AutoCommit = 0;
285 my $error = $self->SUPER::insert($options{options} ? %{$options{options}} : ());
287 $dbh->rollback if $oldAutoCommit;
291 $self->refnum($self->cust_main->refnum) unless $self->refnum;
292 $self->refnum( [ $self->refnum ] ) unless ref($self->refnum);
293 $self->process_m2m( 'link_table' => 'pkg_referral',
294 'target_table' => 'part_referral',
295 'params' => $self->refnum,
298 if ( $self->discountnum ) {
299 my $error = $self->insert_discount();
301 $dbh->rollback if $oldAutoCommit;
306 #if ( $self->reg_code ) {
307 # my $reg_code = qsearchs('reg_code', { 'code' => $self->reg_code } );
308 # $error = $reg_code->delete;
310 # $dbh->rollback if $oldAutoCommit;
315 my $conf = new FS::Conf;
317 if ( $conf->config('ticket_system') && $options{ticket_subject} ) {
320 # use lib ( "/opt/rt3/local/lib", "/opt/rt3/lib" );
327 use FS::TicketSystem;
328 FS::TicketSystem->init();
330 my $q = new RT::Queue($RT::SystemUser);
331 $q->Load($options{ticket_queue}) if $options{ticket_queue};
332 my $t = new RT::Ticket($RT::SystemUser);
333 my $mime = new MIME::Entity;
334 $mime->build( Type => 'text/plain', Data => $options{ticket_subject} );
335 $t->Create( $options{ticket_queue} ? (Queue => $q) : (),
336 Subject => $options{ticket_subject},
339 $t->AddLink( Type => 'MemberOf',
340 Target => 'freeside://freeside/cust_main/'. $self->custnum,
344 if ($conf->config('welcome_letter') && $self->cust_main->num_pkgs == 1) {
345 my $queue = new FS::queue {
346 'job' => 'FS::cust_main::queueable_print',
348 $error = $queue->insert(
349 'custnum' => $self->custnum,
350 'template' => 'welcome_letter',
354 warn "can't send welcome letter: $error";
359 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
366 This method now works but you probably shouldn't use it.
368 You don't want to delete billing items, because there would then be no record
369 the customer ever purchased the item. Instead, see the cancel method.
374 # return "Can't delete cust_pkg records!";
377 =item replace [ OLD_RECORD ] [ HASHREF | OPTION => VALUE ... ]
379 Replaces the OLD_RECORD with this one in the database. If there is an error,
380 returns the error, otherwise returns false.
382 Currently, custnum, setup, bill, adjourn, susp, expire, and cancel may be changed.
384 Changing pkgpart may have disasterous effects. See the order subroutine.
386 setup and bill are normally updated by calling the bill method of a customer
387 object (see L<FS::cust_main>).
389 suspend is normally updated by the suspend and unsuspend methods.
391 cancel is normally updated by the cancel method (and also the order subroutine
394 Available options are:
400 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.
404 the access_user (see L<FS::access_user>) providing the reason
408 hashref of keys and values - cust_pkg_option records will be created, updated or removed as appopriate
417 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
422 ( ref($_[0]) eq 'HASH' )
426 #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
427 #return "Can't change otaker!" if $old->otaker ne $new->otaker;
430 #return "Can't change setup once it exists!"
431 # if $old->getfield('setup') &&
432 # $old->getfield('setup') != $new->getfield('setup');
434 #some logic for bill, susp, cancel?
436 local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
438 local $SIG{HUP} = 'IGNORE';
439 local $SIG{INT} = 'IGNORE';
440 local $SIG{QUIT} = 'IGNORE';
441 local $SIG{TERM} = 'IGNORE';
442 local $SIG{TSTP} = 'IGNORE';
443 local $SIG{PIPE} = 'IGNORE';
445 my $oldAutoCommit = $FS::UID::AutoCommit;
446 local $FS::UID::AutoCommit = 0;
449 foreach my $method ( qw(adjourn expire) ) { # How many reasons?
450 if ($options->{'reason'} && $new->$method && $old->$method ne $new->$method) {
451 my $error = $new->insert_reason(
452 'reason' => $options->{'reason'},
453 'date' => $new->$method,
455 'reason_otaker' => $options->{'reason_otaker'},
458 dbh->rollback if $oldAutoCommit;
459 return "Error inserting cust_pkg_reason: $error";
464 #save off and freeze RADIUS attributes for any associated svc_acct records
466 if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
468 #also check for specific exports?
469 # to avoid spurious modify export events
470 @svc_acct = map { $_->svc_x }
471 grep { $_->part_svc->svcdb eq 'svc_acct' }
474 $_->snapshot foreach @svc_acct;
478 my $error = $new->SUPER::replace($old,
479 $options->{options} ? $options->{options} : ()
482 $dbh->rollback if $oldAutoCommit;
486 #for prepaid packages,
487 #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
488 foreach my $old_svc_acct ( @svc_acct ) {
489 my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
490 my $s_error = $new_svc_acct->replace($old_svc_acct);
492 $dbh->rollback if $oldAutoCommit;
497 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
504 Checks all fields to make sure this is a valid billing item. If there is an
505 error, returns the error, otherwise returns false. Called by the insert and
513 $self->locationnum('') if !$self->locationnum || $self->locationnum == -1;
516 $self->ut_numbern('pkgnum')
517 || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
518 || $self->ut_numbern('pkgpart')
519 || $self->ut_foreign_keyn('locationnum', 'cust_location', 'locationnum')
520 || $self->ut_numbern('start_date')
521 || $self->ut_numbern('setup')
522 || $self->ut_numbern('bill')
523 || $self->ut_numbern('susp')
524 || $self->ut_numbern('cancel')
525 || $self->ut_numbern('adjourn')
526 || $self->ut_numbern('expire')
527 || $self->ut_enum('no_auto', [ '', 'Y' ])
529 return $error if $error;
531 if ( $self->reg_code ) {
533 unless ( grep { $self->pkgpart == $_->pkgpart }
534 map { $_->reg_code_pkg }
535 qsearchs( 'reg_code', { 'code' => $self->reg_code,
536 'agentnum' => $self->cust_main->agentnum })
538 return "Unknown registration code";
541 } elsif ( $self->promo_code ) {
544 qsearchs('part_pkg', {
545 'pkgpart' => $self->pkgpart,
546 'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
548 return 'Unknown promotional code' unless $promo_part_pkg;
552 unless ( $disable_agentcheck ) {
554 qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
555 return "agent ". $agent->agentnum. ':'. $agent->agent.
556 " can't purchase pkgpart ". $self->pkgpart
557 unless $agent->pkgpart_hashref->{ $self->pkgpart }
558 || $agent->agentnum == $self->part_pkg->agentnum;
561 $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
562 return $error if $error;
566 $self->usernum($FS::CurrentUser::CurrentUser->usernum) unless $self->usernum;
568 if ( $self->dbdef_table->column('manual_flag') ) {
569 $self->manual_flag('') if $self->manual_flag eq ' ';
570 $self->manual_flag =~ /^([01]?)$/
571 or return "Illegal manual_flag ". $self->manual_flag;
572 $self->manual_flag($1);
578 =item cancel [ OPTION => VALUE ... ]
580 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
581 in this package, then cancels the package itself (sets the cancel field to
584 Available options are:
588 =item quiet - can be set true to supress email cancellation notices.
590 =item time - can be set to cancel the package based on a specific future or historical date. Using time ensures that the remaining amount is calculated correctly. Note however that this is an immediate cancel and just changes the date. You are PROBABLY looking to expire the account instead of using this.
592 =item reason - 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.
594 =item date - can be set to a unix style timestamp to specify when to cancel (expire)
596 =item nobill - can be set true to skip billing if it might otherwise be done.
598 =item unused_credit - can be set to 1 to credit the remaining time, or 0 to
599 not credit it. This must be set (by change()) when changing the package
600 to a different pkgpart or location, and probably shouldn't be in any other
601 case. If it's not set, the 'unused_credit_cancel' part_pkg option will
606 If there is an error, returns the error, otherwise returns false.
611 my( $self, %options ) = @_;
614 my $conf = new FS::Conf;
616 warn "cust_pkg::cancel called with options".
617 join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
620 local $SIG{HUP} = 'IGNORE';
621 local $SIG{INT} = 'IGNORE';
622 local $SIG{QUIT} = 'IGNORE';
623 local $SIG{TERM} = 'IGNORE';
624 local $SIG{TSTP} = 'IGNORE';
625 local $SIG{PIPE} = 'IGNORE';
627 my $oldAutoCommit = $FS::UID::AutoCommit;
628 local $FS::UID::AutoCommit = 0;
631 my $old = $self->select_for_update;
633 if ( $old->get('cancel') || $self->get('cancel') ) {
634 dbh->rollback if $oldAutoCommit;
635 return ""; # no error
638 my $date = $options{date} if $options{date}; # expire/cancel later
639 $date = '' if ($date && $date <= time); # complain instead?
641 #race condition: usage could be ongoing until unprovisioned
642 #resolved by performing a change package instead (which unprovisions) and
644 if ( !$options{nobill} && !$date && $conf->exists('bill_usage_on_cancel') ) {
645 my $copy = $self->new({$self->hash});
647 $copy->cust_main->bill( pkg_list => [ $copy ], cancel => 1 );
648 warn "Error billing during cancel, custnum ".
649 #$self->cust_main->custnum. ": $error"
654 my $cancel_time = $options{'time'} || time;
656 if ( $options{'reason'} ) {
657 $error = $self->insert_reason( 'reason' => $options{'reason'},
658 'action' => $date ? 'expire' : 'cancel',
659 'date' => $date ? $date : $cancel_time,
660 'reason_otaker' => $options{'reason_otaker'},
663 dbh->rollback if $oldAutoCommit;
664 return "Error inserting cust_pkg_reason: $error";
671 foreach my $cust_svc (
674 sort { $a->[1] <=> $b->[1] }
675 map { [ $_, $_->svc_x->table_info->{'cancel_weight'} ]; }
676 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
678 my $error = $cust_svc->cancel( ('date' => $date) );
681 $dbh->rollback if $oldAutoCommit;
682 return "Error expiring cust_svc: $error";
686 foreach my $cust_svc (
689 sort { $a->[1] <=> $b->[1] }
690 map { [ $_, $_->svc_x->table_info->{'cancel_weight'} ]; }
691 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
693 my $error = $cust_svc->cancel;
696 $dbh->rollback if $oldAutoCommit;
697 return "Error cancelling cust_svc: $error";
702 # Add a credit for remaining service
703 my $last_bill = $self->getfield('last_bill') || 0;
704 my $next_bill = $self->getfield('bill') || 0;
706 if ( exists($options{'unused_credit'}) ) {
707 $do_credit = $options{'unused_credit'};
710 $do_credit = $self->part_pkg->option('unused_credit_cancel', 1);
713 and $last_bill > 0 # the package has been billed
714 and $next_bill > 0 # the package has a next bill date
715 and $next_bill >= $cancel_time # which is in the future
717 my $remaining_value = $self->calc_remain('time' => $cancel_time);
718 if ( $remaining_value > 0 ) {
719 # && !$options{'no_credit'} ) {
720 # Undocumented, unused option.
721 # part_pkg configuration should decide this anyway.
722 my $error = $self->cust_main->credit(
724 'Credit for unused time on '. $self->part_pkg->pkg,
725 'reason_type' => $conf->config('cancel_credit_type'),
728 $dbh->rollback if $oldAutoCommit;
729 return "Error crediting customer \$$remaining_value for unused time on".
730 $self->part_pkg->pkg. ": $error";
732 } #if $remaining_value
735 my %hash = $self->hash;
736 $date ? ($hash{'expire'} = $date) : ($hash{'cancel'} = $cancel_time);
737 my $new = new FS::cust_pkg ( \%hash );
738 $error = $new->replace( $self, options => { $self->options } );
740 $dbh->rollback if $oldAutoCommit;
744 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
745 return '' if $date; #no errors
747 my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
748 if ( !$options{'quiet'} &&
749 $conf->exists('emailcancel', $self->cust_main->agentnum) &&
751 my $msgnum = $conf->config('cancel_msgnum', $self->cust_main->agentnum);
754 my $msg_template = qsearchs('msg_template', { msgnum => $msgnum });
755 $error = $msg_template->send( 'cust_main' => $self->cust_main,
760 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
761 'to' => \@invoicing_list,
762 'subject' => ( $conf->config('cancelsubject') || 'Cancellation Notice' ),
763 'body' => [ map "$_\n", $conf->config('cancelmessage') ],
766 #should this do something on errors?
773 =item cancel_if_expired [ NOW_TIMESTAMP ]
775 Cancels this package if its expire date has been reached.
779 sub cancel_if_expired {
781 my $time = shift || time;
782 return '' unless $self->expire && $self->expire <= $time;
783 my $error = $self->cancel;
785 return "Error cancelling expired pkg ". $self->pkgnum. " for custnum ".
786 $self->custnum. ": $error";
793 Cancels any pending expiration (sets the expire field to null).
795 If there is an error, returns the error, otherwise returns false.
800 my( $self, %options ) = @_;
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 my $pkgnum = $old->pkgnum;
817 if ( $old->get('cancel') || $self->get('cancel') ) {
818 dbh->rollback if $oldAutoCommit;
819 return "Can't unexpire cancelled package $pkgnum";
820 # or at least it's pointless
823 unless ( $old->get('expire') && $self->get('expire') ) {
824 dbh->rollback if $oldAutoCommit;
825 return ""; # no error
828 my %hash = $self->hash;
829 $hash{'expire'} = '';
830 my $new = new FS::cust_pkg ( \%hash );
831 $error = $new->replace( $self, options => { $self->options } );
833 $dbh->rollback if $oldAutoCommit;
837 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
843 =item suspend [ OPTION => VALUE ... ]
845 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
846 package, then suspends the package itself (sets the susp field to now).
848 Available options are:
852 =item reason - 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.
854 =item date - can be set to a unix style timestamp to specify when to suspend (adjourn)
858 If there is an error, returns the error, otherwise returns false.
863 my( $self, %options ) = @_;
866 local $SIG{HUP} = 'IGNORE';
867 local $SIG{INT} = 'IGNORE';
868 local $SIG{QUIT} = 'IGNORE';
869 local $SIG{TERM} = 'IGNORE';
870 local $SIG{TSTP} = 'IGNORE';
871 local $SIG{PIPE} = 'IGNORE';
873 my $oldAutoCommit = $FS::UID::AutoCommit;
874 local $FS::UID::AutoCommit = 0;
877 my $old = $self->select_for_update;
879 my $pkgnum = $old->pkgnum;
880 if ( $old->get('cancel') || $self->get('cancel') ) {
881 dbh->rollback if $oldAutoCommit;
882 return "Can't suspend cancelled package $pkgnum";
885 if ( $old->get('susp') || $self->get('susp') ) {
886 dbh->rollback if $oldAutoCommit;
887 return ""; # no error # complain on adjourn?
890 my $date = $options{date} if $options{date}; # adjourn/suspend later
891 $date = '' if ($date && $date <= time); # complain instead?
893 if ( $date && $old->get('expire') && $old->get('expire') < $date ) {
894 dbh->rollback if $oldAutoCommit;
895 return "Package $pkgnum expires before it would be suspended.";
898 my $suspend_time = $options{'time'} || time;
900 if ( $options{'reason'} ) {
901 $error = $self->insert_reason( 'reason' => $options{'reason'},
902 'action' => $date ? 'adjourn' : 'suspend',
903 'date' => $date ? $date : $suspend_time,
904 'reason_otaker' => $options{'reason_otaker'},
907 dbh->rollback if $oldAutoCommit;
908 return "Error inserting cust_pkg_reason: $error";
916 foreach my $cust_svc (
917 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
919 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
921 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
922 $dbh->rollback if $oldAutoCommit;
923 return "Illegal svcdb value in part_svc!";
926 require "FS/$svcdb.pm";
928 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
930 $error = $svc->suspend;
932 $dbh->rollback if $oldAutoCommit;
935 my( $label, $value ) = $cust_svc->label;
936 push @labels, "$label: $value";
940 my $conf = new FS::Conf;
941 if ( $conf->config('suspend_email_admin') ) {
943 my $error = send_email(
944 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
945 #invoice_from ??? well as good as any
946 'to' => $conf->config('suspend_email_admin'),
947 'subject' => 'FREESIDE NOTIFICATION: Customer package suspended',
949 "This is an automatic message from your Freeside installation\n",
950 "informing you that the following customer package has been suspended:\n",
952 'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
953 'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
954 ( map { "Service : $_\n" } @labels ),
959 warn "WARNING: can't send suspension admin email (suspending anyway): ".
967 my %hash = $self->hash;
969 $hash{'adjourn'} = $date;
971 $hash{'susp'} = $suspend_time;
973 my $new = new FS::cust_pkg ( \%hash );
974 $error = $new->replace( $self, options => { $self->options } );
976 $dbh->rollback if $oldAutoCommit;
980 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
985 =item unsuspend [ OPTION => VALUE ... ]
987 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
988 package, then unsuspends the package itself (clears the susp field and the
989 adjourn field if it is in the past).
991 Available options are:
995 =item adjust_next_bill
997 Can be set true to adjust the next bill date forward by
998 the amount of time the account was inactive. This was set true by default
999 since 1.4.2 and 1.5.0pre6; however, starting with 1.7.0 this needs to be
1000 explicitly requested. Price plans for which this makes sense (anniversary-date
1001 based than prorate or subscription) could have an option to enable this
1006 If there is an error, returns the error, otherwise returns false.
1011 my( $self, %opt ) = @_;
1014 local $SIG{HUP} = 'IGNORE';
1015 local $SIG{INT} = 'IGNORE';
1016 local $SIG{QUIT} = 'IGNORE';
1017 local $SIG{TERM} = 'IGNORE';
1018 local $SIG{TSTP} = 'IGNORE';
1019 local $SIG{PIPE} = 'IGNORE';
1021 my $oldAutoCommit = $FS::UID::AutoCommit;
1022 local $FS::UID::AutoCommit = 0;
1025 my $old = $self->select_for_update;
1027 my $pkgnum = $old->pkgnum;
1028 if ( $old->get('cancel') || $self->get('cancel') ) {
1029 dbh->rollback if $oldAutoCommit;
1030 return "Can't unsuspend cancelled package $pkgnum";
1033 unless ( $old->get('susp') && $self->get('susp') ) {
1034 dbh->rollback if $oldAutoCommit;
1035 return ""; # no error # complain instead?
1038 foreach my $cust_svc (
1039 qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
1041 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
1043 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
1044 $dbh->rollback if $oldAutoCommit;
1045 return "Illegal svcdb value in part_svc!";
1048 require "FS/$svcdb.pm";
1050 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
1052 $error = $svc->unsuspend;
1054 $dbh->rollback if $oldAutoCommit;
1061 my %hash = $self->hash;
1062 my $inactive = time - $hash{'susp'};
1064 my $conf = new FS::Conf;
1066 if ( $inactive > 0 &&
1067 ( $hash{'bill'} || $hash{'setup'} ) &&
1068 ( $opt{'adjust_next_bill'} ||
1069 $conf->exists('unsuspend-always_adjust_next_bill_date') ||
1070 $self->part_pkg->option('unsuspend_adjust_bill', 1) )
1073 $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive;
1078 $hash{'adjourn'} = '' if $hash{'adjourn'} < time;
1079 my $new = new FS::cust_pkg ( \%hash );
1080 $error = $new->replace( $self, options => { $self->options } );
1082 $dbh->rollback if $oldAutoCommit;
1086 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1093 Cancels any pending suspension (sets the adjourn field to null).
1095 If there is an error, returns the error, otherwise returns false.
1100 my( $self, %options ) = @_;
1103 local $SIG{HUP} = 'IGNORE';
1104 local $SIG{INT} = 'IGNORE';
1105 local $SIG{QUIT} = 'IGNORE';
1106 local $SIG{TERM} = 'IGNORE';
1107 local $SIG{TSTP} = 'IGNORE';
1108 local $SIG{PIPE} = 'IGNORE';
1110 my $oldAutoCommit = $FS::UID::AutoCommit;
1111 local $FS::UID::AutoCommit = 0;
1114 my $old = $self->select_for_update;
1116 my $pkgnum = $old->pkgnum;
1117 if ( $old->get('cancel') || $self->get('cancel') ) {
1118 dbh->rollback if $oldAutoCommit;
1119 return "Can't unadjourn cancelled package $pkgnum";
1120 # or at least it's pointless
1123 if ( $old->get('susp') || $self->get('susp') ) {
1124 dbh->rollback if $oldAutoCommit;
1125 return "Can't unadjourn suspended package $pkgnum";
1126 # perhaps this is arbitrary
1129 unless ( $old->get('adjourn') && $self->get('adjourn') ) {
1130 dbh->rollback if $oldAutoCommit;
1131 return ""; # no error
1134 my %hash = $self->hash;
1135 $hash{'adjourn'} = '';
1136 my $new = new FS::cust_pkg ( \%hash );
1137 $error = $new->replace( $self, options => { $self->options } );
1139 $dbh->rollback if $oldAutoCommit;
1143 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1150 =item change HASHREF | OPTION => VALUE ...
1152 Changes this package: cancels it and creates a new one, with a different
1153 pkgpart or locationnum or both. All services are transferred to the new
1154 package (no change will be made if this is not possible).
1156 Options may be passed as a list of key/value pairs or as a hash reference.
1163 New locationnum, to change the location for this package.
1167 New FS::cust_location object, to create a new location and assign it
1172 New pkgpart (see L<FS::part_pkg>).
1176 New refnum (see L<FS::part_referral>).
1180 Set to true to transfer billing dates (start_date, setup, last_bill, bill,
1181 susp, adjourn, cancel, expire, and contract_end) to the new package.
1185 At least one of locationnum, cust_location, pkgpart, refnum must be specified
1186 (otherwise, what's the point?)
1188 Returns either the new FS::cust_pkg object or a scalar error.
1192 my $err_or_new_cust_pkg = $old_cust_pkg->change
1196 #some false laziness w/order
1199 my $opt = ref($_[0]) ? shift : { @_ };
1201 # my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
1204 my $conf = new FS::Conf;
1206 # Transactionize this whole mess
1207 local $SIG{HUP} = 'IGNORE';
1208 local $SIG{INT} = 'IGNORE';
1209 local $SIG{QUIT} = 'IGNORE';
1210 local $SIG{TERM} = 'IGNORE';
1211 local $SIG{TSTP} = 'IGNORE';
1212 local $SIG{PIPE} = 'IGNORE';
1214 my $oldAutoCommit = $FS::UID::AutoCommit;
1215 local $FS::UID::AutoCommit = 0;
1224 #$hash{$_} = $self->$_() foreach qw( last_bill bill );
1226 #$hash{$_} = $self->$_() foreach qw( setup );
1228 $hash{'setup'} = $time if $self->setup;
1230 $hash{'change_date'} = $time;
1231 $hash{"change_$_"} = $self->$_()
1232 foreach qw( pkgnum pkgpart locationnum );
1234 if ( $opt->{'cust_location'} &&
1235 ( ! $opt->{'locationnum'} || $opt->{'locationnum'} == -1 ) ) {
1236 $error = $opt->{'cust_location'}->insert;
1238 $dbh->rollback if $oldAutoCommit;
1239 return "inserting cust_location (transaction rolled back): $error";
1241 $opt->{'locationnum'} = $opt->{'cust_location'}->locationnum;
1244 my $unused_credit = 0;
1245 if ( $opt->{'keep_dates'} ) {
1246 foreach my $date ( qw(setup bill last_bill susp adjourn cancel expire
1247 start_date contract_end ) ) {
1248 $hash{$date} = $self->getfield($date);
1251 # Special case. If the pkgpart is changing, and the customer is
1252 # going to be credited for remaining time, don't keep setup, bill,
1253 # or last_bill dates, and DO pass the flag to cancel() to credit
1255 if ( $opt->{'pkgpart'}
1256 and $opt->{'pkgpart'} != $self->pkgpart
1257 and $self->part_pkg->option('unused_credit_change', 1) ) {
1259 $hash{$_} = '' foreach qw(setup bill last_bill);
1262 # Create the new package.
1263 my $cust_pkg = new FS::cust_pkg {
1264 custnum => $self->custnum,
1265 pkgpart => ( $opt->{'pkgpart'} || $self->pkgpart ),
1266 refnum => ( $opt->{'refnum'} || $self->refnum ),
1267 locationnum => ( $opt->{'locationnum'} || $self->locationnum ),
1271 $error = $cust_pkg->insert( 'change' => 1 );
1273 $dbh->rollback if $oldAutoCommit;
1277 # Transfer services and cancel old package.
1279 $error = $self->transfer($cust_pkg);
1280 if ($error and $error == 0) {
1281 # $old_pkg->transfer failed.
1282 $dbh->rollback if $oldAutoCommit;
1286 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1287 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1288 $error = $self->transfer($cust_pkg, 'change_svcpart'=>1 );
1289 if ($error and $error == 0) {
1290 # $old_pkg->transfer failed.
1291 $dbh->rollback if $oldAutoCommit;
1297 # Transfers were successful, but we still had services left on the old
1298 # package. We can't change the package under this circumstances, so abort.
1299 $dbh->rollback if $oldAutoCommit;
1300 return "Unable to transfer all services from package ". $self->pkgnum;
1303 #reset usage if changing pkgpart
1304 # AND usage rollover is off (otherwise adds twice, now and at package bill)
1305 if ($self->pkgpart != $cust_pkg->pkgpart) {
1306 my $part_pkg = $cust_pkg->part_pkg;
1307 $error = $part_pkg->reset_usage($cust_pkg, $part_pkg->is_prepaid
1311 if $part_pkg->can('reset_usage') && ! $part_pkg->option('usage_rollover',1);
1314 $dbh->rollback if $oldAutoCommit;
1315 return "Error setting usage values: $error";
1319 #Good to go, cancel old package. Notify 'cancel' of whether to credit
1321 $error = $self->cancel( quiet=>1, unused_credit => $unused_credit );
1323 $dbh->rollback if $oldAutoCommit;
1327 if ( $conf->exists('cust_pkg-change_pkgpart-bill_now') ) {
1329 my $error = $cust_pkg->cust_main->bill( 'pkg_list' => [ $cust_pkg ] );
1331 $dbh->rollback if $oldAutoCommit;
1336 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1343 use Storable 'thaw';
1345 sub process_bulk_cust_pkg {
1347 my $param = thaw(decode_base64(shift));
1348 warn Dumper($param) if $DEBUG;
1350 my $old_part_pkg = qsearchs('part_pkg',
1351 { pkgpart => $param->{'old_pkgpart'} });
1352 my $new_part_pkg = qsearchs('part_pkg',
1353 { pkgpart => $param->{'new_pkgpart'} });
1354 die "Must select a new package type\n" unless $new_part_pkg;
1355 #my $keep_dates = $param->{'keep_dates'} || 0;
1356 my $keep_dates = 1; # there is no good reason to turn this off
1358 local $SIG{HUP} = 'IGNORE';
1359 local $SIG{INT} = 'IGNORE';
1360 local $SIG{QUIT} = 'IGNORE';
1361 local $SIG{TERM} = 'IGNORE';
1362 local $SIG{TSTP} = 'IGNORE';
1363 local $SIG{PIPE} = 'IGNORE';
1365 my $oldAutoCommit = $FS::UID::AutoCommit;
1366 local $FS::UID::AutoCommit = 0;
1369 my @cust_pkgs = qsearch('cust_pkg', { 'pkgpart' => $param->{'old_pkgpart'} } );
1372 foreach my $old_cust_pkg ( @cust_pkgs ) {
1374 $job->update_statustext(int(100*$i/(scalar @cust_pkgs)));
1375 if ( $old_cust_pkg->getfield('cancel') ) {
1376 warn '[process_bulk_cust_pkg ] skipping canceled pkgnum '.
1377 $old_cust_pkg->pkgnum."\n"
1381 warn '[process_bulk_cust_pkg] changing pkgnum '.$old_cust_pkg->pkgnum."\n"
1383 my $error = $old_cust_pkg->change(
1384 'pkgpart' => $param->{'new_pkgpart'},
1385 'keep_dates' => $keep_dates
1387 if ( !ref($error) ) { # change returns the cust_pkg on success
1389 die "Error changing pkgnum ".$old_cust_pkg->pkgnum.": '$error'\n";
1392 $dbh->commit if $oldAutoCommit;
1398 Returns the last bill date, or if there is no last bill date, the setup date.
1399 Useful for billing metered services.
1405 return $self->setfield('last_bill', $_[0]) if @_;
1406 return $self->getfield('last_bill') if $self->getfield('last_bill');
1407 my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
1408 'edate' => $self->bill, } );
1409 $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
1412 =item last_cust_pkg_reason ACTION
1414 Returns the most recent ACTION FS::cust_pkg_reason associated with the package.
1415 Returns false if there is no reason or the package is not currenly ACTION'd
1416 ACTION is one of adjourn, susp, cancel, or expire.
1420 sub last_cust_pkg_reason {
1421 my ( $self, $action ) = ( shift, shift );
1422 my $date = $self->get($action);
1424 'table' => 'cust_pkg_reason',
1425 'hashref' => { 'pkgnum' => $self->pkgnum,
1426 'action' => substr(uc($action), 0, 1),
1429 'order_by' => 'ORDER BY num DESC LIMIT 1',
1433 =item last_reason ACTION
1435 Returns the most recent ACTION FS::reason associated with the package.
1436 Returns false if there is no reason or the package is not currenly ACTION'd
1437 ACTION is one of adjourn, susp, cancel, or expire.
1442 my $cust_pkg_reason = shift->last_cust_pkg_reason(@_);
1443 $cust_pkg_reason->reason
1444 if $cust_pkg_reason;
1449 Returns the definition for this billing item, as an FS::part_pkg object (see
1456 return $self->{'_pkgpart'} if $self->{'_pkgpart'};
1457 cluck "cust_pkg->part_pkg called" if $DEBUG > 1;
1458 qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
1463 Returns the cancelled package this package was changed from, if any.
1469 return '' unless $self->change_pkgnum;
1470 qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
1475 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
1482 $self->part_pkg->calc_setup($self, @_);
1487 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
1494 $self->part_pkg->calc_recur($self, @_);
1499 Calls the I<base_recur> of the FS::part_pkg object associated with this billing
1506 $self->part_pkg->base_recur($self, @_);
1511 Calls the I<calc_remain> of the FS::part_pkg object associated with this
1518 $self->part_pkg->calc_remain($self, @_);
1523 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
1530 $self->part_pkg->calc_cancel($self, @_);
1535 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
1541 qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
1544 =item cust_pkg_detail [ DETAILTYPE ]
1546 Returns any customer package details for this package (see
1547 L<FS::cust_pkg_detail>).
1549 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
1553 sub cust_pkg_detail {
1555 my %hash = ( 'pkgnum' => $self->pkgnum );
1556 $hash{detailtype} = shift if @_;
1558 'table' => 'cust_pkg_detail',
1559 'hashref' => \%hash,
1560 'order_by' => 'ORDER BY weight, pkgdetailnum',
1564 =item set_cust_pkg_detail DETAILTYPE [ DETAIL, DETAIL, ... ]
1566 Sets customer package details for this package (see L<FS::cust_pkg_detail>).
1568 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
1570 If there is an error, returns the error, otherwise returns false.
1574 sub set_cust_pkg_detail {
1575 my( $self, $detailtype, @details ) = @_;
1577 local $SIG{HUP} = 'IGNORE';
1578 local $SIG{INT} = 'IGNORE';
1579 local $SIG{QUIT} = 'IGNORE';
1580 local $SIG{TERM} = 'IGNORE';
1581 local $SIG{TSTP} = 'IGNORE';
1582 local $SIG{PIPE} = 'IGNORE';
1584 my $oldAutoCommit = $FS::UID::AutoCommit;
1585 local $FS::UID::AutoCommit = 0;
1588 foreach my $current ( $self->cust_pkg_detail($detailtype) ) {
1589 my $error = $current->delete;
1591 $dbh->rollback if $oldAutoCommit;
1592 return "error removing old detail: $error";
1596 foreach my $detail ( @details ) {
1597 my $cust_pkg_detail = new FS::cust_pkg_detail {
1598 'pkgnum' => $self->pkgnum,
1599 'detailtype' => $detailtype,
1600 'detail' => $detail,
1602 my $error = $cust_pkg_detail->insert;
1604 $dbh->rollback if $oldAutoCommit;
1605 return "error adding new detail: $error";
1610 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1617 Returns the new-style customer billing events (see L<FS::cust_event>) for this invoice.
1621 #false laziness w/cust_bill.pm
1625 'table' => 'cust_event',
1626 'addl_from' => 'JOIN part_event USING ( eventpart )',
1627 'hashref' => { 'tablenum' => $self->pkgnum },
1628 'extra_sql' => " AND eventtable = 'cust_pkg' ",
1632 =item num_cust_event
1634 Returns the number of new-style customer billing events (see L<FS::cust_event>) for this invoice.
1638 #false laziness w/cust_bill.pm
1639 sub num_cust_event {
1642 "SELECT COUNT(*) FROM cust_event JOIN part_event USING ( eventpart ) ".
1643 " WHERE tablenum = ? AND eventtable = 'cust_pkg'";
1644 my $sth = dbh->prepare($sql) or die dbh->errstr. " preparing $sql";
1645 $sth->execute($self->pkgnum) or die $sth->errstr. " executing $sql";
1646 $sth->fetchrow_arrayref->[0];
1649 =item cust_svc [ SVCPART ]
1651 Returns the services for this package, as FS::cust_svc objects (see
1652 L<FS::cust_svc>). If a svcpart is specified, return only the matching
1660 return () unless $self->num_cust_svc(@_);
1663 return qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum,
1664 'svcpart' => shift, } );
1667 cluck "cust_pkg->cust_svc called" if $DEBUG > 2;
1669 #if ( $self->{'_svcnum'} ) {
1670 # values %{ $self->{'_svcnum'}->cache };
1672 $self->_sort_cust_svc(
1673 [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
1679 =item overlimit [ SVCPART ]
1681 Returns the services for this package which have exceeded their
1682 usage limit as FS::cust_svc objects (see L<FS::cust_svc>). If a svcpart
1683 is specified, return only the matching services.
1689 return () unless $self->num_cust_svc(@_);
1690 grep { $_->overlimit } $self->cust_svc(@_);
1693 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
1695 Returns historical services for this package created before END TIMESTAMP and
1696 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
1697 (see L<FS::h_cust_svc>). If MODE is 'I' (for 'invoice'), services with the
1698 I<pkg_svc.hidden> flag will be omitted.
1704 my ($end, $start, $mode) = @_;
1705 my @cust_svc = $self->_sort_cust_svc(
1706 [ qsearch( 'h_cust_svc',
1707 { 'pkgnum' => $self->pkgnum, },
1708 FS::h_cust_svc->sql_h_search(@_),
1711 if ( $mode eq 'I' ) {
1712 my %hidden_svcpart = map { $_->svcpart => $_->hidden } $self->part_svc;
1713 return grep { !$hidden_svcpart{$_->svcpart} } @cust_svc;
1720 sub _sort_cust_svc {
1721 my( $self, $arrayref ) = @_;
1724 sub ($$) { my ($a, $b) = @_; $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] };
1729 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
1730 'svcpart' => $_->svcpart } );
1732 $pkg_svc ? $pkg_svc->primary_svc : '',
1733 $pkg_svc ? $pkg_svc->quantity : 0,
1740 =item num_cust_svc [ SVCPART ]
1742 Returns the number of provisioned services for this package. If a svcpart is
1743 specified, counts only the matching services.
1750 return $self->{'_num_cust_svc'}
1752 && exists($self->{'_num_cust_svc'})
1753 && $self->{'_num_cust_svc'} =~ /\d/;
1755 cluck "cust_pkg->num_cust_svc called, _num_cust_svc:".$self->{'_num_cust_svc'}
1758 my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
1759 $sql .= ' AND svcpart = ?' if @_;
1761 my $sth = dbh->prepare($sql) or die dbh->errstr;
1762 $sth->execute($self->pkgnum, @_) or die $sth->errstr;
1763 $sth->fetchrow_arrayref->[0];
1766 =item available_part_svc
1768 Returns a list of FS::part_svc objects representing services included in this
1769 package but not yet provisioned. Each FS::part_svc object also has an extra
1770 field, I<num_avail>, which specifies the number of available services.
1774 sub available_part_svc {
1776 grep { $_->num_avail > 0 }
1778 my $part_svc = $_->part_svc;
1779 $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
1780 $_->quantity - $self->num_cust_svc($_->svcpart);
1782 # more evil encapsulation breakage
1783 if($part_svc->{'Hash'}{'num_avail'} > 0) {
1784 my @exports = $part_svc->part_export_did;
1785 $part_svc->{'Hash'}{'can_get_dids'} = scalar(@exports);
1790 $self->part_pkg->pkg_svc;
1795 Returns a list of FS::part_svc objects representing provisioned and available
1796 services included in this package. Each FS::part_svc object also has the
1797 following extra fields:
1801 =item num_cust_svc (count)
1803 =item num_avail (quantity - count)
1805 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
1808 label -> ($cust_svc->label)[1]
1817 #XXX some sort of sort order besides numeric by svcpart...
1818 my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
1820 my $part_svc = $pkg_svc->part_svc;
1821 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1822 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
1823 $part_svc->{'Hash'}{'num_avail'} =
1824 max( 0, $pkg_svc->quantity - $num_cust_svc );
1825 $part_svc->{'Hash'}{'cust_pkg_svc'} =
1826 $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
1827 $part_svc->{'Hash'}{'hidden'} = $pkg_svc->hidden;
1829 } $self->part_pkg->pkg_svc;
1832 push @part_svc, map {
1834 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1835 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
1836 $part_svc->{'Hash'}{'num_avail'} = 0; #0-$num_cust_svc ?
1837 $part_svc->{'Hash'}{'cust_pkg_svc'} =
1838 $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
1840 } $self->extra_part_svc;
1846 =item extra_part_svc
1848 Returns a list of FS::part_svc objects corresponding to services in this
1849 package which are still provisioned but not (any longer) available in the
1854 sub extra_part_svc {
1857 my $pkgnum = $self->pkgnum;
1858 my $pkgpart = $self->pkgpart;
1861 # 'table' => 'part_svc',
1864 # "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
1865 # WHERE pkg_svc.svcpart = part_svc.svcpart
1866 # AND pkg_svc.pkgpart = ?
1869 # AND 0 < ( SELECT COUNT(*) FROM cust_svc
1870 # LEFT JOIN cust_pkg USING ( pkgnum )
1871 # WHERE cust_svc.svcpart = part_svc.svcpart
1874 # 'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
1877 #seems to benchmark slightly faster...
1879 #'select' => 'DISTINCT ON (svcpart) part_svc.*',
1880 #MySQL doesn't grok DISINCT ON
1881 'select' => 'DISTINCT part_svc.*',
1882 'table' => 'part_svc',
1884 'LEFT JOIN pkg_svc ON ( pkg_svc.svcpart = part_svc.svcpart
1885 AND pkg_svc.pkgpart = ?
1888 LEFT JOIN cust_svc ON ( cust_svc.svcpart = part_svc.svcpart )
1889 LEFT JOIN cust_pkg USING ( pkgnum )
1892 'extra_sql' => "WHERE pkgsvcnum IS NULL AND cust_pkg.pkgnum = ? ",
1893 'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
1899 Returns a short status string for this package, currently:
1903 =item not yet billed
1905 =item one-time charge
1920 my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
1922 return 'cancelled' if $self->get('cancel');
1923 return 'suspended' if $self->susp;
1924 return 'not yet billed' unless $self->setup;
1925 return 'one-time charge' if $freq =~ /^(0|$)/;
1929 =item ucfirst_status
1931 Returns the status with the first character capitalized.
1935 sub ucfirst_status {
1936 ucfirst(shift->status);
1941 Class method that returns the list of possible status strings for packages
1942 (see L<the status method|/status>). For example:
1944 @statuses = FS::cust_pkg->statuses();
1948 tie my %statuscolor, 'Tie::IxHash',
1949 'not yet billed' => '009999', #teal? cyan?
1950 'one-time charge' => '000000',
1951 'active' => '00CC00',
1952 'suspended' => 'FF9900',
1953 'cancelled' => 'FF0000',
1957 my $self = shift; #could be class...
1958 #grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
1959 # # mayble split btw one-time vs. recur
1965 Returns a hex triplet color string for this package's status.
1971 $statuscolor{$self->status};
1976 Returns a label for this package. (Currently "pkgnum: pkg - comment" or
1977 "pkg-comment" depending on user preference).
1983 my $label = $self->part_pkg->pkg_comment( 'nopkgpart' => 1 );
1984 $label = $self->pkgnum. ": $label"
1985 if $FS::CurrentUser::CurrentUser->option('show_pkgnum');
1989 =item pkg_label_long
1991 Returns a long label for this package, adding the primary service's label to
1996 sub pkg_label_long {
1998 my $label = $self->pkg_label;
1999 my $cust_svc = $self->primary_cust_svc;
2000 $label .= ' ('. ($cust_svc->label)[1]. ')' if $cust_svc;
2004 =item primary_cust_svc
2006 Returns a primary service (as FS::cust_svc object) if one can be identified.
2010 #for labeling purposes - might not 100% match up with part_pkg->svcpart's idea
2012 sub primary_cust_svc {
2015 my @cust_svc = $self->cust_svc;
2017 return '' unless @cust_svc; #no serivces - irrelevant then
2019 return $cust_svc[0] if scalar(@cust_svc) == 1; #always return a single service
2021 # primary service as specified in the package definition
2022 # or exactly one service definition with quantity one
2023 my $svcpart = $self->part_pkg->svcpart;
2024 @cust_svc = grep { $_->svcpart == $svcpart } @cust_svc;
2025 return $cust_svc[0] if scalar(@cust_svc) == 1;
2027 #couldn't identify one thing..
2033 Returns a list of lists, calling the label method for all services
2034 (see L<FS::cust_svc>) of this billing item.
2040 map { [ $_->label ] } $self->cust_svc;
2043 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
2045 Like the labels method, but returns historical information on services that
2046 were active as of END_TIMESTAMP and (optionally) not cancelled before
2047 START_TIMESTAMP. If MODE is 'I' (for 'invoice'), services with the
2048 I<pkg_svc.hidden> flag will be omitted.
2050 Returns a list of lists, calling the label method for all (historical) services
2051 (see L<FS::h_cust_svc>) of this billing item.
2057 map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
2062 Like labels, except returns a simple flat list, and shortens long
2063 (currently >5 or the cust_bill-max_same_services configuration value) lists of
2064 identical services to one line that lists the service label and the number of
2065 individual services rather than individual items.
2070 shift->_labels_short( 'labels', @_ );
2073 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
2075 Like h_labels, except returns a simple flat list, and shortens long
2076 (currently >5 or the cust_bill-max_same_services configuration value) lists of
2077 identical services to one line that lists the service label and the number of
2078 individual services rather than individual items.
2082 sub h_labels_short {
2083 shift->_labels_short( 'h_labels', @_ );
2087 my( $self, $method ) = ( shift, shift );
2089 my $conf = new FS::Conf;
2090 my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
2093 #tie %labels, 'Tie::IxHash';
2094 push @{ $labels{$_->[0]} }, $_->[1]
2095 foreach $self->$method(@_);
2097 foreach my $label ( keys %labels ) {
2099 my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
2100 my $num = scalar(@values);
2101 if ( $num > $max_same_services ) {
2102 push @labels, "$label ($num)";
2104 if ( $conf->exists('cust_bill-consolidate_services') ) {
2105 # push @labels, "$label: ". join(', ', @values);
2107 my $detail = "$label: ";
2108 $detail .= shift(@values). ', '
2109 while @values && length($detail.$values[0]) < 78;
2111 push @labels, $detail;
2114 push @labels, map { "$label: $_" } @values;
2125 Returns the parent customer object (see L<FS::cust_main>).
2131 qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
2134 #these subs are in location_Mixin.pm now... unfortunately the POD doesn't mixin
2138 Returns the location object, if any (see L<FS::cust_location>).
2140 =item cust_location_or_main
2142 If this package is associated with a location, returns the locaiton (see
2143 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
2145 =item location_label [ OPTION => VALUE ... ]
2147 Returns the label of the location object (see L<FS::cust_location>).
2151 #end of subs in location_Mixin.pm now... unfortunately the POD doesn't mixin
2153 =item seconds_since TIMESTAMP
2155 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
2156 package have been online since TIMESTAMP, according to the session monitor.
2158 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
2159 L<Time::Local> and L<Date::Parse> for conversion functions.
2164 my($self, $since) = @_;
2167 foreach my $cust_svc (
2168 grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
2170 $seconds += $cust_svc->seconds_since($since);
2177 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2179 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
2180 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
2183 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2184 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2190 sub seconds_since_sqlradacct {
2191 my($self, $start, $end) = @_;
2195 foreach my $cust_svc (
2197 my $part_svc = $_->part_svc;
2198 $part_svc->svcdb eq 'svc_acct'
2199 && scalar($part_svc->part_export('sqlradius'));
2202 $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
2209 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2211 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2212 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2216 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2217 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2222 sub attribute_since_sqlradacct {
2223 my($self, $start, $end, $attrib) = @_;
2227 foreach my $cust_svc (
2229 my $part_svc = $_->part_svc;
2230 $part_svc->svcdb eq 'svc_acct'
2231 && scalar($part_svc->part_export('sqlradius'));
2234 $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
2246 my( $self, $value ) = @_;
2247 if ( defined($value) ) {
2248 $self->setfield('quantity', $value);
2250 $self->getfield('quantity') || 1;
2253 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
2255 Transfers as many services as possible from this package to another package.
2257 The destination package can be specified by pkgnum by passing an FS::cust_pkg
2258 object. The destination package must already exist.
2260 Services are moved only if the destination allows services with the correct
2261 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true. Use
2262 this option with caution! No provision is made for export differences
2263 between the old and new service definitions. Probably only should be used
2264 when your exports for all service definitions of a given svcdb are identical.
2265 (attempt a transfer without it first, to move all possible svcpart-matching
2268 Any services that can't be moved remain in the original package.
2270 Returns an error, if there is one; otherwise, returns the number of services
2271 that couldn't be moved.
2276 my ($self, $dest_pkgnum, %opt) = @_;
2282 if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
2283 $dest = $dest_pkgnum;
2284 $dest_pkgnum = $dest->pkgnum;
2286 $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
2289 return ('Package does not exist: '.$dest_pkgnum) unless $dest;
2291 foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
2292 $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
2295 foreach my $cust_svc ($dest->cust_svc) {
2296 $target{$cust_svc->svcpart}--;
2299 my %svcpart2svcparts = ();
2300 if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2301 warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
2302 foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
2303 next if exists $svcpart2svcparts{$svcpart};
2304 my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
2305 $svcpart2svcparts{$svcpart} = [
2307 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
2309 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
2310 'svcpart' => $_ } );
2312 $pkg_svc ? $pkg_svc->primary_svc : '',
2313 $pkg_svc ? $pkg_svc->quantity : 0,
2317 grep { $_ != $svcpart }
2319 qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
2321 warn "alternates for svcpart $svcpart: ".
2322 join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
2327 foreach my $cust_svc ($self->cust_svc) {
2328 if($target{$cust_svc->svcpart} > 0) {
2329 $target{$cust_svc->svcpart}--;
2330 my $new = new FS::cust_svc { $cust_svc->hash };
2331 $new->pkgnum($dest_pkgnum);
2332 my $error = $new->replace($cust_svc);
2333 return $error if $error;
2334 } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2336 warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
2337 warn "alternates to consider: ".
2338 join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
2340 my @alternate = grep {
2341 warn "considering alternate svcpart $_: ".
2342 "$target{$_} available in new package\n"
2345 } @{$svcpart2svcparts{$cust_svc->svcpart}};
2347 warn "alternate(s) found\n" if $DEBUG;
2348 my $change_svcpart = $alternate[0];
2349 $target{$change_svcpart}--;
2350 my $new = new FS::cust_svc { $cust_svc->hash };
2351 $new->svcpart($change_svcpart);
2352 $new->pkgnum($dest_pkgnum);
2353 my $error = $new->replace($cust_svc);
2354 return $error if $error;
2367 This method is deprecated. See the I<depend_jobnum> option to the insert and
2368 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
2375 local $SIG{HUP} = 'IGNORE';
2376 local $SIG{INT} = 'IGNORE';
2377 local $SIG{QUIT} = 'IGNORE';
2378 local $SIG{TERM} = 'IGNORE';
2379 local $SIG{TSTP} = 'IGNORE';
2380 local $SIG{PIPE} = 'IGNORE';
2382 my $oldAutoCommit = $FS::UID::AutoCommit;
2383 local $FS::UID::AutoCommit = 0;
2386 foreach my $cust_svc ( $self->cust_svc ) {
2387 #false laziness w/svc_Common::insert
2388 my $svc_x = $cust_svc->svc_x;
2389 foreach my $part_export ( $cust_svc->part_svc->part_export ) {
2390 my $error = $part_export->export_insert($svc_x);
2392 $dbh->rollback if $oldAutoCommit;
2398 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2405 Associates this package with a (suspension or cancellation) reason (see
2406 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
2409 Available options are:
2415 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.
2419 the access_user (see L<FS::access_user>) providing the reason
2427 the action (cancel, susp, adjourn, expire) associated with the reason
2431 If there is an error, returns the error, otherwise returns false.
2436 my ($self, %options) = @_;
2438 my $otaker = $options{reason_otaker} ||
2439 $FS::CurrentUser::CurrentUser->username;
2442 if ( $options{'reason'} =~ /^(\d+)$/ ) {
2446 } elsif ( ref($options{'reason'}) ) {
2448 return 'Enter a new reason (or select an existing one)'
2449 unless $options{'reason'}->{'reason'} !~ /^\s*$/;
2451 my $reason = new FS::reason({
2452 'reason_type' => $options{'reason'}->{'typenum'},
2453 'reason' => $options{'reason'}->{'reason'},
2455 my $error = $reason->insert;
2456 return $error if $error;
2458 $reasonnum = $reason->reasonnum;
2461 return "Unparsable reason: ". $options{'reason'};
2464 my $cust_pkg_reason =
2465 new FS::cust_pkg_reason({ 'pkgnum' => $self->pkgnum,
2466 'reasonnum' => $reasonnum,
2467 'otaker' => $otaker,
2468 'action' => substr(uc($options{'action'}),0,1),
2469 'date' => $options{'date'}
2474 $cust_pkg_reason->insert;
2477 =item insert_discount
2479 Associates this package with a discount (see L<FS::cust_pkg_discount>, possibly
2480 inserting a new discount on the fly (see L<FS::discount>).
2482 Available options are:
2490 If there is an error, returns the error, otherwise returns false.
2494 sub insert_discount {
2495 #my ($self, %options) = @_;
2498 my $cust_pkg_discount = new FS::cust_pkg_discount {
2499 'pkgnum' => $self->pkgnum,
2500 'discountnum' => $self->discountnum,
2502 'end_date' => '', #XXX
2503 'otaker' => $self->otaker,
2504 #for the create a new discount case
2505 '_type' => $self->discountnum__type,
2506 'amount' => $self->discountnum_amount,
2507 'percent' => $self->discountnum_percent,
2508 'months' => $self->discountnum_months,
2509 #'disabled' => $self->discountnum_disabled,
2512 $cust_pkg_discount->insert;
2515 =item set_usage USAGE_VALUE_HASHREF
2517 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2518 to which they should be set (see L<FS::svc_acct>). Currently seconds,
2519 upbytes, downbytes, and totalbytes are appropriate keys.
2521 All svc_accts which are part of this package have their values reset.
2526 my ($self, $valueref, %opt) = @_;
2528 foreach my $cust_svc ($self->cust_svc){
2529 my $svc_x = $cust_svc->svc_x;
2530 $svc_x->set_usage($valueref, %opt)
2531 if $svc_x->can("set_usage");
2535 =item recharge USAGE_VALUE_HASHREF
2537 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2538 to which they should be set (see L<FS::svc_acct>). Currently seconds,
2539 upbytes, downbytes, and totalbytes are appropriate keys.
2541 All svc_accts which are part of this package have their values incremented.
2546 my ($self, $valueref) = @_;
2548 foreach my $cust_svc ($self->cust_svc){
2549 my $svc_x = $cust_svc->svc_x;
2550 $svc_x->recharge($valueref)
2551 if $svc_x->can("recharge");
2555 =item cust_pkg_discount
2559 sub cust_pkg_discount {
2561 qsearch('cust_pkg_discount', { 'pkgnum' => $self->pkgnum } );
2564 =item cust_pkg_discount_active
2568 sub cust_pkg_discount_active {
2570 grep { $_->status eq 'active' } $self->cust_pkg_discount;
2575 =head1 CLASS METHODS
2581 Returns an SQL expression identifying recurring packages.
2585 sub recurring_sql { "
2586 '0' != ( select freq from part_pkg
2587 where cust_pkg.pkgpart = part_pkg.pkgpart )
2592 Returns an SQL expression identifying one-time packages.
2597 '0' = ( select freq from part_pkg
2598 where cust_pkg.pkgpart = part_pkg.pkgpart )
2603 Returns an SQL expression identifying ordered packages (recurring packages not
2609 $_[0]->recurring_sql. " AND ". $_[0]->not_yet_billed_sql;
2614 Returns an SQL expression identifying active packages.
2619 $_[0]->recurring_sql. "
2620 AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
2621 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2622 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
2625 =item not_yet_billed_sql
2627 Returns an SQL expression identifying packages which have not yet been billed.
2631 sub not_yet_billed_sql { "
2632 ( cust_pkg.setup IS NULL OR cust_pkg.setup = 0 )
2633 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2634 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
2639 Returns an SQL expression identifying inactive packages (one-time packages
2640 that are otherwise unsuspended/uncancelled).
2644 sub inactive_sql { "
2645 ". $_[0]->onetime_sql(). "
2646 AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
2647 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2648 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
2654 Returns an SQL expression identifying suspended packages.
2658 sub suspended_sql { susp_sql(@_); }
2660 #$_[0]->recurring_sql(). ' AND '.
2662 ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2663 AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0
2670 Returns an SQL exprression identifying cancelled packages.
2674 sub cancelled_sql { cancel_sql(@_); }
2676 #$_[0]->recurring_sql(). ' AND '.
2677 "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
2682 Returns an SQL expression to give the package status as a string.
2688 WHEN cust_pkg.cancel IS NOT NULL THEN 'cancelled'
2689 WHEN cust_pkg.susp IS NOT NULL THEN 'suspended'
2690 WHEN cust_pkg.setup IS NULL THEN 'not yet billed'
2691 WHEN ".onetime_sql()." THEN 'one-time charge'
2696 =item search HASHREF
2700 Returns a qsearch hash expression to search for parameters specified in HASHREF.
2701 Valid parameters are
2709 active, inactive, suspended, cancel (or cancelled)
2713 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
2717 boolean selects custom packages
2723 pkgpart or arrayref or hashref of pkgparts
2727 arrayref of beginning and ending epoch date
2731 arrayref of beginning and ending epoch date
2735 arrayref of beginning and ending epoch date
2739 arrayref of beginning and ending epoch date
2743 arrayref of beginning and ending epoch date
2747 arrayref of beginning and ending epoch date
2751 arrayref of beginning and ending epoch date
2755 pkgnum or APKG_pkgnum
2759 a value suited to passing to FS::UI::Web::cust_header
2763 specifies the user for agent virtualization
2767 boolean selects packages containing fcc form 477 telco lines
2774 my ($class, $params) = @_;
2781 if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2783 "cust_main.agentnum = $1";
2790 if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
2792 "cust_pkg.custnum = $1";
2799 if ( $params->{'pkgbatch'} =~ /^([\w\/\-\:\.]+)$/ and $1 ) {
2801 "cust_pkg.pkgbatch = '$1'";
2808 if ( $params->{'magic'} eq 'active'
2809 || $params->{'status'} eq 'active' ) {
2811 push @where, FS::cust_pkg->active_sql();
2813 } elsif ( $params->{'magic'} =~ /^not[ _]yet[ _]billed$/
2814 || $params->{'status'} =~ /^not[ _]yet[ _]billed$/ ) {
2816 push @where, FS::cust_pkg->not_yet_billed_sql();
2818 } elsif ( $params->{'magic'} =~ /^(one-time charge|inactive)/
2819 || $params->{'status'} =~ /^(one-time charge|inactive)/ ) {
2821 push @where, FS::cust_pkg->inactive_sql();
2823 } elsif ( $params->{'magic'} eq 'suspended'
2824 || $params->{'status'} eq 'suspended' ) {
2826 push @where, FS::cust_pkg->suspended_sql();
2828 } elsif ( $params->{'magic'} =~ /^cancell?ed$/
2829 || $params->{'status'} =~ /^cancell?ed$/ ) {
2831 push @where, FS::cust_pkg->cancelled_sql();
2836 # parse package class
2839 #false lazinessish w/graph/cust_bill_pkg.cgi
2842 if ( exists($params->{'classnum'})
2843 && $params->{'classnum'} =~ /^(\d*)$/
2847 if ( $classnum ) { #a specific class
2848 push @where, "part_pkg.classnum = $classnum";
2850 #@pkg_class = ( qsearchs('pkg_class', { 'classnum' => $classnum } ) );
2851 #die "classnum $classnum not found!" unless $pkg_class[0];
2852 #$title .= $pkg_class[0]->classname.' ';
2854 } elsif ( $classnum eq '' ) { #the empty class
2856 push @where, "part_pkg.classnum IS NULL";
2857 #$title .= 'Empty class ';
2858 #@pkg_class = ( '(empty class)' );
2859 } elsif ( $classnum eq '0' ) {
2860 #@pkg_class = qsearch('pkg_class', {} ); # { 'disabled' => '' } );
2861 #push @pkg_class, '(empty class)';
2863 die "illegal classnum";
2869 # parse package report options
2872 my @report_option = ();
2873 if ( exists($params->{'report_option'})
2874 && $params->{'report_option'} =~ /^([,\d]*)$/
2877 @report_option = split(',', $1);
2880 if (@report_option) {
2881 # this will result in the empty set for the dangling comma case as it should
2883 map{ "0 < ( SELECT count(*) FROM part_pkg_option
2884 WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
2885 AND optionname = 'report_option_$_'
2886 AND optionvalue = '1' )"
2896 push @where, "part_pkg.custom = 'Y'" if $params->{custom};
2902 push @where, "part_pkg.fcc_ds0s > 0" if $params->{fcc_line};
2908 if ( exists($params->{'censustract'}) ) {
2909 $params->{'censustract'} =~ /^([.\d]*)$/;
2910 my $censustract = "cust_main.censustract = '$1'";
2911 $censustract .= ' OR cust_main.censustract is NULL' unless $1;
2912 push @where, "( $censustract )";
2919 if ( ref($params->{'pkgpart'}) ) {
2922 if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
2923 @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
2924 } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
2925 @pkgpart = @{ $params->{'pkgpart'} };
2927 die 'unhandled pkgpart ref '. $params->{'pkgpart'};
2930 @pkgpart = grep /^(\d+)$/, @pkgpart;
2932 push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
2934 } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
2935 push @where, "pkgpart = $1";
2944 #false laziness w/report_cust_pkg.html
2947 'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
2948 'active' => { 'susp'=>1, 'cancel'=>1 },
2949 'suspended' => { 'cancel' => 1 },
2954 if( exists($params->{'active'} ) ) {
2955 # This overrides all the other date-related fields
2956 my($beginning, $ending) = @{$params->{'active'}};
2958 "cust_pkg.setup IS NOT NULL",
2959 "cust_pkg.setup <= $ending",
2960 "(cust_pkg.cancel IS NULL OR cust_pkg.cancel >= $beginning )",
2961 "NOT (".FS::cust_pkg->onetime_sql . ")";
2964 foreach my $field (qw( setup last_bill bill adjourn susp expire contract_end cancel )) {
2966 next unless exists($params->{$field});
2968 my($beginning, $ending) = @{$params->{$field}};
2970 next if $beginning == 0 && $ending == 4294967295;
2973 "cust_pkg.$field IS NOT NULL",
2974 "cust_pkg.$field >= $beginning",
2975 "cust_pkg.$field <= $ending";
2977 $orderby ||= "ORDER BY cust_pkg.$field";
2982 $orderby ||= 'ORDER BY bill';
2985 # parse magic, legacy, etc.
2988 if ( $params->{'magic'} &&
2989 $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
2992 $orderby = 'ORDER BY pkgnum';
2994 if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
2995 push @where, "pkgpart = $1";
2998 } elsif ( $params->{'query'} eq 'pkgnum' ) {
3000 $orderby = 'ORDER BY pkgnum';
3002 } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
3004 $orderby = 'ORDER BY pkgnum';
3007 SELECT count(*) FROM pkg_svc
3008 WHERE pkg_svc.pkgpart = cust_pkg.pkgpart
3009 AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
3010 WHERE cust_svc.pkgnum = cust_pkg.pkgnum
3011 AND cust_svc.svcpart = pkg_svc.svcpart
3018 # setup queries, links, subs, etc. for the search
3021 # here is the agent virtualization
3022 if ($params->{CurrentUser}) {
3024 qsearchs('access_user', { username => $params->{CurrentUser} });
3027 push @where, $access_user->agentnums_sql('table'=>'cust_main');
3032 push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
3035 my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
3037 my $addl_from = 'LEFT JOIN cust_main USING ( custnum ) '.
3038 'LEFT JOIN part_pkg USING ( pkgpart ) '.
3039 'LEFT JOIN pkg_class ON ( part_pkg.classnum = pkg_class.classnum ) ';
3041 my $count_query = "SELECT COUNT(*) FROM cust_pkg $addl_from $extra_sql";
3044 'table' => 'cust_pkg',
3046 'select' => join(', ',
3048 ( map "part_pkg.$_", qw( pkg freq ) ),
3049 'pkg_class.classname',
3050 'cust_main.custnum AS cust_main_custnum',
3051 FS::UI::Web::cust_sql_fields(
3052 $params->{'cust_fields'}
3055 'extra_sql' => "$extra_sql $orderby",
3056 'addl_from' => $addl_from,
3057 'count_query' => $count_query,
3064 Returns a list of two package counts. The first is a count of packages
3065 based on the supplied criteria and the second is the count of residential
3066 packages with those same criteria. Criteria are specified as in the search
3072 my ($class, $params) = @_;
3074 my $sql_query = $class->search( $params );
3076 my $count_sql = delete($sql_query->{'count_query'});
3077 $count_sql =~ s/ FROM/,count(CASE WHEN cust_main.company IS NULL OR cust_main.company = '' THEN 1 END) FROM/
3078 or die "couldn't parse count_sql";
3080 my $count_sth = dbh->prepare($count_sql)
3081 or die "Error preparing $count_sql: ". dbh->errstr;
3083 or die "Error executing $count_sql: ". $count_sth->errstr;
3084 my $count_arrayref = $count_sth->fetchrow_arrayref;
3086 return ( @$count_arrayref );
3093 Returns a list: the first item is an SQL fragment identifying matching
3094 packages/customers via location (taking into account shipping and package
3095 address taxation, if enabled), and subsequent items are the parameters to
3096 substitute for the placeholders in that fragment.
3101 my($class, %opt) = @_;
3102 my $ornull = $opt{'ornull'};
3104 my $conf = new FS::Conf;
3106 # '?' placeholders in _location_sql_where
3107 my $x = $ornull ? 3 : 2;
3108 my @bill_param = ( ('city')x3, ('county')x$x, ('state')x$x, 'country' );
3112 if ( $conf->exists('tax-ship_address') ) {
3115 ( ( ship_last IS NULL OR ship_last = '' )
3116 AND ". _location_sql_where('cust_main', '', $ornull ). "
3118 OR ( ship_last IS NOT NULL AND ship_last != ''
3119 AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
3122 # AND payby != 'COMP'
3124 @main_param = ( @bill_param, @bill_param );
3128 $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
3129 @main_param = @bill_param;
3135 if ( $conf->exists('tax-pkg_address') ) {
3137 my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
3140 ( cust_pkg.locationnum IS NULL AND $main_where )
3141 OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where )
3144 @param = ( @main_param, @bill_param );
3148 $where = $main_where;
3149 @param = @main_param;
3157 #subroutine, helper for location_sql
3158 sub _location_sql_where {
3160 my $prefix = @_ ? shift : '';
3161 my $ornull = @_ ? shift : '';
3163 # $ornull = $ornull ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
3165 $ornull = $ornull ? ' OR ? IS NULL ' : '';
3167 my $or_empty_city = " OR ( ? = '' AND $table.${prefix}city IS NULL ) ";
3168 my $or_empty_county = " OR ( ? = '' AND $table.${prefix}county IS NULL ) ";
3169 my $or_empty_state = " OR ( ? = '' AND $table.${prefix}state IS NULL ) ";
3171 # ( $table.${prefix}city = ? $or_empty_city $ornull )
3173 ( $table.${prefix}city = ? OR ? = '' OR CAST(? AS text) IS NULL )
3174 AND ( $table.${prefix}county = ? $or_empty_county $ornull )
3175 AND ( $table.${prefix}state = ? $or_empty_state $ornull )
3176 AND $table.${prefix}country = ?
3184 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
3186 CUSTNUM is a customer (see L<FS::cust_main>)
3188 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
3189 L<FS::part_pkg>) to order for this customer. Duplicates are of course
3192 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
3193 remove for this customer. The services (see L<FS::cust_svc>) are moved to the
3194 new billing items. An error is returned if this is not possible (see
3195 L<FS::pkg_svc>). An empty arrayref is equivalent to not specifying this
3198 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
3199 newly-created cust_pkg objects.
3201 REFNUM, if specified, will specify the FS::pkg_referral record to be created
3202 and inserted. Multiple FS::pkg_referral records can be created by
3203 setting I<refnum> to an array reference of refnums or a hash reference with
3204 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
3205 record will be created corresponding to cust_main.refnum.
3210 my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
3212 my $conf = new FS::Conf;
3214 # Transactionize this whole mess
3215 local $SIG{HUP} = 'IGNORE';
3216 local $SIG{INT} = 'IGNORE';
3217 local $SIG{QUIT} = 'IGNORE';
3218 local $SIG{TERM} = 'IGNORE';
3219 local $SIG{TSTP} = 'IGNORE';
3220 local $SIG{PIPE} = 'IGNORE';
3222 my $oldAutoCommit = $FS::UID::AutoCommit;
3223 local $FS::UID::AutoCommit = 0;
3227 # my $cust_main = qsearchs('cust_main', { custnum => $custnum });
3228 # return "Customer not found: $custnum" unless $cust_main;
3230 warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
3233 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
3236 my $change = scalar(@old_cust_pkg) != 0;
3239 if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
3241 warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
3242 " to pkgpart ". $pkgparts->[0]. "\n"
3245 my $err_or_cust_pkg =
3246 $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
3247 'refnum' => $refnum,
3250 unless (ref($err_or_cust_pkg)) {
3251 $dbh->rollback if $oldAutoCommit;
3252 return $err_or_cust_pkg;
3255 push @$return_cust_pkg, $err_or_cust_pkg;
3256 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3261 # Create the new packages.
3262 foreach my $pkgpart (@$pkgparts) {
3264 warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
3266 my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
3267 pkgpart => $pkgpart,
3271 $error = $cust_pkg->insert( 'change' => $change );
3273 $dbh->rollback if $oldAutoCommit;
3276 push @$return_cust_pkg, $cust_pkg;
3278 # $return_cust_pkg now contains refs to all of the newly
3281 # Transfer services and cancel old packages.
3282 foreach my $old_pkg (@old_cust_pkg) {
3284 warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
3287 foreach my $new_pkg (@$return_cust_pkg) {
3288 $error = $old_pkg->transfer($new_pkg);
3289 if ($error and $error == 0) {
3290 # $old_pkg->transfer failed.
3291 $dbh->rollback if $oldAutoCommit;
3296 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
3297 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
3298 foreach my $new_pkg (@$return_cust_pkg) {
3299 $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
3300 if ($error and $error == 0) {
3301 # $old_pkg->transfer failed.
3302 $dbh->rollback if $oldAutoCommit;
3309 # Transfers were successful, but we went through all of the
3310 # new packages and still had services left on the old package.
3311 # We can't cancel the package under the circumstances, so abort.
3312 $dbh->rollback if $oldAutoCommit;
3313 return "Unable to transfer all services from package ".$old_pkg->pkgnum;
3315 $error = $old_pkg->cancel( quiet=>1 );
3321 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3325 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
3327 A bulk change method to change packages for multiple customers.
3329 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
3330 L<FS::part_pkg>) to order for each customer. Duplicates are of course
3333 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
3334 replace. The services (see L<FS::cust_svc>) are moved to the
3335 new billing items. An error is returned if this is not possible (see
3338 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
3339 newly-created cust_pkg objects.
3344 my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
3346 # Transactionize this whole mess
3347 local $SIG{HUP} = 'IGNORE';
3348 local $SIG{INT} = 'IGNORE';
3349 local $SIG{QUIT} = 'IGNORE';
3350 local $SIG{TERM} = 'IGNORE';
3351 local $SIG{TSTP} = 'IGNORE';
3352 local $SIG{PIPE} = 'IGNORE';
3354 my $oldAutoCommit = $FS::UID::AutoCommit;
3355 local $FS::UID::AutoCommit = 0;
3359 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
3362 while(scalar(@old_cust_pkg)) {
3364 my $custnum = $old_cust_pkg[0]->custnum;
3365 my (@remove) = map { $_->pkgnum }
3366 grep { $_->custnum == $custnum } @old_cust_pkg;
3367 @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
3369 my $error = order $custnum, $pkgparts, \@remove, \@return;
3371 push @errors, $error
3373 push @$return_cust_pkg, @return;
3376 if (scalar(@errors)) {
3377 $dbh->rollback if $oldAutoCommit;
3378 return join(' / ', @errors);
3381 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3385 # Used by FS::Upgrade to migrate to a new database.
3386 sub _upgrade_data { # class method
3387 my ($class, %opts) = @_;
3388 $class->_upgrade_otaker(%opts);
3390 # RT#10139, bug resulting in contract_end being set when it shouldn't
3391 'UPDATE cust_pkg SET contract_end = NULL WHERE contract_end = -1',
3392 # RT#10830, bad calculation of prorate date near end of year
3393 # the date range for bill is December 2009, and we move it forward
3394 # one year if it's before the previous bill date (which it should
3396 'UPDATE cust_pkg SET bill = bill + (365*24*60*60) WHERE bill < last_bill
3397 AND bill > 1259654400 AND bill < 1262332800 AND (SELECT plan FROM part_pkg
3398 WHERE part_pkg.pkgpart = cust_pkg.pkgpart) = \'prorate\'',
3400 foreach my $sql (@statements) {
3401 my $sth = dbh->prepare($sql);
3402 $sth->execute or die $sth->errstr;
3410 sub order is not OO. Perhaps it should be moved to FS::cust_main and made so?
3412 In sub order, the @pkgparts array (passed by reference) is clobbered.
3414 Also in sub order, no money is adjusted. Once FS::part_pkg defines a standard
3415 method to pass dates to the recur_prog expression, it should do so.
3417 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
3418 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
3419 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
3420 configuration values. Probably need a subroutine which decides what to do
3421 based on whether or not we've fetched the user yet, rather than a hash. See
3422 FS::UID and the TODO.
3424 Now that things are transactional should the check in the insert method be
3429 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
3430 L<FS::pkg_svc>, schema.html from the base documentation