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>)
130 date package was ordered (also remains same on changes)
142 date (next bill date)
170 order taker (see L<FS::access_user>)
174 If this field is set to 1, disables the automatic
175 unsuspension of this package when using the B<unsuspendauto> config option.
179 If not set, defaults to 1
183 Date of change from previous package
193 =item change_locationnum
201 Note: setup, last_bill, bill, adjourn, susp, expire, cancel and change_date
202 are specified as UNIX timestamps; see L<perlfunc/"time">. Also see
203 L<Time::Local> and L<Date::Parse> for conversion functions.
211 Create a new billing item. To add the item to the database, see L<"insert">.
215 sub table { 'cust_pkg'; }
216 sub cust_linked { $_[0]->cust_main_custnum; }
217 sub cust_unlinked_msg {
219 "WARNING: can't find cust_main.custnum ". $self->custnum.
220 ' (cust_pkg.pkgnum '. $self->pkgnum. ')';
223 =item insert [ OPTION => VALUE ... ]
225 Adds this billing item to the database ("Orders" the item). If there is an
226 error, returns the error, otherwise returns false.
228 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
229 will be used to look up the package definition and agent restrictions will be
232 If the additional field I<refnum> is defined, an FS::pkg_referral record will
233 be created and inserted. Multiple FS::pkg_referral records can be created by
234 setting I<refnum> to an array reference of refnums or a hash reference with
235 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
236 record will be created corresponding to cust_main.refnum.
238 The following options are available:
244 If set true, supresses any referral credit to a referring customer.
248 cust_pkg_option records will be created
252 a ticket will be added to this customer with this subject
256 an optional queue name for ticket additions
263 my( $self, %options ) = @_;
265 my $error = $self->check_pkgpart;
266 return $error if $error;
268 if ( $self->part_pkg->option('start_1st', 1) && !$self->start_date ) {
269 my ($sec,$min,$hour,$mday,$mon,$year) = (localtime(time) )[0,1,2,3,4,5];
270 $mon += 1 unless $mday == 1;
271 until ( $mon < 12 ) { $mon -= 12; $year++; }
272 $self->start_date( timelocal_nocheck(0,0,0,1,$mon,$year) );
275 foreach my $action ( qw(expire adjourn contract_end) ) {
276 my $months = $self->part_pkg->option("${action}_months",1);
277 if($months and !$self->$action) {
278 my $start = $self->start_date || $self->setup || time;
279 $self->$action( $self->part_pkg->add_freq($start, $months) );
283 $self->order_date(time);
285 local $SIG{HUP} = 'IGNORE';
286 local $SIG{INT} = 'IGNORE';
287 local $SIG{QUIT} = 'IGNORE';
288 local $SIG{TERM} = 'IGNORE';
289 local $SIG{TSTP} = 'IGNORE';
290 local $SIG{PIPE} = 'IGNORE';
292 my $oldAutoCommit = $FS::UID::AutoCommit;
293 local $FS::UID::AutoCommit = 0;
296 $error = $self->SUPER::insert($options{options} ? %{$options{options}} : ());
298 $dbh->rollback if $oldAutoCommit;
302 $self->refnum($self->cust_main->refnum) unless $self->refnum;
303 $self->refnum( [ $self->refnum ] ) unless ref($self->refnum);
304 $self->process_m2m( 'link_table' => 'pkg_referral',
305 'target_table' => 'part_referral',
306 'params' => $self->refnum,
309 if ( $self->discountnum ) {
310 my $error = $self->insert_discount();
312 $dbh->rollback if $oldAutoCommit;
317 #if ( $self->reg_code ) {
318 # my $reg_code = qsearchs('reg_code', { 'code' => $self->reg_code } );
319 # $error = $reg_code->delete;
321 # $dbh->rollback if $oldAutoCommit;
326 my $conf = new FS::Conf;
328 if ( $conf->config('ticket_system') && $options{ticket_subject} ) {
331 # use lib ( "/opt/rt3/local/lib", "/opt/rt3/lib" );
338 use FS::TicketSystem;
339 FS::TicketSystem->init();
341 my $q = new RT::Queue($RT::SystemUser);
342 $q->Load($options{ticket_queue}) if $options{ticket_queue};
343 my $t = new RT::Ticket($RT::SystemUser);
344 my $mime = new MIME::Entity;
345 $mime->build( Type => 'text/plain', Data => $options{ticket_subject} );
346 $t->Create( $options{ticket_queue} ? (Queue => $q) : (),
347 Subject => $options{ticket_subject},
350 $t->AddLink( Type => 'MemberOf',
351 Target => 'freeside://freeside/cust_main/'. $self->custnum,
355 if ($conf->config('welcome_letter') && $self->cust_main->num_pkgs == 1) {
356 my $queue = new FS::queue {
357 'job' => 'FS::cust_main::queueable_print',
359 $error = $queue->insert(
360 'custnum' => $self->custnum,
361 'template' => 'welcome_letter',
365 warn "can't send welcome letter: $error";
370 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
377 This method now works but you probably shouldn't use it.
379 You don't want to delete packages, because there would then be no record
380 the customer ever purchased the package. Instead, see the cancel method and
381 hide cancelled packages.
388 local $SIG{HUP} = 'IGNORE';
389 local $SIG{INT} = 'IGNORE';
390 local $SIG{QUIT} = 'IGNORE';
391 local $SIG{TERM} = 'IGNORE';
392 local $SIG{TSTP} = 'IGNORE';
393 local $SIG{PIPE} = 'IGNORE';
395 my $oldAutoCommit = $FS::UID::AutoCommit;
396 local $FS::UID::AutoCommit = 0;
399 foreach my $cust_pkg_discount ($self->cust_pkg_discount) {
400 my $error = $cust_pkg_discount->delete;
402 $dbh->rollback if $oldAutoCommit;
406 #cust_bill_pkg_discount?
408 foreach my $cust_pkg_detail ($self->cust_pkg_detail) {
409 my $error = $cust_pkg_detail->delete;
411 $dbh->rollback if $oldAutoCommit;
416 foreach my $cust_pkg_reason (
418 'table' => 'cust_pkg_reason',
419 'hashref' => { 'pkgnum' => $self->pkgnum },
423 my $error = $cust_pkg_reason->delete;
425 $dbh->rollback if $oldAutoCommit;
432 my $error = $self->SUPER::delete(@_);
434 $dbh->rollback if $oldAutoCommit;
438 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
444 =item replace [ OLD_RECORD ] [ HASHREF | OPTION => VALUE ... ]
446 Replaces the OLD_RECORD with this one in the database. If there is an error,
447 returns the error, otherwise returns false.
449 Currently, custnum, setup, bill, adjourn, susp, expire, and cancel may be changed.
451 Changing pkgpart may have disasterous effects. See the order subroutine.
453 setup and bill are normally updated by calling the bill method of a customer
454 object (see L<FS::cust_main>).
456 suspend is normally updated by the suspend and unsuspend methods.
458 cancel is normally updated by the cancel method (and also the order subroutine
461 Available options are:
467 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.
471 the access_user (see L<FS::access_user>) providing the reason
475 hashref of keys and values - cust_pkg_option records will be created, updated or removed as appopriate
484 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
489 ( ref($_[0]) eq 'HASH' )
493 #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
494 #return "Can't change otaker!" if $old->otaker ne $new->otaker;
497 #return "Can't change setup once it exists!"
498 # if $old->getfield('setup') &&
499 # $old->getfield('setup') != $new->getfield('setup');
501 #some logic for bill, susp, cancel?
503 local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
505 local $SIG{HUP} = 'IGNORE';
506 local $SIG{INT} = 'IGNORE';
507 local $SIG{QUIT} = 'IGNORE';
508 local $SIG{TERM} = 'IGNORE';
509 local $SIG{TSTP} = 'IGNORE';
510 local $SIG{PIPE} = 'IGNORE';
512 my $oldAutoCommit = $FS::UID::AutoCommit;
513 local $FS::UID::AutoCommit = 0;
516 foreach my $method ( qw(adjourn expire) ) { # How many reasons?
517 if ($options->{'reason'} && $new->$method && $old->$method ne $new->$method) {
518 my $error = $new->insert_reason(
519 'reason' => $options->{'reason'},
520 'date' => $new->$method,
522 'reason_otaker' => $options->{'reason_otaker'},
525 dbh->rollback if $oldAutoCommit;
526 return "Error inserting cust_pkg_reason: $error";
531 #save off and freeze RADIUS attributes for any associated svc_acct records
533 if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
535 #also check for specific exports?
536 # to avoid spurious modify export events
537 @svc_acct = map { $_->svc_x }
538 grep { $_->part_svc->svcdb eq 'svc_acct' }
541 $_->snapshot foreach @svc_acct;
545 my $error = $new->SUPER::replace($old,
546 $options->{options} ? $options->{options} : ()
549 $dbh->rollback if $oldAutoCommit;
553 #for prepaid packages,
554 #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
555 foreach my $old_svc_acct ( @svc_acct ) {
556 my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
558 $new_svc_acct->replace( $old_svc_acct,
559 'depend_jobnum' => $options->{depend_jobnum},
562 $dbh->rollback if $oldAutoCommit;
567 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
574 Checks all fields to make sure this is a valid billing item. If there is an
575 error, returns the error, otherwise returns false. Called by the insert and
583 $self->locationnum('') if !$self->locationnum || $self->locationnum == -1;
586 $self->ut_numbern('pkgnum')
587 || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
588 || $self->ut_numbern('pkgpart')
589 || $self->check_pkgpart
590 || $self->ut_foreign_keyn('locationnum', 'cust_location', 'locationnum')
591 || $self->ut_numbern('start_date')
592 || $self->ut_numbern('setup')
593 || $self->ut_numbern('bill')
594 || $self->ut_numbern('susp')
595 || $self->ut_numbern('cancel')
596 || $self->ut_numbern('adjourn')
597 || $self->ut_numbern('expire')
598 || $self->ut_enum('no_auto', [ '', 'Y' ])
599 || $self->ut_enum('waive_setup', [ '', 'Y' ])
600 || $self->ut_numbern('agent_pkgid')
602 return $error if $error;
604 return "A package with both start date (future start) and setup date (already started) will never bill"
605 if $self->start_date && $self->setup;
607 $self->usernum($FS::CurrentUser::CurrentUser->usernum) unless $self->usernum;
609 if ( $self->dbdef_table->column('manual_flag') ) {
610 $self->manual_flag('') if $self->manual_flag eq ' ';
611 $self->manual_flag =~ /^([01]?)$/
612 or return "Illegal manual_flag ". $self->manual_flag;
613 $self->manual_flag($1);
626 my $error = $self->ut_numbern('pkgpart');
627 return $error if $error;
629 if ( $self->reg_code ) {
631 unless ( grep { $self->pkgpart == $_->pkgpart }
632 map { $_->reg_code_pkg }
633 qsearchs( 'reg_code', { 'code' => $self->reg_code,
634 'agentnum' => $self->cust_main->agentnum })
636 return "Unknown registration code";
639 } elsif ( $self->promo_code ) {
642 qsearchs('part_pkg', {
643 'pkgpart' => $self->pkgpart,
644 'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
646 return 'Unknown promotional code' unless $promo_part_pkg;
650 unless ( $disable_agentcheck ) {
652 qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
653 return "agent ". $agent->agentnum. ':'. $agent->agent.
654 " can't purchase pkgpart ". $self->pkgpart
655 unless $agent->pkgpart_hashref->{ $self->pkgpart }
656 || $agent->agentnum == $self->part_pkg->agentnum;
659 $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
660 return $error if $error;
668 =item cancel [ OPTION => VALUE ... ]
670 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
671 in this package, then cancels the package itself (sets the cancel field to
674 Available options are:
678 =item quiet - can be set true to supress email cancellation notices.
680 =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.
682 =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.
684 =item date - can be set to a unix style timestamp to specify when to cancel (expire)
686 =item nobill - can be set true to skip billing if it might otherwise be done.
688 =item unused_credit - can be set to 1 to credit the remaining time, or 0 to
689 not credit it. This must be set (by change()) when changing the package
690 to a different pkgpart or location, and probably shouldn't be in any other
691 case. If it's not set, the 'unused_credit_cancel' part_pkg option will
696 If there is an error, returns the error, otherwise returns false.
701 my( $self, %options ) = @_;
704 my $conf = new FS::Conf;
706 warn "cust_pkg::cancel called with options".
707 join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
710 local $SIG{HUP} = 'IGNORE';
711 local $SIG{INT} = 'IGNORE';
712 local $SIG{QUIT} = 'IGNORE';
713 local $SIG{TERM} = 'IGNORE';
714 local $SIG{TSTP} = 'IGNORE';
715 local $SIG{PIPE} = 'IGNORE';
717 my $oldAutoCommit = $FS::UID::AutoCommit;
718 local $FS::UID::AutoCommit = 0;
721 my $old = $self->select_for_update;
723 if ( $old->get('cancel') || $self->get('cancel') ) {
724 dbh->rollback if $oldAutoCommit;
725 return ""; # no error
728 my $date = $options{date} if $options{date}; # expire/cancel later
729 $date = '' if ($date && $date <= time); # complain instead?
731 #race condition: usage could be ongoing until unprovisioned
732 #resolved by performing a change package instead (which unprovisions) and
734 if ( !$options{nobill} && !$date && $conf->exists('bill_usage_on_cancel') ) {
735 my $copy = $self->new({$self->hash});
737 $copy->cust_main->bill( pkg_list => [ $copy ], cancel => 1 );
738 warn "Error billing during cancel, custnum ".
739 #$self->cust_main->custnum. ": $error"
744 my $cancel_time = $options{'time'} || time;
746 if ( $options{'reason'} ) {
747 $error = $self->insert_reason( 'reason' => $options{'reason'},
748 'action' => $date ? 'expire' : 'cancel',
749 'date' => $date ? $date : $cancel_time,
750 'reason_otaker' => $options{'reason_otaker'},
753 dbh->rollback if $oldAutoCommit;
754 return "Error inserting cust_pkg_reason: $error";
758 my %svc_cancel_opt = ();
759 $svc_cancel_opt{'date'} = $date if $date;
760 foreach my $cust_svc (
763 sort { $a->[1] <=> $b->[1] }
764 map { [ $_, $_->svc_x->table_info->{'cancel_weight'} ]; }
765 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
767 my $part_svc = $cust_svc->part_svc;
768 next if ( defined($part_svc) and $part_svc->preserve );
769 my $error = $cust_svc->cancel( %svc_cancel_opt );
772 $dbh->rollback if $oldAutoCommit;
773 return 'Error '. ($svc_cancel_opt{'date'} ? 'expiring' : 'canceling' ).
780 # Add a credit for remaining service
781 my $last_bill = $self->getfield('last_bill') || 0;
782 my $next_bill = $self->getfield('bill') || 0;
784 if ( exists($options{'unused_credit'}) ) {
785 $do_credit = $options{'unused_credit'};
788 $do_credit = $self->part_pkg->option('unused_credit_cancel', 1);
791 and $last_bill > 0 # the package has been billed
792 and $next_bill > 0 # the package has a next bill date
793 and $next_bill >= $cancel_time # which is in the future
795 my $remaining_value = $self->calc_remain('time' => $cancel_time);
796 if ( $remaining_value > 0 ) {
797 my $error = $self->cust_main->credit(
799 'Credit for unused time on '. $self->part_pkg->pkg,
800 'reason_type' => $conf->config('cancel_credit_type'),
803 $dbh->rollback if $oldAutoCommit;
804 return "Error crediting customer \$$remaining_value for unused time".
805 " on ". $self->part_pkg->pkg. ": $error";
807 } #if $remaining_value
812 my %hash = $self->hash;
813 $date ? ($hash{'expire'} = $date) : ($hash{'cancel'} = $cancel_time);
814 my $new = new FS::cust_pkg ( \%hash );
815 $error = $new->replace( $self, options => { $self->options } );
817 $dbh->rollback if $oldAutoCommit;
821 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
822 return '' if $date; #no errors
824 my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
825 if ( !$options{'quiet'} &&
826 $conf->exists('emailcancel', $self->cust_main->agentnum) &&
828 my $msgnum = $conf->config('cancel_msgnum', $self->cust_main->agentnum);
831 my $msg_template = qsearchs('msg_template', { msgnum => $msgnum });
832 $error = $msg_template->send( 'cust_main' => $self->cust_main,
837 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
838 'to' => \@invoicing_list,
839 'subject' => ( $conf->config('cancelsubject') || 'Cancellation Notice' ),
840 'body' => [ map "$_\n", $conf->config('cancelmessage') ],
843 #should this do something on errors?
850 =item cancel_if_expired [ NOW_TIMESTAMP ]
852 Cancels this package if its expire date has been reached.
856 sub cancel_if_expired {
858 my $time = shift || time;
859 return '' unless $self->expire && $self->expire <= $time;
860 my $error = $self->cancel;
862 return "Error cancelling expired pkg ". $self->pkgnum. " for custnum ".
863 $self->custnum. ": $error";
870 Cancels any pending expiration (sets the expire field to null).
872 If there is an error, returns the error, otherwise returns false.
877 my( $self, %options ) = @_;
880 local $SIG{HUP} = 'IGNORE';
881 local $SIG{INT} = 'IGNORE';
882 local $SIG{QUIT} = 'IGNORE';
883 local $SIG{TERM} = 'IGNORE';
884 local $SIG{TSTP} = 'IGNORE';
885 local $SIG{PIPE} = 'IGNORE';
887 my $oldAutoCommit = $FS::UID::AutoCommit;
888 local $FS::UID::AutoCommit = 0;
891 my $old = $self->select_for_update;
893 my $pkgnum = $old->pkgnum;
894 if ( $old->get('cancel') || $self->get('cancel') ) {
895 dbh->rollback if $oldAutoCommit;
896 return "Can't unexpire cancelled package $pkgnum";
897 # or at least it's pointless
900 unless ( $old->get('expire') && $self->get('expire') ) {
901 dbh->rollback if $oldAutoCommit;
902 return ""; # no error
905 my %hash = $self->hash;
906 $hash{'expire'} = '';
907 my $new = new FS::cust_pkg ( \%hash );
908 $error = $new->replace( $self, options => { $self->options } );
910 $dbh->rollback if $oldAutoCommit;
914 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
920 =item suspend [ OPTION => VALUE ... ]
922 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
923 package, then suspends the package itself (sets the susp field to now).
925 Available options are:
929 =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.
931 =item date - can be set to a unix style timestamp to specify when to suspend (adjourn)
935 If there is an error, returns the error, otherwise returns false.
940 my( $self, %options ) = @_;
943 local $SIG{HUP} = 'IGNORE';
944 local $SIG{INT} = 'IGNORE';
945 local $SIG{QUIT} = 'IGNORE';
946 local $SIG{TERM} = 'IGNORE';
947 local $SIG{TSTP} = 'IGNORE';
948 local $SIG{PIPE} = 'IGNORE';
950 my $oldAutoCommit = $FS::UID::AutoCommit;
951 local $FS::UID::AutoCommit = 0;
954 my $old = $self->select_for_update;
956 my $pkgnum = $old->pkgnum;
957 if ( $old->get('cancel') || $self->get('cancel') ) {
958 dbh->rollback if $oldAutoCommit;
959 return "Can't suspend cancelled package $pkgnum";
962 if ( $old->get('susp') || $self->get('susp') ) {
963 dbh->rollback if $oldAutoCommit;
964 return ""; # no error # complain on adjourn?
967 my $date = $options{date} if $options{date}; # adjourn/suspend later
968 $date = '' if ($date && $date <= time); # complain instead?
970 if ( $date && $old->get('expire') && $old->get('expire') < $date ) {
971 dbh->rollback if $oldAutoCommit;
972 return "Package $pkgnum expires before it would be suspended.";
975 my $suspend_time = $options{'time'} || time;
977 if ( $options{'reason'} ) {
978 $error = $self->insert_reason( 'reason' => $options{'reason'},
979 'action' => $date ? 'adjourn' : 'suspend',
980 'date' => $date ? $date : $suspend_time,
981 'reason_otaker' => $options{'reason_otaker'},
984 dbh->rollback if $oldAutoCommit;
985 return "Error inserting cust_pkg_reason: $error";
993 foreach my $cust_svc (
994 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
996 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
998 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
999 $dbh->rollback if $oldAutoCommit;
1000 return "Illegal svcdb value in part_svc!";
1003 require "FS/$svcdb.pm";
1005 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
1007 $error = $svc->suspend;
1009 $dbh->rollback if $oldAutoCommit;
1012 my( $label, $value ) = $cust_svc->label;
1013 push @labels, "$label: $value";
1017 my $conf = new FS::Conf;
1018 if ( $conf->config('suspend_email_admin') ) {
1020 my $error = send_email(
1021 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
1022 #invoice_from ??? well as good as any
1023 'to' => $conf->config('suspend_email_admin'),
1024 'subject' => 'FREESIDE NOTIFICATION: Customer package suspended',
1026 "This is an automatic message from your Freeside installation\n",
1027 "informing you that the following customer package has been suspended:\n",
1029 'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
1030 'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
1031 ( map { "Service : $_\n" } @labels ),
1036 warn "WARNING: can't send suspension admin email (suspending anyway): ".
1044 my %hash = $self->hash;
1046 $hash{'adjourn'} = $date;
1048 $hash{'susp'} = $suspend_time;
1050 my $new = new FS::cust_pkg ( \%hash );
1051 $error = $new->replace( $self, options => { $self->options } );
1053 $dbh->rollback if $oldAutoCommit;
1057 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1062 =item unsuspend [ OPTION => VALUE ... ]
1064 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
1065 package, then unsuspends the package itself (clears the susp field and the
1066 adjourn field if it is in the past).
1068 Available options are:
1072 =item adjust_next_bill
1074 Can be set true to adjust the next bill date forward by
1075 the amount of time the account was inactive. This was set true by default
1076 since 1.4.2 and 1.5.0pre6; however, starting with 1.7.0 this needs to be
1077 explicitly requested. Price plans for which this makes sense (anniversary-date
1078 based than prorate or subscription) could have an option to enable this
1083 If there is an error, returns the error, otherwise returns false.
1088 my( $self, %opt ) = @_;
1091 local $SIG{HUP} = 'IGNORE';
1092 local $SIG{INT} = 'IGNORE';
1093 local $SIG{QUIT} = 'IGNORE';
1094 local $SIG{TERM} = 'IGNORE';
1095 local $SIG{TSTP} = 'IGNORE';
1096 local $SIG{PIPE} = 'IGNORE';
1098 my $oldAutoCommit = $FS::UID::AutoCommit;
1099 local $FS::UID::AutoCommit = 0;
1102 my $old = $self->select_for_update;
1104 my $pkgnum = $old->pkgnum;
1105 if ( $old->get('cancel') || $self->get('cancel') ) {
1106 dbh->rollback if $oldAutoCommit;
1107 return "Can't unsuspend cancelled package $pkgnum";
1110 unless ( $old->get('susp') && $self->get('susp') ) {
1111 dbh->rollback if $oldAutoCommit;
1112 return ""; # no error # complain instead?
1115 foreach my $cust_svc (
1116 qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
1118 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
1120 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
1121 $dbh->rollback if $oldAutoCommit;
1122 return "Illegal svcdb value in part_svc!";
1125 require "FS/$svcdb.pm";
1127 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
1129 $error = $svc->unsuspend;
1131 $dbh->rollback if $oldAutoCommit;
1138 my %hash = $self->hash;
1139 my $inactive = time - $hash{'susp'};
1141 my $conf = new FS::Conf;
1143 if ( $inactive > 0 &&
1144 ( $hash{'bill'} || $hash{'setup'} ) &&
1145 ( $opt{'adjust_next_bill'} ||
1146 $conf->exists('unsuspend-always_adjust_next_bill_date') ||
1147 $self->part_pkg->option('unsuspend_adjust_bill', 1) )
1150 $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive;
1155 $hash{'adjourn'} = '' if $hash{'adjourn'} < time;
1156 my $new = new FS::cust_pkg ( \%hash );
1157 $error = $new->replace( $self, options => { $self->options } );
1159 $dbh->rollback if $oldAutoCommit;
1163 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1170 Cancels any pending suspension (sets the adjourn field to null).
1172 If there is an error, returns the error, otherwise returns false.
1177 my( $self, %options ) = @_;
1180 local $SIG{HUP} = 'IGNORE';
1181 local $SIG{INT} = 'IGNORE';
1182 local $SIG{QUIT} = 'IGNORE';
1183 local $SIG{TERM} = 'IGNORE';
1184 local $SIG{TSTP} = 'IGNORE';
1185 local $SIG{PIPE} = 'IGNORE';
1187 my $oldAutoCommit = $FS::UID::AutoCommit;
1188 local $FS::UID::AutoCommit = 0;
1191 my $old = $self->select_for_update;
1193 my $pkgnum = $old->pkgnum;
1194 if ( $old->get('cancel') || $self->get('cancel') ) {
1195 dbh->rollback if $oldAutoCommit;
1196 return "Can't unadjourn cancelled package $pkgnum";
1197 # or at least it's pointless
1200 if ( $old->get('susp') || $self->get('susp') ) {
1201 dbh->rollback if $oldAutoCommit;
1202 return "Can't unadjourn suspended package $pkgnum";
1203 # perhaps this is arbitrary
1206 unless ( $old->get('adjourn') && $self->get('adjourn') ) {
1207 dbh->rollback if $oldAutoCommit;
1208 return ""; # no error
1211 my %hash = $self->hash;
1212 $hash{'adjourn'} = '';
1213 my $new = new FS::cust_pkg ( \%hash );
1214 $error = $new->replace( $self, options => { $self->options } );
1216 $dbh->rollback if $oldAutoCommit;
1220 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1227 =item change HASHREF | OPTION => VALUE ...
1229 Changes this package: cancels it and creates a new one, with a different
1230 pkgpart or locationnum or both. All services are transferred to the new
1231 package (no change will be made if this is not possible).
1233 Options may be passed as a list of key/value pairs or as a hash reference.
1240 New locationnum, to change the location for this package.
1244 New FS::cust_location object, to create a new location and assign it
1249 New pkgpart (see L<FS::part_pkg>).
1253 New refnum (see L<FS::part_referral>).
1257 Set to true to transfer billing dates (start_date, setup, last_bill, bill,
1258 susp, adjourn, cancel, expire, and contract_end) to the new package.
1262 At least one of locationnum, cust_location, pkgpart, refnum must be specified
1263 (otherwise, what's the point?)
1265 Returns either the new FS::cust_pkg object or a scalar error.
1269 my $err_or_new_cust_pkg = $old_cust_pkg->change
1273 #some false laziness w/order
1276 my $opt = ref($_[0]) ? shift : { @_ };
1278 # my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
1281 my $conf = new FS::Conf;
1283 # Transactionize this whole mess
1284 local $SIG{HUP} = 'IGNORE';
1285 local $SIG{INT} = 'IGNORE';
1286 local $SIG{QUIT} = 'IGNORE';
1287 local $SIG{TERM} = 'IGNORE';
1288 local $SIG{TSTP} = 'IGNORE';
1289 local $SIG{PIPE} = 'IGNORE';
1291 my $oldAutoCommit = $FS::UID::AutoCommit;
1292 local $FS::UID::AutoCommit = 0;
1301 #$hash{$_} = $self->$_() foreach qw( last_bill bill );
1303 #$hash{$_} = $self->$_() foreach qw( setup );
1305 $hash{'setup'} = $time if $self->setup;
1307 $hash{'change_date'} = $time;
1308 $hash{"change_$_"} = $self->$_()
1309 foreach qw( pkgnum pkgpart locationnum );
1311 if ( $opt->{'cust_location'} &&
1312 ( ! $opt->{'locationnum'} || $opt->{'locationnum'} == -1 ) ) {
1313 $error = $opt->{'cust_location'}->insert;
1315 $dbh->rollback if $oldAutoCommit;
1316 return "inserting cust_location (transaction rolled back): $error";
1318 $opt->{'locationnum'} = $opt->{'cust_location'}->locationnum;
1321 my $unused_credit = 0;
1322 if ( $opt->{'keep_dates'} ) {
1323 foreach my $date ( qw(setup bill last_bill susp adjourn cancel expire
1324 start_date contract_end ) ) {
1325 $hash{$date} = $self->getfield($date);
1328 # Special case. If the pkgpart is changing, and the customer is
1329 # going to be credited for remaining time, don't keep setup, bill,
1330 # or last_bill dates, and DO pass the flag to cancel() to credit
1332 if ( $opt->{'pkgpart'}
1333 and $opt->{'pkgpart'} != $self->pkgpart
1334 and $self->part_pkg->option('unused_credit_change', 1) ) {
1336 $hash{$_} = '' foreach qw(setup bill last_bill);
1339 # Create the new package.
1340 my $cust_pkg = new FS::cust_pkg {
1341 custnum => $self->custnum,
1342 pkgpart => ( $opt->{'pkgpart'} || $self->pkgpart ),
1343 refnum => ( $opt->{'refnum'} || $self->refnum ),
1344 locationnum => ( $opt->{'locationnum'} || $self->locationnum ),
1348 $error = $cust_pkg->insert( 'change' => 1 );
1350 $dbh->rollback if $oldAutoCommit;
1354 # Transfer services and cancel old package.
1356 $error = $self->transfer($cust_pkg);
1357 if ($error and $error == 0) {
1358 # $old_pkg->transfer failed.
1359 $dbh->rollback if $oldAutoCommit;
1363 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1364 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1365 $error = $self->transfer($cust_pkg, 'change_svcpart'=>1 );
1366 if ($error and $error == 0) {
1367 # $old_pkg->transfer failed.
1368 $dbh->rollback if $oldAutoCommit;
1374 # Transfers were successful, but we still had services left on the old
1375 # package. We can't change the package under this circumstances, so abort.
1376 $dbh->rollback if $oldAutoCommit;
1377 return "Unable to transfer all services from package ". $self->pkgnum;
1380 #reset usage if changing pkgpart
1381 # AND usage rollover is off (otherwise adds twice, now and at package bill)
1382 if ($self->pkgpart != $cust_pkg->pkgpart) {
1383 my $part_pkg = $cust_pkg->part_pkg;
1384 $error = $part_pkg->reset_usage($cust_pkg, $part_pkg->is_prepaid
1388 if $part_pkg->can('reset_usage') && ! $part_pkg->option('usage_rollover',1);
1391 $dbh->rollback if $oldAutoCommit;
1392 return "Error setting usage values: $error";
1396 #Good to go, cancel old package. Notify 'cancel' of whether to credit
1398 $error = $self->cancel( quiet=>1, unused_credit => $unused_credit );
1400 $dbh->rollback if $oldAutoCommit;
1404 if ( $conf->exists('cust_pkg-change_pkgpart-bill_now') ) {
1406 my $error = $cust_pkg->cust_main->bill( 'pkg_list' => [ $cust_pkg ] );
1408 $dbh->rollback if $oldAutoCommit;
1413 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1420 use Storable 'thaw';
1422 sub process_bulk_cust_pkg {
1424 my $param = thaw(decode_base64(shift));
1425 warn Dumper($param) if $DEBUG;
1427 my $old_part_pkg = qsearchs('part_pkg',
1428 { pkgpart => $param->{'old_pkgpart'} });
1429 my $new_part_pkg = qsearchs('part_pkg',
1430 { pkgpart => $param->{'new_pkgpart'} });
1431 die "Must select a new package type\n" unless $new_part_pkg;
1432 #my $keep_dates = $param->{'keep_dates'} || 0;
1433 my $keep_dates = 1; # there is no good reason to turn this off
1435 local $SIG{HUP} = 'IGNORE';
1436 local $SIG{INT} = 'IGNORE';
1437 local $SIG{QUIT} = 'IGNORE';
1438 local $SIG{TERM} = 'IGNORE';
1439 local $SIG{TSTP} = 'IGNORE';
1440 local $SIG{PIPE} = 'IGNORE';
1442 my $oldAutoCommit = $FS::UID::AutoCommit;
1443 local $FS::UID::AutoCommit = 0;
1446 my @cust_pkgs = qsearch('cust_pkg', { 'pkgpart' => $param->{'old_pkgpart'} } );
1449 foreach my $old_cust_pkg ( @cust_pkgs ) {
1451 $job->update_statustext(int(100*$i/(scalar @cust_pkgs)));
1452 if ( $old_cust_pkg->getfield('cancel') ) {
1453 warn '[process_bulk_cust_pkg ] skipping canceled pkgnum '.
1454 $old_cust_pkg->pkgnum."\n"
1458 warn '[process_bulk_cust_pkg] changing pkgnum '.$old_cust_pkg->pkgnum."\n"
1460 my $error = $old_cust_pkg->change(
1461 'pkgpart' => $param->{'new_pkgpart'},
1462 'keep_dates' => $keep_dates
1464 if ( !ref($error) ) { # change returns the cust_pkg on success
1466 die "Error changing pkgnum ".$old_cust_pkg->pkgnum.": '$error'\n";
1469 $dbh->commit if $oldAutoCommit;
1475 Returns the last bill date, or if there is no last bill date, the setup date.
1476 Useful for billing metered services.
1482 return $self->setfield('last_bill', $_[0]) if @_;
1483 return $self->getfield('last_bill') if $self->getfield('last_bill');
1484 my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
1485 'edate' => $self->bill, } );
1486 $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
1489 =item last_cust_pkg_reason ACTION
1491 Returns the most recent ACTION FS::cust_pkg_reason associated with the package.
1492 Returns false if there is no reason or the package is not currenly ACTION'd
1493 ACTION is one of adjourn, susp, cancel, or expire.
1497 sub last_cust_pkg_reason {
1498 my ( $self, $action ) = ( shift, shift );
1499 my $date = $self->get($action);
1501 'table' => 'cust_pkg_reason',
1502 'hashref' => { 'pkgnum' => $self->pkgnum,
1503 'action' => substr(uc($action), 0, 1),
1506 'order_by' => 'ORDER BY num DESC LIMIT 1',
1510 =item last_reason ACTION
1512 Returns the most recent ACTION FS::reason associated with the package.
1513 Returns false if there is no reason or the package is not currenly ACTION'd
1514 ACTION is one of adjourn, susp, cancel, or expire.
1519 my $cust_pkg_reason = shift->last_cust_pkg_reason(@_);
1520 $cust_pkg_reason->reason
1521 if $cust_pkg_reason;
1526 Returns the definition for this billing item, as an FS::part_pkg object (see
1533 return $self->{'_pkgpart'} if $self->{'_pkgpart'};
1534 cluck "cust_pkg->part_pkg called" if $DEBUG > 1;
1535 qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
1540 Returns the cancelled package this package was changed from, if any.
1546 return '' unless $self->change_pkgnum;
1547 qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
1552 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
1559 $self->part_pkg->calc_setup($self, @_);
1564 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
1571 $self->part_pkg->calc_recur($self, @_);
1576 Calls the I<base_recur> of the FS::part_pkg object associated with this billing
1583 $self->part_pkg->base_recur($self, @_);
1588 Calls the I<calc_remain> of the FS::part_pkg object associated with this
1595 $self->part_pkg->calc_remain($self, @_);
1600 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
1607 $self->part_pkg->calc_cancel($self, @_);
1612 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
1618 qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
1621 =item cust_pkg_detail [ DETAILTYPE ]
1623 Returns any customer package details for this package (see
1624 L<FS::cust_pkg_detail>).
1626 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
1630 sub cust_pkg_detail {
1632 my %hash = ( 'pkgnum' => $self->pkgnum );
1633 $hash{detailtype} = shift if @_;
1635 'table' => 'cust_pkg_detail',
1636 'hashref' => \%hash,
1637 'order_by' => 'ORDER BY weight, pkgdetailnum',
1641 =item set_cust_pkg_detail DETAILTYPE [ DETAIL, DETAIL, ... ]
1643 Sets customer package details for this package (see L<FS::cust_pkg_detail>).
1645 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
1647 If there is an error, returns the error, otherwise returns false.
1651 sub set_cust_pkg_detail {
1652 my( $self, $detailtype, @details ) = @_;
1654 local $SIG{HUP} = 'IGNORE';
1655 local $SIG{INT} = 'IGNORE';
1656 local $SIG{QUIT} = 'IGNORE';
1657 local $SIG{TERM} = 'IGNORE';
1658 local $SIG{TSTP} = 'IGNORE';
1659 local $SIG{PIPE} = 'IGNORE';
1661 my $oldAutoCommit = $FS::UID::AutoCommit;
1662 local $FS::UID::AutoCommit = 0;
1665 foreach my $current ( $self->cust_pkg_detail($detailtype) ) {
1666 my $error = $current->delete;
1668 $dbh->rollback if $oldAutoCommit;
1669 return "error removing old detail: $error";
1673 foreach my $detail ( @details ) {
1674 my $cust_pkg_detail = new FS::cust_pkg_detail {
1675 'pkgnum' => $self->pkgnum,
1676 'detailtype' => $detailtype,
1677 'detail' => $detail,
1679 my $error = $cust_pkg_detail->insert;
1681 $dbh->rollback if $oldAutoCommit;
1682 return "error adding new detail: $error";
1687 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1694 Returns the new-style customer billing events (see L<FS::cust_event>) for this invoice.
1698 #false laziness w/cust_bill.pm
1702 'table' => 'cust_event',
1703 'addl_from' => 'JOIN part_event USING ( eventpart )',
1704 'hashref' => { 'tablenum' => $self->pkgnum },
1705 'extra_sql' => " AND eventtable = 'cust_pkg' ",
1709 =item num_cust_event
1711 Returns the number of new-style customer billing events (see L<FS::cust_event>) for this invoice.
1715 #false laziness w/cust_bill.pm
1716 sub num_cust_event {
1719 "SELECT COUNT(*) FROM cust_event JOIN part_event USING ( eventpart ) ".
1720 " WHERE tablenum = ? AND eventtable = 'cust_pkg'";
1721 my $sth = dbh->prepare($sql) or die dbh->errstr. " preparing $sql";
1722 $sth->execute($self->pkgnum) or die $sth->errstr. " executing $sql";
1723 $sth->fetchrow_arrayref->[0];
1726 =item cust_svc [ SVCPART ]
1728 Returns the services for this package, as FS::cust_svc objects (see
1729 L<FS::cust_svc>). If a svcpart is specified, return only the matching
1737 return () unless $self->num_cust_svc(@_);
1740 return qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum,
1741 'svcpart' => shift, } );
1744 cluck "cust_pkg->cust_svc called" if $DEBUG > 2;
1746 #if ( $self->{'_svcnum'} ) {
1747 # values %{ $self->{'_svcnum'}->cache };
1749 $self->_sort_cust_svc(
1750 [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
1756 =item overlimit [ SVCPART ]
1758 Returns the services for this package which have exceeded their
1759 usage limit as FS::cust_svc objects (see L<FS::cust_svc>). If a svcpart
1760 is specified, return only the matching services.
1766 return () unless $self->num_cust_svc(@_);
1767 grep { $_->overlimit } $self->cust_svc(@_);
1770 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
1772 Returns historical services for this package created before END TIMESTAMP and
1773 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
1774 (see L<FS::h_cust_svc>). If MODE is 'I' (for 'invoice'), services with the
1775 I<pkg_svc.hidden> flag will be omitted.
1781 warn "$me _h_cust_svc called on $self\n"
1784 my ($end, $start, $mode) = @_;
1785 my @cust_svc = $self->_sort_cust_svc(
1786 [ qsearch( 'h_cust_svc',
1787 { 'pkgnum' => $self->pkgnum, },
1788 FS::h_cust_svc->sql_h_search(@_),
1791 if ( $mode eq 'I' ) {
1792 my %hidden_svcpart = map { $_->svcpart => $_->hidden } $self->part_svc;
1793 return grep { !$hidden_svcpart{$_->svcpart} } @cust_svc;
1799 sub _sort_cust_svc {
1800 my( $self, $arrayref ) = @_;
1803 sub ($$) { my ($a, $b) = @_; $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] };
1808 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
1809 'svcpart' => $_->svcpart } );
1811 $pkg_svc ? $pkg_svc->primary_svc : '',
1812 $pkg_svc ? $pkg_svc->quantity : 0,
1819 =item num_cust_svc [ SVCPART ]
1821 Returns the number of provisioned services for this package. If a svcpart is
1822 specified, counts only the matching services.
1829 return $self->{'_num_cust_svc'}
1831 && exists($self->{'_num_cust_svc'})
1832 && $self->{'_num_cust_svc'} =~ /\d/;
1834 cluck "cust_pkg->num_cust_svc called, _num_cust_svc:".$self->{'_num_cust_svc'}
1837 my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
1838 $sql .= ' AND svcpart = ?' if @_;
1840 my $sth = dbh->prepare($sql) or die dbh->errstr;
1841 $sth->execute($self->pkgnum, @_) or die $sth->errstr;
1842 $sth->fetchrow_arrayref->[0];
1845 =item available_part_svc
1847 Returns a list of FS::part_svc objects representing services included in this
1848 package but not yet provisioned. Each FS::part_svc object also has an extra
1849 field, I<num_avail>, which specifies the number of available services.
1853 sub available_part_svc {
1855 grep { $_->num_avail > 0 }
1857 my $part_svc = $_->part_svc;
1858 $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
1859 $_->quantity - $self->num_cust_svc($_->svcpart);
1861 # more evil encapsulation breakage
1862 if($part_svc->{'Hash'}{'num_avail'} > 0) {
1863 my @exports = $part_svc->part_export_did;
1864 $part_svc->{'Hash'}{'can_get_dids'} = scalar(@exports);
1869 $self->part_pkg->pkg_svc;
1874 Returns a list of FS::part_svc objects representing provisioned and available
1875 services included in this package. Each FS::part_svc object also has the
1876 following extra fields:
1880 =item num_cust_svc (count)
1882 =item num_avail (quantity - count)
1884 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
1887 label -> ($cust_svc->label)[1]
1896 #XXX some sort of sort order besides numeric by svcpart...
1897 my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
1899 my $part_svc = $pkg_svc->part_svc;
1900 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1901 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
1902 $part_svc->{'Hash'}{'num_avail'} =
1903 max( 0, $pkg_svc->quantity - $num_cust_svc );
1904 $part_svc->{'Hash'}{'cust_pkg_svc'} =
1905 $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
1906 $part_svc->{'Hash'}{'hidden'} = $pkg_svc->hidden;
1908 } $self->part_pkg->pkg_svc;
1911 push @part_svc, map {
1913 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1914 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
1915 $part_svc->{'Hash'}{'num_avail'} = 0; #0-$num_cust_svc ?
1916 $part_svc->{'Hash'}{'cust_pkg_svc'} =
1917 $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
1919 } $self->extra_part_svc;
1925 =item extra_part_svc
1927 Returns a list of FS::part_svc objects corresponding to services in this
1928 package which are still provisioned but not (any longer) available in the
1933 sub extra_part_svc {
1936 my $pkgnum = $self->pkgnum;
1937 my $pkgpart = $self->pkgpart;
1940 # 'table' => 'part_svc',
1943 # "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
1944 # WHERE pkg_svc.svcpart = part_svc.svcpart
1945 # AND pkg_svc.pkgpart = ?
1948 # AND 0 < ( SELECT COUNT(*) FROM cust_svc
1949 # LEFT JOIN cust_pkg USING ( pkgnum )
1950 # WHERE cust_svc.svcpart = part_svc.svcpart
1953 # 'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
1956 #seems to benchmark slightly faster...
1958 #'select' => 'DISTINCT ON (svcpart) part_svc.*',
1959 #MySQL doesn't grok DISINCT ON
1960 'select' => 'DISTINCT part_svc.*',
1961 'table' => 'part_svc',
1963 'LEFT JOIN pkg_svc ON ( pkg_svc.svcpart = part_svc.svcpart
1964 AND pkg_svc.pkgpart = ?
1967 LEFT JOIN cust_svc ON ( cust_svc.svcpart = part_svc.svcpart )
1968 LEFT JOIN cust_pkg USING ( pkgnum )
1971 'extra_sql' => "WHERE pkgsvcnum IS NULL AND cust_pkg.pkgnum = ? ",
1972 'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
1978 Returns a short status string for this package, currently:
1982 =item not yet billed
1984 =item one-time charge
1999 my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
2001 return 'cancelled' if $self->get('cancel');
2002 return 'suspended' if $self->susp;
2003 return 'not yet billed' unless $self->setup;
2004 return 'one-time charge' if $freq =~ /^(0|$)/;
2008 =item ucfirst_status
2010 Returns the status with the first character capitalized.
2014 sub ucfirst_status {
2015 ucfirst(shift->status);
2020 Class method that returns the list of possible status strings for packages
2021 (see L<the status method|/status>). For example:
2023 @statuses = FS::cust_pkg->statuses();
2027 tie my %statuscolor, 'Tie::IxHash',
2028 'not yet billed' => '009999', #teal? cyan?
2029 'one-time charge' => '000000',
2030 'active' => '00CC00',
2031 'suspended' => 'FF9900',
2032 'cancelled' => 'FF0000',
2036 my $self = shift; #could be class...
2037 #grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
2038 # # mayble split btw one-time vs. recur
2044 Returns a hex triplet color string for this package's status.
2050 $statuscolor{$self->status};
2055 Returns a label for this package. (Currently "pkgnum: pkg - comment" or
2056 "pkg-comment" depending on user preference).
2062 my $label = $self->part_pkg->pkg_comment( 'nopkgpart' => 1 );
2063 $label = $self->pkgnum. ": $label"
2064 if $FS::CurrentUser::CurrentUser->option('show_pkgnum');
2068 =item pkg_label_long
2070 Returns a long label for this package, adding the primary service's label to
2075 sub pkg_label_long {
2077 my $label = $self->pkg_label;
2078 my $cust_svc = $self->primary_cust_svc;
2079 $label .= ' ('. ($cust_svc->label)[1]. ')' if $cust_svc;
2083 =item primary_cust_svc
2085 Returns a primary service (as FS::cust_svc object) if one can be identified.
2089 #for labeling purposes - might not 100% match up with part_pkg->svcpart's idea
2091 sub primary_cust_svc {
2094 my @cust_svc = $self->cust_svc;
2096 return '' unless @cust_svc; #no serivces - irrelevant then
2098 return $cust_svc[0] if scalar(@cust_svc) == 1; #always return a single service
2100 # primary service as specified in the package definition
2101 # or exactly one service definition with quantity one
2102 my $svcpart = $self->part_pkg->svcpart;
2103 @cust_svc = grep { $_->svcpart == $svcpart } @cust_svc;
2104 return $cust_svc[0] if scalar(@cust_svc) == 1;
2106 #couldn't identify one thing..
2112 Returns a list of lists, calling the label method for all services
2113 (see L<FS::cust_svc>) of this billing item.
2119 map { [ $_->label ] } $self->cust_svc;
2122 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
2124 Like the labels method, but returns historical information on services that
2125 were active as of END_TIMESTAMP and (optionally) not cancelled before
2126 START_TIMESTAMP. If MODE is 'I' (for 'invoice'), services with the
2127 I<pkg_svc.hidden> flag will be omitted.
2129 Returns a list of lists, calling the label method for all (historical) services
2130 (see L<FS::h_cust_svc>) of this billing item.
2136 warn "$me _h_labels called on $self\n"
2138 map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
2143 Like labels, except returns a simple flat list, and shortens long
2144 (currently >5 or the cust_bill-max_same_services configuration value) lists of
2145 identical services to one line that lists the service label and the number of
2146 individual services rather than individual items.
2151 shift->_labels_short( 'labels', @_ );
2154 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
2156 Like h_labels, except returns a simple flat list, and shortens long
2157 (currently >5 or the cust_bill-max_same_services configuration value) lists of
2158 identical services to one line that lists the service label and the number of
2159 individual services rather than individual items.
2163 sub h_labels_short {
2164 shift->_labels_short( 'h_labels', @_ );
2168 my( $self, $method ) = ( shift, shift );
2170 warn "$me _labels_short called on $self with $method method\n"
2173 my $conf = new FS::Conf;
2174 my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
2176 warn "$me _labels_short populating \%labels\n"
2180 #tie %labels, 'Tie::IxHash';
2181 push @{ $labels{$_->[0]} }, $_->[1]
2182 foreach $self->$method(@_);
2184 warn "$me _labels_short populating \@labels\n"
2188 foreach my $label ( keys %labels ) {
2190 my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
2191 my $num = scalar(@values);
2192 warn "$me _labels_short $num items for $label\n"
2195 if ( $num > $max_same_services ) {
2196 warn "$me _labels_short more than $max_same_services, so summarizing\n"
2198 push @labels, "$label ($num)";
2200 if ( $conf->exists('cust_bill-consolidate_services') ) {
2201 warn "$me _labels_short consolidating services\n"
2203 # push @labels, "$label: ". join(', ', @values);
2205 my $detail = "$label: ";
2206 $detail .= shift(@values). ', '
2208 && ( length($detail.$values[0]) < 78 || $detail eq "$label: " );
2210 push @labels, $detail;
2212 warn "$me _labels_short done consolidating services\n"
2215 warn "$me _labels_short adding service data\n"
2217 push @labels, map { "$label: $_" } @values;
2228 Returns the parent customer object (see L<FS::cust_main>).
2234 qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
2237 #these subs are in location_Mixin.pm now... unfortunately the POD doesn't mixin
2241 Returns the location object, if any (see L<FS::cust_location>).
2243 =item cust_location_or_main
2245 If this package is associated with a location, returns the locaiton (see
2246 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
2248 =item location_label [ OPTION => VALUE ... ]
2250 Returns the label of the location object (see L<FS::cust_location>).
2254 #end of subs in location_Mixin.pm now... unfortunately the POD doesn't mixin
2256 =item seconds_since TIMESTAMP
2258 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
2259 package have been online since TIMESTAMP, according to the session monitor.
2261 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
2262 L<Time::Local> and L<Date::Parse> for conversion functions.
2267 my($self, $since) = @_;
2270 foreach my $cust_svc (
2271 grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
2273 $seconds += $cust_svc->seconds_since($since);
2280 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2282 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
2283 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
2286 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2287 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2293 sub seconds_since_sqlradacct {
2294 my($self, $start, $end) = @_;
2298 foreach my $cust_svc (
2300 my $part_svc = $_->part_svc;
2301 $part_svc->svcdb eq 'svc_acct'
2302 && scalar($part_svc->part_export('sqlradius'));
2305 $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
2312 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2314 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2315 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2319 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2320 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2325 sub attribute_since_sqlradacct {
2326 my($self, $start, $end, $attrib) = @_;
2330 foreach my $cust_svc (
2332 my $part_svc = $_->part_svc;
2333 $part_svc->svcdb eq 'svc_acct'
2334 && scalar($part_svc->part_export('sqlradius'));
2337 $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
2349 my( $self, $value ) = @_;
2350 if ( defined($value) ) {
2351 $self->setfield('quantity', $value);
2353 $self->getfield('quantity') || 1;
2356 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
2358 Transfers as many services as possible from this package to another package.
2360 The destination package can be specified by pkgnum by passing an FS::cust_pkg
2361 object. The destination package must already exist.
2363 Services are moved only if the destination allows services with the correct
2364 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true. Use
2365 this option with caution! No provision is made for export differences
2366 between the old and new service definitions. Probably only should be used
2367 when your exports for all service definitions of a given svcdb are identical.
2368 (attempt a transfer without it first, to move all possible svcpart-matching
2371 Any services that can't be moved remain in the original package.
2373 Returns an error, if there is one; otherwise, returns the number of services
2374 that couldn't be moved.
2379 my ($self, $dest_pkgnum, %opt) = @_;
2385 if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
2386 $dest = $dest_pkgnum;
2387 $dest_pkgnum = $dest->pkgnum;
2389 $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
2392 return ('Package does not exist: '.$dest_pkgnum) unless $dest;
2394 foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
2395 $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
2398 foreach my $cust_svc ($dest->cust_svc) {
2399 $target{$cust_svc->svcpart}--;
2402 my %svcpart2svcparts = ();
2403 if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2404 warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
2405 foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
2406 next if exists $svcpart2svcparts{$svcpart};
2407 my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
2408 $svcpart2svcparts{$svcpart} = [
2410 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
2412 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
2413 'svcpart' => $_ } );
2415 $pkg_svc ? $pkg_svc->primary_svc : '',
2416 $pkg_svc ? $pkg_svc->quantity : 0,
2420 grep { $_ != $svcpart }
2422 qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
2424 warn "alternates for svcpart $svcpart: ".
2425 join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
2430 foreach my $cust_svc ($self->cust_svc) {
2431 if($target{$cust_svc->svcpart} > 0) {
2432 $target{$cust_svc->svcpart}--;
2433 my $new = new FS::cust_svc { $cust_svc->hash };
2434 $new->pkgnum($dest_pkgnum);
2435 my $error = $new->replace($cust_svc);
2436 return $error if $error;
2437 } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2439 warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
2440 warn "alternates to consider: ".
2441 join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
2443 my @alternate = grep {
2444 warn "considering alternate svcpart $_: ".
2445 "$target{$_} available in new package\n"
2448 } @{$svcpart2svcparts{$cust_svc->svcpart}};
2450 warn "alternate(s) found\n" if $DEBUG;
2451 my $change_svcpart = $alternate[0];
2452 $target{$change_svcpart}--;
2453 my $new = new FS::cust_svc { $cust_svc->hash };
2454 $new->svcpart($change_svcpart);
2455 $new->pkgnum($dest_pkgnum);
2456 my $error = $new->replace($cust_svc);
2457 return $error if $error;
2470 This method is deprecated. See the I<depend_jobnum> option to the insert and
2471 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
2478 local $SIG{HUP} = 'IGNORE';
2479 local $SIG{INT} = 'IGNORE';
2480 local $SIG{QUIT} = 'IGNORE';
2481 local $SIG{TERM} = 'IGNORE';
2482 local $SIG{TSTP} = 'IGNORE';
2483 local $SIG{PIPE} = 'IGNORE';
2485 my $oldAutoCommit = $FS::UID::AutoCommit;
2486 local $FS::UID::AutoCommit = 0;
2489 foreach my $cust_svc ( $self->cust_svc ) {
2490 #false laziness w/svc_Common::insert
2491 my $svc_x = $cust_svc->svc_x;
2492 foreach my $part_export ( $cust_svc->part_svc->part_export ) {
2493 my $error = $part_export->export_insert($svc_x);
2495 $dbh->rollback if $oldAutoCommit;
2501 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2508 Associates this package with a (suspension or cancellation) reason (see
2509 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
2512 Available options are:
2518 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.
2522 the access_user (see L<FS::access_user>) providing the reason
2530 the action (cancel, susp, adjourn, expire) associated with the reason
2534 If there is an error, returns the error, otherwise returns false.
2539 my ($self, %options) = @_;
2541 my $otaker = $options{reason_otaker} ||
2542 $FS::CurrentUser::CurrentUser->username;
2545 if ( $options{'reason'} =~ /^(\d+)$/ ) {
2549 } elsif ( ref($options{'reason'}) ) {
2551 return 'Enter a new reason (or select an existing one)'
2552 unless $options{'reason'}->{'reason'} !~ /^\s*$/;
2554 my $reason = new FS::reason({
2555 'reason_type' => $options{'reason'}->{'typenum'},
2556 'reason' => $options{'reason'}->{'reason'},
2558 my $error = $reason->insert;
2559 return $error if $error;
2561 $reasonnum = $reason->reasonnum;
2564 return "Unparsable reason: ". $options{'reason'};
2567 my $cust_pkg_reason =
2568 new FS::cust_pkg_reason({ 'pkgnum' => $self->pkgnum,
2569 'reasonnum' => $reasonnum,
2570 'otaker' => $otaker,
2571 'action' => substr(uc($options{'action'}),0,1),
2572 'date' => $options{'date'}
2577 $cust_pkg_reason->insert;
2580 =item insert_discount
2582 Associates this package with a discount (see L<FS::cust_pkg_discount>, possibly
2583 inserting a new discount on the fly (see L<FS::discount>).
2585 Available options are:
2593 If there is an error, returns the error, otherwise returns false.
2597 sub insert_discount {
2598 #my ($self, %options) = @_;
2601 my $cust_pkg_discount = new FS::cust_pkg_discount {
2602 'pkgnum' => $self->pkgnum,
2603 'discountnum' => $self->discountnum,
2605 'end_date' => '', #XXX
2606 #for the create a new discount case
2607 '_type' => $self->discountnum__type,
2608 'amount' => $self->discountnum_amount,
2609 'percent' => $self->discountnum_percent,
2610 'months' => $self->discountnum_months,
2611 #'disabled' => $self->discountnum_disabled,
2614 $cust_pkg_discount->insert;
2617 =item set_usage USAGE_VALUE_HASHREF
2619 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2620 to which they should be set (see L<FS::svc_acct>). Currently seconds,
2621 upbytes, downbytes, and totalbytes are appropriate keys.
2623 All svc_accts which are part of this package have their values reset.
2628 my ($self, $valueref, %opt) = @_;
2630 foreach my $cust_svc ($self->cust_svc){
2631 my $svc_x = $cust_svc->svc_x;
2632 $svc_x->set_usage($valueref, %opt)
2633 if $svc_x->can("set_usage");
2637 =item recharge USAGE_VALUE_HASHREF
2639 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2640 to which they should be set (see L<FS::svc_acct>). Currently seconds,
2641 upbytes, downbytes, and totalbytes are appropriate keys.
2643 All svc_accts which are part of this package have their values incremented.
2648 my ($self, $valueref) = @_;
2650 foreach my $cust_svc ($self->cust_svc){
2651 my $svc_x = $cust_svc->svc_x;
2652 $svc_x->recharge($valueref)
2653 if $svc_x->can("recharge");
2657 =item cust_pkg_discount
2661 sub cust_pkg_discount {
2663 qsearch('cust_pkg_discount', { 'pkgnum' => $self->pkgnum } );
2666 =item cust_pkg_discount_active
2670 sub cust_pkg_discount_active {
2672 grep { $_->status eq 'active' } $self->cust_pkg_discount;
2677 =head1 CLASS METHODS
2683 Returns an SQL expression identifying recurring packages.
2687 sub recurring_sql { "
2688 '0' != ( select freq from part_pkg
2689 where cust_pkg.pkgpart = part_pkg.pkgpart )
2694 Returns an SQL expression identifying one-time packages.
2699 '0' = ( select freq from part_pkg
2700 where cust_pkg.pkgpart = part_pkg.pkgpart )
2705 Returns an SQL expression identifying ordered packages (recurring packages not
2711 $_[0]->recurring_sql. " AND ". $_[0]->not_yet_billed_sql;
2716 Returns an SQL expression identifying active packages.
2721 $_[0]->recurring_sql. "
2722 AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
2723 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2724 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
2727 =item not_yet_billed_sql
2729 Returns an SQL expression identifying packages which have not yet been billed.
2733 sub not_yet_billed_sql { "
2734 ( cust_pkg.setup IS NULL OR cust_pkg.setup = 0 )
2735 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2736 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
2741 Returns an SQL expression identifying inactive packages (one-time packages
2742 that are otherwise unsuspended/uncancelled).
2746 sub inactive_sql { "
2747 ". $_[0]->onetime_sql(). "
2748 AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
2749 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2750 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
2756 Returns an SQL expression identifying suspended packages.
2760 sub suspended_sql { susp_sql(@_); }
2762 #$_[0]->recurring_sql(). ' AND '.
2764 ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2765 AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0
2772 Returns an SQL exprression identifying cancelled packages.
2776 sub cancelled_sql { cancel_sql(@_); }
2778 #$_[0]->recurring_sql(). ' AND '.
2779 "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
2784 Returns an SQL expression to give the package status as a string.
2790 WHEN cust_pkg.cancel IS NOT NULL THEN 'cancelled'
2791 WHEN cust_pkg.susp IS NOT NULL THEN 'suspended'
2792 WHEN cust_pkg.setup IS NULL THEN 'not yet billed'
2793 WHEN ".onetime_sql()." THEN 'one-time charge'
2798 =item search HASHREF
2802 Returns a qsearch hash expression to search for parameters specified in HASHREF.
2803 Valid parameters are
2811 active, inactive, suspended, cancel (or cancelled)
2815 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
2819 boolean selects custom packages
2825 pkgpart or arrayref or hashref of pkgparts
2829 arrayref of beginning and ending epoch date
2833 arrayref of beginning and ending epoch date
2837 arrayref of beginning and ending epoch date
2841 arrayref of beginning and ending epoch date
2845 arrayref of beginning and ending epoch date
2849 arrayref of beginning and ending epoch date
2853 arrayref of beginning and ending epoch date
2857 pkgnum or APKG_pkgnum
2861 a value suited to passing to FS::UI::Web::cust_header
2865 specifies the user for agent virtualization
2869 boolean selects packages containing fcc form 477 telco lines
2876 my ($class, $params) = @_;
2883 if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2885 "cust_main.agentnum = $1";
2892 if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
2894 "cust_pkg.custnum = $1";
2901 if ( $params->{'pkgbatch'} =~ /^([\w\/\-\:\.]+)$/ and $1 ) {
2903 "cust_pkg.pkgbatch = '$1'";
2910 if ( $params->{'magic'} eq 'active'
2911 || $params->{'status'} eq 'active' ) {
2913 push @where, FS::cust_pkg->active_sql();
2915 } elsif ( $params->{'magic'} =~ /^not[ _]yet[ _]billed$/
2916 || $params->{'status'} =~ /^not[ _]yet[ _]billed$/ ) {
2918 push @where, FS::cust_pkg->not_yet_billed_sql();
2920 } elsif ( $params->{'magic'} =~ /^(one-time charge|inactive)/
2921 || $params->{'status'} =~ /^(one-time charge|inactive)/ ) {
2923 push @where, FS::cust_pkg->inactive_sql();
2925 } elsif ( $params->{'magic'} eq 'suspended'
2926 || $params->{'status'} eq 'suspended' ) {
2928 push @where, FS::cust_pkg->suspended_sql();
2930 } elsif ( $params->{'magic'} =~ /^cancell?ed$/
2931 || $params->{'status'} =~ /^cancell?ed$/ ) {
2933 push @where, FS::cust_pkg->cancelled_sql();
2938 # parse package class
2941 #false lazinessish w/graph/cust_bill_pkg.cgi
2944 if ( exists($params->{'classnum'})
2945 && $params->{'classnum'} =~ /^(\d*)$/
2949 if ( $classnum ) { #a specific class
2950 push @where, "part_pkg.classnum = $classnum";
2952 #@pkg_class = ( qsearchs('pkg_class', { 'classnum' => $classnum } ) );
2953 #die "classnum $classnum not found!" unless $pkg_class[0];
2954 #$title .= $pkg_class[0]->classname.' ';
2956 } elsif ( $classnum eq '' ) { #the empty class
2958 push @where, "part_pkg.classnum IS NULL";
2959 #$title .= 'Empty class ';
2960 #@pkg_class = ( '(empty class)' );
2961 } elsif ( $classnum eq '0' ) {
2962 #@pkg_class = qsearch('pkg_class', {} ); # { 'disabled' => '' } );
2963 #push @pkg_class, '(empty class)';
2965 die "illegal classnum";
2971 # parse package report options
2974 my @report_option = ();
2975 if ( exists($params->{'report_option'})
2976 && $params->{'report_option'} =~ /^([,\d]*)$/
2979 @report_option = split(',', $1);
2982 if (@report_option) {
2983 # this will result in the empty set for the dangling comma case as it should
2985 map{ "0 < ( SELECT count(*) FROM part_pkg_option
2986 WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
2987 AND optionname = 'report_option_$_'
2988 AND optionvalue = '1' )"
2998 push @where, "part_pkg.custom = 'Y'" if $params->{custom};
3004 push @where, "part_pkg.fcc_ds0s > 0" if $params->{fcc_line};
3010 if ( exists($params->{'censustract'}) ) {
3011 $params->{'censustract'} =~ /^([.\d]*)$/;
3012 my $censustract = "cust_main.censustract = '$1'";
3013 $censustract .= ' OR cust_main.censustract is NULL' unless $1;
3014 push @where, "( $censustract )";
3021 if ( ref($params->{'pkgpart'}) ) {
3024 if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
3025 @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
3026 } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
3027 @pkgpart = @{ $params->{'pkgpart'} };
3029 die 'unhandled pkgpart ref '. $params->{'pkgpart'};
3032 @pkgpart = grep /^(\d+)$/, @pkgpart;
3034 push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
3036 } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
3037 push @where, "pkgpart = $1";
3046 #false laziness w/report_cust_pkg.html
3049 'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
3050 'active' => { 'susp'=>1, 'cancel'=>1 },
3051 'suspended' => { 'cancel' => 1 },
3056 if( exists($params->{'active'} ) ) {
3057 # This overrides all the other date-related fields
3058 my($beginning, $ending) = @{$params->{'active'}};
3060 "cust_pkg.setup IS NOT NULL",
3061 "cust_pkg.setup <= $ending",
3062 "(cust_pkg.cancel IS NULL OR cust_pkg.cancel >= $beginning )",
3063 "NOT (".FS::cust_pkg->onetime_sql . ")";
3066 foreach my $field (qw( setup last_bill bill adjourn susp expire contract_end cancel )) {
3068 next unless exists($params->{$field});
3070 my($beginning, $ending) = @{$params->{$field}};
3072 next if $beginning == 0 && $ending == 4294967295;
3075 "cust_pkg.$field IS NOT NULL",
3076 "cust_pkg.$field >= $beginning",
3077 "cust_pkg.$field <= $ending";
3079 $orderby ||= "ORDER BY cust_pkg.$field";
3084 $orderby ||= 'ORDER BY bill';
3087 # parse magic, legacy, etc.
3090 if ( $params->{'magic'} &&
3091 $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
3094 $orderby = 'ORDER BY pkgnum';
3096 if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
3097 push @where, "pkgpart = $1";
3100 } elsif ( $params->{'query'} eq 'pkgnum' ) {
3102 $orderby = 'ORDER BY pkgnum';
3104 } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
3106 $orderby = 'ORDER BY pkgnum';
3109 SELECT count(*) FROM pkg_svc
3110 WHERE pkg_svc.pkgpart = cust_pkg.pkgpart
3111 AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
3112 WHERE cust_svc.pkgnum = cust_pkg.pkgnum
3113 AND cust_svc.svcpart = pkg_svc.svcpart
3120 # setup queries, links, subs, etc. for the search
3123 # here is the agent virtualization
3124 if ($params->{CurrentUser}) {
3126 qsearchs('access_user', { username => $params->{CurrentUser} });
3129 push @where, $access_user->agentnums_sql('table'=>'cust_main');
3134 push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
3137 my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
3139 my $addl_from = 'LEFT JOIN cust_main USING ( custnum ) '.
3140 'LEFT JOIN part_pkg USING ( pkgpart ) '.
3141 'LEFT JOIN pkg_class ON ( part_pkg.classnum = pkg_class.classnum ) ';
3143 my $count_query = "SELECT COUNT(*) FROM cust_pkg $addl_from $extra_sql";
3146 'table' => 'cust_pkg',
3148 'select' => join(', ',
3150 ( map "part_pkg.$_", qw( pkg freq ) ),
3151 'pkg_class.classname',
3152 'cust_main.custnum AS cust_main_custnum',
3153 FS::UI::Web::cust_sql_fields(
3154 $params->{'cust_fields'}
3157 'extra_sql' => "$extra_sql $orderby",
3158 'addl_from' => $addl_from,
3159 'count_query' => $count_query,
3166 Returns a list of two package counts. The first is a count of packages
3167 based on the supplied criteria and the second is the count of residential
3168 packages with those same criteria. Criteria are specified as in the search
3174 my ($class, $params) = @_;
3176 my $sql_query = $class->search( $params );
3178 my $count_sql = delete($sql_query->{'count_query'});
3179 $count_sql =~ s/ FROM/,count(CASE WHEN cust_main.company IS NULL OR cust_main.company = '' THEN 1 END) FROM/
3180 or die "couldn't parse count_sql";
3182 my $count_sth = dbh->prepare($count_sql)
3183 or die "Error preparing $count_sql: ". dbh->errstr;
3185 or die "Error executing $count_sql: ". $count_sth->errstr;
3186 my $count_arrayref = $count_sth->fetchrow_arrayref;
3188 return ( @$count_arrayref );
3195 Returns a list: the first item is an SQL fragment identifying matching
3196 packages/customers via location (taking into account shipping and package
3197 address taxation, if enabled), and subsequent items are the parameters to
3198 substitute for the placeholders in that fragment.
3203 my($class, %opt) = @_;
3204 my $ornull = $opt{'ornull'};
3206 my $conf = new FS::Conf;
3208 # '?' placeholders in _location_sql_where
3209 my $x = $ornull ? 3 : 2;
3210 my @bill_param = ( ('city')x3, ('county')x$x, ('state')x$x, 'country' );
3214 if ( $conf->exists('tax-ship_address') ) {
3217 ( ( ship_last IS NULL OR ship_last = '' )
3218 AND ". _location_sql_where('cust_main', '', $ornull ). "
3220 OR ( ship_last IS NOT NULL AND ship_last != ''
3221 AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
3224 # AND payby != 'COMP'
3226 @main_param = ( @bill_param, @bill_param );
3230 $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
3231 @main_param = @bill_param;
3237 if ( $conf->exists('tax-pkg_address') ) {
3239 my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
3242 ( cust_pkg.locationnum IS NULL AND $main_where )
3243 OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where )
3246 @param = ( @main_param, @bill_param );
3250 $where = $main_where;
3251 @param = @main_param;
3259 #subroutine, helper for location_sql
3260 sub _location_sql_where {
3262 my $prefix = @_ ? shift : '';
3263 my $ornull = @_ ? shift : '';
3265 # $ornull = $ornull ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
3267 $ornull = $ornull ? ' OR ? IS NULL ' : '';
3269 my $or_empty_city = " OR ( ? = '' AND $table.${prefix}city IS NULL ) ";
3270 my $or_empty_county = " OR ( ? = '' AND $table.${prefix}county IS NULL ) ";
3271 my $or_empty_state = " OR ( ? = '' AND $table.${prefix}state IS NULL ) ";
3273 # ( $table.${prefix}city = ? $or_empty_city $ornull )
3275 ( $table.${prefix}city = ? OR ? = '' OR CAST(? AS text) IS NULL )
3276 AND ( $table.${prefix}county = ? $or_empty_county $ornull )
3277 AND ( $table.${prefix}state = ? $or_empty_state $ornull )
3278 AND $table.${prefix}country = ?
3286 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
3288 CUSTNUM is a customer (see L<FS::cust_main>)
3290 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
3291 L<FS::part_pkg>) to order for this customer. Duplicates are of course
3294 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
3295 remove for this customer. The services (see L<FS::cust_svc>) are moved to the
3296 new billing items. An error is returned if this is not possible (see
3297 L<FS::pkg_svc>). An empty arrayref is equivalent to not specifying this
3300 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
3301 newly-created cust_pkg objects.
3303 REFNUM, if specified, will specify the FS::pkg_referral record to be created
3304 and inserted. Multiple FS::pkg_referral records can be created by
3305 setting I<refnum> to an array reference of refnums or a hash reference with
3306 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
3307 record will be created corresponding to cust_main.refnum.
3312 my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
3314 my $conf = new FS::Conf;
3316 # Transactionize this whole mess
3317 local $SIG{HUP} = 'IGNORE';
3318 local $SIG{INT} = 'IGNORE';
3319 local $SIG{QUIT} = 'IGNORE';
3320 local $SIG{TERM} = 'IGNORE';
3321 local $SIG{TSTP} = 'IGNORE';
3322 local $SIG{PIPE} = 'IGNORE';
3324 my $oldAutoCommit = $FS::UID::AutoCommit;
3325 local $FS::UID::AutoCommit = 0;
3329 # my $cust_main = qsearchs('cust_main', { custnum => $custnum });
3330 # return "Customer not found: $custnum" unless $cust_main;
3332 warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
3335 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
3338 my $change = scalar(@old_cust_pkg) != 0;
3341 if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
3343 warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
3344 " to pkgpart ". $pkgparts->[0]. "\n"
3347 my $err_or_cust_pkg =
3348 $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
3349 'refnum' => $refnum,
3352 unless (ref($err_or_cust_pkg)) {
3353 $dbh->rollback if $oldAutoCommit;
3354 return $err_or_cust_pkg;
3357 push @$return_cust_pkg, $err_or_cust_pkg;
3358 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3363 # Create the new packages.
3364 foreach my $pkgpart (@$pkgparts) {
3366 warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
3368 my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
3369 pkgpart => $pkgpart,
3373 $error = $cust_pkg->insert( 'change' => $change );
3375 $dbh->rollback if $oldAutoCommit;
3378 push @$return_cust_pkg, $cust_pkg;
3380 # $return_cust_pkg now contains refs to all of the newly
3383 # Transfer services and cancel old packages.
3384 foreach my $old_pkg (@old_cust_pkg) {
3386 warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
3389 foreach my $new_pkg (@$return_cust_pkg) {
3390 $error = $old_pkg->transfer($new_pkg);
3391 if ($error and $error == 0) {
3392 # $old_pkg->transfer failed.
3393 $dbh->rollback if $oldAutoCommit;
3398 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
3399 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
3400 foreach my $new_pkg (@$return_cust_pkg) {
3401 $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
3402 if ($error and $error == 0) {
3403 # $old_pkg->transfer failed.
3404 $dbh->rollback if $oldAutoCommit;
3411 # Transfers were successful, but we went through all of the
3412 # new packages and still had services left on the old package.
3413 # We can't cancel the package under the circumstances, so abort.
3414 $dbh->rollback if $oldAutoCommit;
3415 return "Unable to transfer all services from package ".$old_pkg->pkgnum;
3417 $error = $old_pkg->cancel( quiet=>1 );
3423 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3427 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
3429 A bulk change method to change packages for multiple customers.
3431 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
3432 L<FS::part_pkg>) to order for each customer. Duplicates are of course
3435 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
3436 replace. The services (see L<FS::cust_svc>) are moved to the
3437 new billing items. An error is returned if this is not possible (see
3440 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
3441 newly-created cust_pkg objects.
3446 my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
3448 # Transactionize this whole mess
3449 local $SIG{HUP} = 'IGNORE';
3450 local $SIG{INT} = 'IGNORE';
3451 local $SIG{QUIT} = 'IGNORE';
3452 local $SIG{TERM} = 'IGNORE';
3453 local $SIG{TSTP} = 'IGNORE';
3454 local $SIG{PIPE} = 'IGNORE';
3456 my $oldAutoCommit = $FS::UID::AutoCommit;
3457 local $FS::UID::AutoCommit = 0;
3461 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
3464 while(scalar(@old_cust_pkg)) {
3466 my $custnum = $old_cust_pkg[0]->custnum;
3467 my (@remove) = map { $_->pkgnum }
3468 grep { $_->custnum == $custnum } @old_cust_pkg;
3469 @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
3471 my $error = order $custnum, $pkgparts, \@remove, \@return;
3473 push @errors, $error
3475 push @$return_cust_pkg, @return;
3478 if (scalar(@errors)) {
3479 $dbh->rollback if $oldAutoCommit;
3480 return join(' / ', @errors);
3483 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3487 # Used by FS::Upgrade to migrate to a new database.
3488 sub _upgrade_data { # class method
3489 my ($class, %opts) = @_;
3490 $class->_upgrade_otaker(%opts);
3492 # RT#10139, bug resulting in contract_end being set when it shouldn't
3493 'UPDATE cust_pkg SET contract_end = NULL WHERE contract_end = -1',
3494 # RT#10830, bad calculation of prorate date near end of year
3495 # the date range for bill is December 2009, and we move it forward
3496 # one year if it's before the previous bill date (which it should
3498 'UPDATE cust_pkg SET bill = bill + (365*24*60*60) WHERE bill < last_bill
3499 AND bill > 1259654400 AND bill < 1262332800 AND (SELECT plan FROM part_pkg
3500 WHERE part_pkg.pkgpart = cust_pkg.pkgpart) = \'prorate\'',
3501 # RT6628, add order_date to cust_pkg
3502 'update cust_pkg set order_date = (select history_date from h_cust_pkg
3503 where h_cust_pkg.pkgnum = cust_pkg.pkgnum and
3504 history_action = \'insert\') where order_date is null',
3506 foreach my $sql (@statements) {
3507 my $sth = dbh->prepare($sql);
3508 $sth->execute or die $sth->errstr;
3516 sub order is not OO. Perhaps it should be moved to FS::cust_main and made so?
3518 In sub order, the @pkgparts array (passed by reference) is clobbered.
3520 Also in sub order, no money is adjusted. Once FS::part_pkg defines a standard
3521 method to pass dates to the recur_prog expression, it should do so.
3523 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
3524 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
3525 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
3526 configuration values. Probably need a subroutine which decides what to do
3527 based on whether or not we've fetched the user yet, rather than a hash. See
3528 FS::UID and the TODO.
3530 Now that things are transactional should the check in the insert method be
3535 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
3536 L<FS::pkg_svc>, schema.html from the base documentation