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
199 Note: setup, last_bill, bill, adjourn, susp, expire, cancel and change_date
200 are specified as UNIX timestamps; see L<perlfunc/"time">. Also see
201 L<Time::Local> and L<Date::Parse> for conversion functions.
209 Create a new billing item. To add the item to the database, see L<"insert">.
213 sub table { 'cust_pkg'; }
214 sub cust_linked { $_[0]->cust_main_custnum; }
215 sub cust_unlinked_msg {
217 "WARNING: can't find cust_main.custnum ". $self->custnum.
218 ' (cust_pkg.pkgnum '. $self->pkgnum. ')';
221 =item insert [ OPTION => VALUE ... ]
223 Adds this billing item to the database ("Orders" the item). If there is an
224 error, returns the error, otherwise returns false.
226 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
227 will be used to look up the package definition and agent restrictions will be
230 If the additional field I<refnum> is defined, an FS::pkg_referral record will
231 be created and inserted. Multiple FS::pkg_referral records can be created by
232 setting I<refnum> to an array reference of refnums or a hash reference with
233 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
234 record will be created corresponding to cust_main.refnum.
236 The following options are available:
242 If set true, supresses any referral credit to a referring customer.
246 cust_pkg_option records will be created
250 a ticket will be added to this customer with this subject
254 an optional queue name for ticket additions
261 my( $self, %options ) = @_;
263 my $error = $self->check_pkgpart;
264 return $error if $error;
266 if ( $self->part_pkg->option('start_1st', 1) && !$self->start_date ) {
267 my ($sec,$min,$hour,$mday,$mon,$year) = (localtime(time) )[0,1,2,3,4,5];
268 $mon += 1 unless $mday == 1;
269 until ( $mon < 12 ) { $mon -= 12; $year++; }
270 $self->start_date( timelocal_nocheck(0,0,0,1,$mon,$year) );
273 foreach my $action ( qw(expire adjourn contract_end) ) {
274 my $months = $self->part_pkg->option("${action}_months",1);
275 if($months and !$self->$action) {
276 my $start = $self->start_date || $self->setup || time;
277 $self->$action( $self->part_pkg->add_freq($start, $months) );
281 $self->order_date(time);
283 local $SIG{HUP} = 'IGNORE';
284 local $SIG{INT} = 'IGNORE';
285 local $SIG{QUIT} = 'IGNORE';
286 local $SIG{TERM} = 'IGNORE';
287 local $SIG{TSTP} = 'IGNORE';
288 local $SIG{PIPE} = 'IGNORE';
290 my $oldAutoCommit = $FS::UID::AutoCommit;
291 local $FS::UID::AutoCommit = 0;
294 $error = $self->SUPER::insert($options{options} ? %{$options{options}} : ());
296 $dbh->rollback if $oldAutoCommit;
300 $self->refnum($self->cust_main->refnum) unless $self->refnum;
301 $self->refnum( [ $self->refnum ] ) unless ref($self->refnum);
302 $self->process_m2m( 'link_table' => 'pkg_referral',
303 'target_table' => 'part_referral',
304 'params' => $self->refnum,
307 if ( $self->discountnum ) {
308 my $error = $self->insert_discount();
310 $dbh->rollback if $oldAutoCommit;
315 #if ( $self->reg_code ) {
316 # my $reg_code = qsearchs('reg_code', { 'code' => $self->reg_code } );
317 # $error = $reg_code->delete;
319 # $dbh->rollback if $oldAutoCommit;
324 my $conf = new FS::Conf;
326 if ( $conf->config('ticket_system') && $options{ticket_subject} ) {
329 # use lib ( "/opt/rt3/local/lib", "/opt/rt3/lib" );
336 use FS::TicketSystem;
337 FS::TicketSystem->init();
339 my $q = new RT::Queue($RT::SystemUser);
340 $q->Load($options{ticket_queue}) if $options{ticket_queue};
341 my $t = new RT::Ticket($RT::SystemUser);
342 my $mime = new MIME::Entity;
343 $mime->build( Type => 'text/plain', Data => $options{ticket_subject} );
344 $t->Create( $options{ticket_queue} ? (Queue => $q) : (),
345 Subject => $options{ticket_subject},
348 $t->AddLink( Type => 'MemberOf',
349 Target => 'freeside://freeside/cust_main/'. $self->custnum,
353 if ($conf->config('welcome_letter') && $self->cust_main->num_pkgs == 1) {
354 my $queue = new FS::queue {
355 'job' => 'FS::cust_main::queueable_print',
357 $error = $queue->insert(
358 'custnum' => $self->custnum,
359 'template' => 'welcome_letter',
363 warn "can't send welcome letter: $error";
368 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
375 This method now works but you probably shouldn't use it.
377 You don't want to delete packages, because there would then be no record
378 the customer ever purchased the package. Instead, see the cancel method and
379 hide cancelled packages.
386 local $SIG{HUP} = 'IGNORE';
387 local $SIG{INT} = 'IGNORE';
388 local $SIG{QUIT} = 'IGNORE';
389 local $SIG{TERM} = 'IGNORE';
390 local $SIG{TSTP} = 'IGNORE';
391 local $SIG{PIPE} = 'IGNORE';
393 my $oldAutoCommit = $FS::UID::AutoCommit;
394 local $FS::UID::AutoCommit = 0;
397 foreach my $cust_pkg_discount ($self->cust_pkg_discount) {
398 my $error = $cust_pkg_discount->delete;
400 $dbh->rollback if $oldAutoCommit;
404 #cust_bill_pkg_discount?
406 foreach my $cust_pkg_detail ($self->cust_pkg_detail) {
407 my $error = $cust_pkg_detail->delete;
409 $dbh->rollback if $oldAutoCommit;
414 foreach my $cust_pkg_reason (
416 'table' => 'cust_pkg_reason',
417 'hashref' => { 'pkgnum' => $self->pkgnum },
421 my $error = $cust_pkg_reason->delete;
423 $dbh->rollback if $oldAutoCommit;
430 my $error = $self->SUPER::delete(@_);
432 $dbh->rollback if $oldAutoCommit;
436 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
442 =item replace [ OLD_RECORD ] [ HASHREF | OPTION => VALUE ... ]
444 Replaces the OLD_RECORD with this one in the database. If there is an error,
445 returns the error, otherwise returns false.
447 Currently, custnum, setup, bill, adjourn, susp, expire, and cancel may be changed.
449 Changing pkgpart may have disasterous effects. See the order subroutine.
451 setup and bill are normally updated by calling the bill method of a customer
452 object (see L<FS::cust_main>).
454 suspend is normally updated by the suspend and unsuspend methods.
456 cancel is normally updated by the cancel method (and also the order subroutine
459 Available options are:
465 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.
469 the access_user (see L<FS::access_user>) providing the reason
473 hashref of keys and values - cust_pkg_option records will be created, updated or removed as appopriate
482 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
487 ( ref($_[0]) eq 'HASH' )
491 #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
492 #return "Can't change otaker!" if $old->otaker ne $new->otaker;
495 #return "Can't change setup once it exists!"
496 # if $old->getfield('setup') &&
497 # $old->getfield('setup') != $new->getfield('setup');
499 #some logic for bill, susp, cancel?
501 local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
503 local $SIG{HUP} = 'IGNORE';
504 local $SIG{INT} = 'IGNORE';
505 local $SIG{QUIT} = 'IGNORE';
506 local $SIG{TERM} = 'IGNORE';
507 local $SIG{TSTP} = 'IGNORE';
508 local $SIG{PIPE} = 'IGNORE';
510 my $oldAutoCommit = $FS::UID::AutoCommit;
511 local $FS::UID::AutoCommit = 0;
514 foreach my $method ( qw(adjourn expire) ) { # How many reasons?
515 if ($options->{'reason'} && $new->$method && $old->$method ne $new->$method) {
516 my $error = $new->insert_reason(
517 'reason' => $options->{'reason'},
518 'date' => $new->$method,
520 'reason_otaker' => $options->{'reason_otaker'},
523 dbh->rollback if $oldAutoCommit;
524 return "Error inserting cust_pkg_reason: $error";
529 #save off and freeze RADIUS attributes for any associated svc_acct records
531 if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
533 #also check for specific exports?
534 # to avoid spurious modify export events
535 @svc_acct = map { $_->svc_x }
536 grep { $_->part_svc->svcdb eq 'svc_acct' }
539 $_->snapshot foreach @svc_acct;
543 my $error = $new->SUPER::replace($old,
544 $options->{options} ? $options->{options} : ()
547 $dbh->rollback if $oldAutoCommit;
551 #for prepaid packages,
552 #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
553 foreach my $old_svc_acct ( @svc_acct ) {
554 my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
556 $new_svc_acct->replace( $old_svc_acct,
557 'depend_jobnum' => $options->{depend_jobnum},
560 $dbh->rollback if $oldAutoCommit;
565 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
572 Checks all fields to make sure this is a valid billing item. If there is an
573 error, returns the error, otherwise returns false. Called by the insert and
581 $self->locationnum('') if !$self->locationnum || $self->locationnum == -1;
584 $self->ut_numbern('pkgnum')
585 || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
586 || $self->ut_numbern('pkgpart')
587 || $self->check_pkgpart
588 || $self->ut_foreign_keyn('locationnum', 'cust_location', 'locationnum')
589 || $self->ut_numbern('start_date')
590 || $self->ut_numbern('setup')
591 || $self->ut_numbern('bill')
592 || $self->ut_numbern('susp')
593 || $self->ut_numbern('cancel')
594 || $self->ut_numbern('adjourn')
595 || $self->ut_numbern('expire')
596 || $self->ut_enum('no_auto', [ '', 'Y' ])
598 return $error if $error;
600 $self->usernum($FS::CurrentUser::CurrentUser->usernum) unless $self->usernum;
602 if ( $self->dbdef_table->column('manual_flag') ) {
603 $self->manual_flag('') if $self->manual_flag eq ' ';
604 $self->manual_flag =~ /^([01]?)$/
605 or return "Illegal manual_flag ". $self->manual_flag;
606 $self->manual_flag($1);
619 my $error = $self->ut_numbern('pkgpart');
620 return $error if $error;
622 if ( $self->reg_code ) {
624 unless ( grep { $self->pkgpart == $_->pkgpart }
625 map { $_->reg_code_pkg }
626 qsearchs( 'reg_code', { 'code' => $self->reg_code,
627 'agentnum' => $self->cust_main->agentnum })
629 return "Unknown registration code";
632 } elsif ( $self->promo_code ) {
635 qsearchs('part_pkg', {
636 'pkgpart' => $self->pkgpart,
637 'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
639 return 'Unknown promotional code' unless $promo_part_pkg;
643 unless ( $disable_agentcheck ) {
645 qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
646 return "agent ". $agent->agentnum. ':'. $agent->agent.
647 " can't purchase pkgpart ". $self->pkgpart
648 unless $agent->pkgpart_hashref->{ $self->pkgpart }
649 || $agent->agentnum == $self->part_pkg->agentnum;
652 $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
653 return $error if $error;
661 =item cancel [ OPTION => VALUE ... ]
663 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
664 in this package, then cancels the package itself (sets the cancel field to
667 Available options are:
671 =item quiet - can be set true to supress email cancellation notices.
673 =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.
675 =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.
677 =item date - can be set to a unix style timestamp to specify when to cancel (expire)
679 =item nobill - can be set true to skip billing if it might otherwise be done.
681 =item unused_credit - can be set to 1 to credit the remaining time, or 0 to
682 not credit it. This must be set (by change()) when changing the package
683 to a different pkgpart or location, and probably shouldn't be in any other
684 case. If it's not set, the 'unused_credit_cancel' part_pkg option will
689 If there is an error, returns the error, otherwise returns false.
694 my( $self, %options ) = @_;
697 my $conf = new FS::Conf;
699 warn "cust_pkg::cancel called with options".
700 join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
703 local $SIG{HUP} = 'IGNORE';
704 local $SIG{INT} = 'IGNORE';
705 local $SIG{QUIT} = 'IGNORE';
706 local $SIG{TERM} = 'IGNORE';
707 local $SIG{TSTP} = 'IGNORE';
708 local $SIG{PIPE} = 'IGNORE';
710 my $oldAutoCommit = $FS::UID::AutoCommit;
711 local $FS::UID::AutoCommit = 0;
714 my $old = $self->select_for_update;
716 if ( $old->get('cancel') || $self->get('cancel') ) {
717 dbh->rollback if $oldAutoCommit;
718 return ""; # no error
721 my $date = $options{date} if $options{date}; # expire/cancel later
722 $date = '' if ($date && $date <= time); # complain instead?
724 #race condition: usage could be ongoing until unprovisioned
725 #resolved by performing a change package instead (which unprovisions) and
727 if ( !$options{nobill} && !$date && $conf->exists('bill_usage_on_cancel') ) {
728 my $copy = $self->new({$self->hash});
730 $copy->cust_main->bill( pkg_list => [ $copy ], cancel => 1 );
731 warn "Error billing during cancel, custnum ".
732 #$self->cust_main->custnum. ": $error"
737 my $cancel_time = $options{'time'} || time;
739 if ( $options{'reason'} ) {
740 $error = $self->insert_reason( 'reason' => $options{'reason'},
741 'action' => $date ? 'expire' : 'cancel',
742 'date' => $date ? $date : $cancel_time,
743 'reason_otaker' => $options{'reason_otaker'},
746 dbh->rollback if $oldAutoCommit;
747 return "Error inserting cust_pkg_reason: $error";
754 foreach my $cust_svc (
757 sort { $a->[1] <=> $b->[1] }
758 map { [ $_, $_->svc_x->table_info->{'cancel_weight'} ]; }
759 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
761 my $error = $cust_svc->cancel( ('date' => $date) );
764 $dbh->rollback if $oldAutoCommit;
765 return "Error expiring cust_svc: $error";
769 foreach my $cust_svc (
772 sort { $a->[1] <=> $b->[1] }
773 map { [ $_, $_->svc_x->table_info->{'cancel_weight'} ]; }
774 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
776 my $error = $cust_svc->cancel;
779 $dbh->rollback if $oldAutoCommit;
780 return "Error cancelling cust_svc: $error";
785 # Add a credit for remaining service
786 my $last_bill = $self->getfield('last_bill') || 0;
787 my $next_bill = $self->getfield('bill') || 0;
789 if ( exists($options{'unused_credit'}) ) {
790 $do_credit = $options{'unused_credit'};
793 $do_credit = $self->part_pkg->option('unused_credit_cancel', 1);
796 and $last_bill > 0 # the package has been billed
797 and $next_bill > 0 # the package has a next bill date
798 and $next_bill >= $cancel_time # which is in the future
800 my $remaining_value = $self->calc_remain('time' => $cancel_time);
801 if ( $remaining_value > 0 ) {
802 # && !$options{'no_credit'} ) {
803 # Undocumented, unused option.
804 # part_pkg configuration should decide this anyway.
805 my $error = $self->cust_main->credit(
807 'Credit for unused time on '. $self->part_pkg->pkg,
808 'reason_type' => $conf->config('cancel_credit_type'),
811 $dbh->rollback if $oldAutoCommit;
812 return "Error crediting customer \$$remaining_value for unused time on".
813 $self->part_pkg->pkg. ": $error";
815 } #if $remaining_value
818 my %hash = $self->hash;
819 $date ? ($hash{'expire'} = $date) : ($hash{'cancel'} = $cancel_time);
820 my $new = new FS::cust_pkg ( \%hash );
821 $error = $new->replace( $self, options => { $self->options } );
823 $dbh->rollback if $oldAutoCommit;
827 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
828 return '' if $date; #no errors
830 my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
831 if ( !$options{'quiet'} &&
832 $conf->exists('emailcancel', $self->cust_main->agentnum) &&
834 my $msgnum = $conf->config('cancel_msgnum', $self->cust_main->agentnum);
837 my $msg_template = qsearchs('msg_template', { msgnum => $msgnum });
838 $error = $msg_template->send( 'cust_main' => $self->cust_main,
843 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
844 'to' => \@invoicing_list,
845 'subject' => ( $conf->config('cancelsubject') || 'Cancellation Notice' ),
846 'body' => [ map "$_\n", $conf->config('cancelmessage') ],
849 #should this do something on errors?
856 =item cancel_if_expired [ NOW_TIMESTAMP ]
858 Cancels this package if its expire date has been reached.
862 sub cancel_if_expired {
864 my $time = shift || time;
865 return '' unless $self->expire && $self->expire <= $time;
866 my $error = $self->cancel;
868 return "Error cancelling expired pkg ". $self->pkgnum. " for custnum ".
869 $self->custnum. ": $error";
876 Cancels any pending expiration (sets the expire field to null).
878 If there is an error, returns the error, otherwise returns false.
883 my( $self, %options ) = @_;
886 local $SIG{HUP} = 'IGNORE';
887 local $SIG{INT} = 'IGNORE';
888 local $SIG{QUIT} = 'IGNORE';
889 local $SIG{TERM} = 'IGNORE';
890 local $SIG{TSTP} = 'IGNORE';
891 local $SIG{PIPE} = 'IGNORE';
893 my $oldAutoCommit = $FS::UID::AutoCommit;
894 local $FS::UID::AutoCommit = 0;
897 my $old = $self->select_for_update;
899 my $pkgnum = $old->pkgnum;
900 if ( $old->get('cancel') || $self->get('cancel') ) {
901 dbh->rollback if $oldAutoCommit;
902 return "Can't unexpire cancelled package $pkgnum";
903 # or at least it's pointless
906 unless ( $old->get('expire') && $self->get('expire') ) {
907 dbh->rollback if $oldAutoCommit;
908 return ""; # no error
911 my %hash = $self->hash;
912 $hash{'expire'} = '';
913 my $new = new FS::cust_pkg ( \%hash );
914 $error = $new->replace( $self, options => { $self->options } );
916 $dbh->rollback if $oldAutoCommit;
920 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
926 =item suspend [ OPTION => VALUE ... ]
928 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
929 package, then suspends the package itself (sets the susp field to now).
931 Available options are:
935 =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.
937 =item date - can be set to a unix style timestamp to specify when to suspend (adjourn)
941 If there is an error, returns the error, otherwise returns false.
946 my( $self, %options ) = @_;
949 local $SIG{HUP} = 'IGNORE';
950 local $SIG{INT} = 'IGNORE';
951 local $SIG{QUIT} = 'IGNORE';
952 local $SIG{TERM} = 'IGNORE';
953 local $SIG{TSTP} = 'IGNORE';
954 local $SIG{PIPE} = 'IGNORE';
956 my $oldAutoCommit = $FS::UID::AutoCommit;
957 local $FS::UID::AutoCommit = 0;
960 my $old = $self->select_for_update;
962 my $pkgnum = $old->pkgnum;
963 if ( $old->get('cancel') || $self->get('cancel') ) {
964 dbh->rollback if $oldAutoCommit;
965 return "Can't suspend cancelled package $pkgnum";
968 if ( $old->get('susp') || $self->get('susp') ) {
969 dbh->rollback if $oldAutoCommit;
970 return ""; # no error # complain on adjourn?
973 my $date = $options{date} if $options{date}; # adjourn/suspend later
974 $date = '' if ($date && $date <= time); # complain instead?
976 if ( $date && $old->get('expire') && $old->get('expire') < $date ) {
977 dbh->rollback if $oldAutoCommit;
978 return "Package $pkgnum expires before it would be suspended.";
981 my $suspend_time = $options{'time'} || time;
983 if ( $options{'reason'} ) {
984 $error = $self->insert_reason( 'reason' => $options{'reason'},
985 'action' => $date ? 'adjourn' : 'suspend',
986 'date' => $date ? $date : $suspend_time,
987 'reason_otaker' => $options{'reason_otaker'},
990 dbh->rollback if $oldAutoCommit;
991 return "Error inserting cust_pkg_reason: $error";
999 foreach my $cust_svc (
1000 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
1002 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
1004 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
1005 $dbh->rollback if $oldAutoCommit;
1006 return "Illegal svcdb value in part_svc!";
1009 require "FS/$svcdb.pm";
1011 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
1013 $error = $svc->suspend;
1015 $dbh->rollback if $oldAutoCommit;
1018 my( $label, $value ) = $cust_svc->label;
1019 push @labels, "$label: $value";
1023 my $conf = new FS::Conf;
1024 if ( $conf->config('suspend_email_admin') ) {
1026 my $error = send_email(
1027 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
1028 #invoice_from ??? well as good as any
1029 'to' => $conf->config('suspend_email_admin'),
1030 'subject' => 'FREESIDE NOTIFICATION: Customer package suspended',
1032 "This is an automatic message from your Freeside installation\n",
1033 "informing you that the following customer package has been suspended:\n",
1035 'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
1036 'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
1037 ( map { "Service : $_\n" } @labels ),
1042 warn "WARNING: can't send suspension admin email (suspending anyway): ".
1050 my %hash = $self->hash;
1052 $hash{'adjourn'} = $date;
1054 $hash{'susp'} = $suspend_time;
1056 my $new = new FS::cust_pkg ( \%hash );
1057 $error = $new->replace( $self, options => { $self->options } );
1059 $dbh->rollback if $oldAutoCommit;
1063 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1068 =item unsuspend [ OPTION => VALUE ... ]
1070 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
1071 package, then unsuspends the package itself (clears the susp field and the
1072 adjourn field if it is in the past).
1074 Available options are:
1078 =item adjust_next_bill
1080 Can be set true to adjust the next bill date forward by
1081 the amount of time the account was inactive. This was set true by default
1082 since 1.4.2 and 1.5.0pre6; however, starting with 1.7.0 this needs to be
1083 explicitly requested. Price plans for which this makes sense (anniversary-date
1084 based than prorate or subscription) could have an option to enable this
1089 If there is an error, returns the error, otherwise returns false.
1094 my( $self, %opt ) = @_;
1097 local $SIG{HUP} = 'IGNORE';
1098 local $SIG{INT} = 'IGNORE';
1099 local $SIG{QUIT} = 'IGNORE';
1100 local $SIG{TERM} = 'IGNORE';
1101 local $SIG{TSTP} = 'IGNORE';
1102 local $SIG{PIPE} = 'IGNORE';
1104 my $oldAutoCommit = $FS::UID::AutoCommit;
1105 local $FS::UID::AutoCommit = 0;
1108 my $old = $self->select_for_update;
1110 my $pkgnum = $old->pkgnum;
1111 if ( $old->get('cancel') || $self->get('cancel') ) {
1112 dbh->rollback if $oldAutoCommit;
1113 return "Can't unsuspend cancelled package $pkgnum";
1116 unless ( $old->get('susp') && $self->get('susp') ) {
1117 dbh->rollback if $oldAutoCommit;
1118 return ""; # no error # complain instead?
1121 foreach my $cust_svc (
1122 qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
1124 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
1126 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
1127 $dbh->rollback if $oldAutoCommit;
1128 return "Illegal svcdb value in part_svc!";
1131 require "FS/$svcdb.pm";
1133 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
1135 $error = $svc->unsuspend;
1137 $dbh->rollback if $oldAutoCommit;
1144 my %hash = $self->hash;
1145 my $inactive = time - $hash{'susp'};
1147 my $conf = new FS::Conf;
1149 if ( $inactive > 0 &&
1150 ( $hash{'bill'} || $hash{'setup'} ) &&
1151 ( $opt{'adjust_next_bill'} ||
1152 $conf->exists('unsuspend-always_adjust_next_bill_date') ||
1153 $self->part_pkg->option('unsuspend_adjust_bill', 1) )
1156 $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive;
1161 $hash{'adjourn'} = '' if $hash{'adjourn'} < time;
1162 my $new = new FS::cust_pkg ( \%hash );
1163 $error = $new->replace( $self, options => { $self->options } );
1165 $dbh->rollback if $oldAutoCommit;
1169 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1176 Cancels any pending suspension (sets the adjourn field to null).
1178 If there is an error, returns the error, otherwise returns false.
1183 my( $self, %options ) = @_;
1186 local $SIG{HUP} = 'IGNORE';
1187 local $SIG{INT} = 'IGNORE';
1188 local $SIG{QUIT} = 'IGNORE';
1189 local $SIG{TERM} = 'IGNORE';
1190 local $SIG{TSTP} = 'IGNORE';
1191 local $SIG{PIPE} = 'IGNORE';
1193 my $oldAutoCommit = $FS::UID::AutoCommit;
1194 local $FS::UID::AutoCommit = 0;
1197 my $old = $self->select_for_update;
1199 my $pkgnum = $old->pkgnum;
1200 if ( $old->get('cancel') || $self->get('cancel') ) {
1201 dbh->rollback if $oldAutoCommit;
1202 return "Can't unadjourn cancelled package $pkgnum";
1203 # or at least it's pointless
1206 if ( $old->get('susp') || $self->get('susp') ) {
1207 dbh->rollback if $oldAutoCommit;
1208 return "Can't unadjourn suspended package $pkgnum";
1209 # perhaps this is arbitrary
1212 unless ( $old->get('adjourn') && $self->get('adjourn') ) {
1213 dbh->rollback if $oldAutoCommit;
1214 return ""; # no error
1217 my %hash = $self->hash;
1218 $hash{'adjourn'} = '';
1219 my $new = new FS::cust_pkg ( \%hash );
1220 $error = $new->replace( $self, options => { $self->options } );
1222 $dbh->rollback if $oldAutoCommit;
1226 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1233 =item change HASHREF | OPTION => VALUE ...
1235 Changes this package: cancels it and creates a new one, with a different
1236 pkgpart or locationnum or both. All services are transferred to the new
1237 package (no change will be made if this is not possible).
1239 Options may be passed as a list of key/value pairs or as a hash reference.
1246 New locationnum, to change the location for this package.
1250 New FS::cust_location object, to create a new location and assign it
1255 New pkgpart (see L<FS::part_pkg>).
1259 New refnum (see L<FS::part_referral>).
1263 Set to true to transfer billing dates (start_date, setup, last_bill, bill,
1264 susp, adjourn, cancel, expire, and contract_end) to the new package.
1268 At least one of locationnum, cust_location, pkgpart, refnum must be specified
1269 (otherwise, what's the point?)
1271 Returns either the new FS::cust_pkg object or a scalar error.
1275 my $err_or_new_cust_pkg = $old_cust_pkg->change
1279 #some false laziness w/order
1282 my $opt = ref($_[0]) ? shift : { @_ };
1284 # my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
1287 my $conf = new FS::Conf;
1289 # Transactionize this whole mess
1290 local $SIG{HUP} = 'IGNORE';
1291 local $SIG{INT} = 'IGNORE';
1292 local $SIG{QUIT} = 'IGNORE';
1293 local $SIG{TERM} = 'IGNORE';
1294 local $SIG{TSTP} = 'IGNORE';
1295 local $SIG{PIPE} = 'IGNORE';
1297 my $oldAutoCommit = $FS::UID::AutoCommit;
1298 local $FS::UID::AutoCommit = 0;
1307 #$hash{$_} = $self->$_() foreach qw( last_bill bill );
1309 #$hash{$_} = $self->$_() foreach qw( setup );
1311 $hash{'setup'} = $time if $self->setup;
1313 $hash{'change_date'} = $time;
1314 $hash{"change_$_"} = $self->$_()
1315 foreach qw( pkgnum pkgpart locationnum );
1317 if ( $opt->{'cust_location'} &&
1318 ( ! $opt->{'locationnum'} || $opt->{'locationnum'} == -1 ) ) {
1319 $error = $opt->{'cust_location'}->insert;
1321 $dbh->rollback if $oldAutoCommit;
1322 return "inserting cust_location (transaction rolled back): $error";
1324 $opt->{'locationnum'} = $opt->{'cust_location'}->locationnum;
1327 my $unused_credit = 0;
1328 if ( $opt->{'keep_dates'} ) {
1329 foreach my $date ( qw(setup bill last_bill susp adjourn cancel expire
1330 start_date contract_end ) ) {
1331 $hash{$date} = $self->getfield($date);
1334 # Special case. If the pkgpart is changing, and the customer is
1335 # going to be credited for remaining time, don't keep setup, bill,
1336 # or last_bill dates, and DO pass the flag to cancel() to credit
1338 if ( $opt->{'pkgpart'}
1339 and $opt->{'pkgpart'} != $self->pkgpart
1340 and $self->part_pkg->option('unused_credit_change', 1) ) {
1342 $hash{$_} = '' foreach qw(setup bill last_bill);
1345 # Create the new package.
1346 my $cust_pkg = new FS::cust_pkg {
1347 custnum => $self->custnum,
1348 pkgpart => ( $opt->{'pkgpart'} || $self->pkgpart ),
1349 refnum => ( $opt->{'refnum'} || $self->refnum ),
1350 locationnum => ( $opt->{'locationnum'} || $self->locationnum ),
1354 $error = $cust_pkg->insert( 'change' => 1 );
1356 $dbh->rollback if $oldAutoCommit;
1360 # Transfer services and cancel old package.
1362 $error = $self->transfer($cust_pkg);
1363 if ($error and $error == 0) {
1364 # $old_pkg->transfer failed.
1365 $dbh->rollback if $oldAutoCommit;
1369 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1370 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1371 $error = $self->transfer($cust_pkg, 'change_svcpart'=>1 );
1372 if ($error and $error == 0) {
1373 # $old_pkg->transfer failed.
1374 $dbh->rollback if $oldAutoCommit;
1380 # Transfers were successful, but we still had services left on the old
1381 # package. We can't change the package under this circumstances, so abort.
1382 $dbh->rollback if $oldAutoCommit;
1383 return "Unable to transfer all services from package ". $self->pkgnum;
1386 #reset usage if changing pkgpart
1387 # AND usage rollover is off (otherwise adds twice, now and at package bill)
1388 if ($self->pkgpart != $cust_pkg->pkgpart) {
1389 my $part_pkg = $cust_pkg->part_pkg;
1390 $error = $part_pkg->reset_usage($cust_pkg, $part_pkg->is_prepaid
1394 if $part_pkg->can('reset_usage') && ! $part_pkg->option('usage_rollover',1);
1397 $dbh->rollback if $oldAutoCommit;
1398 return "Error setting usage values: $error";
1402 #Good to go, cancel old package. Notify 'cancel' of whether to credit
1404 $error = $self->cancel( quiet=>1, unused_credit => $unused_credit );
1406 $dbh->rollback if $oldAutoCommit;
1410 if ( $conf->exists('cust_pkg-change_pkgpart-bill_now') ) {
1412 my $error = $cust_pkg->cust_main->bill( 'pkg_list' => [ $cust_pkg ] );
1414 $dbh->rollback if $oldAutoCommit;
1419 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1426 use Storable 'thaw';
1428 sub process_bulk_cust_pkg {
1430 my $param = thaw(decode_base64(shift));
1431 warn Dumper($param) if $DEBUG;
1433 my $old_part_pkg = qsearchs('part_pkg',
1434 { pkgpart => $param->{'old_pkgpart'} });
1435 my $new_part_pkg = qsearchs('part_pkg',
1436 { pkgpart => $param->{'new_pkgpart'} });
1437 die "Must select a new package type\n" unless $new_part_pkg;
1438 #my $keep_dates = $param->{'keep_dates'} || 0;
1439 my $keep_dates = 1; # there is no good reason to turn this off
1441 local $SIG{HUP} = 'IGNORE';
1442 local $SIG{INT} = 'IGNORE';
1443 local $SIG{QUIT} = 'IGNORE';
1444 local $SIG{TERM} = 'IGNORE';
1445 local $SIG{TSTP} = 'IGNORE';
1446 local $SIG{PIPE} = 'IGNORE';
1448 my $oldAutoCommit = $FS::UID::AutoCommit;
1449 local $FS::UID::AutoCommit = 0;
1452 my @cust_pkgs = qsearch('cust_pkg', { 'pkgpart' => $param->{'old_pkgpart'} } );
1455 foreach my $old_cust_pkg ( @cust_pkgs ) {
1457 $job->update_statustext(int(100*$i/(scalar @cust_pkgs)));
1458 if ( $old_cust_pkg->getfield('cancel') ) {
1459 warn '[process_bulk_cust_pkg ] skipping canceled pkgnum '.
1460 $old_cust_pkg->pkgnum."\n"
1464 warn '[process_bulk_cust_pkg] changing pkgnum '.$old_cust_pkg->pkgnum."\n"
1466 my $error = $old_cust_pkg->change(
1467 'pkgpart' => $param->{'new_pkgpart'},
1468 'keep_dates' => $keep_dates
1470 if ( !ref($error) ) { # change returns the cust_pkg on success
1472 die "Error changing pkgnum ".$old_cust_pkg->pkgnum.": '$error'\n";
1475 $dbh->commit if $oldAutoCommit;
1481 Returns the last bill date, or if there is no last bill date, the setup date.
1482 Useful for billing metered services.
1488 return $self->setfield('last_bill', $_[0]) if @_;
1489 return $self->getfield('last_bill') if $self->getfield('last_bill');
1490 my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
1491 'edate' => $self->bill, } );
1492 $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
1495 =item last_cust_pkg_reason ACTION
1497 Returns the most recent ACTION FS::cust_pkg_reason associated with the package.
1498 Returns false if there is no reason or the package is not currenly ACTION'd
1499 ACTION is one of adjourn, susp, cancel, or expire.
1503 sub last_cust_pkg_reason {
1504 my ( $self, $action ) = ( shift, shift );
1505 my $date = $self->get($action);
1507 'table' => 'cust_pkg_reason',
1508 'hashref' => { 'pkgnum' => $self->pkgnum,
1509 'action' => substr(uc($action), 0, 1),
1512 'order_by' => 'ORDER BY num DESC LIMIT 1',
1516 =item last_reason ACTION
1518 Returns the most recent ACTION FS::reason associated with the package.
1519 Returns false if there is no reason or the package is not currenly ACTION'd
1520 ACTION is one of adjourn, susp, cancel, or expire.
1525 my $cust_pkg_reason = shift->last_cust_pkg_reason(@_);
1526 $cust_pkg_reason->reason
1527 if $cust_pkg_reason;
1532 Returns the definition for this billing item, as an FS::part_pkg object (see
1539 return $self->{'_pkgpart'} if $self->{'_pkgpart'};
1540 cluck "cust_pkg->part_pkg called" if $DEBUG > 1;
1541 qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
1546 Returns the cancelled package this package was changed from, if any.
1552 return '' unless $self->change_pkgnum;
1553 qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
1558 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
1565 $self->part_pkg->calc_setup($self, @_);
1570 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
1577 $self->part_pkg->calc_recur($self, @_);
1582 Calls the I<base_recur> of the FS::part_pkg object associated with this billing
1589 $self->part_pkg->base_recur($self, @_);
1594 Calls the I<calc_remain> of the FS::part_pkg object associated with this
1601 $self->part_pkg->calc_remain($self, @_);
1606 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
1613 $self->part_pkg->calc_cancel($self, @_);
1618 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
1624 qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
1627 =item cust_pkg_detail [ DETAILTYPE ]
1629 Returns any customer package details for this package (see
1630 L<FS::cust_pkg_detail>).
1632 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
1636 sub cust_pkg_detail {
1638 my %hash = ( 'pkgnum' => $self->pkgnum );
1639 $hash{detailtype} = shift if @_;
1641 'table' => 'cust_pkg_detail',
1642 'hashref' => \%hash,
1643 'order_by' => 'ORDER BY weight, pkgdetailnum',
1647 =item set_cust_pkg_detail DETAILTYPE [ DETAIL, DETAIL, ... ]
1649 Sets customer package details for this package (see L<FS::cust_pkg_detail>).
1651 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
1653 If there is an error, returns the error, otherwise returns false.
1657 sub set_cust_pkg_detail {
1658 my( $self, $detailtype, @details ) = @_;
1660 local $SIG{HUP} = 'IGNORE';
1661 local $SIG{INT} = 'IGNORE';
1662 local $SIG{QUIT} = 'IGNORE';
1663 local $SIG{TERM} = 'IGNORE';
1664 local $SIG{TSTP} = 'IGNORE';
1665 local $SIG{PIPE} = 'IGNORE';
1667 my $oldAutoCommit = $FS::UID::AutoCommit;
1668 local $FS::UID::AutoCommit = 0;
1671 foreach my $current ( $self->cust_pkg_detail($detailtype) ) {
1672 my $error = $current->delete;
1674 $dbh->rollback if $oldAutoCommit;
1675 return "error removing old detail: $error";
1679 foreach my $detail ( @details ) {
1680 my $cust_pkg_detail = new FS::cust_pkg_detail {
1681 'pkgnum' => $self->pkgnum,
1682 'detailtype' => $detailtype,
1683 'detail' => $detail,
1685 my $error = $cust_pkg_detail->insert;
1687 $dbh->rollback if $oldAutoCommit;
1688 return "error adding new detail: $error";
1693 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1700 Returns the new-style customer billing events (see L<FS::cust_event>) for this invoice.
1704 #false laziness w/cust_bill.pm
1708 'table' => 'cust_event',
1709 'addl_from' => 'JOIN part_event USING ( eventpart )',
1710 'hashref' => { 'tablenum' => $self->pkgnum },
1711 'extra_sql' => " AND eventtable = 'cust_pkg' ",
1715 =item num_cust_event
1717 Returns the number of new-style customer billing events (see L<FS::cust_event>) for this invoice.
1721 #false laziness w/cust_bill.pm
1722 sub num_cust_event {
1725 "SELECT COUNT(*) FROM cust_event JOIN part_event USING ( eventpart ) ".
1726 " WHERE tablenum = ? AND eventtable = 'cust_pkg'";
1727 my $sth = dbh->prepare($sql) or die dbh->errstr. " preparing $sql";
1728 $sth->execute($self->pkgnum) or die $sth->errstr. " executing $sql";
1729 $sth->fetchrow_arrayref->[0];
1732 =item cust_svc [ SVCPART ]
1734 Returns the services for this package, as FS::cust_svc objects (see
1735 L<FS::cust_svc>). If a svcpart is specified, return only the matching
1743 return () unless $self->num_cust_svc(@_);
1746 return qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum,
1747 'svcpart' => shift, } );
1750 cluck "cust_pkg->cust_svc called" if $DEBUG > 2;
1752 #if ( $self->{'_svcnum'} ) {
1753 # values %{ $self->{'_svcnum'}->cache };
1755 $self->_sort_cust_svc(
1756 [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
1762 =item overlimit [ SVCPART ]
1764 Returns the services for this package which have exceeded their
1765 usage limit as FS::cust_svc objects (see L<FS::cust_svc>). If a svcpart
1766 is specified, return only the matching services.
1772 return () unless $self->num_cust_svc(@_);
1773 grep { $_->overlimit } $self->cust_svc(@_);
1776 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
1778 Returns historical services for this package created before END TIMESTAMP and
1779 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
1780 (see L<FS::h_cust_svc>). If MODE is 'I' (for 'invoice'), services with the
1781 I<pkg_svc.hidden> flag will be omitted.
1787 my ($end, $start, $mode) = @_;
1788 my @cust_svc = $self->_sort_cust_svc(
1789 [ qsearch( 'h_cust_svc',
1790 { 'pkgnum' => $self->pkgnum, },
1791 FS::h_cust_svc->sql_h_search(@_),
1794 if ( $mode eq 'I' ) {
1795 my %hidden_svcpart = map { $_->svcpart => $_->hidden } $self->part_svc;
1796 return grep { !$hidden_svcpart{$_->svcpart} } @cust_svc;
1803 sub _sort_cust_svc {
1804 my( $self, $arrayref ) = @_;
1807 sub ($$) { my ($a, $b) = @_; $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] };
1812 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
1813 'svcpart' => $_->svcpart } );
1815 $pkg_svc ? $pkg_svc->primary_svc : '',
1816 $pkg_svc ? $pkg_svc->quantity : 0,
1823 =item num_cust_svc [ SVCPART ]
1825 Returns the number of provisioned services for this package. If a svcpart is
1826 specified, counts only the matching services.
1833 return $self->{'_num_cust_svc'}
1835 && exists($self->{'_num_cust_svc'})
1836 && $self->{'_num_cust_svc'} =~ /\d/;
1838 cluck "cust_pkg->num_cust_svc called, _num_cust_svc:".$self->{'_num_cust_svc'}
1841 my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
1842 $sql .= ' AND svcpart = ?' if @_;
1844 my $sth = dbh->prepare($sql) or die dbh->errstr;
1845 $sth->execute($self->pkgnum, @_) or die $sth->errstr;
1846 $sth->fetchrow_arrayref->[0];
1849 =item available_part_svc
1851 Returns a list of FS::part_svc objects representing services included in this
1852 package but not yet provisioned. Each FS::part_svc object also has an extra
1853 field, I<num_avail>, which specifies the number of available services.
1857 sub available_part_svc {
1859 grep { $_->num_avail > 0 }
1861 my $part_svc = $_->part_svc;
1862 $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
1863 $_->quantity - $self->num_cust_svc($_->svcpart);
1865 # more evil encapsulation breakage
1866 if($part_svc->{'Hash'}{'num_avail'} > 0) {
1867 my @exports = $part_svc->part_export_did;
1868 $part_svc->{'Hash'}{'can_get_dids'} = scalar(@exports);
1873 $self->part_pkg->pkg_svc;
1878 Returns a list of FS::part_svc objects representing provisioned and available
1879 services included in this package. Each FS::part_svc object also has the
1880 following extra fields:
1884 =item num_cust_svc (count)
1886 =item num_avail (quantity - count)
1888 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
1891 label -> ($cust_svc->label)[1]
1900 #XXX some sort of sort order besides numeric by svcpart...
1901 my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
1903 my $part_svc = $pkg_svc->part_svc;
1904 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1905 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
1906 $part_svc->{'Hash'}{'num_avail'} =
1907 max( 0, $pkg_svc->quantity - $num_cust_svc );
1908 $part_svc->{'Hash'}{'cust_pkg_svc'} =
1909 $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
1910 $part_svc->{'Hash'}{'hidden'} = $pkg_svc->hidden;
1912 } $self->part_pkg->pkg_svc;
1915 push @part_svc, map {
1917 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1918 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
1919 $part_svc->{'Hash'}{'num_avail'} = 0; #0-$num_cust_svc ?
1920 $part_svc->{'Hash'}{'cust_pkg_svc'} =
1921 $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
1923 } $self->extra_part_svc;
1929 =item extra_part_svc
1931 Returns a list of FS::part_svc objects corresponding to services in this
1932 package which are still provisioned but not (any longer) available in the
1937 sub extra_part_svc {
1940 my $pkgnum = $self->pkgnum;
1941 my $pkgpart = $self->pkgpart;
1944 # 'table' => 'part_svc',
1947 # "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
1948 # WHERE pkg_svc.svcpart = part_svc.svcpart
1949 # AND pkg_svc.pkgpart = ?
1952 # AND 0 < ( SELECT COUNT(*) FROM cust_svc
1953 # LEFT JOIN cust_pkg USING ( pkgnum )
1954 # WHERE cust_svc.svcpart = part_svc.svcpart
1957 # 'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
1960 #seems to benchmark slightly faster...
1962 #'select' => 'DISTINCT ON (svcpart) part_svc.*',
1963 #MySQL doesn't grok DISINCT ON
1964 'select' => 'DISTINCT part_svc.*',
1965 'table' => 'part_svc',
1967 'LEFT JOIN pkg_svc ON ( pkg_svc.svcpart = part_svc.svcpart
1968 AND pkg_svc.pkgpart = ?
1971 LEFT JOIN cust_svc ON ( cust_svc.svcpart = part_svc.svcpart )
1972 LEFT JOIN cust_pkg USING ( pkgnum )
1975 'extra_sql' => "WHERE pkgsvcnum IS NULL AND cust_pkg.pkgnum = ? ",
1976 'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
1982 Returns a short status string for this package, currently:
1986 =item not yet billed
1988 =item one-time charge
2003 my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
2005 return 'cancelled' if $self->get('cancel');
2006 return 'suspended' if $self->susp;
2007 return 'not yet billed' unless $self->setup;
2008 return 'one-time charge' if $freq =~ /^(0|$)/;
2012 =item ucfirst_status
2014 Returns the status with the first character capitalized.
2018 sub ucfirst_status {
2019 ucfirst(shift->status);
2024 Class method that returns the list of possible status strings for packages
2025 (see L<the status method|/status>). For example:
2027 @statuses = FS::cust_pkg->statuses();
2031 tie my %statuscolor, 'Tie::IxHash',
2032 'not yet billed' => '009999', #teal? cyan?
2033 'one-time charge' => '000000',
2034 'active' => '00CC00',
2035 'suspended' => 'FF9900',
2036 'cancelled' => 'FF0000',
2040 my $self = shift; #could be class...
2041 #grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
2042 # # mayble split btw one-time vs. recur
2048 Returns a hex triplet color string for this package's status.
2054 $statuscolor{$self->status};
2059 Returns a label for this package. (Currently "pkgnum: pkg - comment" or
2060 "pkg-comment" depending on user preference).
2066 my $label = $self->part_pkg->pkg_comment( 'nopkgpart' => 1 );
2067 $label = $self->pkgnum. ": $label"
2068 if $FS::CurrentUser::CurrentUser->option('show_pkgnum');
2072 =item pkg_label_long
2074 Returns a long label for this package, adding the primary service's label to
2079 sub pkg_label_long {
2081 my $label = $self->pkg_label;
2082 my $cust_svc = $self->primary_cust_svc;
2083 $label .= ' ('. ($cust_svc->label)[1]. ')' if $cust_svc;
2087 =item primary_cust_svc
2089 Returns a primary service (as FS::cust_svc object) if one can be identified.
2093 #for labeling purposes - might not 100% match up with part_pkg->svcpart's idea
2095 sub primary_cust_svc {
2098 my @cust_svc = $self->cust_svc;
2100 return '' unless @cust_svc; #no serivces - irrelevant then
2102 return $cust_svc[0] if scalar(@cust_svc) == 1; #always return a single service
2104 # primary service as specified in the package definition
2105 # or exactly one service definition with quantity one
2106 my $svcpart = $self->part_pkg->svcpart;
2107 @cust_svc = grep { $_->svcpart == $svcpart } @cust_svc;
2108 return $cust_svc[0] if scalar(@cust_svc) == 1;
2110 #couldn't identify one thing..
2116 Returns a list of lists, calling the label method for all services
2117 (see L<FS::cust_svc>) of this billing item.
2123 map { [ $_->label ] } $self->cust_svc;
2126 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
2128 Like the labels method, but returns historical information on services that
2129 were active as of END_TIMESTAMP and (optionally) not cancelled before
2130 START_TIMESTAMP. If MODE is 'I' (for 'invoice'), services with the
2131 I<pkg_svc.hidden> flag will be omitted.
2133 Returns a list of lists, calling the label method for all (historical) services
2134 (see L<FS::h_cust_svc>) of this billing item.
2140 map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
2145 Like labels, except returns a simple flat list, and shortens long
2146 (currently >5 or the cust_bill-max_same_services configuration value) lists of
2147 identical services to one line that lists the service label and the number of
2148 individual services rather than individual items.
2153 shift->_labels_short( 'labels', @_ );
2156 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
2158 Like h_labels, except returns a simple flat list, and shortens long
2159 (currently >5 or the cust_bill-max_same_services configuration value) lists of
2160 identical services to one line that lists the service label and the number of
2161 individual services rather than individual items.
2165 sub h_labels_short {
2166 shift->_labels_short( 'h_labels', @_ );
2170 my( $self, $method ) = ( shift, shift );
2172 my $conf = new FS::Conf;
2173 my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
2176 #tie %labels, 'Tie::IxHash';
2177 push @{ $labels{$_->[0]} }, $_->[1]
2178 foreach $self->$method(@_);
2180 foreach my $label ( keys %labels ) {
2182 my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
2183 my $num = scalar(@values);
2184 if ( $num > $max_same_services ) {
2185 push @labels, "$label ($num)";
2187 if ( $conf->exists('cust_bill-consolidate_services') ) {
2188 # push @labels, "$label: ". join(', ', @values);
2190 my $detail = "$label: ";
2191 $detail .= shift(@values). ', '
2192 while @values && length($detail.$values[0]) < 78;
2194 push @labels, $detail;
2197 push @labels, map { "$label: $_" } @values;
2208 Returns the parent customer object (see L<FS::cust_main>).
2214 qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
2217 #these subs are in location_Mixin.pm now... unfortunately the POD doesn't mixin
2221 Returns the location object, if any (see L<FS::cust_location>).
2223 =item cust_location_or_main
2225 If this package is associated with a location, returns the locaiton (see
2226 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
2228 =item location_label [ OPTION => VALUE ... ]
2230 Returns the label of the location object (see L<FS::cust_location>).
2234 #end of subs in location_Mixin.pm now... unfortunately the POD doesn't mixin
2236 =item seconds_since TIMESTAMP
2238 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
2239 package have been online since TIMESTAMP, according to the session monitor.
2241 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
2242 L<Time::Local> and L<Date::Parse> for conversion functions.
2247 my($self, $since) = @_;
2250 foreach my $cust_svc (
2251 grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
2253 $seconds += $cust_svc->seconds_since($since);
2260 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2262 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
2263 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
2266 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2267 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2273 sub seconds_since_sqlradacct {
2274 my($self, $start, $end) = @_;
2278 foreach my $cust_svc (
2280 my $part_svc = $_->part_svc;
2281 $part_svc->svcdb eq 'svc_acct'
2282 && scalar($part_svc->part_export('sqlradius'));
2285 $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
2292 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2294 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2295 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2299 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2300 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2305 sub attribute_since_sqlradacct {
2306 my($self, $start, $end, $attrib) = @_;
2310 foreach my $cust_svc (
2312 my $part_svc = $_->part_svc;
2313 $part_svc->svcdb eq 'svc_acct'
2314 && scalar($part_svc->part_export('sqlradius'));
2317 $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
2329 my( $self, $value ) = @_;
2330 if ( defined($value) ) {
2331 $self->setfield('quantity', $value);
2333 $self->getfield('quantity') || 1;
2336 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
2338 Transfers as many services as possible from this package to another package.
2340 The destination package can be specified by pkgnum by passing an FS::cust_pkg
2341 object. The destination package must already exist.
2343 Services are moved only if the destination allows services with the correct
2344 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true. Use
2345 this option with caution! No provision is made for export differences
2346 between the old and new service definitions. Probably only should be used
2347 when your exports for all service definitions of a given svcdb are identical.
2348 (attempt a transfer without it first, to move all possible svcpart-matching
2351 Any services that can't be moved remain in the original package.
2353 Returns an error, if there is one; otherwise, returns the number of services
2354 that couldn't be moved.
2359 my ($self, $dest_pkgnum, %opt) = @_;
2365 if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
2366 $dest = $dest_pkgnum;
2367 $dest_pkgnum = $dest->pkgnum;
2369 $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
2372 return ('Package does not exist: '.$dest_pkgnum) unless $dest;
2374 foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
2375 $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
2378 foreach my $cust_svc ($dest->cust_svc) {
2379 $target{$cust_svc->svcpart}--;
2382 my %svcpart2svcparts = ();
2383 if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2384 warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
2385 foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
2386 next if exists $svcpart2svcparts{$svcpart};
2387 my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
2388 $svcpart2svcparts{$svcpart} = [
2390 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
2392 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
2393 'svcpart' => $_ } );
2395 $pkg_svc ? $pkg_svc->primary_svc : '',
2396 $pkg_svc ? $pkg_svc->quantity : 0,
2400 grep { $_ != $svcpart }
2402 qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
2404 warn "alternates for svcpart $svcpart: ".
2405 join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
2410 foreach my $cust_svc ($self->cust_svc) {
2411 if($target{$cust_svc->svcpart} > 0) {
2412 $target{$cust_svc->svcpart}--;
2413 my $new = new FS::cust_svc { $cust_svc->hash };
2414 $new->pkgnum($dest_pkgnum);
2415 my $error = $new->replace($cust_svc);
2416 return $error if $error;
2417 } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2419 warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
2420 warn "alternates to consider: ".
2421 join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
2423 my @alternate = grep {
2424 warn "considering alternate svcpart $_: ".
2425 "$target{$_} available in new package\n"
2428 } @{$svcpart2svcparts{$cust_svc->svcpart}};
2430 warn "alternate(s) found\n" if $DEBUG;
2431 my $change_svcpart = $alternate[0];
2432 $target{$change_svcpart}--;
2433 my $new = new FS::cust_svc { $cust_svc->hash };
2434 $new->svcpart($change_svcpart);
2435 $new->pkgnum($dest_pkgnum);
2436 my $error = $new->replace($cust_svc);
2437 return $error if $error;
2450 This method is deprecated. See the I<depend_jobnum> option to the insert and
2451 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
2458 local $SIG{HUP} = 'IGNORE';
2459 local $SIG{INT} = 'IGNORE';
2460 local $SIG{QUIT} = 'IGNORE';
2461 local $SIG{TERM} = 'IGNORE';
2462 local $SIG{TSTP} = 'IGNORE';
2463 local $SIG{PIPE} = 'IGNORE';
2465 my $oldAutoCommit = $FS::UID::AutoCommit;
2466 local $FS::UID::AutoCommit = 0;
2469 foreach my $cust_svc ( $self->cust_svc ) {
2470 #false laziness w/svc_Common::insert
2471 my $svc_x = $cust_svc->svc_x;
2472 foreach my $part_export ( $cust_svc->part_svc->part_export ) {
2473 my $error = $part_export->export_insert($svc_x);
2475 $dbh->rollback if $oldAutoCommit;
2481 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2488 Associates this package with a (suspension or cancellation) reason (see
2489 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
2492 Available options are:
2498 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.
2502 the access_user (see L<FS::access_user>) providing the reason
2510 the action (cancel, susp, adjourn, expire) associated with the reason
2514 If there is an error, returns the error, otherwise returns false.
2519 my ($self, %options) = @_;
2521 my $otaker = $options{reason_otaker} ||
2522 $FS::CurrentUser::CurrentUser->username;
2525 if ( $options{'reason'} =~ /^(\d+)$/ ) {
2529 } elsif ( ref($options{'reason'}) ) {
2531 return 'Enter a new reason (or select an existing one)'
2532 unless $options{'reason'}->{'reason'} !~ /^\s*$/;
2534 my $reason = new FS::reason({
2535 'reason_type' => $options{'reason'}->{'typenum'},
2536 'reason' => $options{'reason'}->{'reason'},
2538 my $error = $reason->insert;
2539 return $error if $error;
2541 $reasonnum = $reason->reasonnum;
2544 return "Unparsable reason: ". $options{'reason'};
2547 my $cust_pkg_reason =
2548 new FS::cust_pkg_reason({ 'pkgnum' => $self->pkgnum,
2549 'reasonnum' => $reasonnum,
2550 'otaker' => $otaker,
2551 'action' => substr(uc($options{'action'}),0,1),
2552 'date' => $options{'date'}
2557 $cust_pkg_reason->insert;
2560 =item insert_discount
2562 Associates this package with a discount (see L<FS::cust_pkg_discount>, possibly
2563 inserting a new discount on the fly (see L<FS::discount>).
2565 Available options are:
2573 If there is an error, returns the error, otherwise returns false.
2577 sub insert_discount {
2578 #my ($self, %options) = @_;
2581 my $cust_pkg_discount = new FS::cust_pkg_discount {
2582 'pkgnum' => $self->pkgnum,
2583 'discountnum' => $self->discountnum,
2585 'end_date' => '', #XXX
2586 #for the create a new discount case
2587 '_type' => $self->discountnum__type,
2588 'amount' => $self->discountnum_amount,
2589 'percent' => $self->discountnum_percent,
2590 'months' => $self->discountnum_months,
2591 #'disabled' => $self->discountnum_disabled,
2594 $cust_pkg_discount->insert;
2597 =item set_usage USAGE_VALUE_HASHREF
2599 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2600 to which they should be set (see L<FS::svc_acct>). Currently seconds,
2601 upbytes, downbytes, and totalbytes are appropriate keys.
2603 All svc_accts which are part of this package have their values reset.
2608 my ($self, $valueref, %opt) = @_;
2610 foreach my $cust_svc ($self->cust_svc){
2611 my $svc_x = $cust_svc->svc_x;
2612 $svc_x->set_usage($valueref, %opt)
2613 if $svc_x->can("set_usage");
2617 =item recharge 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 incremented.
2628 my ($self, $valueref) = @_;
2630 foreach my $cust_svc ($self->cust_svc){
2631 my $svc_x = $cust_svc->svc_x;
2632 $svc_x->recharge($valueref)
2633 if $svc_x->can("recharge");
2637 =item cust_pkg_discount
2641 sub cust_pkg_discount {
2643 qsearch('cust_pkg_discount', { 'pkgnum' => $self->pkgnum } );
2646 =item cust_pkg_discount_active
2650 sub cust_pkg_discount_active {
2652 grep { $_->status eq 'active' } $self->cust_pkg_discount;
2657 =head1 CLASS METHODS
2663 Returns an SQL expression identifying recurring packages.
2667 sub recurring_sql { "
2668 '0' != ( select freq from part_pkg
2669 where cust_pkg.pkgpart = part_pkg.pkgpart )
2674 Returns an SQL expression identifying one-time packages.
2679 '0' = ( select freq from part_pkg
2680 where cust_pkg.pkgpart = part_pkg.pkgpart )
2685 Returns an SQL expression identifying ordered packages (recurring packages not
2691 $_[0]->recurring_sql. " AND ". $_[0]->not_yet_billed_sql;
2696 Returns an SQL expression identifying active packages.
2701 $_[0]->recurring_sql. "
2702 AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
2703 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2704 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
2707 =item not_yet_billed_sql
2709 Returns an SQL expression identifying packages which have not yet been billed.
2713 sub not_yet_billed_sql { "
2714 ( cust_pkg.setup IS NULL OR cust_pkg.setup = 0 )
2715 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2716 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
2721 Returns an SQL expression identifying inactive packages (one-time packages
2722 that are otherwise unsuspended/uncancelled).
2726 sub inactive_sql { "
2727 ". $_[0]->onetime_sql(). "
2728 AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
2729 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2730 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
2736 Returns an SQL expression identifying suspended packages.
2740 sub suspended_sql { susp_sql(@_); }
2742 #$_[0]->recurring_sql(). ' AND '.
2744 ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2745 AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0
2752 Returns an SQL exprression identifying cancelled packages.
2756 sub cancelled_sql { cancel_sql(@_); }
2758 #$_[0]->recurring_sql(). ' AND '.
2759 "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
2764 Returns an SQL expression to give the package status as a string.
2770 WHEN cust_pkg.cancel IS NOT NULL THEN 'cancelled'
2771 WHEN cust_pkg.susp IS NOT NULL THEN 'suspended'
2772 WHEN cust_pkg.setup IS NULL THEN 'not yet billed'
2773 WHEN ".onetime_sql()." THEN 'one-time charge'
2778 =item search HASHREF
2782 Returns a qsearch hash expression to search for parameters specified in HASHREF.
2783 Valid parameters are
2791 active, inactive, suspended, cancel (or cancelled)
2795 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
2799 boolean selects custom packages
2805 pkgpart or arrayref or hashref of pkgparts
2809 arrayref of beginning and ending epoch date
2813 arrayref of beginning and ending epoch date
2817 arrayref of beginning and ending epoch date
2821 arrayref of beginning and ending epoch date
2825 arrayref of beginning and ending epoch date
2829 arrayref of beginning and ending epoch date
2833 arrayref of beginning and ending epoch date
2837 pkgnum or APKG_pkgnum
2841 a value suited to passing to FS::UI::Web::cust_header
2845 specifies the user for agent virtualization
2849 boolean selects packages containing fcc form 477 telco lines
2856 my ($class, $params) = @_;
2863 if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2865 "cust_main.agentnum = $1";
2872 if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
2874 "cust_pkg.custnum = $1";
2881 if ( $params->{'pkgbatch'} =~ /^([\w\/\-\:\.]+)$/ and $1 ) {
2883 "cust_pkg.pkgbatch = '$1'";
2890 if ( $params->{'magic'} eq 'active'
2891 || $params->{'status'} eq 'active' ) {
2893 push @where, FS::cust_pkg->active_sql();
2895 } elsif ( $params->{'magic'} =~ /^not[ _]yet[ _]billed$/
2896 || $params->{'status'} =~ /^not[ _]yet[ _]billed$/ ) {
2898 push @where, FS::cust_pkg->not_yet_billed_sql();
2900 } elsif ( $params->{'magic'} =~ /^(one-time charge|inactive)/
2901 || $params->{'status'} =~ /^(one-time charge|inactive)/ ) {
2903 push @where, FS::cust_pkg->inactive_sql();
2905 } elsif ( $params->{'magic'} eq 'suspended'
2906 || $params->{'status'} eq 'suspended' ) {
2908 push @where, FS::cust_pkg->suspended_sql();
2910 } elsif ( $params->{'magic'} =~ /^cancell?ed$/
2911 || $params->{'status'} =~ /^cancell?ed$/ ) {
2913 push @where, FS::cust_pkg->cancelled_sql();
2918 # parse package class
2921 #false lazinessish w/graph/cust_bill_pkg.cgi
2924 if ( exists($params->{'classnum'})
2925 && $params->{'classnum'} =~ /^(\d*)$/
2929 if ( $classnum ) { #a specific class
2930 push @where, "part_pkg.classnum = $classnum";
2932 #@pkg_class = ( qsearchs('pkg_class', { 'classnum' => $classnum } ) );
2933 #die "classnum $classnum not found!" unless $pkg_class[0];
2934 #$title .= $pkg_class[0]->classname.' ';
2936 } elsif ( $classnum eq '' ) { #the empty class
2938 push @where, "part_pkg.classnum IS NULL";
2939 #$title .= 'Empty class ';
2940 #@pkg_class = ( '(empty class)' );
2941 } elsif ( $classnum eq '0' ) {
2942 #@pkg_class = qsearch('pkg_class', {} ); # { 'disabled' => '' } );
2943 #push @pkg_class, '(empty class)';
2945 die "illegal classnum";
2951 # parse package report options
2954 my @report_option = ();
2955 if ( exists($params->{'report_option'})
2956 && $params->{'report_option'} =~ /^([,\d]*)$/
2959 @report_option = split(',', $1);
2962 if (@report_option) {
2963 # this will result in the empty set for the dangling comma case as it should
2965 map{ "0 < ( SELECT count(*) FROM part_pkg_option
2966 WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
2967 AND optionname = 'report_option_$_'
2968 AND optionvalue = '1' )"
2978 push @where, "part_pkg.custom = 'Y'" if $params->{custom};
2984 push @where, "part_pkg.fcc_ds0s > 0" if $params->{fcc_line};
2990 if ( exists($params->{'censustract'}) ) {
2991 $params->{'censustract'} =~ /^([.\d]*)$/;
2992 my $censustract = "cust_main.censustract = '$1'";
2993 $censustract .= ' OR cust_main.censustract is NULL' unless $1;
2994 push @where, "( $censustract )";
3001 if ( ref($params->{'pkgpart'}) ) {
3004 if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
3005 @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
3006 } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
3007 @pkgpart = @{ $params->{'pkgpart'} };
3009 die 'unhandled pkgpart ref '. $params->{'pkgpart'};
3012 @pkgpart = grep /^(\d+)$/, @pkgpart;
3014 push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
3016 } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
3017 push @where, "pkgpart = $1";
3026 #false laziness w/report_cust_pkg.html
3029 'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
3030 'active' => { 'susp'=>1, 'cancel'=>1 },
3031 'suspended' => { 'cancel' => 1 },
3036 if( exists($params->{'active'} ) ) {
3037 # This overrides all the other date-related fields
3038 my($beginning, $ending) = @{$params->{'active'}};
3040 "cust_pkg.setup IS NOT NULL",
3041 "cust_pkg.setup <= $ending",
3042 "(cust_pkg.cancel IS NULL OR cust_pkg.cancel >= $beginning )",
3043 "NOT (".FS::cust_pkg->onetime_sql . ")";
3046 foreach my $field (qw( setup last_bill bill adjourn susp expire contract_end cancel )) {
3048 next unless exists($params->{$field});
3050 my($beginning, $ending) = @{$params->{$field}};
3052 next if $beginning == 0 && $ending == 4294967295;
3055 "cust_pkg.$field IS NOT NULL",
3056 "cust_pkg.$field >= $beginning",
3057 "cust_pkg.$field <= $ending";
3059 $orderby ||= "ORDER BY cust_pkg.$field";
3064 $orderby ||= 'ORDER BY bill';
3067 # parse magic, legacy, etc.
3070 if ( $params->{'magic'} &&
3071 $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
3074 $orderby = 'ORDER BY pkgnum';
3076 if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
3077 push @where, "pkgpart = $1";
3080 } elsif ( $params->{'query'} eq 'pkgnum' ) {
3082 $orderby = 'ORDER BY pkgnum';
3084 } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
3086 $orderby = 'ORDER BY pkgnum';
3089 SELECT count(*) FROM pkg_svc
3090 WHERE pkg_svc.pkgpart = cust_pkg.pkgpart
3091 AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
3092 WHERE cust_svc.pkgnum = cust_pkg.pkgnum
3093 AND cust_svc.svcpart = pkg_svc.svcpart
3100 # setup queries, links, subs, etc. for the search
3103 # here is the agent virtualization
3104 if ($params->{CurrentUser}) {
3106 qsearchs('access_user', { username => $params->{CurrentUser} });
3109 push @where, $access_user->agentnums_sql('table'=>'cust_main');
3114 push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
3117 my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
3119 my $addl_from = 'LEFT JOIN cust_main USING ( custnum ) '.
3120 'LEFT JOIN part_pkg USING ( pkgpart ) '.
3121 'LEFT JOIN pkg_class ON ( part_pkg.classnum = pkg_class.classnum ) ';
3123 my $count_query = "SELECT COUNT(*) FROM cust_pkg $addl_from $extra_sql";
3126 'table' => 'cust_pkg',
3128 'select' => join(', ',
3130 ( map "part_pkg.$_", qw( pkg freq ) ),
3131 'pkg_class.classname',
3132 'cust_main.custnum AS cust_main_custnum',
3133 FS::UI::Web::cust_sql_fields(
3134 $params->{'cust_fields'}
3137 'extra_sql' => "$extra_sql $orderby",
3138 'addl_from' => $addl_from,
3139 'count_query' => $count_query,
3146 Returns a list of two package counts. The first is a count of packages
3147 based on the supplied criteria and the second is the count of residential
3148 packages with those same criteria. Criteria are specified as in the search
3154 my ($class, $params) = @_;
3156 my $sql_query = $class->search( $params );
3158 my $count_sql = delete($sql_query->{'count_query'});
3159 $count_sql =~ s/ FROM/,count(CASE WHEN cust_main.company IS NULL OR cust_main.company = '' THEN 1 END) FROM/
3160 or die "couldn't parse count_sql";
3162 my $count_sth = dbh->prepare($count_sql)
3163 or die "Error preparing $count_sql: ". dbh->errstr;
3165 or die "Error executing $count_sql: ". $count_sth->errstr;
3166 my $count_arrayref = $count_sth->fetchrow_arrayref;
3168 return ( @$count_arrayref );
3175 Returns a list: the first item is an SQL fragment identifying matching
3176 packages/customers via location (taking into account shipping and package
3177 address taxation, if enabled), and subsequent items are the parameters to
3178 substitute for the placeholders in that fragment.
3183 my($class, %opt) = @_;
3184 my $ornull = $opt{'ornull'};
3186 my $conf = new FS::Conf;
3188 # '?' placeholders in _location_sql_where
3189 my $x = $ornull ? 3 : 2;
3190 my @bill_param = ( ('city')x3, ('county')x$x, ('state')x$x, 'country' );
3194 if ( $conf->exists('tax-ship_address') ) {
3197 ( ( ship_last IS NULL OR ship_last = '' )
3198 AND ". _location_sql_where('cust_main', '', $ornull ). "
3200 OR ( ship_last IS NOT NULL AND ship_last != ''
3201 AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
3204 # AND payby != 'COMP'
3206 @main_param = ( @bill_param, @bill_param );
3210 $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
3211 @main_param = @bill_param;
3217 if ( $conf->exists('tax-pkg_address') ) {
3219 my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
3222 ( cust_pkg.locationnum IS NULL AND $main_where )
3223 OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where )
3226 @param = ( @main_param, @bill_param );
3230 $where = $main_where;
3231 @param = @main_param;
3239 #subroutine, helper for location_sql
3240 sub _location_sql_where {
3242 my $prefix = @_ ? shift : '';
3243 my $ornull = @_ ? shift : '';
3245 # $ornull = $ornull ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
3247 $ornull = $ornull ? ' OR ? IS NULL ' : '';
3249 my $or_empty_city = " OR ( ? = '' AND $table.${prefix}city IS NULL ) ";
3250 my $or_empty_county = " OR ( ? = '' AND $table.${prefix}county IS NULL ) ";
3251 my $or_empty_state = " OR ( ? = '' AND $table.${prefix}state IS NULL ) ";
3253 # ( $table.${prefix}city = ? $or_empty_city $ornull )
3255 ( $table.${prefix}city = ? OR ? = '' OR CAST(? AS text) IS NULL )
3256 AND ( $table.${prefix}county = ? $or_empty_county $ornull )
3257 AND ( $table.${prefix}state = ? $or_empty_state $ornull )
3258 AND $table.${prefix}country = ?
3266 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
3268 CUSTNUM is a customer (see L<FS::cust_main>)
3270 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
3271 L<FS::part_pkg>) to order for this customer. Duplicates are of course
3274 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
3275 remove for this customer. The services (see L<FS::cust_svc>) are moved to the
3276 new billing items. An error is returned if this is not possible (see
3277 L<FS::pkg_svc>). An empty arrayref is equivalent to not specifying this
3280 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
3281 newly-created cust_pkg objects.
3283 REFNUM, if specified, will specify the FS::pkg_referral record to be created
3284 and inserted. Multiple FS::pkg_referral records can be created by
3285 setting I<refnum> to an array reference of refnums or a hash reference with
3286 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
3287 record will be created corresponding to cust_main.refnum.
3292 my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
3294 my $conf = new FS::Conf;
3296 # Transactionize this whole mess
3297 local $SIG{HUP} = 'IGNORE';
3298 local $SIG{INT} = 'IGNORE';
3299 local $SIG{QUIT} = 'IGNORE';
3300 local $SIG{TERM} = 'IGNORE';
3301 local $SIG{TSTP} = 'IGNORE';
3302 local $SIG{PIPE} = 'IGNORE';
3304 my $oldAutoCommit = $FS::UID::AutoCommit;
3305 local $FS::UID::AutoCommit = 0;
3309 # my $cust_main = qsearchs('cust_main', { custnum => $custnum });
3310 # return "Customer not found: $custnum" unless $cust_main;
3312 warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
3315 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
3318 my $change = scalar(@old_cust_pkg) != 0;
3321 if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
3323 warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
3324 " to pkgpart ". $pkgparts->[0]. "\n"
3327 my $err_or_cust_pkg =
3328 $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
3329 'refnum' => $refnum,
3332 unless (ref($err_or_cust_pkg)) {
3333 $dbh->rollback if $oldAutoCommit;
3334 return $err_or_cust_pkg;
3337 push @$return_cust_pkg, $err_or_cust_pkg;
3338 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3343 # Create the new packages.
3344 foreach my $pkgpart (@$pkgparts) {
3346 warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
3348 my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
3349 pkgpart => $pkgpart,
3353 $error = $cust_pkg->insert( 'change' => $change );
3355 $dbh->rollback if $oldAutoCommit;
3358 push @$return_cust_pkg, $cust_pkg;
3360 # $return_cust_pkg now contains refs to all of the newly
3363 # Transfer services and cancel old packages.
3364 foreach my $old_pkg (@old_cust_pkg) {
3366 warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
3369 foreach my $new_pkg (@$return_cust_pkg) {
3370 $error = $old_pkg->transfer($new_pkg);
3371 if ($error and $error == 0) {
3372 # $old_pkg->transfer failed.
3373 $dbh->rollback if $oldAutoCommit;
3378 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
3379 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
3380 foreach my $new_pkg (@$return_cust_pkg) {
3381 $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
3382 if ($error and $error == 0) {
3383 # $old_pkg->transfer failed.
3384 $dbh->rollback if $oldAutoCommit;
3391 # Transfers were successful, but we went through all of the
3392 # new packages and still had services left on the old package.
3393 # We can't cancel the package under the circumstances, so abort.
3394 $dbh->rollback if $oldAutoCommit;
3395 return "Unable to transfer all services from package ".$old_pkg->pkgnum;
3397 $error = $old_pkg->cancel( quiet=>1 );
3403 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3407 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
3409 A bulk change method to change packages for multiple customers.
3411 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
3412 L<FS::part_pkg>) to order for each customer. Duplicates are of course
3415 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
3416 replace. The services (see L<FS::cust_svc>) are moved to the
3417 new billing items. An error is returned if this is not possible (see
3420 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
3421 newly-created cust_pkg objects.
3426 my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
3428 # Transactionize this whole mess
3429 local $SIG{HUP} = 'IGNORE';
3430 local $SIG{INT} = 'IGNORE';
3431 local $SIG{QUIT} = 'IGNORE';
3432 local $SIG{TERM} = 'IGNORE';
3433 local $SIG{TSTP} = 'IGNORE';
3434 local $SIG{PIPE} = 'IGNORE';
3436 my $oldAutoCommit = $FS::UID::AutoCommit;
3437 local $FS::UID::AutoCommit = 0;
3441 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
3444 while(scalar(@old_cust_pkg)) {
3446 my $custnum = $old_cust_pkg[0]->custnum;
3447 my (@remove) = map { $_->pkgnum }
3448 grep { $_->custnum == $custnum } @old_cust_pkg;
3449 @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
3451 my $error = order $custnum, $pkgparts, \@remove, \@return;
3453 push @errors, $error
3455 push @$return_cust_pkg, @return;
3458 if (scalar(@errors)) {
3459 $dbh->rollback if $oldAutoCommit;
3460 return join(' / ', @errors);
3463 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3467 # Used by FS::Upgrade to migrate to a new database.
3468 sub _upgrade_data { # class method
3469 my ($class, %opts) = @_;
3470 $class->_upgrade_otaker(%opts);
3472 # RT#10139, bug resulting in contract_end being set when it shouldn't
3473 'UPDATE cust_pkg SET contract_end = NULL WHERE contract_end = -1',
3474 # RT#10830, bad calculation of prorate date near end of year
3475 # the date range for bill is December 2009, and we move it forward
3476 # one year if it's before the previous bill date (which it should
3478 'UPDATE cust_pkg SET bill = bill + (365*24*60*60) WHERE bill < last_bill
3479 AND bill > 1259654400 AND bill < 1262332800 AND (SELECT plan FROM part_pkg
3480 WHERE part_pkg.pkgpart = cust_pkg.pkgpart) = \'prorate\'',
3481 # RT6628, add order_date to cust_pkg
3482 'update cust_pkg set order_date = (select history_date from h_cust_pkg
3483 where h_cust_pkg.pkgnum = cust_pkg.pkgnum and
3484 history_action = \'insert\') where order_date is null',
3486 foreach my $sql (@statements) {
3487 my $sth = dbh->prepare($sql);
3488 $sth->execute or die $sth->errstr;
3496 sub order is not OO. Perhaps it should be moved to FS::cust_main and made so?
3498 In sub order, the @pkgparts array (passed by reference) is clobbered.
3500 Also in sub order, no money is adjusted. Once FS::part_pkg defines a standard
3501 method to pass dates to the recur_prog expression, it should do so.
3503 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
3504 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
3505 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
3506 configuration values. Probably need a subroutine which decides what to do
3507 based on whether or not we've fetched the user yet, rather than a hash. See
3508 FS::UID and the TODO.
3510 Now that things are transactional should the check in the insert method be
3515 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
3516 L<FS::pkg_svc>, schema.html from the base documentation