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)
162 order taker (see L<FS::access_user>)
166 If this field is set to 1, disables the automatic
167 unsuspension of this package when using the B<unsuspendauto> config option.
171 If not set, defaults to 1
175 Date of change from previous package
185 =item change_locationnum
191 Note: setup, last_bill, bill, adjourn, susp, expire, cancel and change_date
192 are specified as UNIX timestamps; see L<perlfunc/"time">. Also see
193 L<Time::Local> and L<Date::Parse> for conversion functions.
201 Create a new billing item. To add the item to the database, see L<"insert">.
205 sub table { 'cust_pkg'; }
206 sub cust_linked { $_[0]->cust_main_custnum; }
207 sub cust_unlinked_msg {
209 "WARNING: can't find cust_main.custnum ". $self->custnum.
210 ' (cust_pkg.pkgnum '. $self->pkgnum. ')';
213 =item insert [ OPTION => VALUE ... ]
215 Adds this billing item to the database ("Orders" the item). If there is an
216 error, returns the error, otherwise returns false.
218 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
219 will be used to look up the package definition and agent restrictions will be
222 If the additional field I<refnum> is defined, an FS::pkg_referral record will
223 be created and inserted. Multiple FS::pkg_referral records can be created by
224 setting I<refnum> to an array reference of refnums or a hash reference with
225 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
226 record will be created corresponding to cust_main.refnum.
228 The following options are available:
234 If set true, supresses any referral credit to a referring customer.
238 cust_pkg_option records will be created
242 a ticket will be added to this customer with this subject
246 an optional queue name for ticket additions
253 my( $self, %options ) = @_;
255 if ( $self->part_pkg->option('start_1st', 1) && !$self->start_date ) {
256 my ($sec,$min,$hour,$mday,$mon,$year) = (localtime(time) )[0,1,2,3,4,5];
257 $mon += 1 unless $mday == 1;
258 until ( $mon < 12 ) { $mon -= 12; $year++; }
259 $self->start_date( timelocal_nocheck(0,0,0,1,$mon,$year) );
262 my $expire_months = $self->part_pkg->option('expire_months', 1);
263 if ( $expire_months && !$self->expire ) {
264 my $start = $self->start_date || $self->setup || time;
266 #false laziness w/part_pkg::add_freq
267 my ($sec,$min,$hour,$mday,$mon,$year) = (localtime($start) )[0,1,2,3,4,5];
268 $mon += $expire_months;
269 until ( $mon < 12 ) { $mon -= 12; $year++; }
271 #$self->expire( timelocal_nocheck($sec,$min,$hour,$mday,$mon,$year) );
272 $self->expire( timelocal_nocheck(0,0,0,$mday,$mon,$year) );
275 local $SIG{HUP} = 'IGNORE';
276 local $SIG{INT} = 'IGNORE';
277 local $SIG{QUIT} = 'IGNORE';
278 local $SIG{TERM} = 'IGNORE';
279 local $SIG{TSTP} = 'IGNORE';
280 local $SIG{PIPE} = 'IGNORE';
282 my $oldAutoCommit = $FS::UID::AutoCommit;
283 local $FS::UID::AutoCommit = 0;
286 my $error = $self->SUPER::insert($options{options} ? %{$options{options}} : ());
288 $dbh->rollback if $oldAutoCommit;
292 $self->refnum($self->cust_main->refnum) unless $self->refnum;
293 $self->refnum( [ $self->refnum ] ) unless ref($self->refnum);
294 $self->process_m2m( 'link_table' => 'pkg_referral',
295 'target_table' => 'part_referral',
296 'params' => $self->refnum,
299 if ( $self->discountnum ) {
300 my $error = $self->insert_discount();
302 $dbh->rollback if $oldAutoCommit;
307 #if ( $self->reg_code ) {
308 # my $reg_code = qsearchs('reg_code', { 'code' => $self->reg_code } );
309 # $error = $reg_code->delete;
311 # $dbh->rollback if $oldAutoCommit;
316 my $conf = new FS::Conf;
318 if ( $conf->config('ticket_system') && $options{ticket_subject} ) {
321 # use lib ( "/opt/rt3/local/lib", "/opt/rt3/lib" );
328 use FS::TicketSystem;
329 FS::TicketSystem->init();
331 my $q = new RT::Queue($RT::SystemUser);
332 $q->Load($options{ticket_queue}) if $options{ticket_queue};
333 my $t = new RT::Ticket($RT::SystemUser);
334 my $mime = new MIME::Entity;
335 $mime->build( Type => 'text/plain', Data => $options{ticket_subject} );
336 $t->Create( $options{ticket_queue} ? (Queue => $q) : (),
337 Subject => $options{ticket_subject},
340 $t->AddLink( Type => 'MemberOf',
341 Target => 'freeside://freeside/cust_main/'. $self->custnum,
345 if ($conf->config('welcome_letter') && $self->cust_main->num_pkgs == 1) {
346 my $queue = new FS::queue {
347 'job' => 'FS::cust_main::queueable_print',
349 $error = $queue->insert(
350 'custnum' => $self->custnum,
351 'template' => 'welcome_letter',
355 warn "can't send welcome letter: $error";
360 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
367 This method now works but you probably shouldn't use it.
369 You don't want to delete billing items, because there would then be no record
370 the customer ever purchased the item. Instead, see the cancel method.
375 # return "Can't delete cust_pkg records!";
378 =item replace [ OLD_RECORD ] [ HASHREF | OPTION => VALUE ... ]
380 Replaces the OLD_RECORD with this one in the database. If there is an error,
381 returns the error, otherwise returns false.
383 Currently, custnum, setup, bill, adjourn, susp, expire, and cancel may be changed.
385 Changing pkgpart may have disasterous effects. See the order subroutine.
387 setup and bill are normally updated by calling the bill method of a customer
388 object (see L<FS::cust_main>).
390 suspend is normally updated by the suspend and unsuspend methods.
392 cancel is normally updated by the cancel method (and also the order subroutine
395 Available options are:
401 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.
405 the access_user (see L<FS::access_user>) providing the reason
409 hashref of keys and values - cust_pkg_option records will be created, updated or removed as appopriate
418 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
423 ( ref($_[0]) eq 'HASH' )
427 #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
428 #return "Can't change otaker!" if $old->otaker ne $new->otaker;
431 #return "Can't change setup once it exists!"
432 # if $old->getfield('setup') &&
433 # $old->getfield('setup') != $new->getfield('setup');
435 #some logic for bill, susp, cancel?
437 local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
439 local $SIG{HUP} = 'IGNORE';
440 local $SIG{INT} = 'IGNORE';
441 local $SIG{QUIT} = 'IGNORE';
442 local $SIG{TERM} = 'IGNORE';
443 local $SIG{TSTP} = 'IGNORE';
444 local $SIG{PIPE} = 'IGNORE';
446 my $oldAutoCommit = $FS::UID::AutoCommit;
447 local $FS::UID::AutoCommit = 0;
450 foreach my $method ( qw(adjourn expire) ) { # How many reasons?
451 if ($options->{'reason'} && $new->$method && $old->$method ne $new->$method) {
452 my $error = $new->insert_reason(
453 'reason' => $options->{'reason'},
454 'date' => $new->$method,
456 'reason_otaker' => $options->{'reason_otaker'},
459 dbh->rollback if $oldAutoCommit;
460 return "Error inserting cust_pkg_reason: $error";
465 #save off and freeze RADIUS attributes for any associated svc_acct records
467 if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
469 #also check for specific exports?
470 # to avoid spurious modify export events
471 @svc_acct = map { $_->svc_x }
472 grep { $_->part_svc->svcdb eq 'svc_acct' }
475 $_->snapshot foreach @svc_acct;
479 my $error = $new->SUPER::replace($old,
480 $options->{options} ? $options->{options} : ()
483 $dbh->rollback if $oldAutoCommit;
487 #for prepaid packages,
488 #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
489 foreach my $old_svc_acct ( @svc_acct ) {
490 my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
491 my $s_error = $new_svc_acct->replace($old_svc_acct);
493 $dbh->rollback if $oldAutoCommit;
498 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
505 Checks all fields to make sure this is a valid billing item. If there is an
506 error, returns the error, otherwise returns false. Called by the insert and
514 $self->locationnum('') if !$self->locationnum || $self->locationnum == -1;
517 $self->ut_numbern('pkgnum')
518 || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
519 || $self->ut_numbern('pkgpart')
520 || $self->ut_foreign_keyn('locationnum', 'cust_location', 'locationnum')
521 || $self->ut_numbern('start_date')
522 || $self->ut_numbern('setup')
523 || $self->ut_numbern('bill')
524 || $self->ut_numbern('susp')
525 || $self->ut_numbern('cancel')
526 || $self->ut_numbern('adjourn')
527 || $self->ut_numbern('expire')
528 || $self->ut_enum('no_auto', [ '', 'Y' ])
530 return $error if $error;
532 if ( $self->reg_code ) {
534 unless ( grep { $self->pkgpart == $_->pkgpart }
535 map { $_->reg_code_pkg }
536 qsearchs( 'reg_code', { 'code' => $self->reg_code,
537 'agentnum' => $self->cust_main->agentnum })
539 return "Unknown registration code";
542 } elsif ( $self->promo_code ) {
545 qsearchs('part_pkg', {
546 'pkgpart' => $self->pkgpart,
547 'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
549 return 'Unknown promotional code' unless $promo_part_pkg;
553 unless ( $disable_agentcheck ) {
555 qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
556 return "agent ". $agent->agentnum. ':'. $agent->agent.
557 " can't purchase pkgpart ". $self->pkgpart
558 unless $agent->pkgpart_hashref->{ $self->pkgpart }
559 || $agent->agentnum == $self->part_pkg->agentnum;
562 $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
563 return $error if $error;
567 $self->usernum($FS::CurrentUser::CurrentUser->usernum) unless $self->usernum;
569 if ( $self->dbdef_table->column('manual_flag') ) {
570 $self->manual_flag('') if $self->manual_flag eq ' ';
571 $self->manual_flag =~ /^([01]?)$/
572 or return "Illegal manual_flag ". $self->manual_flag;
573 $self->manual_flag($1);
579 =item cancel [ OPTION => VALUE ... ]
581 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
582 in this package, then cancels the package itself (sets the cancel field to
585 Available options are:
589 =item quiet - can be set true to supress email cancellation notices.
591 =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.
593 =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.
595 =item date - can be set to a unix style timestamp to specify when to cancel (expire)
597 =item nobill - can be set true to skip billing if it might otherwise be done.
601 If there is an error, returns the error, otherwise returns false.
606 my( $self, %options ) = @_;
609 my $conf = new FS::Conf;
611 warn "cust_pkg::cancel called with options".
612 join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
615 local $SIG{HUP} = 'IGNORE';
616 local $SIG{INT} = 'IGNORE';
617 local $SIG{QUIT} = 'IGNORE';
618 local $SIG{TERM} = 'IGNORE';
619 local $SIG{TSTP} = 'IGNORE';
620 local $SIG{PIPE} = 'IGNORE';
622 my $oldAutoCommit = $FS::UID::AutoCommit;
623 local $FS::UID::AutoCommit = 0;
626 my $old = $self->select_for_update;
628 if ( $old->get('cancel') || $self->get('cancel') ) {
629 dbh->rollback if $oldAutoCommit;
630 return ""; # no error
633 my $date = $options{date} if $options{date}; # expire/cancel later
634 $date = '' if ($date && $date <= time); # complain instead?
636 #race condition: usage could be ongoing until unprovisioned
637 #resolved by performing a change package instead (which unprovisions) and
639 if ( !$options{nobill} && !$date && $conf->exists('bill_usage_on_cancel') ) {
640 my $copy = $self->new({$self->hash});
642 $copy->cust_main->bill( pkg_list => [ $copy ], cancel => 1 );
643 warn "Error billing during cancel, custnum ".
644 #$self->cust_main->custnum. ": $error"
650 my $cancel_time = $options{'time'} || time;
652 if ( $options{'reason'} ) {
653 $error = $self->insert_reason( 'reason' => $options{'reason'},
654 'action' => $date ? 'expire' : 'cancel',
655 'date' => $date ? $date : $cancel_time,
656 'reason_otaker' => $options{'reason_otaker'},
659 dbh->rollback if $oldAutoCommit;
660 return "Error inserting cust_pkg_reason: $error";
666 foreach my $cust_svc (
669 sort { $a->[1] <=> $b->[1] }
670 map { [ $_, $_->svc_x->table_info->{'cancel_weight'} ]; }
671 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
674 my $error = $cust_svc->cancel;
677 $dbh->rollback if $oldAutoCommit;
678 return "Error cancelling cust_svc: $error";
682 # Add a credit for remaining service
683 my $remaining_value = $self->calc_remain(time=>$cancel_time);
684 if ( $remaining_value > 0 && !$options{'no_credit'} ) {
685 my $error = $self->cust_main->credit(
687 'Credit for unused time on '. $self->part_pkg->pkg,
688 'reason_type' => $conf->config('cancel_credit_type'),
691 $dbh->rollback if $oldAutoCommit;
692 return "Error crediting customer \$$remaining_value for unused time on".
693 $self->part_pkg->pkg. ": $error";
698 my %hash = $self->hash;
699 $date ? ($hash{'expire'} = $date) : ($hash{'cancel'} = $cancel_time);
700 my $new = new FS::cust_pkg ( \%hash );
701 $error = $new->replace( $self, options => { $self->options } );
703 $dbh->rollback if $oldAutoCommit;
707 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
708 return '' if $date; #no errors
710 my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
711 if ( !$options{'quiet'} && $conf->exists('emailcancel') && @invoicing_list ) {
712 my $msgnum = $conf->config('cancel_msgnum', $self->cust_main->agentnum);
715 my $msg_template = qsearchs('msg_template', { msgnum => $msgnum });
716 $error = $msg_template->send( 'cust_main' => $self->cust_main,
721 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
722 'to' => \@invoicing_list,
723 'subject' => ( $conf->config('cancelsubject') || 'Cancellation Notice' ),
724 'body' => [ map "$_\n", $conf->config('cancelmessage') ],
727 #should this do something on errors?
734 =item cancel_if_expired [ NOW_TIMESTAMP ]
736 Cancels this package if its expire date has been reached.
740 sub cancel_if_expired {
742 my $time = shift || time;
743 return '' unless $self->expire && $self->expire <= $time;
744 my $error = $self->cancel;
746 return "Error cancelling expired pkg ". $self->pkgnum. " for custnum ".
747 $self->custnum. ": $error";
754 Cancels any pending expiration (sets the expire field to null).
756 If there is an error, returns the error, otherwise returns false.
761 my( $self, %options ) = @_;
764 local $SIG{HUP} = 'IGNORE';
765 local $SIG{INT} = 'IGNORE';
766 local $SIG{QUIT} = 'IGNORE';
767 local $SIG{TERM} = 'IGNORE';
768 local $SIG{TSTP} = 'IGNORE';
769 local $SIG{PIPE} = 'IGNORE';
771 my $oldAutoCommit = $FS::UID::AutoCommit;
772 local $FS::UID::AutoCommit = 0;
775 my $old = $self->select_for_update;
777 my $pkgnum = $old->pkgnum;
778 if ( $old->get('cancel') || $self->get('cancel') ) {
779 dbh->rollback if $oldAutoCommit;
780 return "Can't unexpire cancelled package $pkgnum";
781 # or at least it's pointless
784 unless ( $old->get('expire') && $self->get('expire') ) {
785 dbh->rollback if $oldAutoCommit;
786 return ""; # no error
789 my %hash = $self->hash;
790 $hash{'expire'} = '';
791 my $new = new FS::cust_pkg ( \%hash );
792 $error = $new->replace( $self, options => { $self->options } );
794 $dbh->rollback if $oldAutoCommit;
798 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
804 =item suspend [ OPTION => VALUE ... ]
806 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
807 package, then suspends the package itself (sets the susp field to now).
809 Available options are:
813 =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.
815 =item date - can be set to a unix style timestamp to specify when to suspend (adjourn)
819 If there is an error, returns the error, otherwise returns false.
824 my( $self, %options ) = @_;
827 local $SIG{HUP} = 'IGNORE';
828 local $SIG{INT} = 'IGNORE';
829 local $SIG{QUIT} = 'IGNORE';
830 local $SIG{TERM} = 'IGNORE';
831 local $SIG{TSTP} = 'IGNORE';
832 local $SIG{PIPE} = 'IGNORE';
834 my $oldAutoCommit = $FS::UID::AutoCommit;
835 local $FS::UID::AutoCommit = 0;
838 my $old = $self->select_for_update;
840 my $pkgnum = $old->pkgnum;
841 if ( $old->get('cancel') || $self->get('cancel') ) {
842 dbh->rollback if $oldAutoCommit;
843 return "Can't suspend cancelled package $pkgnum";
846 if ( $old->get('susp') || $self->get('susp') ) {
847 dbh->rollback if $oldAutoCommit;
848 return ""; # no error # complain on adjourn?
851 my $date = $options{date} if $options{date}; # adjourn/suspend later
852 $date = '' if ($date && $date <= time); # complain instead?
854 if ( $date && $old->get('expire') && $old->get('expire') < $date ) {
855 dbh->rollback if $oldAutoCommit;
856 return "Package $pkgnum expires before it would be suspended.";
859 my $suspend_time = $options{'time'} || time;
861 if ( $options{'reason'} ) {
862 $error = $self->insert_reason( 'reason' => $options{'reason'},
863 'action' => $date ? 'adjourn' : 'suspend',
864 'date' => $date ? $date : $suspend_time,
865 'reason_otaker' => $options{'reason_otaker'},
868 dbh->rollback if $oldAutoCommit;
869 return "Error inserting cust_pkg_reason: $error";
877 foreach my $cust_svc (
878 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
880 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
882 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
883 $dbh->rollback if $oldAutoCommit;
884 return "Illegal svcdb value in part_svc!";
887 require "FS/$svcdb.pm";
889 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
891 $error = $svc->suspend;
893 $dbh->rollback if $oldAutoCommit;
896 my( $label, $value ) = $cust_svc->label;
897 push @labels, "$label: $value";
901 my $conf = new FS::Conf;
902 if ( $conf->config('suspend_email_admin') ) {
904 my $error = send_email(
905 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
906 #invoice_from ??? well as good as any
907 'to' => $conf->config('suspend_email_admin'),
908 'subject' => 'FREESIDE NOTIFICATION: Customer package suspended',
910 "This is an automatic message from your Freeside installation\n",
911 "informing you that the following customer package has been suspended:\n",
913 'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
914 'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
915 ( map { "Service : $_\n" } @labels ),
920 warn "WARNING: can't send suspension admin email (suspending anyway): ".
928 my %hash = $self->hash;
930 $hash{'adjourn'} = $date;
932 $hash{'susp'} = $suspend_time;
934 my $new = new FS::cust_pkg ( \%hash );
935 $error = $new->replace( $self, options => { $self->options } );
937 $dbh->rollback if $oldAutoCommit;
941 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
946 =item unsuspend [ OPTION => VALUE ... ]
948 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
949 package, then unsuspends the package itself (clears the susp field and the
950 adjourn field if it is in the past).
952 Available options are:
956 =item adjust_next_bill
958 Can be set true to adjust the next bill date forward by
959 the amount of time the account was inactive. This was set true by default
960 since 1.4.2 and 1.5.0pre6; however, starting with 1.7.0 this needs to be
961 explicitly requested. Price plans for which this makes sense (anniversary-date
962 based than prorate or subscription) could have an option to enable this
967 If there is an error, returns the error, otherwise returns false.
972 my( $self, %opt ) = @_;
975 local $SIG{HUP} = 'IGNORE';
976 local $SIG{INT} = 'IGNORE';
977 local $SIG{QUIT} = 'IGNORE';
978 local $SIG{TERM} = 'IGNORE';
979 local $SIG{TSTP} = 'IGNORE';
980 local $SIG{PIPE} = 'IGNORE';
982 my $oldAutoCommit = $FS::UID::AutoCommit;
983 local $FS::UID::AutoCommit = 0;
986 my $old = $self->select_for_update;
988 my $pkgnum = $old->pkgnum;
989 if ( $old->get('cancel') || $self->get('cancel') ) {
990 dbh->rollback if $oldAutoCommit;
991 return "Can't unsuspend cancelled package $pkgnum";
994 unless ( $old->get('susp') && $self->get('susp') ) {
995 dbh->rollback if $oldAutoCommit;
996 return ""; # no error # complain instead?
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->unsuspend;
1015 $dbh->rollback if $oldAutoCommit;
1022 my %hash = $self->hash;
1023 my $inactive = time - $hash{'susp'};
1025 my $conf = new FS::Conf;
1027 if ( $inactive > 0 &&
1028 ( $hash{'bill'} || $hash{'setup'} ) &&
1029 ( $opt{'adjust_next_bill'} ||
1030 $conf->exists('unsuspend-always_adjust_next_bill_date') ||
1031 $self->part_pkg->option('unsuspend_adjust_bill', 1) )
1034 $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive;
1039 $hash{'adjourn'} = '' if $hash{'adjourn'} < time;
1040 my $new = new FS::cust_pkg ( \%hash );
1041 $error = $new->replace( $self, options => { $self->options } );
1043 $dbh->rollback if $oldAutoCommit;
1047 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1054 Cancels any pending suspension (sets the adjourn field to null).
1056 If there is an error, returns the error, otherwise returns false.
1061 my( $self, %options ) = @_;
1064 local $SIG{HUP} = 'IGNORE';
1065 local $SIG{INT} = 'IGNORE';
1066 local $SIG{QUIT} = 'IGNORE';
1067 local $SIG{TERM} = 'IGNORE';
1068 local $SIG{TSTP} = 'IGNORE';
1069 local $SIG{PIPE} = 'IGNORE';
1071 my $oldAutoCommit = $FS::UID::AutoCommit;
1072 local $FS::UID::AutoCommit = 0;
1075 my $old = $self->select_for_update;
1077 my $pkgnum = $old->pkgnum;
1078 if ( $old->get('cancel') || $self->get('cancel') ) {
1079 dbh->rollback if $oldAutoCommit;
1080 return "Can't unadjourn cancelled package $pkgnum";
1081 # or at least it's pointless
1084 if ( $old->get('susp') || $self->get('susp') ) {
1085 dbh->rollback if $oldAutoCommit;
1086 return "Can't unadjourn suspended package $pkgnum";
1087 # perhaps this is arbitrary
1090 unless ( $old->get('adjourn') && $self->get('adjourn') ) {
1091 dbh->rollback if $oldAutoCommit;
1092 return ""; # no error
1095 my %hash = $self->hash;
1096 $hash{'adjourn'} = '';
1097 my $new = new FS::cust_pkg ( \%hash );
1098 $error = $new->replace( $self, options => { $self->options } );
1100 $dbh->rollback if $oldAutoCommit;
1104 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1111 =item change HASHREF | OPTION => VALUE ...
1113 Changes this package: cancels it and creates a new one, with a different
1114 pkgpart or locationnum or both. All services are transferred to the new
1115 package (no change will be made if this is not possible).
1117 Options may be passed as a list of key/value pairs or as a hash reference.
1124 New locationnum, to change the location for this package.
1128 New FS::cust_location object, to create a new location and assign it
1133 New pkgpart (see L<FS::part_pkg>).
1137 New refnum (see L<FS::part_referral>).
1141 At least one option must be specified (otherwise, what's the point?)
1143 Returns either the new FS::cust_pkg object or a scalar error.
1147 my $err_or_new_cust_pkg = $old_cust_pkg->change
1151 #some false laziness w/order
1154 my $opt = ref($_[0]) ? shift : { @_ };
1156 # my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
1159 my $conf = new FS::Conf;
1161 # Transactionize this whole mess
1162 local $SIG{HUP} = 'IGNORE';
1163 local $SIG{INT} = 'IGNORE';
1164 local $SIG{QUIT} = 'IGNORE';
1165 local $SIG{TERM} = 'IGNORE';
1166 local $SIG{TSTP} = 'IGNORE';
1167 local $SIG{PIPE} = 'IGNORE';
1169 my $oldAutoCommit = $FS::UID::AutoCommit;
1170 local $FS::UID::AutoCommit = 0;
1179 #$hash{$_} = $self->$_() foreach qw( last_bill bill );
1181 #$hash{$_} = $self->$_() foreach qw( setup );
1183 $hash{'setup'} = $time if $self->setup;
1185 $hash{'change_date'} = $time;
1186 $hash{"change_$_"} = $self->$_()
1187 foreach qw( pkgnum pkgpart locationnum );
1189 if ( $opt->{'cust_location'} &&
1190 ( ! $opt->{'locationnum'} || $opt->{'locationnum'} == -1 ) ) {
1191 $error = $opt->{'cust_location'}->insert;
1193 $dbh->rollback if $oldAutoCommit;
1194 return "inserting cust_location (transaction rolled back): $error";
1196 $opt->{'locationnum'} = $opt->{'cust_location'}->locationnum;
1199 # Create the new package.
1200 my $cust_pkg = new FS::cust_pkg {
1201 custnum => $self->custnum,
1202 pkgpart => ( $opt->{'pkgpart'} || $self->pkgpart ),
1203 refnum => ( $opt->{'refnum'} || $self->refnum ),
1204 locationnum => ( $opt->{'locationnum'} || $self->locationnum ),
1208 $error = $cust_pkg->insert( 'change' => 1 );
1210 $dbh->rollback if $oldAutoCommit;
1214 # Transfer services and cancel old package.
1216 $error = $self->transfer($cust_pkg);
1217 if ($error and $error == 0) {
1218 # $old_pkg->transfer failed.
1219 $dbh->rollback if $oldAutoCommit;
1223 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1224 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1225 $error = $self->transfer($cust_pkg, 'change_svcpart'=>1 );
1226 if ($error and $error == 0) {
1227 # $old_pkg->transfer failed.
1228 $dbh->rollback if $oldAutoCommit;
1234 # Transfers were successful, but we still had services left on the old
1235 # package. We can't change the package under this circumstances, so abort.
1236 $dbh->rollback if $oldAutoCommit;
1237 return "Unable to transfer all services from package ". $self->pkgnum;
1240 #reset usage if changing pkgpart
1241 # AND usage rollover is off (otherwise adds twice, now and at package bill)
1242 if ($self->pkgpart != $cust_pkg->pkgpart) {
1243 my $part_pkg = $cust_pkg->part_pkg;
1244 $error = $part_pkg->reset_usage($cust_pkg, $part_pkg->is_prepaid
1248 if $part_pkg->can('reset_usage') && ! $part_pkg->option('usage_rollover');
1251 $dbh->rollback if $oldAutoCommit;
1252 return "Error setting usage values: $error";
1256 #Good to go, cancel old package.
1257 $error = $self->cancel( quiet=>1 );
1259 $dbh->rollback if $oldAutoCommit;
1263 if ( $conf->exists('cust_pkg-change_pkgpart-bill_now') ) {
1265 my $error = $cust_pkg->cust_main->bill( 'pkg_list' => [ $cust_pkg ] );
1267 $dbh->rollback if $oldAutoCommit;
1272 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1280 Returns the last bill date, or if there is no last bill date, the setup date.
1281 Useful for billing metered services.
1287 return $self->setfield('last_bill', $_[0]) if @_;
1288 return $self->getfield('last_bill') if $self->getfield('last_bill');
1289 my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
1290 'edate' => $self->bill, } );
1291 $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
1294 =item last_cust_pkg_reason ACTION
1296 Returns the most recent ACTION FS::cust_pkg_reason associated with the package.
1297 Returns false if there is no reason or the package is not currenly ACTION'd
1298 ACTION is one of adjourn, susp, cancel, or expire.
1302 sub last_cust_pkg_reason {
1303 my ( $self, $action ) = ( shift, shift );
1304 my $date = $self->get($action);
1306 'table' => 'cust_pkg_reason',
1307 'hashref' => { 'pkgnum' => $self->pkgnum,
1308 'action' => substr(uc($action), 0, 1),
1311 'order_by' => 'ORDER BY num DESC LIMIT 1',
1315 =item last_reason ACTION
1317 Returns the most recent ACTION FS::reason associated with the package.
1318 Returns false if there is no reason or the package is not currenly ACTION'd
1319 ACTION is one of adjourn, susp, cancel, or expire.
1324 my $cust_pkg_reason = shift->last_cust_pkg_reason(@_);
1325 $cust_pkg_reason->reason
1326 if $cust_pkg_reason;
1331 Returns the definition for this billing item, as an FS::part_pkg object (see
1338 return $self->{'_pkgpart'} if $self->{'_pkgpart'};
1339 cluck "cust_pkg->part_pkg called" if $DEBUG > 1;
1340 qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
1345 Returns the cancelled package this package was changed from, if any.
1351 return '' unless $self->change_pkgnum;
1352 qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
1357 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
1364 $self->part_pkg->calc_setup($self, @_);
1369 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
1376 $self->part_pkg->calc_recur($self, @_);
1381 Calls the I<calc_remain> of the FS::part_pkg object associated with this
1388 $self->part_pkg->calc_remain($self, @_);
1393 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
1400 $self->part_pkg->calc_cancel($self, @_);
1405 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
1411 qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
1414 =item cust_pkg_detail [ DETAILTYPE ]
1416 Returns any customer package details for this package (see
1417 L<FS::cust_pkg_detail>).
1419 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
1423 sub cust_pkg_detail {
1425 my %hash = ( 'pkgnum' => $self->pkgnum );
1426 $hash{detailtype} = shift if @_;
1428 'table' => 'cust_pkg_detail',
1429 'hashref' => \%hash,
1430 'order_by' => 'ORDER BY weight, pkgdetailnum',
1434 =item set_cust_pkg_detail DETAILTYPE [ DETAIL, DETAIL, ... ]
1436 Sets customer package details for this package (see L<FS::cust_pkg_detail>).
1438 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
1440 If there is an error, returns the error, otherwise returns false.
1444 sub set_cust_pkg_detail {
1445 my( $self, $detailtype, @details ) = @_;
1447 local $SIG{HUP} = 'IGNORE';
1448 local $SIG{INT} = 'IGNORE';
1449 local $SIG{QUIT} = 'IGNORE';
1450 local $SIG{TERM} = 'IGNORE';
1451 local $SIG{TSTP} = 'IGNORE';
1452 local $SIG{PIPE} = 'IGNORE';
1454 my $oldAutoCommit = $FS::UID::AutoCommit;
1455 local $FS::UID::AutoCommit = 0;
1458 foreach my $current ( $self->cust_pkg_detail($detailtype) ) {
1459 my $error = $current->delete;
1461 $dbh->rollback if $oldAutoCommit;
1462 return "error removing old detail: $error";
1466 foreach my $detail ( @details ) {
1467 my $cust_pkg_detail = new FS::cust_pkg_detail {
1468 'pkgnum' => $self->pkgnum,
1469 'detailtype' => $detailtype,
1470 'detail' => $detail,
1472 my $error = $cust_pkg_detail->insert;
1474 $dbh->rollback if $oldAutoCommit;
1475 return "error adding new detail: $error";
1480 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1487 Returns the new-style customer billing events (see L<FS::cust_event>) for this invoice.
1491 #false laziness w/cust_bill.pm
1495 'table' => 'cust_event',
1496 'addl_from' => 'JOIN part_event USING ( eventpart )',
1497 'hashref' => { 'tablenum' => $self->pkgnum },
1498 'extra_sql' => " AND eventtable = 'cust_pkg' ",
1502 =item num_cust_event
1504 Returns the number of new-style customer billing events (see L<FS::cust_event>) for this invoice.
1508 #false laziness w/cust_bill.pm
1509 sub num_cust_event {
1512 "SELECT COUNT(*) FROM cust_event JOIN part_event USING ( eventpart ) ".
1513 " WHERE tablenum = ? AND eventtable = 'cust_pkg'";
1514 my $sth = dbh->prepare($sql) or die dbh->errstr. " preparing $sql";
1515 $sth->execute($self->pkgnum) or die $sth->errstr. " executing $sql";
1516 $sth->fetchrow_arrayref->[0];
1519 =item cust_svc [ SVCPART ]
1521 Returns the services for this package, as FS::cust_svc objects (see
1522 L<FS::cust_svc>). If a svcpart is specified, return only the matching
1530 return () unless $self->num_cust_svc(@_);
1533 return qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum,
1534 'svcpart' => shift, } );
1537 cluck "cust_pkg->cust_svc called" if $DEBUG > 2;
1539 #if ( $self->{'_svcnum'} ) {
1540 # values %{ $self->{'_svcnum'}->cache };
1542 $self->_sort_cust_svc(
1543 [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
1549 =item overlimit [ SVCPART ]
1551 Returns the services for this package which have exceeded their
1552 usage limit as FS::cust_svc objects (see L<FS::cust_svc>). If a svcpart
1553 is specified, return only the matching services.
1559 return () unless $self->num_cust_svc(@_);
1560 grep { $_->overlimit } $self->cust_svc(@_);
1563 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ]
1565 Returns historical services for this package created before END TIMESTAMP and
1566 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
1567 (see L<FS::h_cust_svc>).
1574 $self->_sort_cust_svc(
1575 [ qsearch( 'h_cust_svc',
1576 { 'pkgnum' => $self->pkgnum, },
1577 FS::h_cust_svc->sql_h_search(@_),
1583 sub _sort_cust_svc {
1584 my( $self, $arrayref ) = @_;
1587 sub ($$) { my ($a, $b) = @_; $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] };
1592 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
1593 'svcpart' => $_->svcpart } );
1595 $pkg_svc ? $pkg_svc->primary_svc : '',
1596 $pkg_svc ? $pkg_svc->quantity : 0,
1603 =item num_cust_svc [ SVCPART ]
1605 Returns the number of provisioned services for this package. If a svcpart is
1606 specified, counts only the matching services.
1613 return $self->{'_num_cust_svc'}
1615 && exists($self->{'_num_cust_svc'})
1616 && $self->{'_num_cust_svc'} =~ /\d/;
1618 cluck "cust_pkg->num_cust_svc called, _num_cust_svc:".$self->{'_num_cust_svc'}
1621 my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
1622 $sql .= ' AND svcpart = ?' if @_;
1624 my $sth = dbh->prepare($sql) or die dbh->errstr;
1625 $sth->execute($self->pkgnum, @_) or die $sth->errstr;
1626 $sth->fetchrow_arrayref->[0];
1629 =item available_part_svc
1631 Returns a list of FS::part_svc objects representing services included in this
1632 package but not yet provisioned. Each FS::part_svc object also has an extra
1633 field, I<num_avail>, which specifies the number of available services.
1637 sub available_part_svc {
1639 grep { $_->num_avail > 0 }
1641 my $part_svc = $_->part_svc;
1642 $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
1643 $_->quantity - $self->num_cust_svc($_->svcpart);
1646 $self->part_pkg->pkg_svc;
1651 Returns a list of FS::part_svc objects representing provisioned and available
1652 services included in this package. Each FS::part_svc object also has the
1653 following extra fields:
1657 =item num_cust_svc (count)
1659 =item num_avail (quantity - count)
1661 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
1664 label -> ($cust_svc->label)[1]
1673 #XXX some sort of sort order besides numeric by svcpart...
1674 my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
1676 my $part_svc = $pkg_svc->part_svc;
1677 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1678 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
1679 $part_svc->{'Hash'}{'num_avail'} =
1680 max( 0, $pkg_svc->quantity - $num_cust_svc );
1681 $part_svc->{'Hash'}{'cust_pkg_svc'} =
1682 $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
1684 } $self->part_pkg->pkg_svc;
1687 push @part_svc, map {
1689 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1690 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
1691 $part_svc->{'Hash'}{'num_avail'} = 0; #0-$num_cust_svc ?
1692 $part_svc->{'Hash'}{'cust_pkg_svc'} =
1693 $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
1695 } $self->extra_part_svc;
1701 =item extra_part_svc
1703 Returns a list of FS::part_svc objects corresponding to services in this
1704 package which are still provisioned but not (any longer) available in the
1709 sub extra_part_svc {
1712 my $pkgnum = $self->pkgnum;
1713 my $pkgpart = $self->pkgpart;
1716 # 'table' => 'part_svc',
1719 # "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
1720 # WHERE pkg_svc.svcpart = part_svc.svcpart
1721 # AND pkg_svc.pkgpart = ?
1724 # AND 0 < ( SELECT COUNT(*) FROM cust_svc
1725 # LEFT JOIN cust_pkg USING ( pkgnum )
1726 # WHERE cust_svc.svcpart = part_svc.svcpart
1729 # 'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
1732 #seems to benchmark slightly faster...
1734 #'select' => 'DISTINCT ON (svcpart) part_svc.*',
1735 #MySQL doesn't grok DISINCT ON
1736 'select' => 'DISTINCT part_svc.*',
1737 'table' => 'part_svc',
1739 'LEFT JOIN pkg_svc ON ( pkg_svc.svcpart = part_svc.svcpart
1740 AND pkg_svc.pkgpart = ?
1743 LEFT JOIN cust_svc ON ( cust_svc.svcpart = part_svc.svcpart )
1744 LEFT JOIN cust_pkg USING ( pkgnum )
1747 'extra_sql' => "WHERE pkgsvcnum IS NULL AND cust_pkg.pkgnum = ? ",
1748 'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
1754 Returns a short status string for this package, currently:
1758 =item not yet billed
1760 =item one-time charge
1775 my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
1777 return 'cancelled' if $self->get('cancel');
1778 return 'suspended' if $self->susp;
1779 return 'not yet billed' unless $self->setup;
1780 return 'one-time charge' if $freq =~ /^(0|$)/;
1784 =item ucfirst_status
1786 Returns the status with the first character capitalized.
1790 sub ucfirst_status {
1791 ucfirst(shift->status);
1796 Class method that returns the list of possible status strings for packages
1797 (see L<the status method|/status>). For example:
1799 @statuses = FS::cust_pkg->statuses();
1803 tie my %statuscolor, 'Tie::IxHash',
1804 'not yet billed' => '000000',
1805 'one-time charge' => '000000',
1806 'active' => '00CC00',
1807 'suspended' => 'FF9900',
1808 'cancelled' => 'FF0000',
1812 my $self = shift; #could be class...
1813 #grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
1814 # # mayble split btw one-time vs. recur
1820 Returns a hex triplet color string for this package's status.
1826 $statuscolor{$self->status};
1831 Returns a label for this package. (Currently "pkgnum: pkg - comment" or
1832 "pkg-comment" depending on user preference).
1838 my $label = $self->part_pkg->pkg_comment( 'nopkgpart' => 1 );
1839 $label = $self->pkgnum. ": $label"
1840 if $FS::CurrentUser::CurrentUser->option('show_pkgnum');
1844 =item pkg_label_long
1846 Returns a long label for this package, adding the primary service's label to
1851 sub pkg_label_long {
1853 my $label = $self->pkg_label;
1854 my $cust_svc = $self->primary_cust_svc;
1855 $label .= ' ('. ($cust_svc->label)[1]. ')' if $cust_svc;
1859 =item primary_cust_svc
1861 Returns a primary service (as FS::cust_svc object) if one can be identified.
1865 #for labeling purposes - might not 100% match up with part_pkg->svcpart's idea
1867 sub primary_cust_svc {
1870 my @cust_svc = $self->cust_svc;
1872 return '' unless @cust_svc; #no serivces - irrelevant then
1874 return $cust_svc[0] if scalar(@cust_svc) == 1; #always return a single service
1876 # primary service as specified in the package definition
1877 # or exactly one service definition with quantity one
1878 my $svcpart = $self->part_pkg->svcpart;
1879 @cust_svc = grep { $_->svcpart == $svcpart } @cust_svc;
1880 return $cust_svc[0] if scalar(@cust_svc) == 1;
1882 #couldn't identify one thing..
1888 Returns a list of lists, calling the label method for all services
1889 (see L<FS::cust_svc>) of this billing item.
1895 map { [ $_->label ] } $self->cust_svc;
1898 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
1900 Like the labels method, but returns historical information on services that
1901 were active as of END_TIMESTAMP and (optionally) not cancelled before
1904 Returns a list of lists, calling the label method for all (historical) services
1905 (see L<FS::h_cust_svc>) of this billing item.
1911 map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
1916 Like labels, except returns a simple flat list, and shortens long
1917 (currently >5 or the cust_bill-max_same_services configuration value) lists of
1918 identical services to one line that lists the service label and the number of
1919 individual services rather than individual items.
1924 shift->_labels_short( 'labels', @_ );
1927 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
1929 Like h_labels, except returns a simple flat list, and shortens long
1930 (currently >5 or the cust_bill-max_same_services configuration value) lists of
1931 identical services to one line that lists the service label and the number of
1932 individual services rather than individual items.
1936 sub h_labels_short {
1937 shift->_labels_short( 'h_labels', @_ );
1941 my( $self, $method ) = ( shift, shift );
1943 my $conf = new FS::Conf;
1944 my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
1947 #tie %labels, 'Tie::IxHash';
1948 push @{ $labels{$_->[0]} }, $_->[1]
1949 foreach $self->$method(@_);
1951 foreach my $label ( keys %labels ) {
1953 my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
1954 my $num = scalar(@values);
1955 if ( $num > $max_same_services ) {
1956 push @labels, "$label ($num)";
1958 if ( $conf->exists('cust_bill-consolidate_services') ) {
1959 # push @labels, "$label: ". join(', ', @values);
1961 my $detail = "$label: ";
1962 $detail .= shift(@values). ', '
1963 while @values && length($detail.$values[0]) < 78;
1965 push @labels, $detail;
1968 push @labels, map { "$label: $_" } @values;
1979 Returns the parent customer object (see L<FS::cust_main>).
1985 qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
1988 #these subs are in location_Mixin.pm now... unfortunately the POD doesn't mixin
1992 Returns the location object, if any (see L<FS::cust_location>).
1994 =item cust_location_or_main
1996 If this package is associated with a location, returns the locaiton (see
1997 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
1999 =item location_label [ OPTION => VALUE ... ]
2001 Returns the label of the location object (see L<FS::cust_location>).
2005 #end of subs in location_Mixin.pm now... unfortunately the POD doesn't mixin
2007 =item seconds_since TIMESTAMP
2009 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
2010 package have been online since TIMESTAMP, according to the session monitor.
2012 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
2013 L<Time::Local> and L<Date::Parse> for conversion functions.
2018 my($self, $since) = @_;
2021 foreach my $cust_svc (
2022 grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
2024 $seconds += $cust_svc->seconds_since($since);
2031 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2033 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
2034 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
2037 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2038 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2044 sub seconds_since_sqlradacct {
2045 my($self, $start, $end) = @_;
2049 foreach my $cust_svc (
2051 my $part_svc = $_->part_svc;
2052 $part_svc->svcdb eq 'svc_acct'
2053 && scalar($part_svc->part_export('sqlradius'));
2056 $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
2063 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2065 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2066 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2070 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2071 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2076 sub attribute_since_sqlradacct {
2077 my($self, $start, $end, $attrib) = @_;
2081 foreach my $cust_svc (
2083 my $part_svc = $_->part_svc;
2084 $part_svc->svcdb eq 'svc_acct'
2085 && scalar($part_svc->part_export('sqlradius'));
2088 $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
2100 my( $self, $value ) = @_;
2101 if ( defined($value) ) {
2102 $self->setfield('quantity', $value);
2104 $self->getfield('quantity') || 1;
2107 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
2109 Transfers as many services as possible from this package to another package.
2111 The destination package can be specified by pkgnum by passing an FS::cust_pkg
2112 object. The destination package must already exist.
2114 Services are moved only if the destination allows services with the correct
2115 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true. Use
2116 this option with caution! No provision is made for export differences
2117 between the old and new service definitions. Probably only should be used
2118 when your exports for all service definitions of a given svcdb are identical.
2119 (attempt a transfer without it first, to move all possible svcpart-matching
2122 Any services that can't be moved remain in the original package.
2124 Returns an error, if there is one; otherwise, returns the number of services
2125 that couldn't be moved.
2130 my ($self, $dest_pkgnum, %opt) = @_;
2136 if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
2137 $dest = $dest_pkgnum;
2138 $dest_pkgnum = $dest->pkgnum;
2140 $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
2143 return ('Package does not exist: '.$dest_pkgnum) unless $dest;
2145 foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
2146 $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
2149 foreach my $cust_svc ($dest->cust_svc) {
2150 $target{$cust_svc->svcpart}--;
2153 my %svcpart2svcparts = ();
2154 if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2155 warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
2156 foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
2157 next if exists $svcpart2svcparts{$svcpart};
2158 my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
2159 $svcpart2svcparts{$svcpart} = [
2161 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
2163 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
2164 'svcpart' => $_ } );
2166 $pkg_svc ? $pkg_svc->primary_svc : '',
2167 $pkg_svc ? $pkg_svc->quantity : 0,
2171 grep { $_ != $svcpart }
2173 qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
2175 warn "alternates for svcpart $svcpart: ".
2176 join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
2181 foreach my $cust_svc ($self->cust_svc) {
2182 if($target{$cust_svc->svcpart} > 0) {
2183 $target{$cust_svc->svcpart}--;
2184 my $new = new FS::cust_svc { $cust_svc->hash };
2185 $new->pkgnum($dest_pkgnum);
2186 my $error = $new->replace($cust_svc);
2187 return $error if $error;
2188 } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2190 warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
2191 warn "alternates to consider: ".
2192 join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
2194 my @alternate = grep {
2195 warn "considering alternate svcpart $_: ".
2196 "$target{$_} available in new package\n"
2199 } @{$svcpart2svcparts{$cust_svc->svcpart}};
2201 warn "alternate(s) found\n" if $DEBUG;
2202 my $change_svcpart = $alternate[0];
2203 $target{$change_svcpart}--;
2204 my $new = new FS::cust_svc { $cust_svc->hash };
2205 $new->svcpart($change_svcpart);
2206 $new->pkgnum($dest_pkgnum);
2207 my $error = $new->replace($cust_svc);
2208 return $error if $error;
2221 This method is deprecated. See the I<depend_jobnum> option to the insert and
2222 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
2229 local $SIG{HUP} = 'IGNORE';
2230 local $SIG{INT} = 'IGNORE';
2231 local $SIG{QUIT} = 'IGNORE';
2232 local $SIG{TERM} = 'IGNORE';
2233 local $SIG{TSTP} = 'IGNORE';
2234 local $SIG{PIPE} = 'IGNORE';
2236 my $oldAutoCommit = $FS::UID::AutoCommit;
2237 local $FS::UID::AutoCommit = 0;
2240 foreach my $cust_svc ( $self->cust_svc ) {
2241 #false laziness w/svc_Common::insert
2242 my $svc_x = $cust_svc->svc_x;
2243 foreach my $part_export ( $cust_svc->part_svc->part_export ) {
2244 my $error = $part_export->export_insert($svc_x);
2246 $dbh->rollback if $oldAutoCommit;
2252 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2259 Associates this package with a (suspension or cancellation) reason (see
2260 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
2263 Available options are:
2269 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.
2273 the access_user (see L<FS::access_user>) providing the reason
2281 the action (cancel, susp, adjourn, expire) associated with the reason
2285 If there is an error, returns the error, otherwise returns false.
2290 my ($self, %options) = @_;
2292 my $otaker = $options{reason_otaker} ||
2293 $FS::CurrentUser::CurrentUser->username;
2296 if ( $options{'reason'} =~ /^(\d+)$/ ) {
2300 } elsif ( ref($options{'reason'}) ) {
2302 return 'Enter a new reason (or select an existing one)'
2303 unless $options{'reason'}->{'reason'} !~ /^\s*$/;
2305 my $reason = new FS::reason({
2306 'reason_type' => $options{'reason'}->{'typenum'},
2307 'reason' => $options{'reason'}->{'reason'},
2309 my $error = $reason->insert;
2310 return $error if $error;
2312 $reasonnum = $reason->reasonnum;
2315 return "Unparsable reason: ". $options{'reason'};
2318 my $cust_pkg_reason =
2319 new FS::cust_pkg_reason({ 'pkgnum' => $self->pkgnum,
2320 'reasonnum' => $reasonnum,
2321 'otaker' => $otaker,
2322 'action' => substr(uc($options{'action'}),0,1),
2323 'date' => $options{'date'}
2328 $cust_pkg_reason->insert;
2331 =item insert_discount
2333 Associates this package with a discount (see L<FS::cust_pkg_discount>, possibly
2334 inserting a new discount on the fly (see L<FS::discount>).
2336 Available options are:
2344 If there is an error, returns the error, otherwise returns false.
2348 sub insert_discount {
2349 #my ($self, %options) = @_;
2352 my $cust_pkg_discount = new FS::cust_pkg_discount {
2353 'pkgnum' => $self->pkgnum,
2354 'discountnum' => $self->discountnum,
2356 'end_date' => '', #XXX
2357 'otaker' => $self->otaker,
2358 #for the create a new discount case
2359 '_type' => $self->discountnum__type,
2360 'amount' => $self->discountnum_amount,
2361 'percent' => $self->discountnum_percent,
2362 'months' => $self->discountnum_months,
2363 #'disabled' => $self->discountnum_disabled,
2366 $cust_pkg_discount->insert;
2369 =item set_usage USAGE_VALUE_HASHREF
2371 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2372 to which they should be set (see L<FS::svc_acct>). Currently seconds,
2373 upbytes, downbytes, and totalbytes are appropriate keys.
2375 All svc_accts which are part of this package have their values reset.
2380 my ($self, $valueref, %opt) = @_;
2382 foreach my $cust_svc ($self->cust_svc){
2383 my $svc_x = $cust_svc->svc_x;
2384 $svc_x->set_usage($valueref, %opt)
2385 if $svc_x->can("set_usage");
2389 =item recharge USAGE_VALUE_HASHREF
2391 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2392 to which they should be set (see L<FS::svc_acct>). Currently seconds,
2393 upbytes, downbytes, and totalbytes are appropriate keys.
2395 All svc_accts which are part of this package have their values incremented.
2400 my ($self, $valueref) = @_;
2402 foreach my $cust_svc ($self->cust_svc){
2403 my $svc_x = $cust_svc->svc_x;
2404 $svc_x->recharge($valueref)
2405 if $svc_x->can("recharge");
2409 =item cust_pkg_discount
2413 sub cust_pkg_discount {
2415 qsearch('cust_pkg_discount', { 'pkgnum' => $self->pkgnum } );
2418 =item cust_pkg_discount_active
2422 sub cust_pkg_discount_active {
2424 grep { $_->status eq 'active' } $self->cust_pkg_discount;
2429 =head1 CLASS METHODS
2435 Returns an SQL expression identifying recurring packages.
2439 sub recurring_sql { "
2440 '0' != ( select freq from part_pkg
2441 where cust_pkg.pkgpart = part_pkg.pkgpart )
2446 Returns an SQL expression identifying one-time packages.
2451 '0' = ( select freq from part_pkg
2452 where cust_pkg.pkgpart = part_pkg.pkgpart )
2457 Returns an SQL expression identifying ordered packages (recurring packages not
2463 $_[0]->recurring_sql. " AND ". $_[0]->not_yet_billed_sql;
2468 Returns an SQL expression identifying active packages.
2473 $_[0]->recurring_sql. "
2474 AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
2475 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2476 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
2479 =item not_yet_billed_sql
2481 Returns an SQL expression identifying packages which have not yet been billed.
2485 sub not_yet_billed_sql { "
2486 ( cust_pkg.setup IS NULL OR cust_pkg.setup = 0 )
2487 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2488 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
2493 Returns an SQL expression identifying inactive packages (one-time packages
2494 that are otherwise unsuspended/uncancelled).
2498 sub inactive_sql { "
2499 ". $_[0]->onetime_sql(). "
2500 AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
2501 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2502 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
2508 Returns an SQL expression identifying suspended packages.
2512 sub suspended_sql { susp_sql(@_); }
2514 #$_[0]->recurring_sql(). ' AND '.
2516 ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2517 AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0
2524 Returns an SQL exprression identifying cancelled packages.
2528 sub cancelled_sql { cancel_sql(@_); }
2530 #$_[0]->recurring_sql(). ' AND '.
2531 "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
2534 =item search HASHREF
2538 Returns a qsearch hash expression to search for parameters specified in HASHREF.
2539 Valid parameters are
2547 active, inactive, suspended, cancel (or cancelled)
2551 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
2555 boolean selects custom packages
2561 pkgpart or arrayref or hashref of pkgparts
2565 arrayref of beginning and ending epoch date
2569 arrayref of beginning and ending epoch date
2573 arrayref of beginning and ending epoch date
2577 arrayref of beginning and ending epoch date
2581 arrayref of beginning and ending epoch date
2585 arrayref of beginning and ending epoch date
2589 arrayref of beginning and ending epoch date
2593 pkgnum or APKG_pkgnum
2597 a value suited to passing to FS::UI::Web::cust_header
2601 specifies the user for agent virtualization
2605 boolean selects packages containing fcc form 477 telco lines
2612 my ($class, $params) = @_;
2619 if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2621 "cust_main.agentnum = $1";
2628 if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
2630 "cust_pkg.custnum = $1";
2637 if ( $params->{'pkgbatch'} =~ /^([\w\/\-\:\.]+)$/ and $1 ) {
2639 "cust_pkg.pkgbatch = '$1'";
2646 if ( $params->{'magic'} eq 'active'
2647 || $params->{'status'} eq 'active' ) {
2649 push @where, FS::cust_pkg->active_sql();
2651 } elsif ( $params->{'magic'} =~ /^not[ _]yet[ _]billed$/
2652 || $params->{'status'} =~ /^not[ _]yet[ _]billed$/ ) {
2654 push @where, FS::cust_pkg->not_yet_billed_sql();
2656 } elsif ( $params->{'magic'} =~ /^(one-time charge|inactive)/
2657 || $params->{'status'} =~ /^(one-time charge|inactive)/ ) {
2659 push @where, FS::cust_pkg->inactive_sql();
2661 } elsif ( $params->{'magic'} eq 'suspended'
2662 || $params->{'status'} eq 'suspended' ) {
2664 push @where, FS::cust_pkg->suspended_sql();
2666 } elsif ( $params->{'magic'} =~ /^cancell?ed$/
2667 || $params->{'status'} =~ /^cancell?ed$/ ) {
2669 push @where, FS::cust_pkg->cancelled_sql();
2674 # parse package class
2677 #false lazinessish w/graph/cust_bill_pkg.cgi
2680 if ( exists($params->{'classnum'})
2681 && $params->{'classnum'} =~ /^(\d*)$/
2685 if ( $classnum ) { #a specific class
2686 push @where, "part_pkg.classnum = $classnum";
2688 #@pkg_class = ( qsearchs('pkg_class', { 'classnum' => $classnum } ) );
2689 #die "classnum $classnum not found!" unless $pkg_class[0];
2690 #$title .= $pkg_class[0]->classname.' ';
2692 } elsif ( $classnum eq '' ) { #the empty class
2694 push @where, "part_pkg.classnum IS NULL";
2695 #$title .= 'Empty class ';
2696 #@pkg_class = ( '(empty class)' );
2697 } elsif ( $classnum eq '0' ) {
2698 #@pkg_class = qsearch('pkg_class', {} ); # { 'disabled' => '' } );
2699 #push @pkg_class, '(empty class)';
2701 die "illegal classnum";
2707 # parse package report options
2710 my @report_option = ();
2711 if ( exists($params->{'report_option'})
2712 && $params->{'report_option'} =~ /^([,\d]*)$/
2715 @report_option = split(',', $1);
2718 if (@report_option) {
2719 # this will result in the empty set for the dangling comma case as it should
2721 map{ "0 < ( SELECT count(*) FROM part_pkg_option
2722 WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
2723 AND optionname = 'report_option_$_'
2724 AND optionvalue = '1' )"
2734 push @where, "part_pkg.custom = 'Y'" if $params->{custom};
2740 push @where, "part_pkg.fcc_ds0s > 0" if $params->{fcc_line};
2746 if ( exists($params->{'censustract'}) ) {
2747 $params->{'censustract'} =~ /^([.\d]*)$/;
2748 my $censustract = "cust_main.censustract = '$1'";
2749 $censustract .= ' OR cust_main.censustract is NULL' unless $1;
2750 push @where, "( $censustract )";
2757 if ( ref($params->{'pkgpart'}) ) {
2760 if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
2761 @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
2762 } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
2763 @pkgpart = @{ $params->{'pkgpart'} };
2765 die 'unhandled pkgpart ref '. $params->{'pkgpart'};
2768 @pkgpart = grep /^(\d+)$/, @pkgpart;
2770 push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
2772 } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
2773 push @where, "pkgpart = $1";
2782 #false laziness w/report_cust_pkg.html
2785 'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
2786 'active' => { 'susp'=>1, 'cancel'=>1 },
2787 'suspended' => { 'cancel' => 1 },
2792 if( exists($params->{'active'} ) ) {
2793 # This overrides all the other date-related fields
2794 my($beginning, $ending) = @{$params->{'active'}};
2796 "cust_pkg.setup IS NOT NULL",
2797 "cust_pkg.setup <= $ending",
2798 "(cust_pkg.cancel IS NULL OR cust_pkg.cancel >= $beginning )",
2799 "NOT (".FS::cust_pkg->onetime_sql . ")";
2802 foreach my $field (qw( setup last_bill bill adjourn susp expire cancel )) {
2804 next unless exists($params->{$field});
2806 my($beginning, $ending) = @{$params->{$field}};
2808 next if $beginning == 0 && $ending == 4294967295;
2811 "cust_pkg.$field IS NOT NULL",
2812 "cust_pkg.$field >= $beginning",
2813 "cust_pkg.$field <= $ending";
2815 $orderby ||= "ORDER BY cust_pkg.$field";
2820 $orderby ||= 'ORDER BY bill';
2823 # parse magic, legacy, etc.
2826 if ( $params->{'magic'} &&
2827 $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
2830 $orderby = 'ORDER BY pkgnum';
2832 if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
2833 push @where, "pkgpart = $1";
2836 } elsif ( $params->{'query'} eq 'pkgnum' ) {
2838 $orderby = 'ORDER BY pkgnum';
2840 } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
2842 $orderby = 'ORDER BY pkgnum';
2845 SELECT count(*) FROM pkg_svc
2846 WHERE pkg_svc.pkgpart = cust_pkg.pkgpart
2847 AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
2848 WHERE cust_svc.pkgnum = cust_pkg.pkgnum
2849 AND cust_svc.svcpart = pkg_svc.svcpart
2856 # setup queries, links, subs, etc. for the search
2859 # here is the agent virtualization
2860 if ($params->{CurrentUser}) {
2862 qsearchs('access_user', { username => $params->{CurrentUser} });
2865 push @where, $access_user->agentnums_sql('table'=>'cust_main');
2870 push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
2873 my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
2875 my $addl_from = 'LEFT JOIN cust_main USING ( custnum ) '.
2876 'LEFT JOIN part_pkg USING ( pkgpart ) '.
2877 'LEFT JOIN pkg_class ON ( part_pkg.classnum = pkg_class.classnum ) ';
2879 my $count_query = "SELECT COUNT(*) FROM cust_pkg $addl_from $extra_sql";
2882 'table' => 'cust_pkg',
2884 'select' => join(', ',
2886 ( map "part_pkg.$_", qw( pkg freq ) ),
2887 'pkg_class.classname',
2888 'cust_main.custnum AS cust_main_custnum',
2889 FS::UI::Web::cust_sql_fields(
2890 $params->{'cust_fields'}
2893 'extra_sql' => "$extra_sql $orderby",
2894 'addl_from' => $addl_from,
2895 'count_query' => $count_query,
2902 Returns a list of two package counts. The first is a count of packages
2903 based on the supplied criteria and the second is the count of residential
2904 packages with those same criteria. Criteria are specified as in the search
2910 my ($class, $params) = @_;
2912 my $sql_query = $class->search( $params );
2914 my $count_sql = delete($sql_query->{'count_query'});
2915 $count_sql =~ s/ FROM/,count(CASE WHEN cust_main.company IS NULL OR cust_main.company = '' THEN 1 END) FROM/
2916 or die "couldn't parse count_sql";
2918 my $count_sth = dbh->prepare($count_sql)
2919 or die "Error preparing $count_sql: ". dbh->errstr;
2921 or die "Error executing $count_sql: ". $count_sth->errstr;
2922 my $count_arrayref = $count_sth->fetchrow_arrayref;
2924 return ( @$count_arrayref );
2931 Returns a list: the first item is an SQL fragment identifying matching
2932 packages/customers via location (taking into account shipping and package
2933 address taxation, if enabled), and subsequent items are the parameters to
2934 substitute for the placeholders in that fragment.
2939 my($class, %opt) = @_;
2940 my $ornull = $opt{'ornull'};
2942 my $conf = new FS::Conf;
2944 # '?' placeholders in _location_sql_where
2945 my $x = $ornull ? 3 : 2;
2946 my @bill_param = ( ('city')x3, ('county')x$x, ('state')x$x, 'country' );
2950 if ( $conf->exists('tax-ship_address') ) {
2953 ( ( ship_last IS NULL OR ship_last = '' )
2954 AND ". _location_sql_where('cust_main', '', $ornull ). "
2956 OR ( ship_last IS NOT NULL AND ship_last != ''
2957 AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
2960 # AND payby != 'COMP'
2962 @main_param = ( @bill_param, @bill_param );
2966 $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
2967 @main_param = @bill_param;
2973 if ( $conf->exists('tax-pkg_address') ) {
2975 my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
2978 ( cust_pkg.locationnum IS NULL AND $main_where )
2979 OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where )
2982 @param = ( @main_param, @bill_param );
2986 $where = $main_where;
2987 @param = @main_param;
2995 #subroutine, helper for location_sql
2996 sub _location_sql_where {
2998 my $prefix = @_ ? shift : '';
2999 my $ornull = @_ ? shift : '';
3001 # $ornull = $ornull ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
3003 $ornull = $ornull ? ' OR ? IS NULL ' : '';
3005 my $or_empty_city = " OR ( ? = '' AND $table.${prefix}city IS NULL ) ";
3006 my $or_empty_county = " OR ( ? = '' AND $table.${prefix}county IS NULL ) ";
3007 my $or_empty_state = " OR ( ? = '' AND $table.${prefix}state IS NULL ) ";
3009 # ( $table.${prefix}city = ? $or_empty_city $ornull )
3011 ( $table.${prefix}city = ? OR ? = '' OR CAST(? AS text) IS NULL )
3012 AND ( $table.${prefix}county = ? $or_empty_county $ornull )
3013 AND ( $table.${prefix}state = ? $or_empty_state $ornull )
3014 AND $table.${prefix}country = ?
3022 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
3024 CUSTNUM is a customer (see L<FS::cust_main>)
3026 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
3027 L<FS::part_pkg>) to order for this customer. Duplicates are of course
3030 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
3031 remove for this customer. The services (see L<FS::cust_svc>) are moved to the
3032 new billing items. An error is returned if this is not possible (see
3033 L<FS::pkg_svc>). An empty arrayref is equivalent to not specifying this
3036 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
3037 newly-created cust_pkg objects.
3039 REFNUM, if specified, will specify the FS::pkg_referral record to be created
3040 and inserted. Multiple FS::pkg_referral records can be created by
3041 setting I<refnum> to an array reference of refnums or a hash reference with
3042 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
3043 record will be created corresponding to cust_main.refnum.
3048 my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
3050 my $conf = new FS::Conf;
3052 # Transactionize this whole mess
3053 local $SIG{HUP} = 'IGNORE';
3054 local $SIG{INT} = 'IGNORE';
3055 local $SIG{QUIT} = 'IGNORE';
3056 local $SIG{TERM} = 'IGNORE';
3057 local $SIG{TSTP} = 'IGNORE';
3058 local $SIG{PIPE} = 'IGNORE';
3060 my $oldAutoCommit = $FS::UID::AutoCommit;
3061 local $FS::UID::AutoCommit = 0;
3065 # my $cust_main = qsearchs('cust_main', { custnum => $custnum });
3066 # return "Customer not found: $custnum" unless $cust_main;
3068 warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
3071 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
3074 my $change = scalar(@old_cust_pkg) != 0;
3077 if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
3079 warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
3080 " to pkgpart ". $pkgparts->[0]. "\n"
3083 my $err_or_cust_pkg =
3084 $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
3085 'refnum' => $refnum,
3088 unless (ref($err_or_cust_pkg)) {
3089 $dbh->rollback if $oldAutoCommit;
3090 return $err_or_cust_pkg;
3093 push @$return_cust_pkg, $err_or_cust_pkg;
3094 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3099 # Create the new packages.
3100 foreach my $pkgpart (@$pkgparts) {
3102 warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
3104 my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
3105 pkgpart => $pkgpart,
3109 $error = $cust_pkg->insert( 'change' => $change );
3111 $dbh->rollback if $oldAutoCommit;
3114 push @$return_cust_pkg, $cust_pkg;
3116 # $return_cust_pkg now contains refs to all of the newly
3119 # Transfer services and cancel old packages.
3120 foreach my $old_pkg (@old_cust_pkg) {
3122 warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
3125 foreach my $new_pkg (@$return_cust_pkg) {
3126 $error = $old_pkg->transfer($new_pkg);
3127 if ($error and $error == 0) {
3128 # $old_pkg->transfer failed.
3129 $dbh->rollback if $oldAutoCommit;
3134 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
3135 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
3136 foreach my $new_pkg (@$return_cust_pkg) {
3137 $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
3138 if ($error and $error == 0) {
3139 # $old_pkg->transfer failed.
3140 $dbh->rollback if $oldAutoCommit;
3147 # Transfers were successful, but we went through all of the
3148 # new packages and still had services left on the old package.
3149 # We can't cancel the package under the circumstances, so abort.
3150 $dbh->rollback if $oldAutoCommit;
3151 return "Unable to transfer all services from package ".$old_pkg->pkgnum;
3153 $error = $old_pkg->cancel( quiet=>1 );
3159 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3163 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
3165 A bulk change method to change packages for multiple customers.
3167 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
3168 L<FS::part_pkg>) to order for each customer. Duplicates are of course
3171 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
3172 replace. The services (see L<FS::cust_svc>) are moved to the
3173 new billing items. An error is returned if this is not possible (see
3176 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
3177 newly-created cust_pkg objects.
3182 my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
3184 # Transactionize this whole mess
3185 local $SIG{HUP} = 'IGNORE';
3186 local $SIG{INT} = 'IGNORE';
3187 local $SIG{QUIT} = 'IGNORE';
3188 local $SIG{TERM} = 'IGNORE';
3189 local $SIG{TSTP} = 'IGNORE';
3190 local $SIG{PIPE} = 'IGNORE';
3192 my $oldAutoCommit = $FS::UID::AutoCommit;
3193 local $FS::UID::AutoCommit = 0;
3197 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
3200 while(scalar(@old_cust_pkg)) {
3202 my $custnum = $old_cust_pkg[0]->custnum;
3203 my (@remove) = map { $_->pkgnum }
3204 grep { $_->custnum == $custnum } @old_cust_pkg;
3205 @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
3207 my $error = order $custnum, $pkgparts, \@remove, \@return;
3209 push @errors, $error
3211 push @$return_cust_pkg, @return;
3214 if (scalar(@errors)) {
3215 $dbh->rollback if $oldAutoCommit;
3216 return join(' / ', @errors);
3219 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3223 # Used by FS::Upgrade to migrate to a new database.
3224 sub _upgrade_data { # class method
3225 my ($class, %opts) = @_;
3226 $class->_upgrade_otaker(%opts);
3233 sub order is not OO. Perhaps it should be moved to FS::cust_main and made so?
3235 In sub order, the @pkgparts array (passed by reference) is clobbered.
3237 Also in sub order, no money is adjusted. Once FS::part_pkg defines a standard
3238 method to pass dates to the recur_prog expression, it should do so.
3240 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
3241 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
3242 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
3243 configuration values. Probably need a subroutine which decides what to do
3244 based on whether or not we've fetched the user yet, rather than a hash. See
3245 FS::UID and the TODO.
3247 Now that things are transactional should the check in the insert method be
3252 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
3253 L<FS::pkg_svc>, schema.html from the base documentation