4 use base qw( FS::otaker_Mixin FS::cust_main_Mixin FS::location_Mixin
5 FS::m2m_Common FS::option_Common );
6 use vars qw($disable_agentcheck $DEBUG $me);
8 use Scalar::Util qw( blessed );
9 use List::Util qw(max);
11 use Time::Local qw( timelocal_nocheck );
13 use FS::UID qw( getotaker dbh );
14 use FS::Misc qw( send_email );
15 use FS::Record qw( qsearch qsearchs );
20 use FS::cust_location;
22 use FS::cust_bill_pkg;
23 use FS::cust_pkg_detail;
28 use FS::cust_pkg_reason;
30 use FS::cust_pkg_discount;
34 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
36 # because they load configuration by setting FS::UID::callback (see TODO)
42 # for sending cancel emails in sub cancel
46 $me = '[FS::cust_pkg]';
48 $disable_agentcheck = 0;
52 my ( $hashref, $cache ) = @_;
53 #if ( $hashref->{'pkgpart'} ) {
54 if ( $hashref->{'pkg'} ) {
55 # #@{ $self->{'_pkgnum'} } = ();
56 # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
57 # $self->{'_pkgpart'} = $subcache;
58 # #push @{ $self->{'_pkgnum'} },
59 # FS::part_pkg->new_or_cached($hashref, $subcache);
60 $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
62 if ( exists $hashref->{'svcnum'} ) {
63 #@{ $self->{'_pkgnum'} } = ();
64 my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
65 $self->{'_svcnum'} = $subcache;
66 #push @{ $self->{'_pkgnum'} },
67 FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
73 FS::cust_pkg - Object methods for cust_pkg objects
79 $record = new FS::cust_pkg \%hash;
80 $record = new FS::cust_pkg { 'column' => 'value' };
82 $error = $record->insert;
84 $error = $new_record->replace($old_record);
86 $error = $record->delete;
88 $error = $record->check;
90 $error = $record->cancel;
92 $error = $record->suspend;
94 $error = $record->unsuspend;
96 $part_pkg = $record->part_pkg;
98 @labels = $record->labels;
100 $seconds = $record->seconds_since($timestamp);
102 $error = FS::cust_pkg::order( $custnum, \@pkgparts );
103 $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
107 An FS::cust_pkg object represents a customer billing item. FS::cust_pkg
108 inherits from FS::Record. The following fields are currently supported:
114 Primary key (assigned automatically for new billing items)
118 Customer (see L<FS::cust_main>)
122 Billing item definition (see L<FS::part_pkg>)
126 Optional link to package location (see L<FS::location>)
138 date (next bill date)
166 order taker (see L<FS::access_user>)
170 If this field is set to 1, disables the automatic
171 unsuspension of this package when using the B<unsuspendauto> config option.
175 If not set, defaults to 1
179 Date of change from previous package
189 =item change_locationnum
195 Note: setup, last_bill, bill, adjourn, susp, expire, cancel and change_date
196 are specified as UNIX timestamps; see L<perlfunc/"time">. Also see
197 L<Time::Local> and L<Date::Parse> for conversion functions.
205 Create a new billing item. To add the item to the database, see L<"insert">.
209 sub table { 'cust_pkg'; }
210 sub cust_linked { $_[0]->cust_main_custnum; }
211 sub cust_unlinked_msg {
213 "WARNING: can't find cust_main.custnum ". $self->custnum.
214 ' (cust_pkg.pkgnum '. $self->pkgnum. ')';
217 =item insert [ OPTION => VALUE ... ]
219 Adds this billing item to the database ("Orders" the item). If there is an
220 error, returns the error, otherwise returns false.
222 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
223 will be used to look up the package definition and agent restrictions will be
226 If the additional field I<refnum> is defined, an FS::pkg_referral record will
227 be created and inserted. Multiple FS::pkg_referral records can be created by
228 setting I<refnum> to an array reference of refnums or a hash reference with
229 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
230 record will be created corresponding to cust_main.refnum.
232 The following options are available:
238 If set true, supresses any referral credit to a referring customer.
242 cust_pkg_option records will be created
246 a ticket will be added to this customer with this subject
250 an optional queue name for ticket additions
257 my( $self, %options ) = @_;
259 if ( $self->part_pkg->option('start_1st', 1) && !$self->start_date ) {
260 my ($sec,$min,$hour,$mday,$mon,$year) = (localtime(time) )[0,1,2,3,4,5];
261 $mon += 1 unless $mday == 1;
262 until ( $mon < 12 ) { $mon -= 12; $year++; }
263 $self->start_date( timelocal_nocheck(0,0,0,1,$mon,$year) );
266 foreach my $action ( qw(expire adjourn contract_end) ) {
267 my $months = $self->part_pkg->option("${action}_months",1);
268 if($months and !$self->$action) {
269 my $start = $self->start_date || $self->setup || time;
270 $self->$action( $self->part_pkg->add_freq($start, $months) );
274 local $SIG{HUP} = 'IGNORE';
275 local $SIG{INT} = 'IGNORE';
276 local $SIG{QUIT} = 'IGNORE';
277 local $SIG{TERM} = 'IGNORE';
278 local $SIG{TSTP} = 'IGNORE';
279 local $SIG{PIPE} = 'IGNORE';
281 my $oldAutoCommit = $FS::UID::AutoCommit;
282 local $FS::UID::AutoCommit = 0;
285 my $error = $self->SUPER::insert($options{options} ? %{$options{options}} : ());
287 $dbh->rollback if $oldAutoCommit;
291 $self->refnum($self->cust_main->refnum) unless $self->refnum;
292 $self->refnum( [ $self->refnum ] ) unless ref($self->refnum);
293 $self->process_m2m( 'link_table' => 'pkg_referral',
294 'target_table' => 'part_referral',
295 'params' => $self->refnum,
298 if ( $self->discountnum ) {
299 my $error = $self->insert_discount();
301 $dbh->rollback if $oldAutoCommit;
306 #if ( $self->reg_code ) {
307 # my $reg_code = qsearchs('reg_code', { 'code' => $self->reg_code } );
308 # $error = $reg_code->delete;
310 # $dbh->rollback if $oldAutoCommit;
315 my $conf = new FS::Conf;
317 if ( $conf->config('ticket_system') && $options{ticket_subject} ) {
320 # use lib ( "/opt/rt3/local/lib", "/opt/rt3/lib" );
327 use FS::TicketSystem;
328 FS::TicketSystem->init();
330 my $q = new RT::Queue($RT::SystemUser);
331 $q->Load($options{ticket_queue}) if $options{ticket_queue};
332 my $t = new RT::Ticket($RT::SystemUser);
333 my $mime = new MIME::Entity;
334 $mime->build( Type => 'text/plain', Data => $options{ticket_subject} );
335 $t->Create( $options{ticket_queue} ? (Queue => $q) : (),
336 Subject => $options{ticket_subject},
339 $t->AddLink( Type => 'MemberOf',
340 Target => 'freeside://freeside/cust_main/'. $self->custnum,
344 if ($conf->config('welcome_letter') && $self->cust_main->num_pkgs == 1) {
345 my $queue = new FS::queue {
346 'job' => 'FS::cust_main::queueable_print',
348 $error = $queue->insert(
349 'custnum' => $self->custnum,
350 'template' => 'welcome_letter',
354 warn "can't send welcome letter: $error";
359 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
366 This method now works but you probably shouldn't use it.
368 You don't want to delete billing items, because there would then be no record
369 the customer ever purchased the item. Instead, see the cancel method.
374 # return "Can't delete cust_pkg records!";
377 =item replace [ OLD_RECORD ] [ HASHREF | OPTION => VALUE ... ]
379 Replaces the OLD_RECORD with this one in the database. If there is an error,
380 returns the error, otherwise returns false.
382 Currently, custnum, setup, bill, adjourn, susp, expire, and cancel may be changed.
384 Changing pkgpart may have disasterous effects. See the order subroutine.
386 setup and bill are normally updated by calling the bill method of a customer
387 object (see L<FS::cust_main>).
389 suspend is normally updated by the suspend and unsuspend methods.
391 cancel is normally updated by the cancel method (and also the order subroutine
394 Available options are:
400 can be set to a cancellation reason (see L<FS:reason>), either a reasonnum of an existing reason, or passing a hashref will create a new reason. The hashref should have the following keys: typenum - Reason type (see L<FS::reason_type>, reason - Text of the new reason.
404 the access_user (see L<FS::access_user>) providing the reason
408 hashref of keys and values - cust_pkg_option records will be created, updated or removed as appopriate
417 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
422 ( ref($_[0]) eq 'HASH' )
426 #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
427 #return "Can't change otaker!" if $old->otaker ne $new->otaker;
430 #return "Can't change setup once it exists!"
431 # if $old->getfield('setup') &&
432 # $old->getfield('setup') != $new->getfield('setup');
434 #some logic for bill, susp, cancel?
436 local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
438 local $SIG{HUP} = 'IGNORE';
439 local $SIG{INT} = 'IGNORE';
440 local $SIG{QUIT} = 'IGNORE';
441 local $SIG{TERM} = 'IGNORE';
442 local $SIG{TSTP} = 'IGNORE';
443 local $SIG{PIPE} = 'IGNORE';
445 my $oldAutoCommit = $FS::UID::AutoCommit;
446 local $FS::UID::AutoCommit = 0;
449 foreach my $method ( qw(adjourn expire) ) { # How many reasons?
450 if ($options->{'reason'} && $new->$method && $old->$method ne $new->$method) {
451 my $error = $new->insert_reason(
452 'reason' => $options->{'reason'},
453 'date' => $new->$method,
455 'reason_otaker' => $options->{'reason_otaker'},
458 dbh->rollback if $oldAutoCommit;
459 return "Error inserting cust_pkg_reason: $error";
464 #save off and freeze RADIUS attributes for any associated svc_acct records
466 if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
468 #also check for specific exports?
469 # to avoid spurious modify export events
470 @svc_acct = map { $_->svc_x }
471 grep { $_->part_svc->svcdb eq 'svc_acct' }
474 $_->snapshot foreach @svc_acct;
478 my $error = $new->SUPER::replace($old,
479 $options->{options} ? $options->{options} : ()
482 $dbh->rollback if $oldAutoCommit;
486 #for prepaid packages,
487 #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
488 foreach my $old_svc_acct ( @svc_acct ) {
489 my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
490 my $s_error = $new_svc_acct->replace($old_svc_acct);
492 $dbh->rollback if $oldAutoCommit;
497 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
504 Checks all fields to make sure this is a valid billing item. If there is an
505 error, returns the error, otherwise returns false. Called by the insert and
513 $self->locationnum('') if !$self->locationnum || $self->locationnum == -1;
516 $self->ut_numbern('pkgnum')
517 || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
518 || $self->ut_numbern('pkgpart')
519 || $self->ut_foreign_keyn('locationnum', 'cust_location', 'locationnum')
520 || $self->ut_numbern('start_date')
521 || $self->ut_numbern('setup')
522 || $self->ut_numbern('bill')
523 || $self->ut_numbern('susp')
524 || $self->ut_numbern('cancel')
525 || $self->ut_numbern('adjourn')
526 || $self->ut_numbern('expire')
527 || $self->ut_enum('no_auto', [ '', 'Y' ])
529 return $error if $error;
531 if ( $self->reg_code ) {
533 unless ( grep { $self->pkgpart == $_->pkgpart }
534 map { $_->reg_code_pkg }
535 qsearchs( 'reg_code', { 'code' => $self->reg_code,
536 'agentnum' => $self->cust_main->agentnum })
538 return "Unknown registration code";
541 } elsif ( $self->promo_code ) {
544 qsearchs('part_pkg', {
545 'pkgpart' => $self->pkgpart,
546 'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
548 return 'Unknown promotional code' unless $promo_part_pkg;
552 unless ( $disable_agentcheck ) {
554 qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
555 return "agent ". $agent->agentnum. ':'. $agent->agent.
556 " can't purchase pkgpart ". $self->pkgpart
557 unless $agent->pkgpart_hashref->{ $self->pkgpart }
558 || $agent->agentnum == $self->part_pkg->agentnum;
561 $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
562 return $error if $error;
566 $self->usernum($FS::CurrentUser::CurrentUser->usernum) unless $self->usernum;
568 if ( $self->dbdef_table->column('manual_flag') ) {
569 $self->manual_flag('') if $self->manual_flag eq ' ';
570 $self->manual_flag =~ /^([01]?)$/
571 or return "Illegal manual_flag ". $self->manual_flag;
572 $self->manual_flag($1);
578 =item cancel [ OPTION => VALUE ... ]
580 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
581 in this package, then cancels the package itself (sets the cancel field to
584 Available options are:
588 =item quiet - can be set true to supress email cancellation notices.
590 =item time - can be set to cancel the package based on a specific future or historical date. Using time ensures that the remaining amount is calculated correctly. Note however that this is an immediate cancel and just changes the date. You are PROBABLY looking to expire the account instead of using this.
592 =item reason - can be set to a cancellation reason (see L<FS:reason>), either a reasonnum of an existing reason, or passing a hashref will create a new reason. The hashref should have the following keys: typenum - Reason type (see L<FS::reason_type>, reason - Text of the new reason.
594 =item date - can be set to a unix style timestamp to specify when to cancel (expire)
596 =item nobill - can be set true to skip billing if it might otherwise be done.
600 If there is an error, returns the error, otherwise returns false.
605 my( $self, %options ) = @_;
608 my $conf = new FS::Conf;
610 warn "cust_pkg::cancel called with options".
611 join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
614 local $SIG{HUP} = 'IGNORE';
615 local $SIG{INT} = 'IGNORE';
616 local $SIG{QUIT} = 'IGNORE';
617 local $SIG{TERM} = 'IGNORE';
618 local $SIG{TSTP} = 'IGNORE';
619 local $SIG{PIPE} = 'IGNORE';
621 my $oldAutoCommit = $FS::UID::AutoCommit;
622 local $FS::UID::AutoCommit = 0;
625 my $old = $self->select_for_update;
627 if ( $old->get('cancel') || $self->get('cancel') ) {
628 dbh->rollback if $oldAutoCommit;
629 return ""; # no error
632 my $date = $options{date} if $options{date}; # expire/cancel later
633 $date = '' if ($date && $date <= time); # complain instead?
635 #race condition: usage could be ongoing until unprovisioned
636 #resolved by performing a change package instead (which unprovisions) and
638 if ( !$options{nobill} && !$date && $conf->exists('bill_usage_on_cancel') ) {
639 my $copy = $self->new({$self->hash});
641 $copy->cust_main->bill( pkg_list => [ $copy ], cancel => 1 );
642 warn "Error billing during cancel, custnum ".
643 #$self->cust_main->custnum. ": $error"
649 my $cancel_time = $options{'time'} || time;
651 if ( $options{'reason'} ) {
652 $error = $self->insert_reason( 'reason' => $options{'reason'},
653 'action' => $date ? 'expire' : 'cancel',
654 'date' => $date ? $date : $cancel_time,
655 'reason_otaker' => $options{'reason_otaker'},
658 dbh->rollback if $oldAutoCommit;
659 return "Error inserting cust_pkg_reason: $error";
665 foreach my $cust_svc (
668 sort { $a->[1] <=> $b->[1] }
669 map { [ $_, $_->svc_x->table_info->{'cancel_weight'} ]; }
670 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
673 my $error = $cust_svc->cancel;
676 $dbh->rollback if $oldAutoCommit;
677 return "Error cancelling cust_svc: $error";
681 # Add a credit for remaining service
682 my $remaining_value = $self->calc_remain(time=>$cancel_time);
683 if ( $remaining_value > 0 && !$options{'no_credit'} ) {
684 my $error = $self->cust_main->credit(
686 'Credit for unused time on '. $self->part_pkg->pkg,
687 'reason_type' => $conf->config('cancel_credit_type'),
690 $dbh->rollback if $oldAutoCommit;
691 return "Error crediting customer \$$remaining_value for unused time on".
692 $self->part_pkg->pkg. ": $error";
697 my %hash = $self->hash;
698 $date ? ($hash{'expire'} = $date) : ($hash{'cancel'} = $cancel_time);
699 my $new = new FS::cust_pkg ( \%hash );
700 $error = $new->replace( $self, options => { $self->options } );
702 $dbh->rollback if $oldAutoCommit;
706 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
707 return '' if $date; #no errors
709 my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
710 if ( !$options{'quiet'} && $conf->exists('emailcancel') && @invoicing_list ) {
711 my $msgnum = $conf->config('cancel_msgnum', $self->cust_main->agentnum);
714 my $msg_template = qsearchs('msg_template', { msgnum => $msgnum });
715 $error = $msg_template->send( 'cust_main' => $self->cust_main,
720 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
721 'to' => \@invoicing_list,
722 'subject' => ( $conf->config('cancelsubject') || 'Cancellation Notice' ),
723 'body' => [ map "$_\n", $conf->config('cancelmessage') ],
726 #should this do something on errors?
733 =item cancel_if_expired [ NOW_TIMESTAMP ]
735 Cancels this package if its expire date has been reached.
739 sub cancel_if_expired {
741 my $time = shift || time;
742 return '' unless $self->expire && $self->expire <= $time;
743 my $error = $self->cancel;
745 return "Error cancelling expired pkg ". $self->pkgnum. " for custnum ".
746 $self->custnum. ": $error";
753 Cancels any pending expiration (sets the expire field to null).
755 If there is an error, returns the error, otherwise returns false.
760 my( $self, %options ) = @_;
763 local $SIG{HUP} = 'IGNORE';
764 local $SIG{INT} = 'IGNORE';
765 local $SIG{QUIT} = 'IGNORE';
766 local $SIG{TERM} = 'IGNORE';
767 local $SIG{TSTP} = 'IGNORE';
768 local $SIG{PIPE} = 'IGNORE';
770 my $oldAutoCommit = $FS::UID::AutoCommit;
771 local $FS::UID::AutoCommit = 0;
774 my $old = $self->select_for_update;
776 my $pkgnum = $old->pkgnum;
777 if ( $old->get('cancel') || $self->get('cancel') ) {
778 dbh->rollback if $oldAutoCommit;
779 return "Can't unexpire cancelled package $pkgnum";
780 # or at least it's pointless
783 unless ( $old->get('expire') && $self->get('expire') ) {
784 dbh->rollback if $oldAutoCommit;
785 return ""; # no error
788 my %hash = $self->hash;
789 $hash{'expire'} = '';
790 my $new = new FS::cust_pkg ( \%hash );
791 $error = $new->replace( $self, options => { $self->options } );
793 $dbh->rollback if $oldAutoCommit;
797 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
803 =item suspend [ OPTION => VALUE ... ]
805 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
806 package, then suspends the package itself (sets the susp field to now).
808 Available options are:
812 =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.
814 =item date - can be set to a unix style timestamp to specify when to suspend (adjourn)
818 If there is an error, returns the error, otherwise returns false.
823 my( $self, %options ) = @_;
826 local $SIG{HUP} = 'IGNORE';
827 local $SIG{INT} = 'IGNORE';
828 local $SIG{QUIT} = 'IGNORE';
829 local $SIG{TERM} = 'IGNORE';
830 local $SIG{TSTP} = 'IGNORE';
831 local $SIG{PIPE} = 'IGNORE';
833 my $oldAutoCommit = $FS::UID::AutoCommit;
834 local $FS::UID::AutoCommit = 0;
837 my $old = $self->select_for_update;
839 my $pkgnum = $old->pkgnum;
840 if ( $old->get('cancel') || $self->get('cancel') ) {
841 dbh->rollback if $oldAutoCommit;
842 return "Can't suspend cancelled package $pkgnum";
845 if ( $old->get('susp') || $self->get('susp') ) {
846 dbh->rollback if $oldAutoCommit;
847 return ""; # no error # complain on adjourn?
850 my $date = $options{date} if $options{date}; # adjourn/suspend later
851 $date = '' if ($date && $date <= time); # complain instead?
853 if ( $date && $old->get('expire') && $old->get('expire') < $date ) {
854 dbh->rollback if $oldAutoCommit;
855 return "Package $pkgnum expires before it would be suspended.";
858 my $suspend_time = $options{'time'} || time;
860 if ( $options{'reason'} ) {
861 $error = $self->insert_reason( 'reason' => $options{'reason'},
862 'action' => $date ? 'adjourn' : 'suspend',
863 'date' => $date ? $date : $suspend_time,
864 'reason_otaker' => $options{'reason_otaker'},
867 dbh->rollback if $oldAutoCommit;
868 return "Error inserting cust_pkg_reason: $error";
876 foreach my $cust_svc (
877 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
879 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
881 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
882 $dbh->rollback if $oldAutoCommit;
883 return "Illegal svcdb value in part_svc!";
886 require "FS/$svcdb.pm";
888 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
890 $error = $svc->suspend;
892 $dbh->rollback if $oldAutoCommit;
895 my( $label, $value ) = $cust_svc->label;
896 push @labels, "$label: $value";
900 my $conf = new FS::Conf;
901 if ( $conf->config('suspend_email_admin') ) {
903 my $error = send_email(
904 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
905 #invoice_from ??? well as good as any
906 'to' => $conf->config('suspend_email_admin'),
907 'subject' => 'FREESIDE NOTIFICATION: Customer package suspended',
909 "This is an automatic message from your Freeside installation\n",
910 "informing you that the following customer package has been suspended:\n",
912 'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
913 'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
914 ( map { "Service : $_\n" } @labels ),
919 warn "WARNING: can't send suspension admin email (suspending anyway): ".
927 my %hash = $self->hash;
929 $hash{'adjourn'} = $date;
931 $hash{'susp'} = $suspend_time;
933 my $new = new FS::cust_pkg ( \%hash );
934 $error = $new->replace( $self, options => { $self->options } );
936 $dbh->rollback if $oldAutoCommit;
940 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
945 =item unsuspend [ OPTION => VALUE ... ]
947 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
948 package, then unsuspends the package itself (clears the susp field and the
949 adjourn field if it is in the past).
951 Available options are:
955 =item adjust_next_bill
957 Can be set true to adjust the next bill date forward by
958 the amount of time the account was inactive. This was set true by default
959 since 1.4.2 and 1.5.0pre6; however, starting with 1.7.0 this needs to be
960 explicitly requested. Price plans for which this makes sense (anniversary-date
961 based than prorate or subscription) could have an option to enable this
966 If there is an error, returns the error, otherwise returns false.
971 my( $self, %opt ) = @_;
974 local $SIG{HUP} = 'IGNORE';
975 local $SIG{INT} = 'IGNORE';
976 local $SIG{QUIT} = 'IGNORE';
977 local $SIG{TERM} = 'IGNORE';
978 local $SIG{TSTP} = 'IGNORE';
979 local $SIG{PIPE} = 'IGNORE';
981 my $oldAutoCommit = $FS::UID::AutoCommit;
982 local $FS::UID::AutoCommit = 0;
985 my $old = $self->select_for_update;
987 my $pkgnum = $old->pkgnum;
988 if ( $old->get('cancel') || $self->get('cancel') ) {
989 dbh->rollback if $oldAutoCommit;
990 return "Can't unsuspend cancelled package $pkgnum";
993 unless ( $old->get('susp') && $self->get('susp') ) {
994 dbh->rollback if $oldAutoCommit;
995 return ""; # no error # complain instead?
998 foreach my $cust_svc (
999 qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
1001 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
1003 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
1004 $dbh->rollback if $oldAutoCommit;
1005 return "Illegal svcdb value in part_svc!";
1008 require "FS/$svcdb.pm";
1010 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
1012 $error = $svc->unsuspend;
1014 $dbh->rollback if $oldAutoCommit;
1021 my %hash = $self->hash;
1022 my $inactive = time - $hash{'susp'};
1024 my $conf = new FS::Conf;
1026 if ( $inactive > 0 &&
1027 ( $hash{'bill'} || $hash{'setup'} ) &&
1028 ( $opt{'adjust_next_bill'} ||
1029 $conf->exists('unsuspend-always_adjust_next_bill_date') ||
1030 $self->part_pkg->option('unsuspend_adjust_bill', 1) )
1033 $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive;
1038 $hash{'adjourn'} = '' if $hash{'adjourn'} < time;
1039 my $new = new FS::cust_pkg ( \%hash );
1040 $error = $new->replace( $self, options => { $self->options } );
1042 $dbh->rollback if $oldAutoCommit;
1046 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1053 Cancels any pending suspension (sets the adjourn field to null).
1055 If there is an error, returns the error, otherwise returns false.
1060 my( $self, %options ) = @_;
1063 local $SIG{HUP} = 'IGNORE';
1064 local $SIG{INT} = 'IGNORE';
1065 local $SIG{QUIT} = 'IGNORE';
1066 local $SIG{TERM} = 'IGNORE';
1067 local $SIG{TSTP} = 'IGNORE';
1068 local $SIG{PIPE} = 'IGNORE';
1070 my $oldAutoCommit = $FS::UID::AutoCommit;
1071 local $FS::UID::AutoCommit = 0;
1074 my $old = $self->select_for_update;
1076 my $pkgnum = $old->pkgnum;
1077 if ( $old->get('cancel') || $self->get('cancel') ) {
1078 dbh->rollback if $oldAutoCommit;
1079 return "Can't unadjourn cancelled package $pkgnum";
1080 # or at least it's pointless
1083 if ( $old->get('susp') || $self->get('susp') ) {
1084 dbh->rollback if $oldAutoCommit;
1085 return "Can't unadjourn suspended package $pkgnum";
1086 # perhaps this is arbitrary
1089 unless ( $old->get('adjourn') && $self->get('adjourn') ) {
1090 dbh->rollback if $oldAutoCommit;
1091 return ""; # no error
1094 my %hash = $self->hash;
1095 $hash{'adjourn'} = '';
1096 my $new = new FS::cust_pkg ( \%hash );
1097 $error = $new->replace( $self, options => { $self->options } );
1099 $dbh->rollback if $oldAutoCommit;
1103 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1110 =item change HASHREF | OPTION => VALUE ...
1112 Changes this package: cancels it and creates a new one, with a different
1113 pkgpart or locationnum or both. All services are transferred to the new
1114 package (no change will be made if this is not possible).
1116 Options may be passed as a list of key/value pairs or as a hash reference.
1123 New locationnum, to change the location for this package.
1127 New FS::cust_location object, to create a new location and assign it
1132 New pkgpart (see L<FS::part_pkg>).
1136 New refnum (see L<FS::part_referral>).
1140 Set to true to transfer billing dates (start_date, setup, last_bill, bill,
1141 susp, adjourn, cancel, expire, and contract_end) to the new package.
1145 At least one of locationnum, cust_location, pkgpart, refnum must be specified
1146 (otherwise, what's the point?)
1148 Returns either the new FS::cust_pkg object or a scalar error.
1152 my $err_or_new_cust_pkg = $old_cust_pkg->change
1156 #some false laziness w/order
1159 my $opt = ref($_[0]) ? shift : { @_ };
1161 # my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
1164 my $conf = new FS::Conf;
1166 # Transactionize this whole mess
1167 local $SIG{HUP} = 'IGNORE';
1168 local $SIG{INT} = 'IGNORE';
1169 local $SIG{QUIT} = 'IGNORE';
1170 local $SIG{TERM} = 'IGNORE';
1171 local $SIG{TSTP} = 'IGNORE';
1172 local $SIG{PIPE} = 'IGNORE';
1174 my $oldAutoCommit = $FS::UID::AutoCommit;
1175 local $FS::UID::AutoCommit = 0;
1184 #$hash{$_} = $self->$_() foreach qw( last_bill bill );
1186 #$hash{$_} = $self->$_() foreach qw( setup );
1188 $hash{'setup'} = $time if $self->setup;
1190 $hash{'change_date'} = $time;
1191 $hash{"change_$_"} = $self->$_()
1192 foreach qw( pkgnum pkgpart locationnum );
1194 if ( $opt->{'cust_location'} &&
1195 ( ! $opt->{'locationnum'} || $opt->{'locationnum'} == -1 ) ) {
1196 $error = $opt->{'cust_location'}->insert;
1198 $dbh->rollback if $oldAutoCommit;
1199 return "inserting cust_location (transaction rolled back): $error";
1201 $opt->{'locationnum'} = $opt->{'cust_location'}->locationnum;
1204 if ( $opt->{'keep_dates'} ) {
1205 foreach my $date ( qw(setup bill last_bill susp adjourn cancel expire
1206 start_date contract_end ) ) {
1207 $hash{$date} = $self->getfield($date);
1211 # Create the new package.
1212 my $cust_pkg = new FS::cust_pkg {
1213 custnum => $self->custnum,
1214 pkgpart => ( $opt->{'pkgpart'} || $self->pkgpart ),
1215 refnum => ( $opt->{'refnum'} || $self->refnum ),
1216 locationnum => ( $opt->{'locationnum'} || $self->locationnum ),
1220 $error = $cust_pkg->insert( 'change' => 1 );
1222 $dbh->rollback if $oldAutoCommit;
1226 # Transfer services and cancel old package.
1228 $error = $self->transfer($cust_pkg);
1229 if ($error and $error == 0) {
1230 # $old_pkg->transfer failed.
1231 $dbh->rollback if $oldAutoCommit;
1235 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1236 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1237 $error = $self->transfer($cust_pkg, 'change_svcpart'=>1 );
1238 if ($error and $error == 0) {
1239 # $old_pkg->transfer failed.
1240 $dbh->rollback if $oldAutoCommit;
1246 # Transfers were successful, but we still had services left on the old
1247 # package. We can't change the package under this circumstances, so abort.
1248 $dbh->rollback if $oldAutoCommit;
1249 return "Unable to transfer all services from package ". $self->pkgnum;
1252 #reset usage if changing pkgpart
1253 # AND usage rollover is off (otherwise adds twice, now and at package bill)
1254 if ($self->pkgpart != $cust_pkg->pkgpart) {
1255 my $part_pkg = $cust_pkg->part_pkg;
1256 $error = $part_pkg->reset_usage($cust_pkg, $part_pkg->is_prepaid
1260 if $part_pkg->can('reset_usage') && ! $part_pkg->option('usage_rollover',1);
1263 $dbh->rollback if $oldAutoCommit;
1264 return "Error setting usage values: $error";
1268 #Good to go, cancel old package.
1269 $error = $self->cancel( quiet=>1 );
1271 $dbh->rollback if $oldAutoCommit;
1275 if ( $conf->exists('cust_pkg-change_pkgpart-bill_now') ) {
1277 my $error = $cust_pkg->cust_main->bill( 'pkg_list' => [ $cust_pkg ] );
1279 $dbh->rollback if $oldAutoCommit;
1284 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1291 use Storable 'thaw';
1293 sub process_bulk_cust_pkg {
1295 my $param = thaw(decode_base64(shift));
1296 warn Dumper($param) if $DEBUG;
1298 my $old_part_pkg = qsearchs('part_pkg',
1299 { pkgpart => $param->{'old_pkgpart'} });
1300 my $new_part_pkg = qsearchs('part_pkg',
1301 { pkgpart => $param->{'new_pkgpart'} });
1302 die "Must select a new package type\n" unless $new_part_pkg;
1303 #my $keep_dates = $param->{'keep_dates'} || 0;
1304 my $keep_dates = 1; # there is no good reason to turn this off
1306 local $SIG{HUP} = 'IGNORE';
1307 local $SIG{INT} = 'IGNORE';
1308 local $SIG{QUIT} = 'IGNORE';
1309 local $SIG{TERM} = 'IGNORE';
1310 local $SIG{TSTP} = 'IGNORE';
1311 local $SIG{PIPE} = 'IGNORE';
1313 my $oldAutoCommit = $FS::UID::AutoCommit;
1314 local $FS::UID::AutoCommit = 0;
1317 my @cust_pkgs = qsearch('cust_pkg', { 'pkgpart' => $param->{'old_pkgpart'} } );
1320 foreach my $old_cust_pkg ( @cust_pkgs ) {
1322 $job->update_statustext(int(100*$i/(scalar @cust_pkgs)));
1323 if ( $old_cust_pkg->getfield('cancel') ) {
1324 warn '[process_bulk_cust_pkg ] skipping canceled pkgnum '.
1325 $old_cust_pkg->pkgnum."\n"
1329 warn '[process_bulk_cust_pkg] changing pkgnum '.$old_cust_pkg->pkgnum."\n"
1331 my $error = $old_cust_pkg->change(
1332 'pkgpart' => $param->{'new_pkgpart'},
1333 'keep_dates' => $keep_dates
1335 if ( !ref($error) ) { # change returns the cust_pkg on success
1337 die "Error changing pkgnum ".$old_cust_pkg->pkgnum.": '$error'\n";
1340 $dbh->commit if $oldAutoCommit;
1346 Returns the last bill date, or if there is no last bill date, the setup date.
1347 Useful for billing metered services.
1353 return $self->setfield('last_bill', $_[0]) if @_;
1354 return $self->getfield('last_bill') if $self->getfield('last_bill');
1355 my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
1356 'edate' => $self->bill, } );
1357 $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
1360 =item last_cust_pkg_reason ACTION
1362 Returns the most recent ACTION FS::cust_pkg_reason associated with the package.
1363 Returns false if there is no reason or the package is not currenly ACTION'd
1364 ACTION is one of adjourn, susp, cancel, or expire.
1368 sub last_cust_pkg_reason {
1369 my ( $self, $action ) = ( shift, shift );
1370 my $date = $self->get($action);
1372 'table' => 'cust_pkg_reason',
1373 'hashref' => { 'pkgnum' => $self->pkgnum,
1374 'action' => substr(uc($action), 0, 1),
1377 'order_by' => 'ORDER BY num DESC LIMIT 1',
1381 =item last_reason ACTION
1383 Returns the most recent ACTION FS::reason associated with the package.
1384 Returns false if there is no reason or the package is not currenly ACTION'd
1385 ACTION is one of adjourn, susp, cancel, or expire.
1390 my $cust_pkg_reason = shift->last_cust_pkg_reason(@_);
1391 $cust_pkg_reason->reason
1392 if $cust_pkg_reason;
1397 Returns the definition for this billing item, as an FS::part_pkg object (see
1404 return $self->{'_pkgpart'} if $self->{'_pkgpart'};
1405 cluck "cust_pkg->part_pkg called" if $DEBUG > 1;
1406 qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
1411 Returns the cancelled package this package was changed from, if any.
1417 return '' unless $self->change_pkgnum;
1418 qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
1423 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
1430 $self->part_pkg->calc_setup($self, @_);
1435 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
1442 $self->part_pkg->calc_recur($self, @_);
1447 Calls the I<base_recur> of the FS::part_pkg object associated with this billing
1454 $self->part_pkg->base_recur($self, @_);
1459 Calls the I<calc_remain> of the FS::part_pkg object associated with this
1466 $self->part_pkg->calc_remain($self, @_);
1471 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
1478 $self->part_pkg->calc_cancel($self, @_);
1483 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
1489 qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
1492 =item cust_pkg_detail [ DETAILTYPE ]
1494 Returns any customer package details for this package (see
1495 L<FS::cust_pkg_detail>).
1497 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
1501 sub cust_pkg_detail {
1503 my %hash = ( 'pkgnum' => $self->pkgnum );
1504 $hash{detailtype} = shift if @_;
1506 'table' => 'cust_pkg_detail',
1507 'hashref' => \%hash,
1508 'order_by' => 'ORDER BY weight, pkgdetailnum',
1512 =item set_cust_pkg_detail DETAILTYPE [ DETAIL, DETAIL, ... ]
1514 Sets customer package details for this package (see L<FS::cust_pkg_detail>).
1516 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
1518 If there is an error, returns the error, otherwise returns false.
1522 sub set_cust_pkg_detail {
1523 my( $self, $detailtype, @details ) = @_;
1525 local $SIG{HUP} = 'IGNORE';
1526 local $SIG{INT} = 'IGNORE';
1527 local $SIG{QUIT} = 'IGNORE';
1528 local $SIG{TERM} = 'IGNORE';
1529 local $SIG{TSTP} = 'IGNORE';
1530 local $SIG{PIPE} = 'IGNORE';
1532 my $oldAutoCommit = $FS::UID::AutoCommit;
1533 local $FS::UID::AutoCommit = 0;
1536 foreach my $current ( $self->cust_pkg_detail($detailtype) ) {
1537 my $error = $current->delete;
1539 $dbh->rollback if $oldAutoCommit;
1540 return "error removing old detail: $error";
1544 foreach my $detail ( @details ) {
1545 my $cust_pkg_detail = new FS::cust_pkg_detail {
1546 'pkgnum' => $self->pkgnum,
1547 'detailtype' => $detailtype,
1548 'detail' => $detail,
1550 my $error = $cust_pkg_detail->insert;
1552 $dbh->rollback if $oldAutoCommit;
1553 return "error adding new detail: $error";
1558 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1565 Returns the new-style customer billing events (see L<FS::cust_event>) for this invoice.
1569 #false laziness w/cust_bill.pm
1573 'table' => 'cust_event',
1574 'addl_from' => 'JOIN part_event USING ( eventpart )',
1575 'hashref' => { 'tablenum' => $self->pkgnum },
1576 'extra_sql' => " AND eventtable = 'cust_pkg' ",
1580 =item num_cust_event
1582 Returns the number of new-style customer billing events (see L<FS::cust_event>) for this invoice.
1586 #false laziness w/cust_bill.pm
1587 sub num_cust_event {
1590 "SELECT COUNT(*) FROM cust_event JOIN part_event USING ( eventpart ) ".
1591 " WHERE tablenum = ? AND eventtable = 'cust_pkg'";
1592 my $sth = dbh->prepare($sql) or die dbh->errstr. " preparing $sql";
1593 $sth->execute($self->pkgnum) or die $sth->errstr. " executing $sql";
1594 $sth->fetchrow_arrayref->[0];
1597 =item cust_svc [ SVCPART ]
1599 Returns the services for this package, as FS::cust_svc objects (see
1600 L<FS::cust_svc>). If a svcpart is specified, return only the matching
1608 return () unless $self->num_cust_svc(@_);
1611 return qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum,
1612 'svcpart' => shift, } );
1615 cluck "cust_pkg->cust_svc called" if $DEBUG > 2;
1617 #if ( $self->{'_svcnum'} ) {
1618 # values %{ $self->{'_svcnum'}->cache };
1620 $self->_sort_cust_svc(
1621 [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
1627 =item overlimit [ SVCPART ]
1629 Returns the services for this package which have exceeded their
1630 usage limit as FS::cust_svc objects (see L<FS::cust_svc>). If a svcpart
1631 is specified, return only the matching services.
1637 return () unless $self->num_cust_svc(@_);
1638 grep { $_->overlimit } $self->cust_svc(@_);
1641 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
1643 Returns historical services for this package created before END TIMESTAMP and
1644 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
1645 (see L<FS::h_cust_svc>). If MODE is 'I' (for 'invoice'), services with the
1646 I<pkg_svc.hidden> flag will be omitted.
1652 my ($end, $start, $mode) = @_;
1654 'table' => 'h_cust_svc',
1655 'hashref' => { 'pkgnum' => $self->pkgnum }
1657 @search{'select', 'extra_sql', 'cache_obj', 'addl_from'} =
1658 FS::h_cust_svc->sql_h_search($end, $start);
1659 if ( $mode eq 'I' ) {
1660 $search{'addl_from'} .= ' JOIN cust_pkg USING (pkgnum)
1661 JOIN pkg_svc USING (pkgpart, svcpart)';
1662 $search{'extra_sql'} = ' AND pkg_svc.hidden IS NULL '.$search{'extra_sql'};
1665 $self->_sort_cust_svc(
1666 [ qsearch(\%search) ]
1670 sub _sort_cust_svc {
1671 my( $self, $arrayref ) = @_;
1674 sub ($$) { my ($a, $b) = @_; $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] };
1679 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
1680 'svcpart' => $_->svcpart } );
1682 $pkg_svc ? $pkg_svc->primary_svc : '',
1683 $pkg_svc ? $pkg_svc->quantity : 0,
1690 =item num_cust_svc [ SVCPART ]
1692 Returns the number of provisioned services for this package. If a svcpart is
1693 specified, counts only the matching services.
1700 return $self->{'_num_cust_svc'}
1702 && exists($self->{'_num_cust_svc'})
1703 && $self->{'_num_cust_svc'} =~ /\d/;
1705 cluck "cust_pkg->num_cust_svc called, _num_cust_svc:".$self->{'_num_cust_svc'}
1708 my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
1709 $sql .= ' AND svcpart = ?' if @_;
1711 my $sth = dbh->prepare($sql) or die dbh->errstr;
1712 $sth->execute($self->pkgnum, @_) or die $sth->errstr;
1713 $sth->fetchrow_arrayref->[0];
1716 =item available_part_svc
1718 Returns a list of FS::part_svc objects representing services included in this
1719 package but not yet provisioned. Each FS::part_svc object also has an extra
1720 field, I<num_avail>, which specifies the number of available services.
1724 sub available_part_svc {
1726 grep { $_->num_avail > 0 }
1728 my $part_svc = $_->part_svc;
1729 $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
1730 $_->quantity - $self->num_cust_svc($_->svcpart);
1733 $self->part_pkg->pkg_svc;
1738 Returns a list of FS::part_svc objects representing provisioned and available
1739 services included in this package. Each FS::part_svc object also has the
1740 following extra fields:
1744 =item num_cust_svc (count)
1746 =item num_avail (quantity - count)
1748 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
1751 label -> ($cust_svc->label)[1]
1760 #XXX some sort of sort order besides numeric by svcpart...
1761 my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
1763 my $part_svc = $pkg_svc->part_svc;
1764 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1765 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
1766 $part_svc->{'Hash'}{'num_avail'} =
1767 max( 0, $pkg_svc->quantity - $num_cust_svc );
1768 $part_svc->{'Hash'}{'cust_pkg_svc'} =
1769 $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
1771 } $self->part_pkg->pkg_svc;
1774 push @part_svc, map {
1776 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1777 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
1778 $part_svc->{'Hash'}{'num_avail'} = 0; #0-$num_cust_svc ?
1779 $part_svc->{'Hash'}{'cust_pkg_svc'} =
1780 $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
1782 } $self->extra_part_svc;
1788 =item extra_part_svc
1790 Returns a list of FS::part_svc objects corresponding to services in this
1791 package which are still provisioned but not (any longer) available in the
1796 sub extra_part_svc {
1799 my $pkgnum = $self->pkgnum;
1800 my $pkgpart = $self->pkgpart;
1803 # 'table' => 'part_svc',
1806 # "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
1807 # WHERE pkg_svc.svcpart = part_svc.svcpart
1808 # AND pkg_svc.pkgpart = ?
1811 # AND 0 < ( SELECT COUNT(*) FROM cust_svc
1812 # LEFT JOIN cust_pkg USING ( pkgnum )
1813 # WHERE cust_svc.svcpart = part_svc.svcpart
1816 # 'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
1819 #seems to benchmark slightly faster...
1821 #'select' => 'DISTINCT ON (svcpart) part_svc.*',
1822 #MySQL doesn't grok DISINCT ON
1823 'select' => 'DISTINCT part_svc.*',
1824 'table' => 'part_svc',
1826 'LEFT JOIN pkg_svc ON ( pkg_svc.svcpart = part_svc.svcpart
1827 AND pkg_svc.pkgpart = ?
1830 LEFT JOIN cust_svc ON ( cust_svc.svcpart = part_svc.svcpart )
1831 LEFT JOIN cust_pkg USING ( pkgnum )
1834 'extra_sql' => "WHERE pkgsvcnum IS NULL AND cust_pkg.pkgnum = ? ",
1835 'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
1841 Returns a short status string for this package, currently:
1845 =item not yet billed
1847 =item one-time charge
1862 my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
1864 return 'cancelled' if $self->get('cancel');
1865 return 'suspended' if $self->susp;
1866 return 'not yet billed' unless $self->setup;
1867 return 'one-time charge' if $freq =~ /^(0|$)/;
1871 =item ucfirst_status
1873 Returns the status with the first character capitalized.
1877 sub ucfirst_status {
1878 ucfirst(shift->status);
1883 Class method that returns the list of possible status strings for packages
1884 (see L<the status method|/status>). For example:
1886 @statuses = FS::cust_pkg->statuses();
1890 tie my %statuscolor, 'Tie::IxHash',
1891 'not yet billed' => '009999', #teal? cyan?
1892 'one-time charge' => '000000',
1893 'active' => '00CC00',
1894 'suspended' => 'FF9900',
1895 'cancelled' => 'FF0000',
1899 my $self = shift; #could be class...
1900 #grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
1901 # # mayble split btw one-time vs. recur
1907 Returns a hex triplet color string for this package's status.
1913 $statuscolor{$self->status};
1918 Returns a label for this package. (Currently "pkgnum: pkg - comment" or
1919 "pkg-comment" depending on user preference).
1925 my $label = $self->part_pkg->pkg_comment( 'nopkgpart' => 1 );
1926 $label = $self->pkgnum. ": $label"
1927 if $FS::CurrentUser::CurrentUser->option('show_pkgnum');
1931 =item pkg_label_long
1933 Returns a long label for this package, adding the primary service's label to
1938 sub pkg_label_long {
1940 my $label = $self->pkg_label;
1941 my $cust_svc = $self->primary_cust_svc;
1942 $label .= ' ('. ($cust_svc->label)[1]. ')' if $cust_svc;
1946 =item primary_cust_svc
1948 Returns a primary service (as FS::cust_svc object) if one can be identified.
1952 #for labeling purposes - might not 100% match up with part_pkg->svcpart's idea
1954 sub primary_cust_svc {
1957 my @cust_svc = $self->cust_svc;
1959 return '' unless @cust_svc; #no serivces - irrelevant then
1961 return $cust_svc[0] if scalar(@cust_svc) == 1; #always return a single service
1963 # primary service as specified in the package definition
1964 # or exactly one service definition with quantity one
1965 my $svcpart = $self->part_pkg->svcpart;
1966 @cust_svc = grep { $_->svcpart == $svcpart } @cust_svc;
1967 return $cust_svc[0] if scalar(@cust_svc) == 1;
1969 #couldn't identify one thing..
1975 Returns a list of lists, calling the label method for all services
1976 (see L<FS::cust_svc>) of this billing item.
1982 map { [ $_->label ] } $self->cust_svc;
1985 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
1987 Like the labels method, but returns historical information on services that
1988 were active as of END_TIMESTAMP and (optionally) not cancelled before
1989 START_TIMESTAMP. If MODE is 'I' (for 'invoice'), services with the
1990 I<pkg_svc.hidden> flag will be omitted.
1992 Returns a list of lists, calling the label method for all (historical) services
1993 (see L<FS::h_cust_svc>) of this billing item.
1999 map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
2004 Like labels, except returns a simple flat list, and shortens long
2005 (currently >5 or the cust_bill-max_same_services configuration value) lists of
2006 identical services to one line that lists the service label and the number of
2007 individual services rather than individual items.
2012 shift->_labels_short( 'labels', @_ );
2015 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
2017 Like h_labels, except returns a simple flat list, and shortens long
2018 (currently >5 or the cust_bill-max_same_services configuration value) lists of
2019 identical services to one line that lists the service label and the number of
2020 individual services rather than individual items.
2024 sub h_labels_short {
2025 shift->_labels_short( 'h_labels', @_ );
2029 my( $self, $method ) = ( shift, shift );
2031 my $conf = new FS::Conf;
2032 my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
2035 #tie %labels, 'Tie::IxHash';
2036 push @{ $labels{$_->[0]} }, $_->[1]
2037 foreach $self->$method(@_);
2039 foreach my $label ( keys %labels ) {
2041 my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
2042 my $num = scalar(@values);
2043 if ( $num > $max_same_services ) {
2044 push @labels, "$label ($num)";
2046 if ( $conf->exists('cust_bill-consolidate_services') ) {
2047 # push @labels, "$label: ". join(', ', @values);
2049 my $detail = "$label: ";
2050 $detail .= shift(@values). ', '
2051 while @values && length($detail.$values[0]) < 78;
2053 push @labels, $detail;
2056 push @labels, map { "$label: $_" } @values;
2067 Returns the parent customer object (see L<FS::cust_main>).
2073 qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
2076 #these subs are in location_Mixin.pm now... unfortunately the POD doesn't mixin
2080 Returns the location object, if any (see L<FS::cust_location>).
2082 =item cust_location_or_main
2084 If this package is associated with a location, returns the locaiton (see
2085 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
2087 =item location_label [ OPTION => VALUE ... ]
2089 Returns the label of the location object (see L<FS::cust_location>).
2093 #end of subs in location_Mixin.pm now... unfortunately the POD doesn't mixin
2095 =item seconds_since TIMESTAMP
2097 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
2098 package have been online since TIMESTAMP, according to the session monitor.
2100 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
2101 L<Time::Local> and L<Date::Parse> for conversion functions.
2106 my($self, $since) = @_;
2109 foreach my $cust_svc (
2110 grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
2112 $seconds += $cust_svc->seconds_since($since);
2119 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2121 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
2122 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
2125 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2126 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2132 sub seconds_since_sqlradacct {
2133 my($self, $start, $end) = @_;
2137 foreach my $cust_svc (
2139 my $part_svc = $_->part_svc;
2140 $part_svc->svcdb eq 'svc_acct'
2141 && scalar($part_svc->part_export('sqlradius'));
2144 $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
2151 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2153 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2154 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2158 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2159 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2164 sub attribute_since_sqlradacct {
2165 my($self, $start, $end, $attrib) = @_;
2169 foreach my $cust_svc (
2171 my $part_svc = $_->part_svc;
2172 $part_svc->svcdb eq 'svc_acct'
2173 && scalar($part_svc->part_export('sqlradius'));
2176 $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
2188 my( $self, $value ) = @_;
2189 if ( defined($value) ) {
2190 $self->setfield('quantity', $value);
2192 $self->getfield('quantity') || 1;
2195 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
2197 Transfers as many services as possible from this package to another package.
2199 The destination package can be specified by pkgnum by passing an FS::cust_pkg
2200 object. The destination package must already exist.
2202 Services are moved only if the destination allows services with the correct
2203 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true. Use
2204 this option with caution! No provision is made for export differences
2205 between the old and new service definitions. Probably only should be used
2206 when your exports for all service definitions of a given svcdb are identical.
2207 (attempt a transfer without it first, to move all possible svcpart-matching
2210 Any services that can't be moved remain in the original package.
2212 Returns an error, if there is one; otherwise, returns the number of services
2213 that couldn't be moved.
2218 my ($self, $dest_pkgnum, %opt) = @_;
2224 if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
2225 $dest = $dest_pkgnum;
2226 $dest_pkgnum = $dest->pkgnum;
2228 $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
2231 return ('Package does not exist: '.$dest_pkgnum) unless $dest;
2233 foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
2234 $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
2237 foreach my $cust_svc ($dest->cust_svc) {
2238 $target{$cust_svc->svcpart}--;
2241 my %svcpart2svcparts = ();
2242 if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2243 warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
2244 foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
2245 next if exists $svcpart2svcparts{$svcpart};
2246 my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
2247 $svcpart2svcparts{$svcpart} = [
2249 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
2251 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
2252 'svcpart' => $_ } );
2254 $pkg_svc ? $pkg_svc->primary_svc : '',
2255 $pkg_svc ? $pkg_svc->quantity : 0,
2259 grep { $_ != $svcpart }
2261 qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
2263 warn "alternates for svcpart $svcpart: ".
2264 join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
2269 foreach my $cust_svc ($self->cust_svc) {
2270 if($target{$cust_svc->svcpart} > 0) {
2271 $target{$cust_svc->svcpart}--;
2272 my $new = new FS::cust_svc { $cust_svc->hash };
2273 $new->pkgnum($dest_pkgnum);
2274 my $error = $new->replace($cust_svc);
2275 return $error if $error;
2276 } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2278 warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
2279 warn "alternates to consider: ".
2280 join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
2282 my @alternate = grep {
2283 warn "considering alternate svcpart $_: ".
2284 "$target{$_} available in new package\n"
2287 } @{$svcpart2svcparts{$cust_svc->svcpart}};
2289 warn "alternate(s) found\n" if $DEBUG;
2290 my $change_svcpart = $alternate[0];
2291 $target{$change_svcpart}--;
2292 my $new = new FS::cust_svc { $cust_svc->hash };
2293 $new->svcpart($change_svcpart);
2294 $new->pkgnum($dest_pkgnum);
2295 my $error = $new->replace($cust_svc);
2296 return $error if $error;
2309 This method is deprecated. See the I<depend_jobnum> option to the insert and
2310 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
2317 local $SIG{HUP} = 'IGNORE';
2318 local $SIG{INT} = 'IGNORE';
2319 local $SIG{QUIT} = 'IGNORE';
2320 local $SIG{TERM} = 'IGNORE';
2321 local $SIG{TSTP} = 'IGNORE';
2322 local $SIG{PIPE} = 'IGNORE';
2324 my $oldAutoCommit = $FS::UID::AutoCommit;
2325 local $FS::UID::AutoCommit = 0;
2328 foreach my $cust_svc ( $self->cust_svc ) {
2329 #false laziness w/svc_Common::insert
2330 my $svc_x = $cust_svc->svc_x;
2331 foreach my $part_export ( $cust_svc->part_svc->part_export ) {
2332 my $error = $part_export->export_insert($svc_x);
2334 $dbh->rollback if $oldAutoCommit;
2340 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2347 Associates this package with a (suspension or cancellation) reason (see
2348 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
2351 Available options are:
2357 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.
2361 the access_user (see L<FS::access_user>) providing the reason
2369 the action (cancel, susp, adjourn, expire) associated with the reason
2373 If there is an error, returns the error, otherwise returns false.
2378 my ($self, %options) = @_;
2380 my $otaker = $options{reason_otaker} ||
2381 $FS::CurrentUser::CurrentUser->username;
2384 if ( $options{'reason'} =~ /^(\d+)$/ ) {
2388 } elsif ( ref($options{'reason'}) ) {
2390 return 'Enter a new reason (or select an existing one)'
2391 unless $options{'reason'}->{'reason'} !~ /^\s*$/;
2393 my $reason = new FS::reason({
2394 'reason_type' => $options{'reason'}->{'typenum'},
2395 'reason' => $options{'reason'}->{'reason'},
2397 my $error = $reason->insert;
2398 return $error if $error;
2400 $reasonnum = $reason->reasonnum;
2403 return "Unparsable reason: ". $options{'reason'};
2406 my $cust_pkg_reason =
2407 new FS::cust_pkg_reason({ 'pkgnum' => $self->pkgnum,
2408 'reasonnum' => $reasonnum,
2409 'otaker' => $otaker,
2410 'action' => substr(uc($options{'action'}),0,1),
2411 'date' => $options{'date'}
2416 $cust_pkg_reason->insert;
2419 =item insert_discount
2421 Associates this package with a discount (see L<FS::cust_pkg_discount>, possibly
2422 inserting a new discount on the fly (see L<FS::discount>).
2424 Available options are:
2432 If there is an error, returns the error, otherwise returns false.
2436 sub insert_discount {
2437 #my ($self, %options) = @_;
2440 my $cust_pkg_discount = new FS::cust_pkg_discount {
2441 'pkgnum' => $self->pkgnum,
2442 'discountnum' => $self->discountnum,
2444 'end_date' => '', #XXX
2445 'otaker' => $self->otaker,
2446 #for the create a new discount case
2447 '_type' => $self->discountnum__type,
2448 'amount' => $self->discountnum_amount,
2449 'percent' => $self->discountnum_percent,
2450 'months' => $self->discountnum_months,
2451 #'disabled' => $self->discountnum_disabled,
2454 $cust_pkg_discount->insert;
2457 =item set_usage USAGE_VALUE_HASHREF
2459 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2460 to which they should be set (see L<FS::svc_acct>). Currently seconds,
2461 upbytes, downbytes, and totalbytes are appropriate keys.
2463 All svc_accts which are part of this package have their values reset.
2468 my ($self, $valueref, %opt) = @_;
2470 foreach my $cust_svc ($self->cust_svc){
2471 my $svc_x = $cust_svc->svc_x;
2472 $svc_x->set_usage($valueref, %opt)
2473 if $svc_x->can("set_usage");
2477 =item recharge USAGE_VALUE_HASHREF
2479 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2480 to which they should be set (see L<FS::svc_acct>). Currently seconds,
2481 upbytes, downbytes, and totalbytes are appropriate keys.
2483 All svc_accts which are part of this package have their values incremented.
2488 my ($self, $valueref) = @_;
2490 foreach my $cust_svc ($self->cust_svc){
2491 my $svc_x = $cust_svc->svc_x;
2492 $svc_x->recharge($valueref)
2493 if $svc_x->can("recharge");
2497 =item cust_pkg_discount
2501 sub cust_pkg_discount {
2503 qsearch('cust_pkg_discount', { 'pkgnum' => $self->pkgnum } );
2506 =item cust_pkg_discount_active
2510 sub cust_pkg_discount_active {
2512 grep { $_->status eq 'active' } $self->cust_pkg_discount;
2517 =head1 CLASS METHODS
2523 Returns an SQL expression identifying recurring packages.
2527 sub recurring_sql { "
2528 '0' != ( select freq from part_pkg
2529 where cust_pkg.pkgpart = part_pkg.pkgpart )
2534 Returns an SQL expression identifying one-time packages.
2539 '0' = ( select freq from part_pkg
2540 where cust_pkg.pkgpart = part_pkg.pkgpart )
2545 Returns an SQL expression identifying ordered packages (recurring packages not
2551 $_[0]->recurring_sql. " AND ". $_[0]->not_yet_billed_sql;
2556 Returns an SQL expression identifying active packages.
2561 $_[0]->recurring_sql. "
2562 AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
2563 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2564 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
2567 =item not_yet_billed_sql
2569 Returns an SQL expression identifying packages which have not yet been billed.
2573 sub not_yet_billed_sql { "
2574 ( cust_pkg.setup IS NULL OR cust_pkg.setup = 0 )
2575 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2576 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
2581 Returns an SQL expression identifying inactive packages (one-time packages
2582 that are otherwise unsuspended/uncancelled).
2586 sub inactive_sql { "
2587 ". $_[0]->onetime_sql(). "
2588 AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
2589 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2590 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
2596 Returns an SQL expression identifying suspended packages.
2600 sub suspended_sql { susp_sql(@_); }
2602 #$_[0]->recurring_sql(). ' AND '.
2604 ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2605 AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0
2612 Returns an SQL exprression identifying cancelled packages.
2616 sub cancelled_sql { cancel_sql(@_); }
2618 #$_[0]->recurring_sql(). ' AND '.
2619 "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
2624 Returns an SQL expression to give the package status as a string.
2630 WHEN cust_pkg.cancel IS NOT NULL THEN 'cancelled'
2631 WHEN cust_pkg.susp IS NOT NULL THEN 'suspended'
2632 WHEN cust_pkg.setup IS NULL THEN 'not yet billed'
2633 WHEN ".onetime_sql()." THEN 'one-time charge'
2638 =item search HASHREF
2642 Returns a qsearch hash expression to search for parameters specified in HASHREF.
2643 Valid parameters are
2651 active, inactive, suspended, cancel (or cancelled)
2655 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
2659 boolean selects custom packages
2665 pkgpart or arrayref or hashref of pkgparts
2669 arrayref of beginning and ending epoch date
2673 arrayref of beginning and ending epoch date
2677 arrayref of beginning and ending epoch date
2681 arrayref of beginning and ending epoch date
2685 arrayref of beginning and ending epoch date
2689 arrayref of beginning and ending epoch date
2693 arrayref of beginning and ending epoch date
2697 pkgnum or APKG_pkgnum
2701 a value suited to passing to FS::UI::Web::cust_header
2705 specifies the user for agent virtualization
2709 boolean selects packages containing fcc form 477 telco lines
2716 my ($class, $params) = @_;
2723 if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2725 "cust_main.agentnum = $1";
2732 if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
2734 "cust_pkg.custnum = $1";
2741 if ( $params->{'pkgbatch'} =~ /^([\w\/\-\:\.]+)$/ and $1 ) {
2743 "cust_pkg.pkgbatch = '$1'";
2750 if ( $params->{'magic'} eq 'active'
2751 || $params->{'status'} eq 'active' ) {
2753 push @where, FS::cust_pkg->active_sql();
2755 } elsif ( $params->{'magic'} =~ /^not[ _]yet[ _]billed$/
2756 || $params->{'status'} =~ /^not[ _]yet[ _]billed$/ ) {
2758 push @where, FS::cust_pkg->not_yet_billed_sql();
2760 } elsif ( $params->{'magic'} =~ /^(one-time charge|inactive)/
2761 || $params->{'status'} =~ /^(one-time charge|inactive)/ ) {
2763 push @where, FS::cust_pkg->inactive_sql();
2765 } elsif ( $params->{'magic'} eq 'suspended'
2766 || $params->{'status'} eq 'suspended' ) {
2768 push @where, FS::cust_pkg->suspended_sql();
2770 } elsif ( $params->{'magic'} =~ /^cancell?ed$/
2771 || $params->{'status'} =~ /^cancell?ed$/ ) {
2773 push @where, FS::cust_pkg->cancelled_sql();
2778 # parse package class
2781 #false lazinessish w/graph/cust_bill_pkg.cgi
2784 if ( exists($params->{'classnum'})
2785 && $params->{'classnum'} =~ /^(\d*)$/
2789 if ( $classnum ) { #a specific class
2790 push @where, "part_pkg.classnum = $classnum";
2792 #@pkg_class = ( qsearchs('pkg_class', { 'classnum' => $classnum } ) );
2793 #die "classnum $classnum not found!" unless $pkg_class[0];
2794 #$title .= $pkg_class[0]->classname.' ';
2796 } elsif ( $classnum eq '' ) { #the empty class
2798 push @where, "part_pkg.classnum IS NULL";
2799 #$title .= 'Empty class ';
2800 #@pkg_class = ( '(empty class)' );
2801 } elsif ( $classnum eq '0' ) {
2802 #@pkg_class = qsearch('pkg_class', {} ); # { 'disabled' => '' } );
2803 #push @pkg_class, '(empty class)';
2805 die "illegal classnum";
2811 # parse package report options
2814 my @report_option = ();
2815 if ( exists($params->{'report_option'})
2816 && $params->{'report_option'} =~ /^([,\d]*)$/
2819 @report_option = split(',', $1);
2822 if (@report_option) {
2823 # this will result in the empty set for the dangling comma case as it should
2825 map{ "0 < ( SELECT count(*) FROM part_pkg_option
2826 WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
2827 AND optionname = 'report_option_$_'
2828 AND optionvalue = '1' )"
2838 push @where, "part_pkg.custom = 'Y'" if $params->{custom};
2844 push @where, "part_pkg.fcc_ds0s > 0" if $params->{fcc_line};
2850 if ( exists($params->{'censustract'}) ) {
2851 $params->{'censustract'} =~ /^([.\d]*)$/;
2852 my $censustract = "cust_main.censustract = '$1'";
2853 $censustract .= ' OR cust_main.censustract is NULL' unless $1;
2854 push @where, "( $censustract )";
2861 if ( ref($params->{'pkgpart'}) ) {
2864 if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
2865 @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
2866 } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
2867 @pkgpart = @{ $params->{'pkgpart'} };
2869 die 'unhandled pkgpart ref '. $params->{'pkgpart'};
2872 @pkgpart = grep /^(\d+)$/, @pkgpart;
2874 push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
2876 } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
2877 push @where, "pkgpart = $1";
2886 #false laziness w/report_cust_pkg.html
2889 'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
2890 'active' => { 'susp'=>1, 'cancel'=>1 },
2891 'suspended' => { 'cancel' => 1 },
2896 if( exists($params->{'active'} ) ) {
2897 # This overrides all the other date-related fields
2898 my($beginning, $ending) = @{$params->{'active'}};
2900 "cust_pkg.setup IS NOT NULL",
2901 "cust_pkg.setup <= $ending",
2902 "(cust_pkg.cancel IS NULL OR cust_pkg.cancel >= $beginning )",
2903 "NOT (".FS::cust_pkg->onetime_sql . ")";
2906 foreach my $field (qw( setup last_bill bill adjourn susp expire contract_end cancel )) {
2908 next unless exists($params->{$field});
2910 my($beginning, $ending) = @{$params->{$field}};
2912 next if $beginning == 0 && $ending == 4294967295;
2915 "cust_pkg.$field IS NOT NULL",
2916 "cust_pkg.$field >= $beginning",
2917 "cust_pkg.$field <= $ending";
2919 $orderby ||= "ORDER BY cust_pkg.$field";
2924 $orderby ||= 'ORDER BY bill';
2927 # parse magic, legacy, etc.
2930 if ( $params->{'magic'} &&
2931 $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
2934 $orderby = 'ORDER BY pkgnum';
2936 if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
2937 push @where, "pkgpart = $1";
2940 } elsif ( $params->{'query'} eq 'pkgnum' ) {
2942 $orderby = 'ORDER BY pkgnum';
2944 } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
2946 $orderby = 'ORDER BY pkgnum';
2949 SELECT count(*) FROM pkg_svc
2950 WHERE pkg_svc.pkgpart = cust_pkg.pkgpart
2951 AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
2952 WHERE cust_svc.pkgnum = cust_pkg.pkgnum
2953 AND cust_svc.svcpart = pkg_svc.svcpart
2960 # setup queries, links, subs, etc. for the search
2963 # here is the agent virtualization
2964 if ($params->{CurrentUser}) {
2966 qsearchs('access_user', { username => $params->{CurrentUser} });
2969 push @where, $access_user->agentnums_sql('table'=>'cust_main');
2974 push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
2977 my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
2979 my $addl_from = 'LEFT JOIN cust_main USING ( custnum ) '.
2980 'LEFT JOIN part_pkg USING ( pkgpart ) '.
2981 'LEFT JOIN pkg_class ON ( part_pkg.classnum = pkg_class.classnum ) ';
2983 my $count_query = "SELECT COUNT(*) FROM cust_pkg $addl_from $extra_sql";
2986 'table' => 'cust_pkg',
2988 'select' => join(', ',
2990 ( map "part_pkg.$_", qw( pkg freq ) ),
2991 'pkg_class.classname',
2992 'cust_main.custnum AS cust_main_custnum',
2993 FS::UI::Web::cust_sql_fields(
2994 $params->{'cust_fields'}
2997 'extra_sql' => "$extra_sql $orderby",
2998 'addl_from' => $addl_from,
2999 'count_query' => $count_query,
3006 Returns a list of two package counts. The first is a count of packages
3007 based on the supplied criteria and the second is the count of residential
3008 packages with those same criteria. Criteria are specified as in the search
3014 my ($class, $params) = @_;
3016 my $sql_query = $class->search( $params );
3018 my $count_sql = delete($sql_query->{'count_query'});
3019 $count_sql =~ s/ FROM/,count(CASE WHEN cust_main.company IS NULL OR cust_main.company = '' THEN 1 END) FROM/
3020 or die "couldn't parse count_sql";
3022 my $count_sth = dbh->prepare($count_sql)
3023 or die "Error preparing $count_sql: ". dbh->errstr;
3025 or die "Error executing $count_sql: ". $count_sth->errstr;
3026 my $count_arrayref = $count_sth->fetchrow_arrayref;
3028 return ( @$count_arrayref );
3035 Returns a list: the first item is an SQL fragment identifying matching
3036 packages/customers via location (taking into account shipping and package
3037 address taxation, if enabled), and subsequent items are the parameters to
3038 substitute for the placeholders in that fragment.
3043 my($class, %opt) = @_;
3044 my $ornull = $opt{'ornull'};
3046 my $conf = new FS::Conf;
3048 # '?' placeholders in _location_sql_where
3049 my $x = $ornull ? 3 : 2;
3050 my @bill_param = ( ('city')x3, ('county')x$x, ('state')x$x, 'country' );
3054 if ( $conf->exists('tax-ship_address') ) {
3057 ( ( ship_last IS NULL OR ship_last = '' )
3058 AND ". _location_sql_where('cust_main', '', $ornull ). "
3060 OR ( ship_last IS NOT NULL AND ship_last != ''
3061 AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
3064 # AND payby != 'COMP'
3066 @main_param = ( @bill_param, @bill_param );
3070 $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
3071 @main_param = @bill_param;
3077 if ( $conf->exists('tax-pkg_address') ) {
3079 my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
3082 ( cust_pkg.locationnum IS NULL AND $main_where )
3083 OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where )
3086 @param = ( @main_param, @bill_param );
3090 $where = $main_where;
3091 @param = @main_param;
3099 #subroutine, helper for location_sql
3100 sub _location_sql_where {
3102 my $prefix = @_ ? shift : '';
3103 my $ornull = @_ ? shift : '';
3105 # $ornull = $ornull ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
3107 $ornull = $ornull ? ' OR ? IS NULL ' : '';
3109 my $or_empty_city = " OR ( ? = '' AND $table.${prefix}city IS NULL ) ";
3110 my $or_empty_county = " OR ( ? = '' AND $table.${prefix}county IS NULL ) ";
3111 my $or_empty_state = " OR ( ? = '' AND $table.${prefix}state IS NULL ) ";
3113 # ( $table.${prefix}city = ? $or_empty_city $ornull )
3115 ( $table.${prefix}city = ? OR ? = '' OR CAST(? AS text) IS NULL )
3116 AND ( $table.${prefix}county = ? $or_empty_county $ornull )
3117 AND ( $table.${prefix}state = ? $or_empty_state $ornull )
3118 AND $table.${prefix}country = ?
3126 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
3128 CUSTNUM is a customer (see L<FS::cust_main>)
3130 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
3131 L<FS::part_pkg>) to order for this customer. Duplicates are of course
3134 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
3135 remove for this customer. The services (see L<FS::cust_svc>) are moved to the
3136 new billing items. An error is returned if this is not possible (see
3137 L<FS::pkg_svc>). An empty arrayref is equivalent to not specifying this
3140 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
3141 newly-created cust_pkg objects.
3143 REFNUM, if specified, will specify the FS::pkg_referral record to be created
3144 and inserted. Multiple FS::pkg_referral records can be created by
3145 setting I<refnum> to an array reference of refnums or a hash reference with
3146 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
3147 record will be created corresponding to cust_main.refnum.
3152 my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
3154 my $conf = new FS::Conf;
3156 # Transactionize this whole mess
3157 local $SIG{HUP} = 'IGNORE';
3158 local $SIG{INT} = 'IGNORE';
3159 local $SIG{QUIT} = 'IGNORE';
3160 local $SIG{TERM} = 'IGNORE';
3161 local $SIG{TSTP} = 'IGNORE';
3162 local $SIG{PIPE} = 'IGNORE';
3164 my $oldAutoCommit = $FS::UID::AutoCommit;
3165 local $FS::UID::AutoCommit = 0;
3169 # my $cust_main = qsearchs('cust_main', { custnum => $custnum });
3170 # return "Customer not found: $custnum" unless $cust_main;
3172 warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
3175 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
3178 my $change = scalar(@old_cust_pkg) != 0;
3181 if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
3183 warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
3184 " to pkgpart ". $pkgparts->[0]. "\n"
3187 my $err_or_cust_pkg =
3188 $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
3189 'refnum' => $refnum,
3192 unless (ref($err_or_cust_pkg)) {
3193 $dbh->rollback if $oldAutoCommit;
3194 return $err_or_cust_pkg;
3197 push @$return_cust_pkg, $err_or_cust_pkg;
3198 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3203 # Create the new packages.
3204 foreach my $pkgpart (@$pkgparts) {
3206 warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
3208 my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
3209 pkgpart => $pkgpart,
3213 $error = $cust_pkg->insert( 'change' => $change );
3215 $dbh->rollback if $oldAutoCommit;
3218 push @$return_cust_pkg, $cust_pkg;
3220 # $return_cust_pkg now contains refs to all of the newly
3223 # Transfer services and cancel old packages.
3224 foreach my $old_pkg (@old_cust_pkg) {
3226 warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
3229 foreach my $new_pkg (@$return_cust_pkg) {
3230 $error = $old_pkg->transfer($new_pkg);
3231 if ($error and $error == 0) {
3232 # $old_pkg->transfer failed.
3233 $dbh->rollback if $oldAutoCommit;
3238 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
3239 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
3240 foreach my $new_pkg (@$return_cust_pkg) {
3241 $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
3242 if ($error and $error == 0) {
3243 # $old_pkg->transfer failed.
3244 $dbh->rollback if $oldAutoCommit;
3251 # Transfers were successful, but we went through all of the
3252 # new packages and still had services left on the old package.
3253 # We can't cancel the package under the circumstances, so abort.
3254 $dbh->rollback if $oldAutoCommit;
3255 return "Unable to transfer all services from package ".$old_pkg->pkgnum;
3257 $error = $old_pkg->cancel( quiet=>1 );
3263 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3267 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
3269 A bulk change method to change packages for multiple customers.
3271 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
3272 L<FS::part_pkg>) to order for each customer. Duplicates are of course
3275 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
3276 replace. The services (see L<FS::cust_svc>) are moved to the
3277 new billing items. An error is returned if this is not possible (see
3280 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
3281 newly-created cust_pkg objects.
3286 my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
3288 # Transactionize this whole mess
3289 local $SIG{HUP} = 'IGNORE';
3290 local $SIG{INT} = 'IGNORE';
3291 local $SIG{QUIT} = 'IGNORE';
3292 local $SIG{TERM} = 'IGNORE';
3293 local $SIG{TSTP} = 'IGNORE';
3294 local $SIG{PIPE} = 'IGNORE';
3296 my $oldAutoCommit = $FS::UID::AutoCommit;
3297 local $FS::UID::AutoCommit = 0;
3301 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
3304 while(scalar(@old_cust_pkg)) {
3306 my $custnum = $old_cust_pkg[0]->custnum;
3307 my (@remove) = map { $_->pkgnum }
3308 grep { $_->custnum == $custnum } @old_cust_pkg;
3309 @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
3311 my $error = order $custnum, $pkgparts, \@remove, \@return;
3313 push @errors, $error
3315 push @$return_cust_pkg, @return;
3318 if (scalar(@errors)) {
3319 $dbh->rollback if $oldAutoCommit;
3320 return join(' / ', @errors);
3323 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3327 # Used by FS::Upgrade to migrate to a new database.
3328 sub _upgrade_data { # class method
3329 my ($class, %opts) = @_;
3330 $class->_upgrade_otaker(%opts);
3331 my $sql =('UPDATE cust_pkg SET contract_end = NULL WHERE contract_end = -1');
3332 my $sth = dbh->prepare($sql);
3333 $sth->execute or die $sth->errstr;
3340 sub order is not OO. Perhaps it should be moved to FS::cust_main and made so?
3342 In sub order, the @pkgparts array (passed by reference) is clobbered.
3344 Also in sub order, no money is adjusted. Once FS::part_pkg defines a standard
3345 method to pass dates to the recur_prog expression, it should do so.
3347 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
3348 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
3349 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
3350 configuration values. Probably need a subroutine which decides what to do
3351 based on whether or not we've fetched the user yet, rather than a hash. See
3352 FS::UID and the TODO.
3354 Now that things are transactional should the check in the insert method be
3359 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
3360 L<FS::pkg_svc>, schema.html from the base documentation