4 use base qw( FS::otaker_Mixin FS::cust_main_Mixin FS::location_Mixin
5 FS::m2m_Common FS::option_Common FS::Record );
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 );
19 use FS::cust_location;
21 use FS::cust_bill_pkg;
22 use FS::cust_pkg_detail;
27 use FS::cust_pkg_reason;
29 use FS::cust_pkg_discount;
33 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
35 # because they load configuration by setting FS::UID::callback (see TODO)
41 # for sending cancel emails in sub cancel
45 $me = '[FS::cust_pkg]';
47 $disable_agentcheck = 0;
51 my ( $hashref, $cache ) = @_;
52 #if ( $hashref->{'pkgpart'} ) {
53 if ( $hashref->{'pkg'} ) {
54 # #@{ $self->{'_pkgnum'} } = ();
55 # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
56 # $self->{'_pkgpart'} = $subcache;
57 # #push @{ $self->{'_pkgnum'} },
58 # FS::part_pkg->new_or_cached($hashref, $subcache);
59 $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
61 if ( exists $hashref->{'svcnum'} ) {
62 #@{ $self->{'_pkgnum'} } = ();
63 my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
64 $self->{'_svcnum'} = $subcache;
65 #push @{ $self->{'_pkgnum'} },
66 FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
72 FS::cust_pkg - Object methods for cust_pkg objects
78 $record = new FS::cust_pkg \%hash;
79 $record = new FS::cust_pkg { 'column' => 'value' };
81 $error = $record->insert;
83 $error = $new_record->replace($old_record);
85 $error = $record->delete;
87 $error = $record->check;
89 $error = $record->cancel;
91 $error = $record->suspend;
93 $error = $record->unsuspend;
95 $part_pkg = $record->part_pkg;
97 @labels = $record->labels;
99 $seconds = $record->seconds_since($timestamp);
101 $error = FS::cust_pkg::order( $custnum, \@pkgparts );
102 $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
106 An FS::cust_pkg object represents a customer billing item. FS::cust_pkg
107 inherits from FS::Record. The following fields are currently supported:
113 Primary key (assigned automatically for new billing items)
117 Customer (see L<FS::cust_main>)
121 Billing item definition (see L<FS::part_pkg>)
125 Optional link to package location (see L<FS::location>)
137 date (next bill date)
161 order taker (see L<FS::access_user>)
165 If this field is set to 1, disables the automatic
166 unsuspension of this package when using the B<unsuspendauto> config option.
170 If not set, defaults to 1
174 Date of change from previous package
184 =item change_locationnum
190 Note: setup, last_bill, bill, adjourn, susp, expire, cancel and change_date
191 are specified as UNIX timestamps; see L<perlfunc/"time">. Also see
192 L<Time::Local> and L<Date::Parse> for conversion functions.
200 Create a new billing item. To add the item to the database, see L<"insert">.
204 sub table { 'cust_pkg'; }
205 sub cust_linked { $_[0]->cust_main_custnum; }
206 sub cust_unlinked_msg {
208 "WARNING: can't find cust_main.custnum ". $self->custnum.
209 ' (cust_pkg.pkgnum '. $self->pkgnum. ')';
212 =item insert [ OPTION => VALUE ... ]
214 Adds this billing item to the database ("Orders" the item). If there is an
215 error, returns the error, otherwise returns false.
217 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
218 will be used to look up the package definition and agent restrictions will be
221 If the additional field I<refnum> is defined, an FS::pkg_referral record will
222 be created and inserted. Multiple FS::pkg_referral records can be created by
223 setting I<refnum> to an array reference of refnums or a hash reference with
224 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
225 record will be created corresponding to cust_main.refnum.
227 The following options are available:
233 If set true, supresses any referral credit to a referring customer.
237 cust_pkg_option records will be created
241 a ticket will be added to this customer with this subject
245 an optional queue name for ticket additions
252 my( $self, %options ) = @_;
254 if ( $self->part_pkg->option('start_1st', 1) && !$self->start_date ) {
255 my ($sec,$min,$hour,$mday,$mon,$year) = (localtime(time) )[0,1,2,3,4,5];
256 $mon += 1 unless $mday == 1;
257 until ( $mon < 12 ) { $mon -= 12; $year++; }
258 $self->start_date( timelocal_nocheck(0,0,0,1,$mon,$year) );
261 my $expire_months = $self->part_pkg->option('expire_months', 1);
262 if ( $expire_months && !$self->expire ) {
263 my $start = $self->start_date || $self->setup || time;
265 #false laziness w/part_pkg::add_freq
266 my ($sec,$min,$hour,$mday,$mon,$year) = (localtime($start) )[0,1,2,3,4,5];
267 $mon += $expire_months;
268 until ( $mon < 12 ) { $mon -= 12; $year++; }
270 #$self->expire( timelocal_nocheck($sec,$min,$hour,$mday,$mon,$year) );
271 $self->expire( timelocal_nocheck(0,0,0,$mday,$mon,$year) );
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->otaker(getotaker) unless $self->otaker;
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 $error = send_email(
712 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
713 'to' => \@invoicing_list,
714 'subject' => ( $conf->config('cancelsubject') || 'Cancellation Notice' ),
715 'body' => [ map "$_\n", $conf->config('cancelmessage') ],
717 #should this do something on errors?
724 =item cancel_if_expired [ NOW_TIMESTAMP ]
726 Cancels this package if its expire date has been reached.
730 sub cancel_if_expired {
732 my $time = shift || time;
733 return '' unless $self->expire && $self->expire <= $time;
734 my $error = $self->cancel;
736 return "Error cancelling expired pkg ". $self->pkgnum. " for custnum ".
737 $self->custnum. ": $error";
744 Cancels any pending expiration (sets the expire field to null).
746 If there is an error, returns the error, otherwise returns false.
751 my( $self, %options ) = @_;
754 local $SIG{HUP} = 'IGNORE';
755 local $SIG{INT} = 'IGNORE';
756 local $SIG{QUIT} = 'IGNORE';
757 local $SIG{TERM} = 'IGNORE';
758 local $SIG{TSTP} = 'IGNORE';
759 local $SIG{PIPE} = 'IGNORE';
761 my $oldAutoCommit = $FS::UID::AutoCommit;
762 local $FS::UID::AutoCommit = 0;
765 my $old = $self->select_for_update;
767 my $pkgnum = $old->pkgnum;
768 if ( $old->get('cancel') || $self->get('cancel') ) {
769 dbh->rollback if $oldAutoCommit;
770 return "Can't unexpire cancelled package $pkgnum";
771 # or at least it's pointless
774 unless ( $old->get('expire') && $self->get('expire') ) {
775 dbh->rollback if $oldAutoCommit;
776 return ""; # no error
779 my %hash = $self->hash;
780 $hash{'expire'} = '';
781 my $new = new FS::cust_pkg ( \%hash );
782 $error = $new->replace( $self, options => { $self->options } );
784 $dbh->rollback if $oldAutoCommit;
788 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
794 =item suspend [ OPTION => VALUE ... ]
796 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
797 package, then suspends the package itself (sets the susp field to now).
799 Available options are:
803 =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.
805 =item date - can be set to a unix style timestamp to specify when to suspend (adjourn)
809 If there is an error, returns the error, otherwise returns false.
814 my( $self, %options ) = @_;
817 local $SIG{HUP} = 'IGNORE';
818 local $SIG{INT} = 'IGNORE';
819 local $SIG{QUIT} = 'IGNORE';
820 local $SIG{TERM} = 'IGNORE';
821 local $SIG{TSTP} = 'IGNORE';
822 local $SIG{PIPE} = 'IGNORE';
824 my $oldAutoCommit = $FS::UID::AutoCommit;
825 local $FS::UID::AutoCommit = 0;
828 my $old = $self->select_for_update;
830 my $pkgnum = $old->pkgnum;
831 if ( $old->get('cancel') || $self->get('cancel') ) {
832 dbh->rollback if $oldAutoCommit;
833 return "Can't suspend cancelled package $pkgnum";
836 if ( $old->get('susp') || $self->get('susp') ) {
837 dbh->rollback if $oldAutoCommit;
838 return ""; # no error # complain on adjourn?
841 my $date = $options{date} if $options{date}; # adjourn/suspend later
842 $date = '' if ($date && $date <= time); # complain instead?
844 if ( $date && $old->get('expire') && $old->get('expire') < $date ) {
845 dbh->rollback if $oldAutoCommit;
846 return "Package $pkgnum expires before it would be suspended.";
849 my $suspend_time = $options{'time'} || time;
851 if ( $options{'reason'} ) {
852 $error = $self->insert_reason( 'reason' => $options{'reason'},
853 'action' => $date ? 'adjourn' : 'suspend',
854 'date' => $date ? $date : $suspend_time,
855 'reason_otaker' => $options{'reason_otaker'},
858 dbh->rollback if $oldAutoCommit;
859 return "Error inserting cust_pkg_reason: $error";
867 foreach my $cust_svc (
868 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
870 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
872 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
873 $dbh->rollback if $oldAutoCommit;
874 return "Illegal svcdb value in part_svc!";
877 require "FS/$svcdb.pm";
879 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
881 $error = $svc->suspend;
883 $dbh->rollback if $oldAutoCommit;
886 my( $label, $value ) = $cust_svc->label;
887 push @labels, "$label: $value";
891 my $conf = new FS::Conf;
892 if ( $conf->config('suspend_email_admin') ) {
894 my $error = send_email(
895 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
896 #invoice_from ??? well as good as any
897 'to' => $conf->config('suspend_email_admin'),
898 'subject' => 'FREESIDE NOTIFICATION: Customer package suspended',
900 "This is an automatic message from your Freeside installation\n",
901 "informing you that the following customer package has been suspended:\n",
903 'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
904 'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
905 ( map { "Service : $_\n" } @labels ),
910 warn "WARNING: can't send suspension admin email (suspending anyway): ".
918 my %hash = $self->hash;
920 $hash{'adjourn'} = $date;
922 $hash{'susp'} = $suspend_time;
924 my $new = new FS::cust_pkg ( \%hash );
925 $error = $new->replace( $self, options => { $self->options } );
927 $dbh->rollback if $oldAutoCommit;
931 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
936 =item unsuspend [ OPTION => VALUE ... ]
938 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
939 package, then unsuspends the package itself (clears the susp field and the
940 adjourn field if it is in the past).
942 Available options are:
946 =item adjust_next_bill
948 Can be set true to adjust the next bill date forward by
949 the amount of time the account was inactive. This was set true by default
950 since 1.4.2 and 1.5.0pre6; however, starting with 1.7.0 this needs to be
951 explicitly requested. Price plans for which this makes sense (anniversary-date
952 based than prorate or subscription) could have an option to enable this
957 If there is an error, returns the error, otherwise returns false.
962 my( $self, %opt ) = @_;
965 local $SIG{HUP} = 'IGNORE';
966 local $SIG{INT} = 'IGNORE';
967 local $SIG{QUIT} = 'IGNORE';
968 local $SIG{TERM} = 'IGNORE';
969 local $SIG{TSTP} = 'IGNORE';
970 local $SIG{PIPE} = 'IGNORE';
972 my $oldAutoCommit = $FS::UID::AutoCommit;
973 local $FS::UID::AutoCommit = 0;
976 my $old = $self->select_for_update;
978 my $pkgnum = $old->pkgnum;
979 if ( $old->get('cancel') || $self->get('cancel') ) {
980 dbh->rollback if $oldAutoCommit;
981 return "Can't unsuspend cancelled package $pkgnum";
984 unless ( $old->get('susp') && $self->get('susp') ) {
985 dbh->rollback if $oldAutoCommit;
986 return ""; # no error # complain instead?
989 foreach my $cust_svc (
990 qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
992 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
994 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
995 $dbh->rollback if $oldAutoCommit;
996 return "Illegal svcdb value in part_svc!";
999 require "FS/$svcdb.pm";
1001 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
1003 $error = $svc->unsuspend;
1005 $dbh->rollback if $oldAutoCommit;
1012 my %hash = $self->hash;
1013 my $inactive = time - $hash{'susp'};
1015 my $conf = new FS::Conf;
1017 $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive
1018 if ( $opt{'adjust_next_bill'}
1019 || $conf->exists('unsuspend-always_adjust_next_bill_date') )
1020 && $inactive > 0 && ( $hash{'bill'} || $hash{'setup'} );
1023 $hash{'adjourn'} = '' if $hash{'adjourn'} < time;
1024 my $new = new FS::cust_pkg ( \%hash );
1025 $error = $new->replace( $self, options => { $self->options } );
1027 $dbh->rollback if $oldAutoCommit;
1031 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1038 Cancels any pending suspension (sets the adjourn field to null).
1040 If there is an error, returns the error, otherwise returns false.
1045 my( $self, %options ) = @_;
1048 local $SIG{HUP} = 'IGNORE';
1049 local $SIG{INT} = 'IGNORE';
1050 local $SIG{QUIT} = 'IGNORE';
1051 local $SIG{TERM} = 'IGNORE';
1052 local $SIG{TSTP} = 'IGNORE';
1053 local $SIG{PIPE} = 'IGNORE';
1055 my $oldAutoCommit = $FS::UID::AutoCommit;
1056 local $FS::UID::AutoCommit = 0;
1059 my $old = $self->select_for_update;
1061 my $pkgnum = $old->pkgnum;
1062 if ( $old->get('cancel') || $self->get('cancel') ) {
1063 dbh->rollback if $oldAutoCommit;
1064 return "Can't unadjourn cancelled package $pkgnum";
1065 # or at least it's pointless
1068 if ( $old->get('susp') || $self->get('susp') ) {
1069 dbh->rollback if $oldAutoCommit;
1070 return "Can't unadjourn suspended package $pkgnum";
1071 # perhaps this is arbitrary
1074 unless ( $old->get('adjourn') && $self->get('adjourn') ) {
1075 dbh->rollback if $oldAutoCommit;
1076 return ""; # no error
1079 my %hash = $self->hash;
1080 $hash{'adjourn'} = '';
1081 my $new = new FS::cust_pkg ( \%hash );
1082 $error = $new->replace( $self, options => { $self->options } );
1084 $dbh->rollback if $oldAutoCommit;
1088 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1095 =item change HASHREF | OPTION => VALUE ...
1097 Changes this package: cancels it and creates a new one, with a different
1098 pkgpart or locationnum or both. All services are transferred to the new
1099 package (no change will be made if this is not possible).
1101 Options may be passed as a list of key/value pairs or as a hash reference.
1108 New locationnum, to change the location for this package.
1112 New FS::cust_location object, to create a new location and assign it
1117 New pkgpart (see L<FS::part_pkg>).
1121 New refnum (see L<FS::part_referral>).
1125 At least one option must be specified (otherwise, what's the point?)
1127 Returns either the new FS::cust_pkg object or a scalar error.
1131 my $err_or_new_cust_pkg = $old_cust_pkg->change
1135 #some false laziness w/order
1138 my $opt = ref($_[0]) ? shift : { @_ };
1140 # my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
1143 my $conf = new FS::Conf;
1145 # Transactionize this whole mess
1146 local $SIG{HUP} = 'IGNORE';
1147 local $SIG{INT} = 'IGNORE';
1148 local $SIG{QUIT} = 'IGNORE';
1149 local $SIG{TERM} = 'IGNORE';
1150 local $SIG{TSTP} = 'IGNORE';
1151 local $SIG{PIPE} = 'IGNORE';
1153 my $oldAutoCommit = $FS::UID::AutoCommit;
1154 local $FS::UID::AutoCommit = 0;
1163 #$hash{$_} = $self->$_() foreach qw( last_bill bill );
1165 #$hash{$_} = $self->$_() foreach qw( setup );
1167 $hash{'setup'} = $time if $self->setup;
1169 $hash{'change_date'} = $time;
1170 $hash{"change_$_"} = $self->$_()
1171 foreach qw( pkgnum pkgpart locationnum );
1173 if ( $opt->{'cust_location'} &&
1174 ( ! $opt->{'locationnum'} || $opt->{'locationnum'} == -1 ) ) {
1175 $error = $opt->{'cust_location'}->insert;
1177 $dbh->rollback if $oldAutoCommit;
1178 return "inserting cust_location (transaction rolled back): $error";
1180 $opt->{'locationnum'} = $opt->{'cust_location'}->locationnum;
1183 # Create the new package.
1184 my $cust_pkg = new FS::cust_pkg {
1185 custnum => $self->custnum,
1186 pkgpart => ( $opt->{'pkgpart'} || $self->pkgpart ),
1187 refnum => ( $opt->{'refnum'} || $self->refnum ),
1188 locationnum => ( $opt->{'locationnum'} || $self->locationnum ),
1192 $error = $cust_pkg->insert( 'change' => 1 );
1194 $dbh->rollback if $oldAutoCommit;
1198 # Transfer services and cancel old package.
1200 $error = $self->transfer($cust_pkg);
1201 if ($error and $error == 0) {
1202 # $old_pkg->transfer failed.
1203 $dbh->rollback if $oldAutoCommit;
1207 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1208 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1209 $error = $self->transfer($cust_pkg, 'change_svcpart'=>1 );
1210 if ($error and $error == 0) {
1211 # $old_pkg->transfer failed.
1212 $dbh->rollback if $oldAutoCommit;
1218 # Transfers were successful, but we still had services left on the old
1219 # package. We can't change the package under this circumstances, so abort.
1220 $dbh->rollback if $oldAutoCommit;
1221 return "Unable to transfer all services from package ". $self->pkgnum;
1224 #reset usage if changing pkgpart
1225 # AND usage rollover is off (otherwise adds twice, now and at package bill)
1226 if ($self->pkgpart != $cust_pkg->pkgpart) {
1227 my $part_pkg = $cust_pkg->part_pkg;
1228 $error = $part_pkg->reset_usage($cust_pkg, $part_pkg->is_prepaid
1232 if $part_pkg->can('reset_usage') && ! $part_pkg->option('usage_rollover');
1235 $dbh->rollback if $oldAutoCommit;
1236 return "Error setting usage values: $error";
1240 #Good to go, cancel old package.
1241 $error = $self->cancel( quiet=>1 );
1243 $dbh->rollback if $oldAutoCommit;
1247 if ( $conf->exists('cust_pkg-change_pkgpart-bill_now') ) {
1249 my $error = $cust_pkg->cust_main->bill( 'pkg_list' => [ $cust_pkg ] );
1251 $dbh->rollback if $oldAutoCommit;
1256 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1264 Returns the last bill date, or if there is no last bill date, the setup date.
1265 Useful for billing metered services.
1271 return $self->setfield('last_bill', $_[0]) if @_;
1272 return $self->getfield('last_bill') if $self->getfield('last_bill');
1273 my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
1274 'edate' => $self->bill, } );
1275 $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
1278 =item last_cust_pkg_reason ACTION
1280 Returns the most recent ACTION FS::cust_pkg_reason associated with the package.
1281 Returns false if there is no reason or the package is not currenly ACTION'd
1282 ACTION is one of adjourn, susp, cancel, or expire.
1286 sub last_cust_pkg_reason {
1287 my ( $self, $action ) = ( shift, shift );
1288 my $date = $self->get($action);
1290 'table' => 'cust_pkg_reason',
1291 'hashref' => { 'pkgnum' => $self->pkgnum,
1292 'action' => substr(uc($action), 0, 1),
1295 'order_by' => 'ORDER BY num DESC LIMIT 1',
1299 =item last_reason ACTION
1301 Returns the most recent ACTION FS::reason associated with the package.
1302 Returns false if there is no reason or the package is not currenly ACTION'd
1303 ACTION is one of adjourn, susp, cancel, or expire.
1308 my $cust_pkg_reason = shift->last_cust_pkg_reason(@_);
1309 $cust_pkg_reason->reason
1310 if $cust_pkg_reason;
1315 Returns the definition for this billing item, as an FS::part_pkg object (see
1322 return $self->{'_pkgpart'} if $self->{'_pkgpart'};
1323 cluck "cust_pkg->part_pkg called" if $DEBUG > 1;
1324 qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
1329 Returns the cancelled package this package was changed from, if any.
1335 return '' unless $self->change_pkgnum;
1336 qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
1341 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
1348 $self->part_pkg->calc_setup($self, @_);
1353 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
1360 $self->part_pkg->calc_recur($self, @_);
1365 Calls the I<calc_remain> of the FS::part_pkg object associated with this
1372 $self->part_pkg->calc_remain($self, @_);
1377 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
1384 $self->part_pkg->calc_cancel($self, @_);
1389 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
1395 qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
1398 =item cust_pkg_detail [ DETAILTYPE ]
1400 Returns any customer package details for this package (see
1401 L<FS::cust_pkg_detail>).
1403 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
1407 sub cust_pkg_detail {
1409 my %hash = ( 'pkgnum' => $self->pkgnum );
1410 $hash{detailtype} = shift if @_;
1412 'table' => 'cust_pkg_detail',
1413 'hashref' => \%hash,
1414 'order_by' => 'ORDER BY weight, pkgdetailnum',
1418 =item set_cust_pkg_detail DETAILTYPE [ DETAIL, DETAIL, ... ]
1420 Sets customer package details for this package (see L<FS::cust_pkg_detail>).
1422 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
1424 If there is an error, returns the error, otherwise returns false.
1428 sub set_cust_pkg_detail {
1429 my( $self, $detailtype, @details ) = @_;
1431 local $SIG{HUP} = 'IGNORE';
1432 local $SIG{INT} = 'IGNORE';
1433 local $SIG{QUIT} = 'IGNORE';
1434 local $SIG{TERM} = 'IGNORE';
1435 local $SIG{TSTP} = 'IGNORE';
1436 local $SIG{PIPE} = 'IGNORE';
1438 my $oldAutoCommit = $FS::UID::AutoCommit;
1439 local $FS::UID::AutoCommit = 0;
1442 foreach my $current ( $self->cust_pkg_detail($detailtype) ) {
1443 my $error = $current->delete;
1445 $dbh->rollback if $oldAutoCommit;
1446 return "error removing old detail: $error";
1450 foreach my $detail ( @details ) {
1451 my $cust_pkg_detail = new FS::cust_pkg_detail {
1452 'pkgnum' => $self->pkgnum,
1453 'detailtype' => $detailtype,
1454 'detail' => $detail,
1456 my $error = $cust_pkg_detail->insert;
1458 $dbh->rollback if $oldAutoCommit;
1459 return "error adding new detail: $error";
1464 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1471 Returns the new-style customer billing events (see L<FS::cust_event>) for this invoice.
1475 #false laziness w/cust_bill.pm
1479 'table' => 'cust_event',
1480 'addl_from' => 'JOIN part_event USING ( eventpart )',
1481 'hashref' => { 'tablenum' => $self->pkgnum },
1482 'extra_sql' => " AND eventtable = 'cust_pkg' ",
1486 =item num_cust_event
1488 Returns the number of new-style customer billing events (see L<FS::cust_event>) for this invoice.
1492 #false laziness w/cust_bill.pm
1493 sub num_cust_event {
1496 "SELECT COUNT(*) FROM cust_event JOIN part_event USING ( eventpart ) ".
1497 " WHERE tablenum = ? AND eventtable = 'cust_pkg'";
1498 my $sth = dbh->prepare($sql) or die dbh->errstr. " preparing $sql";
1499 $sth->execute($self->pkgnum) or die $sth->errstr. " executing $sql";
1500 $sth->fetchrow_arrayref->[0];
1503 =item cust_svc [ SVCPART ]
1505 Returns the services for this package, as FS::cust_svc objects (see
1506 L<FS::cust_svc>). If a svcpart is specified, return only the matching
1514 return () unless $self->num_cust_svc(@_);
1517 return qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum,
1518 'svcpart' => shift, } );
1521 cluck "cust_pkg->cust_svc called" if $DEBUG > 2;
1523 #if ( $self->{'_svcnum'} ) {
1524 # values %{ $self->{'_svcnum'}->cache };
1526 $self->_sort_cust_svc(
1527 [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
1533 =item overlimit [ SVCPART ]
1535 Returns the services for this package which have exceeded their
1536 usage limit as FS::cust_svc objects (see L<FS::cust_svc>). If a svcpart
1537 is specified, return only the matching services.
1543 return () unless $self->num_cust_svc(@_);
1544 grep { $_->overlimit } $self->cust_svc(@_);
1547 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ]
1549 Returns historical services for this package created before END TIMESTAMP and
1550 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
1551 (see L<FS::h_cust_svc>).
1558 $self->_sort_cust_svc(
1559 [ qsearch( 'h_cust_svc',
1560 { 'pkgnum' => $self->pkgnum, },
1561 FS::h_cust_svc->sql_h_search(@_),
1567 sub _sort_cust_svc {
1568 my( $self, $arrayref ) = @_;
1571 sub ($$) { my ($a, $b) = @_; $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] };
1576 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
1577 'svcpart' => $_->svcpart } );
1579 $pkg_svc ? $pkg_svc->primary_svc : '',
1580 $pkg_svc ? $pkg_svc->quantity : 0,
1587 =item num_cust_svc [ SVCPART ]
1589 Returns the number of provisioned services for this package. If a svcpart is
1590 specified, counts only the matching services.
1597 return $self->{'_num_cust_svc'}
1599 && exists($self->{'_num_cust_svc'})
1600 && $self->{'_num_cust_svc'} =~ /\d/;
1602 cluck "cust_pkg->num_cust_svc called, _num_cust_svc:".$self->{'_num_cust_svc'}
1605 my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
1606 $sql .= ' AND svcpart = ?' if @_;
1608 my $sth = dbh->prepare($sql) or die dbh->errstr;
1609 $sth->execute($self->pkgnum, @_) or die $sth->errstr;
1610 $sth->fetchrow_arrayref->[0];
1613 =item available_part_svc
1615 Returns a list of FS::part_svc objects representing services included in this
1616 package but not yet provisioned. Each FS::part_svc object also has an extra
1617 field, I<num_avail>, which specifies the number of available services.
1621 sub available_part_svc {
1623 grep { $_->num_avail > 0 }
1625 my $part_svc = $_->part_svc;
1626 $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
1627 $_->quantity - $self->num_cust_svc($_->svcpart);
1630 $self->part_pkg->pkg_svc;
1635 Returns a list of FS::part_svc objects representing provisioned and available
1636 services included in this package. Each FS::part_svc object also has the
1637 following extra fields:
1641 =item num_cust_svc (count)
1643 =item num_avail (quantity - count)
1645 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
1648 label -> ($cust_svc->label)[1]
1657 #XXX some sort of sort order besides numeric by svcpart...
1658 my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
1660 my $part_svc = $pkg_svc->part_svc;
1661 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1662 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
1663 $part_svc->{'Hash'}{'num_avail'} =
1664 max( 0, $pkg_svc->quantity - $num_cust_svc );
1665 $part_svc->{'Hash'}{'cust_pkg_svc'} =
1666 $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
1668 } $self->part_pkg->pkg_svc;
1671 push @part_svc, map {
1673 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1674 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
1675 $part_svc->{'Hash'}{'num_avail'} = 0; #0-$num_cust_svc ?
1676 $part_svc->{'Hash'}{'cust_pkg_svc'} =
1677 $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
1679 } $self->extra_part_svc;
1685 =item extra_part_svc
1687 Returns a list of FS::part_svc objects corresponding to services in this
1688 package which are still provisioned but not (any longer) available in the
1693 sub extra_part_svc {
1696 my $pkgnum = $self->pkgnum;
1697 my $pkgpart = $self->pkgpart;
1700 # 'table' => 'part_svc',
1703 # "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
1704 # WHERE pkg_svc.svcpart = part_svc.svcpart
1705 # AND pkg_svc.pkgpart = ?
1708 # AND 0 < ( SELECT COUNT(*) FROM cust_svc
1709 # LEFT JOIN cust_pkg USING ( pkgnum )
1710 # WHERE cust_svc.svcpart = part_svc.svcpart
1713 # 'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
1716 #seems to benchmark slightly faster...
1718 #'select' => 'DISTINCT ON (svcpart) part_svc.*',
1719 #MySQL doesn't grok DISINCT ON
1720 'select' => 'DISTINCT part_svc.*',
1721 'table' => 'part_svc',
1723 'LEFT JOIN pkg_svc ON ( pkg_svc.svcpart = part_svc.svcpart
1724 AND pkg_svc.pkgpart = ?
1727 LEFT JOIN cust_svc ON ( cust_svc.svcpart = part_svc.svcpart )
1728 LEFT JOIN cust_pkg USING ( pkgnum )
1731 'extra_sql' => "WHERE pkgsvcnum IS NULL AND cust_pkg.pkgnum = ? ",
1732 'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
1738 Returns a short status string for this package, currently:
1742 =item not yet billed
1744 =item one-time charge
1759 my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
1761 return 'cancelled' if $self->get('cancel');
1762 return 'suspended' if $self->susp;
1763 return 'not yet billed' unless $self->setup;
1764 return 'one-time charge' if $freq =~ /^(0|$)/;
1770 Class method that returns the list of possible status strings for packages
1771 (see L<the status method|/status>). For example:
1773 @statuses = FS::cust_pkg->statuses();
1777 tie my %statuscolor, 'Tie::IxHash',
1778 'not yet billed' => '000000',
1779 'one-time charge' => '000000',
1780 'active' => '00CC00',
1781 'suspended' => 'FF9900',
1782 'cancelled' => 'FF0000',
1786 my $self = shift; #could be class...
1787 #grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
1788 # # mayble split btw one-time vs. recur
1794 Returns a hex triplet color string for this package's status.
1800 $statuscolor{$self->status};
1805 Returns a label for this package. (Currently "pkgnum: pkg - comment" or
1806 "pkg-comment" depending on user preference).
1812 my $label = $self->part_pkg->pkg_comment( 'nopkgpart' => 1 );
1813 $label = $self->pkgnum. ": $label"
1814 if $FS::CurrentUser::CurrentUser->option('show_pkgnum');
1818 =item pkg_label_long
1820 Returns a long label for this package, adding the primary service's label to
1825 sub pkg_label_long {
1827 my $label = $self->pkg_label;
1828 my $cust_svc = $self->primary_cust_svc;
1829 $label .= ' ('. ($cust_svc->label)[1]. ')' if $cust_svc;
1833 =item primary_cust_svc
1835 Returns a primary service (as FS::cust_svc object) if one can be identified.
1839 #for labeling purposes - might not 100% match up with part_pkg->svcpart's idea
1841 sub primary_cust_svc {
1844 my @cust_svc = $self->cust_svc;
1846 return '' unless @cust_svc; #no serivces - irrelevant then
1848 return $cust_svc[0] if scalar(@cust_svc) == 1; #always return a single service
1850 # primary service as specified in the package definition
1851 # or exactly one service definition with quantity one
1852 my $svcpart = $self->part_pkg->svcpart;
1853 @cust_svc = grep { $_->svcpart == $svcpart } @cust_svc;
1854 return $cust_svc[0] if scalar(@cust_svc) == 1;
1856 #couldn't identify one thing..
1862 Returns a list of lists, calling the label method for all services
1863 (see L<FS::cust_svc>) of this billing item.
1869 map { [ $_->label ] } $self->cust_svc;
1872 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
1874 Like the labels method, but returns historical information on services that
1875 were active as of END_TIMESTAMP and (optionally) not cancelled before
1878 Returns a list of lists, calling the label method for all (historical) services
1879 (see L<FS::h_cust_svc>) of this billing item.
1885 map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
1890 Like labels, except returns a simple flat list, and shortens long
1891 (currently >5 or the cust_bill-max_same_services configuration value) lists of
1892 identical services to one line that lists the service label and the number of
1893 individual services rather than individual items.
1898 shift->_labels_short( 'labels', @_ );
1901 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
1903 Like h_labels, except returns a simple flat list, and shortens long
1904 (currently >5 or the cust_bill-max_same_services configuration value) lists of
1905 identical services to one line that lists the service label and the number of
1906 individual services rather than individual items.
1910 sub h_labels_short {
1911 shift->_labels_short( 'h_labels', @_ );
1915 my( $self, $method ) = ( shift, shift );
1917 my $conf = new FS::Conf;
1918 my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
1921 #tie %labels, 'Tie::IxHash';
1922 push @{ $labels{$_->[0]} }, $_->[1]
1923 foreach $self->h_labels(@_);
1925 foreach my $label ( keys %labels ) {
1927 my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
1928 my $num = scalar(@values);
1929 if ( $num > $max_same_services ) {
1930 push @labels, "$label ($num)";
1932 if ( $conf->exists('cust_bill-consolidate_services') ) {
1933 # push @labels, "$label: ". join(', ', @values);
1935 my $detail = "$label: ";
1936 $detail .= shift(@values). ', '
1937 while @values && length($detail.$values[0]) < 78;
1939 push @labels, $detail;
1942 push @labels, map { "$label: $_" } @values;
1953 Returns the parent customer object (see L<FS::cust_main>).
1959 qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
1962 #these subs are in location_Mixin.pm now... unfortunately the POD doesn't mixin
1966 Returns the location object, if any (see L<FS::cust_location>).
1968 =item cust_location_or_main
1970 If this package is associated with a location, returns the locaiton (see
1971 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
1973 =item location_label [ OPTION => VALUE ... ]
1975 Returns the label of the location object (see L<FS::cust_location>).
1979 #end of subs in location_Mixin.pm now... unfortunately the POD doesn't mixin
1981 =item seconds_since TIMESTAMP
1983 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
1984 package have been online since TIMESTAMP, according to the session monitor.
1986 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1987 L<Time::Local> and L<Date::Parse> for conversion functions.
1992 my($self, $since) = @_;
1995 foreach my $cust_svc (
1996 grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
1998 $seconds += $cust_svc->seconds_since($since);
2005 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2007 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
2008 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
2011 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2012 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2018 sub seconds_since_sqlradacct {
2019 my($self, $start, $end) = @_;
2023 foreach my $cust_svc (
2025 my $part_svc = $_->part_svc;
2026 $part_svc->svcdb eq 'svc_acct'
2027 && scalar($part_svc->part_export('sqlradius'));
2030 $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
2037 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2039 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2040 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2044 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2045 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2050 sub attribute_since_sqlradacct {
2051 my($self, $start, $end, $attrib) = @_;
2055 foreach my $cust_svc (
2057 my $part_svc = $_->part_svc;
2058 $part_svc->svcdb eq 'svc_acct'
2059 && scalar($part_svc->part_export('sqlradius'));
2062 $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
2074 my( $self, $value ) = @_;
2075 if ( defined($value) ) {
2076 $self->setfield('quantity', $value);
2078 $self->getfield('quantity') || 1;
2081 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
2083 Transfers as many services as possible from this package to another package.
2085 The destination package can be specified by pkgnum by passing an FS::cust_pkg
2086 object. The destination package must already exist.
2088 Services are moved only if the destination allows services with the correct
2089 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true. Use
2090 this option with caution! No provision is made for export differences
2091 between the old and new service definitions. Probably only should be used
2092 when your exports for all service definitions of a given svcdb are identical.
2093 (attempt a transfer without it first, to move all possible svcpart-matching
2096 Any services that can't be moved remain in the original package.
2098 Returns an error, if there is one; otherwise, returns the number of services
2099 that couldn't be moved.
2104 my ($self, $dest_pkgnum, %opt) = @_;
2110 if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
2111 $dest = $dest_pkgnum;
2112 $dest_pkgnum = $dest->pkgnum;
2114 $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
2117 return ('Package does not exist: '.$dest_pkgnum) unless $dest;
2119 foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
2120 $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
2123 foreach my $cust_svc ($dest->cust_svc) {
2124 $target{$cust_svc->svcpart}--;
2127 my %svcpart2svcparts = ();
2128 if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2129 warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
2130 foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
2131 next if exists $svcpart2svcparts{$svcpart};
2132 my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
2133 $svcpart2svcparts{$svcpart} = [
2135 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
2137 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
2138 'svcpart' => $_ } );
2140 $pkg_svc ? $pkg_svc->primary_svc : '',
2141 $pkg_svc ? $pkg_svc->quantity : 0,
2145 grep { $_ != $svcpart }
2147 qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
2149 warn "alternates for svcpart $svcpart: ".
2150 join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
2155 foreach my $cust_svc ($self->cust_svc) {
2156 if($target{$cust_svc->svcpart} > 0) {
2157 $target{$cust_svc->svcpart}--;
2158 my $new = new FS::cust_svc { $cust_svc->hash };
2159 $new->pkgnum($dest_pkgnum);
2160 my $error = $new->replace($cust_svc);
2161 return $error if $error;
2162 } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2164 warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
2165 warn "alternates to consider: ".
2166 join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
2168 my @alternate = grep {
2169 warn "considering alternate svcpart $_: ".
2170 "$target{$_} available in new package\n"
2173 } @{$svcpart2svcparts{$cust_svc->svcpart}};
2175 warn "alternate(s) found\n" if $DEBUG;
2176 my $change_svcpart = $alternate[0];
2177 $target{$change_svcpart}--;
2178 my $new = new FS::cust_svc { $cust_svc->hash };
2179 $new->svcpart($change_svcpart);
2180 $new->pkgnum($dest_pkgnum);
2181 my $error = $new->replace($cust_svc);
2182 return $error if $error;
2195 This method is deprecated. See the I<depend_jobnum> option to the insert and
2196 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
2203 local $SIG{HUP} = 'IGNORE';
2204 local $SIG{INT} = 'IGNORE';
2205 local $SIG{QUIT} = 'IGNORE';
2206 local $SIG{TERM} = 'IGNORE';
2207 local $SIG{TSTP} = 'IGNORE';
2208 local $SIG{PIPE} = 'IGNORE';
2210 my $oldAutoCommit = $FS::UID::AutoCommit;
2211 local $FS::UID::AutoCommit = 0;
2214 foreach my $cust_svc ( $self->cust_svc ) {
2215 #false laziness w/svc_Common::insert
2216 my $svc_x = $cust_svc->svc_x;
2217 foreach my $part_export ( $cust_svc->part_svc->part_export ) {
2218 my $error = $part_export->export_insert($svc_x);
2220 $dbh->rollback if $oldAutoCommit;
2226 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2233 Associates this package with a (suspension or cancellation) reason (see
2234 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
2237 Available options are:
2243 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.
2247 the access_user (see L<FS::access_user>) providing the reason
2255 the action (cancel, susp, adjourn, expire) associated with the reason
2259 If there is an error, returns the error, otherwise returns false.
2264 my ($self, %options) = @_;
2266 my $otaker = $options{reason_otaker} ||
2267 $FS::CurrentUser::CurrentUser->username;
2270 if ( $options{'reason'} =~ /^(\d+)$/ ) {
2274 } elsif ( ref($options{'reason'}) ) {
2276 return 'Enter a new reason (or select an existing one)'
2277 unless $options{'reason'}->{'reason'} !~ /^\s*$/;
2279 my $reason = new FS::reason({
2280 'reason_type' => $options{'reason'}->{'typenum'},
2281 'reason' => $options{'reason'}->{'reason'},
2283 my $error = $reason->insert;
2284 return $error if $error;
2286 $reasonnum = $reason->reasonnum;
2289 return "Unparsable reason: ". $options{'reason'};
2292 my $cust_pkg_reason =
2293 new FS::cust_pkg_reason({ 'pkgnum' => $self->pkgnum,
2294 'reasonnum' => $reasonnum,
2295 'otaker' => $otaker,
2296 'action' => substr(uc($options{'action'}),0,1),
2297 'date' => $options{'date'}
2302 $cust_pkg_reason->insert;
2305 =item insert_discount
2307 Associates this package with a discount (see L<FS::cust_pkg_discount>, possibly
2308 inserting a new discount on the fly (see L<FS::discount>).
2310 Available options are:
2318 If there is an error, returns the error, otherwise returns false.
2322 sub insert_discount {
2323 #my ($self, %options) = @_;
2326 my $cust_pkg_discount = new FS::cust_pkg_discount {
2327 'pkgnum' => $self->pkgnum,
2328 'discountnum' => $self->discountnum,
2330 'end_date' => '', #XXX
2331 'otaker' => $self->otaker,
2332 #for the create a new discount case
2333 '_type' => $self->discountnum__type,
2334 'amount' => $self->discountnum_amount,
2335 'percent' => $self->discountnum_percent,
2336 'months' => $self->discountnum_months,
2337 #'disabled' => $self->discountnum_disabled,
2340 $cust_pkg_discount->insert;
2343 =item set_usage USAGE_VALUE_HASHREF
2345 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2346 to which they should be set (see L<FS::svc_acct>). Currently seconds,
2347 upbytes, downbytes, and totalbytes are appropriate keys.
2349 All svc_accts which are part of this package have their values reset.
2354 my ($self, $valueref, %opt) = @_;
2356 foreach my $cust_svc ($self->cust_svc){
2357 my $svc_x = $cust_svc->svc_x;
2358 $svc_x->set_usage($valueref, %opt)
2359 if $svc_x->can("set_usage");
2363 =item recharge USAGE_VALUE_HASHREF
2365 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2366 to which they should be set (see L<FS::svc_acct>). Currently seconds,
2367 upbytes, downbytes, and totalbytes are appropriate keys.
2369 All svc_accts which are part of this package have their values incremented.
2374 my ($self, $valueref) = @_;
2376 foreach my $cust_svc ($self->cust_svc){
2377 my $svc_x = $cust_svc->svc_x;
2378 $svc_x->recharge($valueref)
2379 if $svc_x->can("recharge");
2383 =item cust_pkg_discount
2387 sub cust_pkg_discount {
2389 qsearch('cust_pkg_discount', { 'pkgnum' => $self->pkgnum } );
2392 =item cust_pkg_discount_active
2396 sub cust_pkg_discount_active {
2398 grep { $_->status eq 'active' } $self->cust_pkg_discount;
2403 =head1 CLASS METHODS
2409 Returns an SQL expression identifying recurring packages.
2413 sub recurring_sql { "
2414 '0' != ( select freq from part_pkg
2415 where cust_pkg.pkgpart = part_pkg.pkgpart )
2420 Returns an SQL expression identifying one-time packages.
2425 '0' = ( select freq from part_pkg
2426 where cust_pkg.pkgpart = part_pkg.pkgpart )
2431 Returns an SQL expression identifying active packages.
2436 ". $_[0]->recurring_sql(). "
2437 AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
2438 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2439 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
2442 =item not_yet_billed_sql
2444 Returns an SQL expression identifying packages which have not yet been billed.
2448 sub not_yet_billed_sql { "
2449 ( cust_pkg.setup IS NULL OR cust_pkg.setup = 0 )
2450 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2451 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
2456 Returns an SQL expression identifying inactive packages (one-time packages
2457 that are otherwise unsuspended/uncancelled).
2461 sub inactive_sql { "
2462 ". $_[0]->onetime_sql(). "
2463 AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
2464 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2465 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
2471 Returns an SQL expression identifying suspended packages.
2475 sub suspended_sql { susp_sql(@_); }
2477 #$_[0]->recurring_sql(). ' AND '.
2479 ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2480 AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0
2487 Returns an SQL exprression identifying cancelled packages.
2491 sub cancelled_sql { cancel_sql(@_); }
2493 #$_[0]->recurring_sql(). ' AND '.
2494 "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
2497 =item search HASHREF
2501 Returns a qsearch hash expression to search for parameters specified in HASHREF.
2502 Valid parameters are
2510 active, inactive, suspended, cancel (or cancelled)
2514 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
2518 boolean selects custom packages
2524 pkgpart or arrayref or hashref of pkgparts
2528 arrayref of beginning and ending epoch date
2532 arrayref of beginning and ending epoch date
2536 arrayref of beginning and ending epoch date
2540 arrayref of beginning and ending epoch date
2544 arrayref of beginning and ending epoch date
2548 arrayref of beginning and ending epoch date
2552 arrayref of beginning and ending epoch date
2556 pkgnum or APKG_pkgnum
2560 a value suited to passing to FS::UI::Web::cust_header
2564 specifies the user for agent virtualization
2571 my ($class, $params) = @_;
2578 if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2580 "cust_main.agentnum = $1";
2587 if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
2589 "cust_pkg.custnum = $1";
2596 if ( $params->{'magic'} eq 'active'
2597 || $params->{'status'} eq 'active' ) {
2599 push @where, FS::cust_pkg->active_sql();
2601 } elsif ( $params->{'magic'} =~ /^not[ _]yet[ _]billed$/
2602 || $params->{'status'} =~ /^not[ _]yet[ _]billed$/ ) {
2604 push @where, FS::cust_pkg->not_yet_billed_sql();
2606 } elsif ( $params->{'magic'} =~ /^(one-time charge|inactive)/
2607 || $params->{'status'} =~ /^(one-time charge|inactive)/ ) {
2609 push @where, FS::cust_pkg->inactive_sql();
2611 } elsif ( $params->{'magic'} eq 'suspended'
2612 || $params->{'status'} eq 'suspended' ) {
2614 push @where, FS::cust_pkg->suspended_sql();
2616 } elsif ( $params->{'magic'} =~ /^cancell?ed$/
2617 || $params->{'status'} =~ /^cancell?ed$/ ) {
2619 push @where, FS::cust_pkg->cancelled_sql();
2624 # parse package class
2627 #false lazinessish w/graph/cust_bill_pkg.cgi
2630 if ( exists($params->{'classnum'})
2631 && $params->{'classnum'} =~ /^(\d*)$/
2635 if ( $classnum ) { #a specific class
2636 push @where, "part_pkg.classnum = $classnum";
2638 #@pkg_class = ( qsearchs('pkg_class', { 'classnum' => $classnum } ) );
2639 #die "classnum $classnum not found!" unless $pkg_class[0];
2640 #$title .= $pkg_class[0]->classname.' ';
2642 } elsif ( $classnum eq '' ) { #the empty class
2644 push @where, "part_pkg.classnum IS NULL";
2645 #$title .= 'Empty class ';
2646 #@pkg_class = ( '(empty class)' );
2647 } elsif ( $classnum eq '0' ) {
2648 #@pkg_class = qsearch('pkg_class', {} ); # { 'disabled' => '' } );
2649 #push @pkg_class, '(empty class)';
2651 die "illegal classnum";
2657 # parse package report options
2660 my @report_option = ();
2661 if ( exists($params->{'report_option'})
2662 && $params->{'report_option'} =~ /^([,\d]*)$/
2665 @report_option = split(',', $1);
2668 if (@report_option) {
2669 # this will result in the empty set for the dangling comma case as it should
2671 map{ "0 < ( SELECT count(*) FROM part_pkg_option
2672 WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
2673 AND optionname = 'report_option_$_'
2674 AND optionvalue = '1' )"
2684 push @where, "part_pkg.custom = 'Y'" if $params->{custom};
2690 if ( exists($params->{'censustract'}) ) {
2691 $params->{'censustract'} =~ /^([.\d]*)$/;
2692 my $censustract = "cust_main.censustract = '$1'";
2693 $censustract .= ' OR cust_main.censustract is NULL' unless $1;
2694 push @where, "( $censustract )";
2701 if ( ref($params->{'pkgpart'}) ) {
2704 if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
2705 @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
2706 } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
2707 @pkgpart = @{ $params->{'pkgpart'} };
2709 die 'unhandled pkgpart ref '. $params->{'pkgpart'};
2712 @pkgpart = grep /^(\d+)$/, @pkgpart;
2714 push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
2716 } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
2717 push @where, "pkgpart = $1";
2726 #false laziness w/report_cust_pkg.html
2729 'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
2730 'active' => { 'susp'=>1, 'cancel'=>1 },
2731 'suspended' => { 'cancel' => 1 },
2736 if( exists($params->{'active'} ) ) {
2737 # This overrides all the other date-related fields
2738 my($beginning, $ending) = @{$params->{'active'}};
2740 "cust_pkg.setup IS NOT NULL",
2741 "cust_pkg.setup <= $ending",
2742 "(cust_pkg.cancel IS NULL OR cust_pkg.cancel >= $beginning )",
2743 "NOT (".FS::cust_pkg->onetime_sql . ")";
2746 foreach my $field (qw( setup last_bill bill adjourn susp expire cancel )) {
2748 next unless exists($params->{$field});
2750 my($beginning, $ending) = @{$params->{$field}};
2752 next if $beginning == 0 && $ending == 4294967295;
2755 "cust_pkg.$field IS NOT NULL",
2756 "cust_pkg.$field >= $beginning",
2757 "cust_pkg.$field <= $ending";
2759 $orderby ||= "ORDER BY cust_pkg.$field";
2764 $orderby ||= 'ORDER BY bill';
2767 # parse magic, legacy, etc.
2770 if ( $params->{'magic'} &&
2771 $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
2774 $orderby = 'ORDER BY pkgnum';
2776 if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
2777 push @where, "pkgpart = $1";
2780 } elsif ( $params->{'query'} eq 'pkgnum' ) {
2782 $orderby = 'ORDER BY pkgnum';
2784 } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
2786 $orderby = 'ORDER BY pkgnum';
2789 SELECT count(*) FROM pkg_svc
2790 WHERE pkg_svc.pkgpart = cust_pkg.pkgpart
2791 AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
2792 WHERE cust_svc.pkgnum = cust_pkg.pkgnum
2793 AND cust_svc.svcpart = pkg_svc.svcpart
2800 # setup queries, links, subs, etc. for the search
2803 # here is the agent virtualization
2804 if ($params->{CurrentUser}) {
2806 qsearchs('access_user', { username => $params->{CurrentUser} });
2809 push @where, $access_user->agentnums_sql('table'=>'cust_main');
2814 push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
2817 my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
2819 my $addl_from = 'LEFT JOIN cust_main USING ( custnum ) '.
2820 'LEFT JOIN part_pkg USING ( pkgpart ) '.
2821 'LEFT JOIN pkg_class ON ( part_pkg.classnum = pkg_class.classnum ) ';
2823 my $count_query = "SELECT COUNT(*) FROM cust_pkg $addl_from $extra_sql";
2826 'table' => 'cust_pkg',
2828 'select' => join(', ',
2830 ( map "part_pkg.$_", qw( pkg freq ) ),
2831 'pkg_class.classname',
2832 'cust_main.custnum AS cust_main_custnum',
2833 FS::UI::Web::cust_sql_fields(
2834 $params->{'cust_fields'}
2837 'extra_sql' => "$extra_sql $orderby",
2838 'addl_from' => $addl_from,
2839 'count_query' => $count_query,
2846 Returns a list: the first item is an SQL fragment identifying matching
2847 packages/customers via location (taking into account shipping and package
2848 address taxation, if enabled), and subsequent items are the parameters to
2849 substitute for the placeholders in that fragment.
2854 my($class, %opt) = @_;
2855 my $ornull = $opt{'ornull'};
2857 my $conf = new FS::Conf;
2859 # '?' placeholders in _location_sql_where
2860 my $x = $ornull ? 3 : 2;
2861 my @bill_param = ( ('city')x3, ('county')x$x, ('state')x$x, 'country' );
2865 if ( $conf->exists('tax-ship_address') ) {
2868 ( ( ship_last IS NULL OR ship_last = '' )
2869 AND ". _location_sql_where('cust_main', '', $ornull ). "
2871 OR ( ship_last IS NOT NULL AND ship_last != ''
2872 AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
2875 # AND payby != 'COMP'
2877 @main_param = ( @bill_param, @bill_param );
2881 $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
2882 @main_param = @bill_param;
2888 if ( $conf->exists('tax-pkg_address') ) {
2890 my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
2893 ( cust_pkg.locationnum IS NULL AND $main_where )
2894 OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where )
2897 @param = ( @main_param, @bill_param );
2901 $where = $main_where;
2902 @param = @main_param;
2910 #subroutine, helper for location_sql
2911 sub _location_sql_where {
2913 my $prefix = @_ ? shift : '';
2914 my $ornull = @_ ? shift : '';
2916 # $ornull = $ornull ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
2918 $ornull = $ornull ? ' OR ? IS NULL ' : '';
2920 my $or_empty_city = " OR ( ? = '' AND $table.${prefix}city IS NULL ) ";
2921 my $or_empty_county = " OR ( ? = '' AND $table.${prefix}county IS NULL ) ";
2922 my $or_empty_state = " OR ( ? = '' AND $table.${prefix}state IS NULL ) ";
2924 # ( $table.${prefix}city = ? $or_empty_city $ornull )
2926 ( $table.${prefix}city = ? OR ? = '' OR CAST(? AS text) IS NULL )
2927 AND ( $table.${prefix}county = ? $or_empty_county $ornull )
2928 AND ( $table.${prefix}state = ? $or_empty_state $ornull )
2929 AND $table.${prefix}country = ?
2937 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
2939 CUSTNUM is a customer (see L<FS::cust_main>)
2941 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
2942 L<FS::part_pkg>) to order for this customer. Duplicates are of course
2945 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
2946 remove for this customer. The services (see L<FS::cust_svc>) are moved to the
2947 new billing items. An error is returned if this is not possible (see
2948 L<FS::pkg_svc>). An empty arrayref is equivalent to not specifying this
2951 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
2952 newly-created cust_pkg objects.
2954 REFNUM, if specified, will specify the FS::pkg_referral record to be created
2955 and inserted. Multiple FS::pkg_referral records can be created by
2956 setting I<refnum> to an array reference of refnums or a hash reference with
2957 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
2958 record will be created corresponding to cust_main.refnum.
2963 my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
2965 my $conf = new FS::Conf;
2967 # Transactionize this whole mess
2968 local $SIG{HUP} = 'IGNORE';
2969 local $SIG{INT} = 'IGNORE';
2970 local $SIG{QUIT} = 'IGNORE';
2971 local $SIG{TERM} = 'IGNORE';
2972 local $SIG{TSTP} = 'IGNORE';
2973 local $SIG{PIPE} = 'IGNORE';
2975 my $oldAutoCommit = $FS::UID::AutoCommit;
2976 local $FS::UID::AutoCommit = 0;
2980 # my $cust_main = qsearchs('cust_main', { custnum => $custnum });
2981 # return "Customer not found: $custnum" unless $cust_main;
2983 warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
2986 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
2989 my $change = scalar(@old_cust_pkg) != 0;
2992 if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
2994 warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
2995 " to pkgpart ". $pkgparts->[0]. "\n"
2998 my $err_or_cust_pkg =
2999 $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
3000 'refnum' => $refnum,
3003 unless (ref($err_or_cust_pkg)) {
3004 $dbh->rollback if $oldAutoCommit;
3005 return $err_or_cust_pkg;
3008 push @$return_cust_pkg, $err_or_cust_pkg;
3009 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3014 # Create the new packages.
3015 foreach my $pkgpart (@$pkgparts) {
3017 warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
3019 my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
3020 pkgpart => $pkgpart,
3024 $error = $cust_pkg->insert( 'change' => $change );
3026 $dbh->rollback if $oldAutoCommit;
3029 push @$return_cust_pkg, $cust_pkg;
3031 # $return_cust_pkg now contains refs to all of the newly
3034 # Transfer services and cancel old packages.
3035 foreach my $old_pkg (@old_cust_pkg) {
3037 warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
3040 foreach my $new_pkg (@$return_cust_pkg) {
3041 $error = $old_pkg->transfer($new_pkg);
3042 if ($error and $error == 0) {
3043 # $old_pkg->transfer failed.
3044 $dbh->rollback if $oldAutoCommit;
3049 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
3050 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
3051 foreach my $new_pkg (@$return_cust_pkg) {
3052 $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
3053 if ($error and $error == 0) {
3054 # $old_pkg->transfer failed.
3055 $dbh->rollback if $oldAutoCommit;
3062 # Transfers were successful, but we went through all of the
3063 # new packages and still had services left on the old package.
3064 # We can't cancel the package under the circumstances, so abort.
3065 $dbh->rollback if $oldAutoCommit;
3066 return "Unable to transfer all services from package ".$old_pkg->pkgnum;
3068 $error = $old_pkg->cancel( quiet=>1 );
3074 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3078 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
3080 A bulk change method to change packages for multiple customers.
3082 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
3083 L<FS::part_pkg>) to order for each customer. Duplicates are of course
3086 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
3087 replace. The services (see L<FS::cust_svc>) are moved to the
3088 new billing items. An error is returned if this is not possible (see
3091 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
3092 newly-created cust_pkg objects.
3097 my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
3099 # Transactionize this whole mess
3100 local $SIG{HUP} = 'IGNORE';
3101 local $SIG{INT} = 'IGNORE';
3102 local $SIG{QUIT} = 'IGNORE';
3103 local $SIG{TERM} = 'IGNORE';
3104 local $SIG{TSTP} = 'IGNORE';
3105 local $SIG{PIPE} = 'IGNORE';
3107 my $oldAutoCommit = $FS::UID::AutoCommit;
3108 local $FS::UID::AutoCommit = 0;
3112 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
3115 while(scalar(@old_cust_pkg)) {
3117 my $custnum = $old_cust_pkg[0]->custnum;
3118 my (@remove) = map { $_->pkgnum }
3119 grep { $_->custnum == $custnum } @old_cust_pkg;
3120 @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
3122 my $error = order $custnum, $pkgparts, \@remove, \@return;
3124 push @errors, $error
3126 push @$return_cust_pkg, @return;
3129 if (scalar(@errors)) {
3130 $dbh->rollback if $oldAutoCommit;
3131 return join(' / ', @errors);
3134 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3138 # Used by FS::Upgrade to migrate to a new database.
3139 sub _upgrade_data { # class method
3140 my ($class, %opts) = @_;
3141 $class->_upgrade_otaker(%opts);
3148 sub order is not OO. Perhaps it should be moved to FS::cust_main and made so?
3150 In sub order, the @pkgparts array (passed by reference) is clobbered.
3152 Also in sub order, no money is adjusted. Once FS::part_pkg defines a standard
3153 method to pass dates to the recur_prog expression, it should do so.
3155 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
3156 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
3157 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
3158 configuration values. Probably need a subroutine which decides what to do
3159 based on whether or not we've fetched the user yet, rather than a hash. See
3160 FS::UID and the TODO.
3162 Now that things are transactional should the check in the insert method be
3167 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
3168 L<FS::pkg_svc>, schema.html from the base documentation