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;
35 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
37 # because they load configuration by setting FS::UID::callback (see TODO)
43 # for sending cancel emails in sub cancel
47 $me = '[FS::cust_pkg]';
49 $disable_agentcheck = 0;
53 my ( $hashref, $cache ) = @_;
54 #if ( $hashref->{'pkgpart'} ) {
55 if ( $hashref->{'pkg'} ) {
56 # #@{ $self->{'_pkgnum'} } = ();
57 # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
58 # $self->{'_pkgpart'} = $subcache;
59 # #push @{ $self->{'_pkgnum'} },
60 # FS::part_pkg->new_or_cached($hashref, $subcache);
61 $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
63 if ( exists $hashref->{'svcnum'} ) {
64 #@{ $self->{'_pkgnum'} } = ();
65 my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
66 $self->{'_svcnum'} = $subcache;
67 #push @{ $self->{'_pkgnum'} },
68 FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
74 FS::cust_pkg - Object methods for cust_pkg objects
80 $record = new FS::cust_pkg \%hash;
81 $record = new FS::cust_pkg { 'column' => 'value' };
83 $error = $record->insert;
85 $error = $new_record->replace($old_record);
87 $error = $record->delete;
89 $error = $record->check;
91 $error = $record->cancel;
93 $error = $record->suspend;
95 $error = $record->unsuspend;
97 $part_pkg = $record->part_pkg;
99 @labels = $record->labels;
101 $seconds = $record->seconds_since($timestamp);
103 $error = FS::cust_pkg::order( $custnum, \@pkgparts );
104 $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
108 An FS::cust_pkg object represents a customer billing item. FS::cust_pkg
109 inherits from FS::Record. The following fields are currently supported:
115 Primary key (assigned automatically for new billing items)
119 Customer (see L<FS::cust_main>)
123 Billing item definition (see L<FS::part_pkg>)
127 Optional link to package location (see L<FS::location>)
131 date package was ordered (also remains same on changes)
143 date (next bill date)
171 order taker (see L<FS::access_user>)
175 If this field is set to 1, disables the automatic
176 unsuspension of this package when using the B<unsuspendauto> config option.
180 If not set, defaults to 1
184 Date of change from previous package
194 =item change_locationnum
202 Note: setup, last_bill, bill, adjourn, susp, expire, cancel and change_date
203 are specified as UNIX timestamps; see L<perlfunc/"time">. Also see
204 L<Time::Local> and L<Date::Parse> for conversion functions.
212 Create a new billing item. To add the item to the database, see L<"insert">.
216 sub table { 'cust_pkg'; }
217 sub cust_linked { $_[0]->cust_main_custnum; }
218 sub cust_unlinked_msg {
220 "WARNING: can't find cust_main.custnum ". $self->custnum.
221 ' (cust_pkg.pkgnum '. $self->pkgnum. ')';
224 =item insert [ OPTION => VALUE ... ]
226 Adds this billing item to the database ("Orders" the item). If there is an
227 error, returns the error, otherwise returns false.
229 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
230 will be used to look up the package definition and agent restrictions will be
233 If the additional field I<refnum> is defined, an FS::pkg_referral record will
234 be created and inserted. Multiple FS::pkg_referral records can be created by
235 setting I<refnum> to an array reference of refnums or a hash reference with
236 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
237 record will be created corresponding to cust_main.refnum.
239 The following options are available:
245 If set true, supresses any referral credit to a referring customer.
249 cust_pkg_option records will be created
253 a ticket will be added to this customer with this subject
257 an optional queue name for ticket additions
264 my( $self, %options ) = @_;
266 my $error = $self->check_pkgpart;
267 return $error if $error;
269 if ( $self->part_pkg->option('start_1st', 1) && !$self->start_date ) {
270 my ($sec,$min,$hour,$mday,$mon,$year) = (localtime(time) )[0,1,2,3,4,5];
271 $mon += 1 unless $mday == 1;
272 until ( $mon < 12 ) { $mon -= 12; $year++; }
273 $self->start_date( timelocal_nocheck(0,0,0,1,$mon,$year) );
276 foreach my $action ( qw(expire adjourn contract_end) ) {
277 my $months = $self->part_pkg->option("${action}_months",1);
278 if($months and !$self->$action) {
279 my $start = $self->start_date || $self->setup || time;
280 $self->$action( $self->part_pkg->add_freq($start, $months) );
284 $self->order_date(time);
286 local $SIG{HUP} = 'IGNORE';
287 local $SIG{INT} = 'IGNORE';
288 local $SIG{QUIT} = 'IGNORE';
289 local $SIG{TERM} = 'IGNORE';
290 local $SIG{TSTP} = 'IGNORE';
291 local $SIG{PIPE} = 'IGNORE';
293 my $oldAutoCommit = $FS::UID::AutoCommit;
294 local $FS::UID::AutoCommit = 0;
297 $error = $self->SUPER::insert($options{options} ? %{$options{options}} : ());
299 $dbh->rollback if $oldAutoCommit;
303 $self->refnum($self->cust_main->refnum) unless $self->refnum;
304 $self->refnum( [ $self->refnum ] ) unless ref($self->refnum);
305 $self->process_m2m( 'link_table' => 'pkg_referral',
306 'target_table' => 'part_referral',
307 'params' => $self->refnum,
310 if ( $self->discountnum ) {
311 my $error = $self->insert_discount();
313 $dbh->rollback if $oldAutoCommit;
318 #if ( $self->reg_code ) {
319 # my $reg_code = qsearchs('reg_code', { 'code' => $self->reg_code } );
320 # $error = $reg_code->delete;
322 # $dbh->rollback if $oldAutoCommit;
327 my $conf = new FS::Conf;
329 if ( $conf->config('ticket_system') && $options{ticket_subject} ) {
332 # use lib ( "/opt/rt3/local/lib", "/opt/rt3/lib" );
339 use FS::TicketSystem;
340 FS::TicketSystem->init();
342 my $q = new RT::Queue($RT::SystemUser);
343 $q->Load($options{ticket_queue}) if $options{ticket_queue};
344 my $t = new RT::Ticket($RT::SystemUser);
345 my $mime = new MIME::Entity;
346 $mime->build( Type => 'text/plain', Data => $options{ticket_subject} );
347 $t->Create( $options{ticket_queue} ? (Queue => $q) : (),
348 Subject => $options{ticket_subject},
351 $t->AddLink( Type => 'MemberOf',
352 Target => 'freeside://freeside/cust_main/'. $self->custnum,
356 if ($conf->config('welcome_letter') && $self->cust_main->num_pkgs == 1) {
357 my $queue = new FS::queue {
358 'job' => 'FS::cust_main::queueable_print',
360 $error = $queue->insert(
361 'custnum' => $self->custnum,
362 'template' => 'welcome_letter',
366 warn "can't send welcome letter: $error";
371 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
378 This method now works but you probably shouldn't use it.
380 You don't want to delete packages, because there would then be no record
381 the customer ever purchased the package. Instead, see the cancel method and
382 hide cancelled packages.
389 local $SIG{HUP} = 'IGNORE';
390 local $SIG{INT} = 'IGNORE';
391 local $SIG{QUIT} = 'IGNORE';
392 local $SIG{TERM} = 'IGNORE';
393 local $SIG{TSTP} = 'IGNORE';
394 local $SIG{PIPE} = 'IGNORE';
396 my $oldAutoCommit = $FS::UID::AutoCommit;
397 local $FS::UID::AutoCommit = 0;
400 foreach my $cust_pkg_discount ($self->cust_pkg_discount) {
401 my $error = $cust_pkg_discount->delete;
403 $dbh->rollback if $oldAutoCommit;
407 #cust_bill_pkg_discount?
409 foreach my $cust_pkg_detail ($self->cust_pkg_detail) {
410 my $error = $cust_pkg_detail->delete;
412 $dbh->rollback if $oldAutoCommit;
417 foreach my $cust_pkg_reason (
419 'table' => 'cust_pkg_reason',
420 'hashref' => { 'pkgnum' => $self->pkgnum },
424 my $error = $cust_pkg_reason->delete;
426 $dbh->rollback if $oldAutoCommit;
433 my $error = $self->SUPER::delete(@_);
435 $dbh->rollback if $oldAutoCommit;
439 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
445 =item replace [ OLD_RECORD ] [ HASHREF | OPTION => VALUE ... ]
447 Replaces the OLD_RECORD with this one in the database. If there is an error,
448 returns the error, otherwise returns false.
450 Currently, custnum, setup, bill, adjourn, susp, expire, and cancel may be changed.
452 Changing pkgpart may have disasterous effects. See the order subroutine.
454 setup and bill are normally updated by calling the bill method of a customer
455 object (see L<FS::cust_main>).
457 suspend is normally updated by the suspend and unsuspend methods.
459 cancel is normally updated by the cancel method (and also the order subroutine
462 Available options are:
468 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.
472 the access_user (see L<FS::access_user>) providing the reason
476 hashref of keys and values - cust_pkg_option records will be created, updated or removed as appopriate
485 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
490 ( ref($_[0]) eq 'HASH' )
494 #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
495 #return "Can't change otaker!" if $old->otaker ne $new->otaker;
498 #return "Can't change setup once it exists!"
499 # if $old->getfield('setup') &&
500 # $old->getfield('setup') != $new->getfield('setup');
502 #some logic for bill, susp, cancel?
504 local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
506 local $SIG{HUP} = 'IGNORE';
507 local $SIG{INT} = 'IGNORE';
508 local $SIG{QUIT} = 'IGNORE';
509 local $SIG{TERM} = 'IGNORE';
510 local $SIG{TSTP} = 'IGNORE';
511 local $SIG{PIPE} = 'IGNORE';
513 my $oldAutoCommit = $FS::UID::AutoCommit;
514 local $FS::UID::AutoCommit = 0;
517 foreach my $method ( qw(adjourn expire) ) { # How many reasons?
518 if ($options->{'reason'} && $new->$method && $old->$method ne $new->$method) {
519 my $error = $new->insert_reason(
520 'reason' => $options->{'reason'},
521 'date' => $new->$method,
523 'reason_otaker' => $options->{'reason_otaker'},
526 dbh->rollback if $oldAutoCommit;
527 return "Error inserting cust_pkg_reason: $error";
532 #save off and freeze RADIUS attributes for any associated svc_acct records
534 if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
536 #also check for specific exports?
537 # to avoid spurious modify export events
538 @svc_acct = map { $_->svc_x }
539 grep { $_->part_svc->svcdb eq 'svc_acct' }
542 $_->snapshot foreach @svc_acct;
546 my $error = $new->SUPER::replace($old,
547 $options->{options} ? $options->{options} : ()
550 $dbh->rollback if $oldAutoCommit;
554 #for prepaid packages,
555 #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
556 foreach my $old_svc_acct ( @svc_acct ) {
557 my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
559 $new_svc_acct->replace( $old_svc_acct,
560 'depend_jobnum' => $options->{depend_jobnum},
563 $dbh->rollback if $oldAutoCommit;
568 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
575 Checks all fields to make sure this is a valid billing item. If there is an
576 error, returns the error, otherwise returns false. Called by the insert and
584 $self->locationnum('') if !$self->locationnum || $self->locationnum == -1;
587 $self->ut_numbern('pkgnum')
588 || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
589 || $self->ut_numbern('pkgpart')
590 || $self->check_pkgpart
591 || $self->ut_foreign_keyn('locationnum', 'cust_location', 'locationnum')
592 || $self->ut_numbern('start_date')
593 || $self->ut_numbern('setup')
594 || $self->ut_numbern('bill')
595 || $self->ut_numbern('susp')
596 || $self->ut_numbern('cancel')
597 || $self->ut_numbern('adjourn')
598 || $self->ut_numbern('expire')
599 || $self->ut_enum('no_auto', [ '', 'Y' ])
600 || $self->ut_enum('waive_setup', [ '', 'Y' ])
601 || $self->ut_numbern('agent_pkgid')
603 return $error if $error;
605 return "A package with both start date (future start) and setup date (already started) will never bill"
606 if $self->start_date && $self->setup;
608 $self->usernum($FS::CurrentUser::CurrentUser->usernum) unless $self->usernum;
610 if ( $self->dbdef_table->column('manual_flag') ) {
611 $self->manual_flag('') if $self->manual_flag eq ' ';
612 $self->manual_flag =~ /^([01]?)$/
613 or return "Illegal manual_flag ". $self->manual_flag;
614 $self->manual_flag($1);
627 my $error = $self->ut_numbern('pkgpart');
628 return $error if $error;
630 if ( $self->reg_code ) {
632 unless ( grep { $self->pkgpart == $_->pkgpart }
633 map { $_->reg_code_pkg }
634 qsearchs( 'reg_code', { 'code' => $self->reg_code,
635 'agentnum' => $self->cust_main->agentnum })
637 return "Unknown registration code";
640 } elsif ( $self->promo_code ) {
643 qsearchs('part_pkg', {
644 'pkgpart' => $self->pkgpart,
645 'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
647 return 'Unknown promotional code' unless $promo_part_pkg;
651 unless ( $disable_agentcheck ) {
653 qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
654 return "agent ". $agent->agentnum. ':'. $agent->agent.
655 " can't purchase pkgpart ". $self->pkgpart
656 unless $agent->pkgpart_hashref->{ $self->pkgpart }
657 || $agent->agentnum == $self->part_pkg->agentnum;
660 $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
661 return $error if $error;
669 =item cancel [ OPTION => VALUE ... ]
671 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
672 in this package, then cancels the package itself (sets the cancel field to
675 Available options are:
679 =item quiet - can be set true to supress email cancellation notices.
681 =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.
683 =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.
685 =item date - can be set to a unix style timestamp to specify when to cancel (expire)
687 =item nobill - can be set true to skip billing if it might otherwise be done.
689 =item unused_credit - can be set to 1 to credit the remaining time, or 0 to
690 not credit it. This must be set (by change()) when changing the package
691 to a different pkgpart or location, and probably shouldn't be in any other
692 case. If it's not set, the 'unused_credit_cancel' part_pkg option will
697 If there is an error, returns the error, otherwise returns false.
702 my( $self, %options ) = @_;
705 my $conf = new FS::Conf;
707 warn "cust_pkg::cancel called with options".
708 join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
711 local $SIG{HUP} = 'IGNORE';
712 local $SIG{INT} = 'IGNORE';
713 local $SIG{QUIT} = 'IGNORE';
714 local $SIG{TERM} = 'IGNORE';
715 local $SIG{TSTP} = 'IGNORE';
716 local $SIG{PIPE} = 'IGNORE';
718 my $oldAutoCommit = $FS::UID::AutoCommit;
719 local $FS::UID::AutoCommit = 0;
722 my $old = $self->select_for_update;
724 if ( $old->get('cancel') || $self->get('cancel') ) {
725 dbh->rollback if $oldAutoCommit;
726 return ""; # no error
729 my $date = $options{date} if $options{date}; # expire/cancel later
730 $date = '' if ($date && $date <= time); # complain instead?
732 #race condition: usage could be ongoing until unprovisioned
733 #resolved by performing a change package instead (which unprovisions) and
735 if ( !$options{nobill} && !$date && $conf->exists('bill_usage_on_cancel') ) {
736 my $copy = $self->new({$self->hash});
738 $copy->cust_main->bill( pkg_list => [ $copy ], cancel => 1 );
739 warn "Error billing during cancel, custnum ".
740 #$self->cust_main->custnum. ": $error"
745 my $cancel_time = $options{'time'} || time;
747 if ( $options{'reason'} ) {
748 $error = $self->insert_reason( 'reason' => $options{'reason'},
749 'action' => $date ? 'expire' : 'cancel',
750 'date' => $date ? $date : $cancel_time,
751 'reason_otaker' => $options{'reason_otaker'},
754 dbh->rollback if $oldAutoCommit;
755 return "Error inserting cust_pkg_reason: $error";
759 my %svc_cancel_opt = ();
760 $svc_cancel_opt{'date'} = $date if $date;
761 foreach my $cust_svc (
764 sort { $a->[1] <=> $b->[1] }
765 map { [ $_, $_->svc_x->table_info->{'cancel_weight'} ]; }
766 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
768 my $part_svc = $cust_svc->part_svc;
769 next if ( defined($part_svc) and $part_svc->preserve );
770 my $error = $cust_svc->cancel( %svc_cancel_opt );
773 $dbh->rollback if $oldAutoCommit;
774 return 'Error '. ($svc_cancel_opt{'date'} ? 'expiring' : 'canceling' ).
781 # Add a credit for remaining service
782 my $last_bill = $self->getfield('last_bill') || 0;
783 my $next_bill = $self->getfield('bill') || 0;
785 if ( exists($options{'unused_credit'}) ) {
786 $do_credit = $options{'unused_credit'};
789 $do_credit = $self->part_pkg->option('unused_credit_cancel', 1);
792 and $last_bill > 0 # the package has been billed
793 and $next_bill > 0 # the package has a next bill date
794 and $next_bill >= $cancel_time # which is in the future
796 my $remaining_value = $self->calc_remain('time' => $cancel_time);
797 if ( $remaining_value > 0 ) {
798 my $error = $self->cust_main->credit(
800 'Credit for unused time on '. $self->part_pkg->pkg,
801 'reason_type' => $conf->config('cancel_credit_type'),
804 $dbh->rollback if $oldAutoCommit;
805 return "Error crediting customer \$$remaining_value for unused time".
806 " on ". $self->part_pkg->pkg. ": $error";
808 } #if $remaining_value
813 my %hash = $self->hash;
814 $date ? ($hash{'expire'} = $date) : ($hash{'cancel'} = $cancel_time);
815 my $new = new FS::cust_pkg ( \%hash );
816 $error = $new->replace( $self, options => { $self->options } );
818 $dbh->rollback if $oldAutoCommit;
822 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
823 return '' if $date; #no errors
825 my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
826 if ( !$options{'quiet'} &&
827 $conf->exists('emailcancel', $self->cust_main->agentnum) &&
829 my $msgnum = $conf->config('cancel_msgnum', $self->cust_main->agentnum);
832 my $msg_template = qsearchs('msg_template', { msgnum => $msgnum });
833 $error = $msg_template->send( 'cust_main' => $self->cust_main,
838 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
839 'to' => \@invoicing_list,
840 'subject' => ( $conf->config('cancelsubject') || 'Cancellation Notice' ),
841 'body' => [ map "$_\n", $conf->config('cancelmessage') ],
844 #should this do something on errors?
851 =item cancel_if_expired [ NOW_TIMESTAMP ]
853 Cancels this package if its expire date has been reached.
857 sub cancel_if_expired {
859 my $time = shift || time;
860 return '' unless $self->expire && $self->expire <= $time;
861 my $error = $self->cancel;
863 return "Error cancelling expired pkg ". $self->pkgnum. " for custnum ".
864 $self->custnum. ": $error";
871 Cancels any pending expiration (sets the expire field to null).
873 If there is an error, returns the error, otherwise returns false.
878 my( $self, %options ) = @_;
881 local $SIG{HUP} = 'IGNORE';
882 local $SIG{INT} = 'IGNORE';
883 local $SIG{QUIT} = 'IGNORE';
884 local $SIG{TERM} = 'IGNORE';
885 local $SIG{TSTP} = 'IGNORE';
886 local $SIG{PIPE} = 'IGNORE';
888 my $oldAutoCommit = $FS::UID::AutoCommit;
889 local $FS::UID::AutoCommit = 0;
892 my $old = $self->select_for_update;
894 my $pkgnum = $old->pkgnum;
895 if ( $old->get('cancel') || $self->get('cancel') ) {
896 dbh->rollback if $oldAutoCommit;
897 return "Can't unexpire cancelled package $pkgnum";
898 # or at least it's pointless
901 unless ( $old->get('expire') && $self->get('expire') ) {
902 dbh->rollback if $oldAutoCommit;
903 return ""; # no error
906 my %hash = $self->hash;
907 $hash{'expire'} = '';
908 my $new = new FS::cust_pkg ( \%hash );
909 $error = $new->replace( $self, options => { $self->options } );
911 $dbh->rollback if $oldAutoCommit;
915 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
921 =item suspend [ OPTION => VALUE ... ]
923 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
924 package, then suspends the package itself (sets the susp field to now).
926 Available options are:
930 =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.
932 =item date - can be set to a unix style timestamp to specify when to suspend (adjourn)
936 If there is an error, returns the error, otherwise returns false.
941 my( $self, %options ) = @_;
944 local $SIG{HUP} = 'IGNORE';
945 local $SIG{INT} = 'IGNORE';
946 local $SIG{QUIT} = 'IGNORE';
947 local $SIG{TERM} = 'IGNORE';
948 local $SIG{TSTP} = 'IGNORE';
949 local $SIG{PIPE} = 'IGNORE';
951 my $oldAutoCommit = $FS::UID::AutoCommit;
952 local $FS::UID::AutoCommit = 0;
955 my $old = $self->select_for_update;
957 my $pkgnum = $old->pkgnum;
958 if ( $old->get('cancel') || $self->get('cancel') ) {
959 dbh->rollback if $oldAutoCommit;
960 return "Can't suspend cancelled package $pkgnum";
963 if ( $old->get('susp') || $self->get('susp') ) {
964 dbh->rollback if $oldAutoCommit;
965 return ""; # no error # complain on adjourn?
968 my $date = $options{date} if $options{date}; # adjourn/suspend later
969 $date = '' if ($date && $date <= time); # complain instead?
971 if ( $date && $old->get('expire') && $old->get('expire') < $date ) {
972 dbh->rollback if $oldAutoCommit;
973 return "Package $pkgnum expires before it would be suspended.";
976 my $suspend_time = $options{'time'} || time;
978 if ( $options{'reason'} ) {
979 $error = $self->insert_reason( 'reason' => $options{'reason'},
980 'action' => $date ? 'adjourn' : 'suspend',
981 'date' => $date ? $date : $suspend_time,
982 'reason_otaker' => $options{'reason_otaker'},
985 dbh->rollback if $oldAutoCommit;
986 return "Error inserting cust_pkg_reason: $error";
994 foreach my $cust_svc (
995 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
997 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
999 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
1000 $dbh->rollback if $oldAutoCommit;
1001 return "Illegal svcdb value in part_svc!";
1004 require "FS/$svcdb.pm";
1006 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
1008 $error = $svc->suspend;
1010 $dbh->rollback if $oldAutoCommit;
1013 my( $label, $value ) = $cust_svc->label;
1014 push @labels, "$label: $value";
1018 my $conf = new FS::Conf;
1019 if ( $conf->config('suspend_email_admin') ) {
1021 my $error = send_email(
1022 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
1023 #invoice_from ??? well as good as any
1024 'to' => $conf->config('suspend_email_admin'),
1025 'subject' => 'FREESIDE NOTIFICATION: Customer package suspended',
1027 "This is an automatic message from your Freeside installation\n",
1028 "informing you that the following customer package has been suspended:\n",
1030 'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
1031 'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
1032 ( map { "Service : $_\n" } @labels ),
1037 warn "WARNING: can't send suspension admin email (suspending anyway): ".
1045 my %hash = $self->hash;
1047 $hash{'adjourn'} = $date;
1049 $hash{'susp'} = $suspend_time;
1051 my $new = new FS::cust_pkg ( \%hash );
1052 $error = $new->replace( $self, options => { $self->options } );
1054 $dbh->rollback if $oldAutoCommit;
1058 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1063 =item unsuspend [ OPTION => VALUE ... ]
1065 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
1066 package, then unsuspends the package itself (clears the susp field and the
1067 adjourn field if it is in the past).
1069 Available options are:
1073 =item adjust_next_bill
1075 Can be set true to adjust the next bill date forward by
1076 the amount of time the account was inactive. This was set true by default
1077 since 1.4.2 and 1.5.0pre6; however, starting with 1.7.0 this needs to be
1078 explicitly requested. Price plans for which this makes sense (anniversary-date
1079 based than prorate or subscription) could have an option to enable this
1084 If there is an error, returns the error, otherwise returns false.
1089 my( $self, %opt ) = @_;
1092 local $SIG{HUP} = 'IGNORE';
1093 local $SIG{INT} = 'IGNORE';
1094 local $SIG{QUIT} = 'IGNORE';
1095 local $SIG{TERM} = 'IGNORE';
1096 local $SIG{TSTP} = 'IGNORE';
1097 local $SIG{PIPE} = 'IGNORE';
1099 my $oldAutoCommit = $FS::UID::AutoCommit;
1100 local $FS::UID::AutoCommit = 0;
1103 my $old = $self->select_for_update;
1105 my $pkgnum = $old->pkgnum;
1106 if ( $old->get('cancel') || $self->get('cancel') ) {
1107 dbh->rollback if $oldAutoCommit;
1108 return "Can't unsuspend cancelled package $pkgnum";
1111 unless ( $old->get('susp') && $self->get('susp') ) {
1112 dbh->rollback if $oldAutoCommit;
1113 return ""; # no error # complain instead?
1116 foreach my $cust_svc (
1117 qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
1119 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
1121 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
1122 $dbh->rollback if $oldAutoCommit;
1123 return "Illegal svcdb value in part_svc!";
1126 require "FS/$svcdb.pm";
1128 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
1130 $error = $svc->unsuspend;
1132 $dbh->rollback if $oldAutoCommit;
1139 my %hash = $self->hash;
1140 my $inactive = time - $hash{'susp'};
1142 my $conf = new FS::Conf;
1144 if ( $inactive > 0 &&
1145 ( $hash{'bill'} || $hash{'setup'} ) &&
1146 ( $opt{'adjust_next_bill'} ||
1147 $conf->exists('unsuspend-always_adjust_next_bill_date') ||
1148 $self->part_pkg->option('unsuspend_adjust_bill', 1) )
1151 $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive;
1156 $hash{'adjourn'} = '' if $hash{'adjourn'} < time;
1157 my $new = new FS::cust_pkg ( \%hash );
1158 $error = $new->replace( $self, options => { $self->options } );
1160 $dbh->rollback if $oldAutoCommit;
1164 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1171 Cancels any pending suspension (sets the adjourn field to null).
1173 If there is an error, returns the error, otherwise returns false.
1178 my( $self, %options ) = @_;
1181 local $SIG{HUP} = 'IGNORE';
1182 local $SIG{INT} = 'IGNORE';
1183 local $SIG{QUIT} = 'IGNORE';
1184 local $SIG{TERM} = 'IGNORE';
1185 local $SIG{TSTP} = 'IGNORE';
1186 local $SIG{PIPE} = 'IGNORE';
1188 my $oldAutoCommit = $FS::UID::AutoCommit;
1189 local $FS::UID::AutoCommit = 0;
1192 my $old = $self->select_for_update;
1194 my $pkgnum = $old->pkgnum;
1195 if ( $old->get('cancel') || $self->get('cancel') ) {
1196 dbh->rollback if $oldAutoCommit;
1197 return "Can't unadjourn cancelled package $pkgnum";
1198 # or at least it's pointless
1201 if ( $old->get('susp') || $self->get('susp') ) {
1202 dbh->rollback if $oldAutoCommit;
1203 return "Can't unadjourn suspended package $pkgnum";
1204 # perhaps this is arbitrary
1207 unless ( $old->get('adjourn') && $self->get('adjourn') ) {
1208 dbh->rollback if $oldAutoCommit;
1209 return ""; # no error
1212 my %hash = $self->hash;
1213 $hash{'adjourn'} = '';
1214 my $new = new FS::cust_pkg ( \%hash );
1215 $error = $new->replace( $self, options => { $self->options } );
1217 $dbh->rollback if $oldAutoCommit;
1221 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1228 =item change HASHREF | OPTION => VALUE ...
1230 Changes this package: cancels it and creates a new one, with a different
1231 pkgpart or locationnum or both. All services are transferred to the new
1232 package (no change will be made if this is not possible).
1234 Options may be passed as a list of key/value pairs or as a hash reference.
1241 New locationnum, to change the location for this package.
1245 New FS::cust_location object, to create a new location and assign it
1250 New pkgpart (see L<FS::part_pkg>).
1254 New refnum (see L<FS::part_referral>).
1258 Set to true to transfer billing dates (start_date, setup, last_bill, bill,
1259 susp, adjourn, cancel, expire, and contract_end) to the new package.
1263 At least one of locationnum, cust_location, pkgpart, refnum must be specified
1264 (otherwise, what's the point?)
1266 Returns either the new FS::cust_pkg object or a scalar error.
1270 my $err_or_new_cust_pkg = $old_cust_pkg->change
1274 #some false laziness w/order
1277 my $opt = ref($_[0]) ? shift : { @_ };
1279 # my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
1282 my $conf = new FS::Conf;
1284 # Transactionize this whole mess
1285 local $SIG{HUP} = 'IGNORE';
1286 local $SIG{INT} = 'IGNORE';
1287 local $SIG{QUIT} = 'IGNORE';
1288 local $SIG{TERM} = 'IGNORE';
1289 local $SIG{TSTP} = 'IGNORE';
1290 local $SIG{PIPE} = 'IGNORE';
1292 my $oldAutoCommit = $FS::UID::AutoCommit;
1293 local $FS::UID::AutoCommit = 0;
1302 #$hash{$_} = $self->$_() foreach qw( last_bill bill );
1304 #$hash{$_} = $self->$_() foreach qw( setup );
1306 $hash{'setup'} = $time if $self->setup;
1308 $hash{'change_date'} = $time;
1309 $hash{"change_$_"} = $self->$_()
1310 foreach qw( pkgnum pkgpart locationnum );
1312 if ( $opt->{'cust_location'} &&
1313 ( ! $opt->{'locationnum'} || $opt->{'locationnum'} == -1 ) ) {
1314 $error = $opt->{'cust_location'}->insert;
1316 $dbh->rollback if $oldAutoCommit;
1317 return "inserting cust_location (transaction rolled back): $error";
1319 $opt->{'locationnum'} = $opt->{'cust_location'}->locationnum;
1322 my $unused_credit = 0;
1323 if ( $opt->{'keep_dates'} ) {
1324 foreach my $date ( qw(setup bill last_bill susp adjourn cancel expire
1325 start_date contract_end ) ) {
1326 $hash{$date} = $self->getfield($date);
1329 # Special case. If the pkgpart is changing, and the customer is
1330 # going to be credited for remaining time, don't keep setup, bill,
1331 # or last_bill dates, and DO pass the flag to cancel() to credit
1333 if ( $opt->{'pkgpart'}
1334 and $opt->{'pkgpart'} != $self->pkgpart
1335 and $self->part_pkg->option('unused_credit_change', 1) ) {
1337 $hash{$_} = '' foreach qw(setup bill last_bill);
1340 # Create the new package.
1341 my $cust_pkg = new FS::cust_pkg {
1342 custnum => $self->custnum,
1343 pkgpart => ( $opt->{'pkgpart'} || $self->pkgpart ),
1344 refnum => ( $opt->{'refnum'} || $self->refnum ),
1345 locationnum => ( $opt->{'locationnum'} || $self->locationnum ),
1349 $error = $cust_pkg->insert( 'change' => 1 );
1351 $dbh->rollback if $oldAutoCommit;
1355 # Transfer services and cancel old package.
1357 $error = $self->transfer($cust_pkg);
1358 if ($error and $error == 0) {
1359 # $old_pkg->transfer failed.
1360 $dbh->rollback if $oldAutoCommit;
1364 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1365 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1366 $error = $self->transfer($cust_pkg, 'change_svcpart'=>1 );
1367 if ($error and $error == 0) {
1368 # $old_pkg->transfer failed.
1369 $dbh->rollback if $oldAutoCommit;
1375 # Transfers were successful, but we still had services left on the old
1376 # package. We can't change the package under this circumstances, so abort.
1377 $dbh->rollback if $oldAutoCommit;
1378 return "Unable to transfer all services from package ". $self->pkgnum;
1381 #reset usage if changing pkgpart
1382 # AND usage rollover is off (otherwise adds twice, now and at package bill)
1383 if ($self->pkgpart != $cust_pkg->pkgpart) {
1384 my $part_pkg = $cust_pkg->part_pkg;
1385 $error = $part_pkg->reset_usage($cust_pkg, $part_pkg->is_prepaid
1389 if $part_pkg->can('reset_usage') && ! $part_pkg->option('usage_rollover',1);
1392 $dbh->rollback if $oldAutoCommit;
1393 return "Error setting usage values: $error";
1397 #Good to go, cancel old package. Notify 'cancel' of whether to credit
1399 $error = $self->cancel( quiet=>1, unused_credit => $unused_credit );
1401 $dbh->rollback if $oldAutoCommit;
1405 if ( $conf->exists('cust_pkg-change_pkgpart-bill_now') ) {
1407 my $error = $cust_pkg->cust_main->bill( 'pkg_list' => [ $cust_pkg ] );
1409 $dbh->rollback if $oldAutoCommit;
1414 $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 'setup' => $self->discountnum_setup,
2612 #'disabled' => $self->discountnum_disabled,
2615 $cust_pkg_discount->insert;
2618 =item set_usage USAGE_VALUE_HASHREF
2620 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2621 to which they should be set (see L<FS::svc_acct>). Currently seconds,
2622 upbytes, downbytes, and totalbytes are appropriate keys.
2624 All svc_accts which are part of this package have their values reset.
2629 my ($self, $valueref, %opt) = @_;
2631 foreach my $cust_svc ($self->cust_svc){
2632 my $svc_x = $cust_svc->svc_x;
2633 $svc_x->set_usage($valueref, %opt)
2634 if $svc_x->can("set_usage");
2638 =item recharge USAGE_VALUE_HASHREF
2640 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2641 to which they should be set (see L<FS::svc_acct>). Currently seconds,
2642 upbytes, downbytes, and totalbytes are appropriate keys.
2644 All svc_accts which are part of this package have their values incremented.
2649 my ($self, $valueref) = @_;
2651 foreach my $cust_svc ($self->cust_svc){
2652 my $svc_x = $cust_svc->svc_x;
2653 $svc_x->recharge($valueref)
2654 if $svc_x->can("recharge");
2658 =item cust_pkg_discount
2662 sub cust_pkg_discount {
2664 qsearch('cust_pkg_discount', { 'pkgnum' => $self->pkgnum } );
2667 =item cust_pkg_discount_active
2671 sub cust_pkg_discount_active {
2673 grep { $_->status eq 'active' } $self->cust_pkg_discount;
2678 =head1 CLASS METHODS
2684 Returns an SQL expression identifying recurring packages.
2688 sub recurring_sql { "
2689 '0' != ( select freq from part_pkg
2690 where cust_pkg.pkgpart = part_pkg.pkgpart )
2695 Returns an SQL expression identifying one-time packages.
2700 '0' = ( select freq from part_pkg
2701 where cust_pkg.pkgpart = part_pkg.pkgpart )
2706 Returns an SQL expression identifying ordered packages (recurring packages not
2712 $_[0]->recurring_sql. " AND ". $_[0]->not_yet_billed_sql;
2717 Returns an SQL expression identifying active packages.
2722 $_[0]->recurring_sql. "
2723 AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
2724 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2725 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
2728 =item not_yet_billed_sql
2730 Returns an SQL expression identifying packages which have not yet been billed.
2734 sub not_yet_billed_sql { "
2735 ( cust_pkg.setup IS NULL OR cust_pkg.setup = 0 )
2736 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2737 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
2742 Returns an SQL expression identifying inactive packages (one-time packages
2743 that are otherwise unsuspended/uncancelled).
2747 sub inactive_sql { "
2748 ". $_[0]->onetime_sql(). "
2749 AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
2750 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2751 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
2757 Returns an SQL expression identifying suspended packages.
2761 sub suspended_sql { susp_sql(@_); }
2763 #$_[0]->recurring_sql(). ' AND '.
2765 ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2766 AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0
2773 Returns an SQL exprression identifying cancelled packages.
2777 sub cancelled_sql { cancel_sql(@_); }
2779 #$_[0]->recurring_sql(). ' AND '.
2780 "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
2785 Returns an SQL expression to give the package status as a string.
2791 WHEN cust_pkg.cancel IS NOT NULL THEN 'cancelled'
2792 WHEN cust_pkg.susp IS NOT NULL THEN 'suspended'
2793 WHEN cust_pkg.setup IS NULL THEN 'not yet billed'
2794 WHEN ".onetime_sql()." THEN 'one-time charge'
2799 =item search HASHREF
2803 Returns a qsearch hash expression to search for parameters specified in HASHREF.
2804 Valid parameters are
2812 active, inactive, suspended, cancel (or cancelled)
2816 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
2820 boolean selects custom packages
2826 pkgpart or arrayref or hashref of pkgparts
2830 arrayref of beginning and ending epoch date
2834 arrayref of beginning and ending epoch date
2838 arrayref of beginning and ending epoch date
2842 arrayref of beginning and ending epoch date
2846 arrayref of beginning and ending epoch date
2850 arrayref of beginning and ending epoch date
2854 arrayref of beginning and ending epoch date
2858 pkgnum or APKG_pkgnum
2862 a value suited to passing to FS::UI::Web::cust_header
2866 specifies the user for agent virtualization
2870 boolean selects packages containing fcc form 477 telco lines
2877 my ($class, $params) = @_;
2884 if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2886 "cust_main.agentnum = $1";
2893 if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
2895 "cust_pkg.custnum = $1";
2902 if ( $params->{'pkgbatch'} =~ /^([\w\/\-\:\.]+)$/ and $1 ) {
2904 "cust_pkg.pkgbatch = '$1'";
2911 if ( $params->{'magic'} eq 'active'
2912 || $params->{'status'} eq 'active' ) {
2914 push @where, FS::cust_pkg->active_sql();
2916 } elsif ( $params->{'magic'} =~ /^not[ _]yet[ _]billed$/
2917 || $params->{'status'} =~ /^not[ _]yet[ _]billed$/ ) {
2919 push @where, FS::cust_pkg->not_yet_billed_sql();
2921 } elsif ( $params->{'magic'} =~ /^(one-time charge|inactive)/
2922 || $params->{'status'} =~ /^(one-time charge|inactive)/ ) {
2924 push @where, FS::cust_pkg->inactive_sql();
2926 } elsif ( $params->{'magic'} eq 'suspended'
2927 || $params->{'status'} eq 'suspended' ) {
2929 push @where, FS::cust_pkg->suspended_sql();
2931 } elsif ( $params->{'magic'} =~ /^cancell?ed$/
2932 || $params->{'status'} =~ /^cancell?ed$/ ) {
2934 push @where, FS::cust_pkg->cancelled_sql();
2939 # parse package class
2942 #false lazinessish w/graph/cust_bill_pkg.cgi
2945 if ( exists($params->{'classnum'})
2946 && $params->{'classnum'} =~ /^(\d*)$/
2950 if ( $classnum ) { #a specific class
2951 push @where, "part_pkg.classnum = $classnum";
2953 #@pkg_class = ( qsearchs('pkg_class', { 'classnum' => $classnum } ) );
2954 #die "classnum $classnum not found!" unless $pkg_class[0];
2955 #$title .= $pkg_class[0]->classname.' ';
2957 } elsif ( $classnum eq '' ) { #the empty class
2959 push @where, "part_pkg.classnum IS NULL";
2960 #$title .= 'Empty class ';
2961 #@pkg_class = ( '(empty class)' );
2962 } elsif ( $classnum eq '0' ) {
2963 #@pkg_class = qsearch('pkg_class', {} ); # { 'disabled' => '' } );
2964 #push @pkg_class, '(empty class)';
2966 die "illegal classnum";
2972 # parse package report options
2975 my @report_option = ();
2976 if ( exists($params->{'report_option'})
2977 && $params->{'report_option'} =~ /^([,\d]*)$/
2980 @report_option = split(',', $1);
2983 if (@report_option) {
2984 # this will result in the empty set for the dangling comma case as it should
2986 map{ "0 < ( SELECT count(*) FROM part_pkg_option
2987 WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
2988 AND optionname = 'report_option_$_'
2989 AND optionvalue = '1' )"
2999 push @where, "part_pkg.custom = 'Y'" if $params->{custom};
3005 push @where, "part_pkg.fcc_ds0s > 0" if $params->{fcc_line};
3011 if ( exists($params->{'censustract'}) ) {
3012 $params->{'censustract'} =~ /^([.\d]*)$/;
3013 my $censustract = "cust_main.censustract = '$1'";
3014 $censustract .= ' OR cust_main.censustract is NULL' unless $1;
3015 push @where, "( $censustract )";
3022 if ( ref($params->{'pkgpart'}) ) {
3025 if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
3026 @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
3027 } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
3028 @pkgpart = @{ $params->{'pkgpart'} };
3030 die 'unhandled pkgpart ref '. $params->{'pkgpart'};
3033 @pkgpart = grep /^(\d+)$/, @pkgpart;
3035 push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
3037 } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
3038 push @where, "pkgpart = $1";
3047 #false laziness w/report_cust_pkg.html
3050 'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
3051 'active' => { 'susp'=>1, 'cancel'=>1 },
3052 'suspended' => { 'cancel' => 1 },
3057 if( exists($params->{'active'} ) ) {
3058 # This overrides all the other date-related fields
3059 my($beginning, $ending) = @{$params->{'active'}};
3061 "cust_pkg.setup IS NOT NULL",
3062 "cust_pkg.setup <= $ending",
3063 "(cust_pkg.cancel IS NULL OR cust_pkg.cancel >= $beginning )",
3064 "NOT (".FS::cust_pkg->onetime_sql . ")";
3067 foreach my $field (qw( setup last_bill bill adjourn susp expire contract_end cancel )) {
3069 next unless exists($params->{$field});
3071 my($beginning, $ending) = @{$params->{$field}};
3073 next if $beginning == 0 && $ending == 4294967295;
3076 "cust_pkg.$field IS NOT NULL",
3077 "cust_pkg.$field >= $beginning",
3078 "cust_pkg.$field <= $ending";
3080 $orderby ||= "ORDER BY cust_pkg.$field";
3085 $orderby ||= 'ORDER BY bill';
3088 # parse magic, legacy, etc.
3091 if ( $params->{'magic'} &&
3092 $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
3095 $orderby = 'ORDER BY pkgnum';
3097 if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
3098 push @where, "pkgpart = $1";
3101 } elsif ( $params->{'query'} eq 'pkgnum' ) {
3103 $orderby = 'ORDER BY pkgnum';
3105 } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
3107 $orderby = 'ORDER BY pkgnum';
3110 SELECT count(*) FROM pkg_svc
3111 WHERE pkg_svc.pkgpart = cust_pkg.pkgpart
3112 AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
3113 WHERE cust_svc.pkgnum = cust_pkg.pkgnum
3114 AND cust_svc.svcpart = pkg_svc.svcpart
3121 # setup queries, links, subs, etc. for the search
3124 # here is the agent virtualization
3125 if ($params->{CurrentUser}) {
3127 qsearchs('access_user', { username => $params->{CurrentUser} });
3130 push @where, $access_user->agentnums_sql('table'=>'cust_main');
3135 push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
3138 my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
3140 my $addl_from = 'LEFT JOIN cust_main USING ( custnum ) '.
3141 'LEFT JOIN part_pkg USING ( pkgpart ) '.
3142 'LEFT JOIN pkg_class ON ( part_pkg.classnum = pkg_class.classnum ) ';
3144 my $count_query = "SELECT COUNT(*) FROM cust_pkg $addl_from $extra_sql";
3147 'table' => 'cust_pkg',
3149 'select' => join(', ',
3151 ( map "part_pkg.$_", qw( pkg freq ) ),
3152 'pkg_class.classname',
3153 'cust_main.custnum AS cust_main_custnum',
3154 FS::UI::Web::cust_sql_fields(
3155 $params->{'cust_fields'}
3158 'extra_sql' => "$extra_sql $orderby",
3159 'addl_from' => $addl_from,
3160 'count_query' => $count_query,
3167 Returns a list of two package counts. The first is a count of packages
3168 based on the supplied criteria and the second is the count of residential
3169 packages with those same criteria. Criteria are specified as in the search
3175 my ($class, $params) = @_;
3177 my $sql_query = $class->search( $params );
3179 my $count_sql = delete($sql_query->{'count_query'});
3180 $count_sql =~ s/ FROM/,count(CASE WHEN cust_main.company IS NULL OR cust_main.company = '' THEN 1 END) FROM/
3181 or die "couldn't parse count_sql";
3183 my $count_sth = dbh->prepare($count_sql)
3184 or die "Error preparing $count_sql: ". dbh->errstr;
3186 or die "Error executing $count_sql: ". $count_sth->errstr;
3187 my $count_arrayref = $count_sth->fetchrow_arrayref;
3189 return ( @$count_arrayref );
3196 Returns a list: the first item is an SQL fragment identifying matching
3197 packages/customers via location (taking into account shipping and package
3198 address taxation, if enabled), and subsequent items are the parameters to
3199 substitute for the placeholders in that fragment.
3204 my($class, %opt) = @_;
3205 my $ornull = $opt{'ornull'};
3207 my $conf = new FS::Conf;
3209 # '?' placeholders in _location_sql_where
3210 my $x = $ornull ? 3 : 2;
3211 my @bill_param = ( ('city')x3, ('county')x$x, ('state')x$x, 'country' );
3215 if ( $conf->exists('tax-ship_address') ) {
3218 ( ( ship_last IS NULL OR ship_last = '' )
3219 AND ". _location_sql_where('cust_main', '', $ornull ). "
3221 OR ( ship_last IS NOT NULL AND ship_last != ''
3222 AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
3225 # AND payby != 'COMP'
3227 @main_param = ( @bill_param, @bill_param );
3231 $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
3232 @main_param = @bill_param;
3238 if ( $conf->exists('tax-pkg_address') ) {
3240 my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
3243 ( cust_pkg.locationnum IS NULL AND $main_where )
3244 OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where )
3247 @param = ( @main_param, @bill_param );
3251 $where = $main_where;
3252 @param = @main_param;
3260 #subroutine, helper for location_sql
3261 sub _location_sql_where {
3263 my $prefix = @_ ? shift : '';
3264 my $ornull = @_ ? shift : '';
3266 # $ornull = $ornull ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
3268 $ornull = $ornull ? ' OR ? IS NULL ' : '';
3270 my $or_empty_city = " OR ( ? = '' AND $table.${prefix}city IS NULL ) ";
3271 my $or_empty_county = " OR ( ? = '' AND $table.${prefix}county IS NULL ) ";
3272 my $or_empty_state = " OR ( ? = '' AND $table.${prefix}state IS NULL ) ";
3274 # ( $table.${prefix}city = ? $or_empty_city $ornull )
3276 ( $table.${prefix}city = ? OR ? = '' OR CAST(? AS text) IS NULL )
3277 AND ( $table.${prefix}county = ? $or_empty_county $ornull )
3278 AND ( $table.${prefix}state = ? $or_empty_state $ornull )
3279 AND $table.${prefix}country = ?
3287 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
3289 CUSTNUM is a customer (see L<FS::cust_main>)
3291 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
3292 L<FS::part_pkg>) to order for this customer. Duplicates are of course
3295 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
3296 remove for this customer. The services (see L<FS::cust_svc>) are moved to the
3297 new billing items. An error is returned if this is not possible (see
3298 L<FS::pkg_svc>). An empty arrayref is equivalent to not specifying this
3301 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
3302 newly-created cust_pkg objects.
3304 REFNUM, if specified, will specify the FS::pkg_referral record to be created
3305 and inserted. Multiple FS::pkg_referral records can be created by
3306 setting I<refnum> to an array reference of refnums or a hash reference with
3307 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
3308 record will be created corresponding to cust_main.refnum.
3313 my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
3315 my $conf = new FS::Conf;
3317 # Transactionize this whole mess
3318 local $SIG{HUP} = 'IGNORE';
3319 local $SIG{INT} = 'IGNORE';
3320 local $SIG{QUIT} = 'IGNORE';
3321 local $SIG{TERM} = 'IGNORE';
3322 local $SIG{TSTP} = 'IGNORE';
3323 local $SIG{PIPE} = 'IGNORE';
3325 my $oldAutoCommit = $FS::UID::AutoCommit;
3326 local $FS::UID::AutoCommit = 0;
3330 # my $cust_main = qsearchs('cust_main', { custnum => $custnum });
3331 # return "Customer not found: $custnum" unless $cust_main;
3333 warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
3336 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
3339 my $change = scalar(@old_cust_pkg) != 0;
3342 if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
3344 warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
3345 " to pkgpart ". $pkgparts->[0]. "\n"
3348 my $err_or_cust_pkg =
3349 $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
3350 'refnum' => $refnum,
3353 unless (ref($err_or_cust_pkg)) {
3354 $dbh->rollback if $oldAutoCommit;
3355 return $err_or_cust_pkg;
3358 push @$return_cust_pkg, $err_or_cust_pkg;
3359 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3364 # Create the new packages.
3365 foreach my $pkgpart (@$pkgparts) {
3367 warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
3369 my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
3370 pkgpart => $pkgpart,
3374 $error = $cust_pkg->insert( 'change' => $change );
3376 $dbh->rollback if $oldAutoCommit;
3379 push @$return_cust_pkg, $cust_pkg;
3381 # $return_cust_pkg now contains refs to all of the newly
3384 # Transfer services and cancel old packages.
3385 foreach my $old_pkg (@old_cust_pkg) {
3387 warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
3390 foreach my $new_pkg (@$return_cust_pkg) {
3391 $error = $old_pkg->transfer($new_pkg);
3392 if ($error and $error == 0) {
3393 # $old_pkg->transfer failed.
3394 $dbh->rollback if $oldAutoCommit;
3399 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
3400 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
3401 foreach my $new_pkg (@$return_cust_pkg) {
3402 $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
3403 if ($error and $error == 0) {
3404 # $old_pkg->transfer failed.
3405 $dbh->rollback if $oldAutoCommit;
3412 # Transfers were successful, but we went through all of the
3413 # new packages and still had services left on the old package.
3414 # We can't cancel the package under the circumstances, so abort.
3415 $dbh->rollback if $oldAutoCommit;
3416 return "Unable to transfer all services from package ".$old_pkg->pkgnum;
3418 $error = $old_pkg->cancel( quiet=>1 );
3424 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3428 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
3430 A bulk change method to change packages for multiple customers.
3432 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
3433 L<FS::part_pkg>) to order for each customer. Duplicates are of course
3436 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
3437 replace. The services (see L<FS::cust_svc>) are moved to the
3438 new billing items. An error is returned if this is not possible (see
3441 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
3442 newly-created cust_pkg objects.
3447 my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
3449 # Transactionize this whole mess
3450 local $SIG{HUP} = 'IGNORE';
3451 local $SIG{INT} = 'IGNORE';
3452 local $SIG{QUIT} = 'IGNORE';
3453 local $SIG{TERM} = 'IGNORE';
3454 local $SIG{TSTP} = 'IGNORE';
3455 local $SIG{PIPE} = 'IGNORE';
3457 my $oldAutoCommit = $FS::UID::AutoCommit;
3458 local $FS::UID::AutoCommit = 0;
3462 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
3465 while(scalar(@old_cust_pkg)) {
3467 my $custnum = $old_cust_pkg[0]->custnum;
3468 my (@remove) = map { $_->pkgnum }
3469 grep { $_->custnum == $custnum } @old_cust_pkg;
3470 @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
3472 my $error = order $custnum, $pkgparts, \@remove, \@return;
3474 push @errors, $error
3476 push @$return_cust_pkg, @return;
3479 if (scalar(@errors)) {
3480 $dbh->rollback if $oldAutoCommit;
3481 return join(' / ', @errors);
3484 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3488 # Used by FS::Upgrade to migrate to a new database.
3489 sub _upgrade_data { # class method
3490 my ($class, %opts) = @_;
3491 $class->_upgrade_otaker(%opts);
3493 # RT#10139, bug resulting in contract_end being set when it shouldn't
3494 'UPDATE cust_pkg SET contract_end = NULL WHERE contract_end = -1',
3495 # RT#10830, bad calculation of prorate date near end of year
3496 # the date range for bill is December 2009, and we move it forward
3497 # one year if it's before the previous bill date (which it should
3499 'UPDATE cust_pkg SET bill = bill + (365*24*60*60) WHERE bill < last_bill
3500 AND bill > 1259654400 AND bill < 1262332800 AND (SELECT plan FROM part_pkg
3501 WHERE part_pkg.pkgpart = cust_pkg.pkgpart) = \'prorate\'',
3502 # RT6628, add order_date to cust_pkg
3503 'update cust_pkg set order_date = (select history_date from h_cust_pkg
3504 where h_cust_pkg.pkgnum = cust_pkg.pkgnum and
3505 history_action = \'insert\') where order_date is null',
3507 foreach my $sql (@statements) {
3508 my $sth = dbh->prepare($sql);
3509 $sth->execute or die $sth->errstr;
3517 sub order is not OO. Perhaps it should be moved to FS::cust_main and made so?
3519 In sub order, the @pkgparts array (passed by reference) is clobbered.
3521 Also in sub order, no money is adjusted. Once FS::part_pkg defines a standard
3522 method to pass dates to the recur_prog expression, it should do so.
3524 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
3525 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
3526 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
3527 configuration values. Probably need a subroutine which decides what to do
3528 based on whether or not we've fetched the user yet, rather than a hash. See
3529 FS::UID and the TODO.
3531 Now that things are transactional should the check in the insert method be
3536 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
3537 L<FS::pkg_svc>, schema.html from the base documentation