4 use vars qw(@ISA $disable_agentcheck $DEBUG $me);
6 use Scalar::Util qw( blessed );
7 use List::Util qw(max);
9 use Time::Local qw( timelocal_nocheck );
11 use FS::UID qw( getotaker dbh );
12 use FS::Misc qw( send_email );
13 use FS::Record qw( qsearch qsearchs );
15 use FS::cust_main_Mixin;
19 use FS::cust_location;
21 use FS::cust_bill_pkg;
22 use FS::cust_pkg_detail;
27 use FS::cust_pkg_reason;
31 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
33 # because they load configuration by setting FS::UID::callback (see TODO)
39 # for sending cancel emails in sub cancel
42 @ISA = qw( FS::m2m_Common FS::cust_main_Mixin FS::option_Common FS::Record );
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 (assigned automatically if null, see L<FS::UID>)
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 local $SIG{HUP} = 'IGNORE';
255 local $SIG{INT} = 'IGNORE';
256 local $SIG{QUIT} = 'IGNORE';
257 local $SIG{TERM} = 'IGNORE';
258 local $SIG{TSTP} = 'IGNORE';
259 local $SIG{PIPE} = 'IGNORE';
261 my $oldAutoCommit = $FS::UID::AutoCommit;
262 local $FS::UID::AutoCommit = 0;
265 my $error = $self->SUPER::insert($options{options} ? %{$options{options}} : ());
267 $dbh->rollback if $oldAutoCommit;
271 $self->refnum($self->cust_main->refnum) unless $self->refnum;
272 $self->refnum( [ $self->refnum ] ) unless ref($self->refnum);
273 $self->process_m2m( 'link_table' => 'pkg_referral',
274 'target_table' => 'part_referral',
275 'params' => $self->refnum,
278 #if ( $self->reg_code ) {
279 # my $reg_code = qsearchs('reg_code', { 'code' => $self->reg_code } );
280 # $error = $reg_code->delete;
282 # $dbh->rollback if $oldAutoCommit;
287 my $conf = new FS::Conf;
289 if ( $conf->config('ticket_system') && $options{ticket_subject} ) {
291 use lib ( "/opt/rt3/local/lib", "/opt/rt3/lib" );
298 my $q = new RT::Queue($RT::SystemUser);
299 $q->Load($options{ticket_queue}) if $options{ticket_queue};
300 my $t = new RT::Ticket($RT::SystemUser);
301 my $mime = new MIME::Entity;
302 $mime->build( Type => 'text/plain', Data => $options{ticket_subject} );
303 $t->Create( $options{ticket_queue} ? (Queue => $q) : (),
304 Subject => $options{ticket_subject},
307 $t->AddLink( Type => 'MemberOf',
308 Target => 'freeside://freeside/cust_main/'. $self->custnum,
312 if ($conf->config('welcome_letter') && $self->cust_main->num_pkgs == 1) {
313 my $queue = new FS::queue {
314 'job' => 'FS::cust_main::queueable_print',
316 $error = $queue->insert(
317 'custnum' => $self->custnum,
318 'template' => 'welcome_letter',
322 warn "can't send welcome letter: $error";
327 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
334 This method now works but you probably shouldn't use it.
336 You don't want to delete billing items, because there would then be no record
337 the customer ever purchased the item. Instead, see the cancel method.
342 # return "Can't delete cust_pkg records!";
345 =item replace [ OLD_RECORD ] [ HASHREF | OPTION => VALUE ... ]
347 Replaces the OLD_RECORD with this one in the database. If there is an error,
348 returns the error, otherwise returns false.
350 Currently, custnum, setup, bill, adjourn, susp, expire, and cancel may be changed.
352 Changing pkgpart may have disasterous effects. See the order subroutine.
354 setup and bill are normally updated by calling the bill method of a customer
355 object (see L<FS::cust_main>).
357 suspend is normally updated by the suspend and unsuspend methods.
359 cancel is normally updated by the cancel method (and also the order subroutine
362 Available options are:
368 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.
372 the access_user (see L<FS::access_user>) providing the reason
376 hashref of keys and values - cust_pkg_option records will be created, updated or removed as appopriate
385 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
390 ( ref($_[0]) eq 'HASH' )
394 #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
395 return "Can't change otaker!" if $old->otaker ne $new->otaker;
398 #return "Can't change setup once it exists!"
399 # if $old->getfield('setup') &&
400 # $old->getfield('setup') != $new->getfield('setup');
402 #some logic for bill, susp, cancel?
404 local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
406 local $SIG{HUP} = 'IGNORE';
407 local $SIG{INT} = 'IGNORE';
408 local $SIG{QUIT} = 'IGNORE';
409 local $SIG{TERM} = 'IGNORE';
410 local $SIG{TSTP} = 'IGNORE';
411 local $SIG{PIPE} = 'IGNORE';
413 my $oldAutoCommit = $FS::UID::AutoCommit;
414 local $FS::UID::AutoCommit = 0;
417 foreach my $method ( qw(adjourn expire) ) { # How many reasons?
418 if ($options->{'reason'} && $new->$method && $old->$method ne $new->$method) {
419 my $error = $new->insert_reason(
420 'reason' => $options->{'reason'},
421 'date' => $new->$method,
423 'reason_otaker' => $options->{'reason_otaker'},
426 dbh->rollback if $oldAutoCommit;
427 return "Error inserting cust_pkg_reason: $error";
432 #save off and freeze RADIUS attributes for any associated svc_acct records
434 if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
436 #also check for specific exports?
437 # to avoid spurious modify export events
438 @svc_acct = map { $_->svc_x }
439 grep { $_->part_svc->svcdb eq 'svc_acct' }
442 $_->snapshot foreach @svc_acct;
446 my $error = $new->SUPER::replace($old,
447 $options->{options} ? $options->{options} : ()
450 $dbh->rollback if $oldAutoCommit;
454 #for prepaid packages,
455 #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
456 foreach my $old_svc_acct ( @svc_acct ) {
457 my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
458 my $s_error = $new_svc_acct->replace($old_svc_acct);
460 $dbh->rollback if $oldAutoCommit;
465 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
472 Checks all fields to make sure this is a valid billing item. If there is an
473 error, returns the error, otherwise returns false. Called by the insert and
481 $self->locationnum('') if !$self->locationnum || $self->locationnum == -1;
484 $self->ut_numbern('pkgnum')
485 || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
486 || $self->ut_numbern('pkgpart')
487 || $self->ut_foreign_keyn('locationnum', 'cust_location', 'locationnum')
488 || $self->ut_numbern('start_date')
489 || $self->ut_numbern('setup')
490 || $self->ut_numbern('bill')
491 || $self->ut_numbern('susp')
492 || $self->ut_numbern('cancel')
493 || $self->ut_numbern('adjourn')
494 || $self->ut_numbern('expire')
496 return $error if $error;
498 if ( $self->reg_code ) {
500 unless ( grep { $self->pkgpart == $_->pkgpart }
501 map { $_->reg_code_pkg }
502 qsearchs( 'reg_code', { 'code' => $self->reg_code,
503 'agentnum' => $self->cust_main->agentnum })
505 return "Unknown registration code";
508 } elsif ( $self->promo_code ) {
511 qsearchs('part_pkg', {
512 'pkgpart' => $self->pkgpart,
513 'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
515 return 'Unknown promotional code' unless $promo_part_pkg;
519 unless ( $disable_agentcheck ) {
521 qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
522 return "agent ". $agent->agentnum. ':'. $agent->agent.
523 " can't purchase pkgpart ". $self->pkgpart
524 unless $agent->pkgpart_hashref->{ $self->pkgpart }
525 || $agent->agentnum == $self->part_pkg->agentnum;
528 $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
529 return $error if $error;
533 if ( $self->part_pkg->option('start_1st') && !$self->start_date ) {
534 my ($sec,$min,$hour,$mday,$mon,$year) = (localtime(time) )[0,1,2,3,4,5];
535 $mon += 1 unless $mday == 1;
536 until ( $mon < 12 ) { $mon -= 12; $year++; }
537 $self->start_date( timelocal_nocheck(0,0,0,1,$mon,$year) );
540 my $expire_months = $self->part_pkg->option('expire_months');
541 if ( $expire_months && !$self->expire ) {
542 my $start = $self->start_date || $self->setup || time;
544 #false laziness w/part_pkg::add_freq
545 my ($sec,$min,$hour,$mday,$mon,$year) = (localtime($start) )[0,1,2,3,4,5];
546 $mon += $expire_months;
547 until ( $mon < 12 ) { $mon -= 12; $year++; }
549 #$self->expire( timelocal_nocheck($sec,$min,$hour,$mday,$mon,$year) );
550 $self->expire( timelocal_nocheck(0,0,0,$mday,$mon,$year) );
553 $self->otaker(getotaker) unless $self->otaker;
554 $self->otaker =~ /^(\w{1,32})$/ or return "Illegal otaker";
557 if ( $self->dbdef_table->column('manual_flag') ) {
558 $self->manual_flag('') if $self->manual_flag eq ' ';
559 $self->manual_flag =~ /^([01]?)$/
560 or return "Illegal manual_flag ". $self->manual_flag;
561 $self->manual_flag($1);
567 =item cancel [ OPTION => VALUE ... ]
569 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
570 in this package, then cancels the package itself (sets the cancel field to
573 Available options are:
577 =item quiet - can be set true to supress email cancellation notices.
579 =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.
581 =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.
583 =item date - can be set to a unix style timestamp to specify when to cancel (expire)
585 =item nobill - can be set true to skip billing if it might otherwise be done.
589 If there is an error, returns the error, otherwise returns false.
594 my( $self, %options ) = @_;
597 my $conf = new FS::Conf;
599 warn "cust_pkg::cancel called with options".
600 join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
603 local $SIG{HUP} = 'IGNORE';
604 local $SIG{INT} = 'IGNORE';
605 local $SIG{QUIT} = 'IGNORE';
606 local $SIG{TERM} = 'IGNORE';
607 local $SIG{TSTP} = 'IGNORE';
608 local $SIG{PIPE} = 'IGNORE';
610 my $oldAutoCommit = $FS::UID::AutoCommit;
611 local $FS::UID::AutoCommit = 0;
614 my $old = $self->select_for_update;
616 if ( $old->get('cancel') || $self->get('cancel') ) {
617 dbh->rollback if $oldAutoCommit;
618 return ""; # no error
621 my $date = $options{date} if $options{date}; # expire/cancel later
622 $date = '' if ($date && $date <= time); # complain instead?
624 #race condition: usage could be ongoing until unprovisioned
625 #resolved by performing a change package instead (which unprovisions) and
627 if ( !$options{nobill} && !$date && $conf->exists('bill_usage_on_cancel') ) {
628 my $copy = $self->new({$self->hash});
630 $copy->cust_main->bill( pkg_list => [ $copy ], cancel => 1 );
631 warn "Error billing during cancel, custnum ".
632 #$self->cust_main->custnum. ": $error"
638 my $cancel_time = $options{'time'} || time;
640 if ( $options{'reason'} ) {
641 $error = $self->insert_reason( 'reason' => $options{'reason'},
642 'action' => $date ? 'expire' : 'cancel',
643 'date' => $date ? $date : $cancel_time,
644 'reason_otaker' => $options{'reason_otaker'},
647 dbh->rollback if $oldAutoCommit;
648 return "Error inserting cust_pkg_reason: $error";
654 foreach my $cust_svc (
657 sort { $a->[1] <=> $b->[1] }
658 map { [ $_, $_->svc_x->table_info->{'cancel_weight'} ]; }
659 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
662 my $error = $cust_svc->cancel;
665 $dbh->rollback if $oldAutoCommit;
666 return "Error cancelling cust_svc: $error";
670 # Add a credit for remaining service
671 my $remaining_value = $self->calc_remain(time=>$cancel_time);
672 if ( $remaining_value > 0 && !$options{'no_credit'} ) {
673 my $error = $self->cust_main->credit(
675 'Credit for unused time on '. $self->part_pkg->pkg,
676 'reason_type' => $conf->config('cancel_credit_type'),
679 $dbh->rollback if $oldAutoCommit;
680 return "Error crediting customer \$$remaining_value for unused time on".
681 $self->part_pkg->pkg. ": $error";
686 my %hash = $self->hash;
687 $date ? ($hash{'expire'} = $date) : ($hash{'cancel'} = $cancel_time);
688 my $new = new FS::cust_pkg ( \%hash );
689 $error = $new->replace( $self, options => { $self->options } );
691 $dbh->rollback if $oldAutoCommit;
695 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
696 return '' if $date; #no errors
698 my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
699 if ( !$options{'quiet'} && $conf->exists('emailcancel') && @invoicing_list ) {
700 my $error = send_email(
701 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
702 'to' => \@invoicing_list,
703 'subject' => ( $conf->config('cancelsubject') || 'Cancellation Notice' ),
704 'body' => [ map "$_\n", $conf->config('cancelmessage') ],
706 #should this do something on errors?
713 =item cancel_if_expired [ NOW_TIMESTAMP ]
715 Cancels this package if its expire date has been reached.
719 sub cancel_if_expired {
721 my $time = shift || time;
722 return '' unless $self->expire && $self->expire <= $time;
723 my $error = $self->cancel;
725 return "Error cancelling expired pkg ". $self->pkgnum. " for custnum ".
726 $self->custnum. ": $error";
733 Cancels any pending expiration (sets the expire field to null).
735 If there is an error, returns the error, otherwise returns false.
740 my( $self, %options ) = @_;
743 local $SIG{HUP} = 'IGNORE';
744 local $SIG{INT} = 'IGNORE';
745 local $SIG{QUIT} = 'IGNORE';
746 local $SIG{TERM} = 'IGNORE';
747 local $SIG{TSTP} = 'IGNORE';
748 local $SIG{PIPE} = 'IGNORE';
750 my $oldAutoCommit = $FS::UID::AutoCommit;
751 local $FS::UID::AutoCommit = 0;
754 my $old = $self->select_for_update;
756 my $pkgnum = $old->pkgnum;
757 if ( $old->get('cancel') || $self->get('cancel') ) {
758 dbh->rollback if $oldAutoCommit;
759 return "Can't unexpire cancelled package $pkgnum";
760 # or at least it's pointless
763 unless ( $old->get('expire') && $self->get('expire') ) {
764 dbh->rollback if $oldAutoCommit;
765 return ""; # no error
768 my %hash = $self->hash;
769 $hash{'expire'} = '';
770 my $new = new FS::cust_pkg ( \%hash );
771 $error = $new->replace( $self, options => { $self->options } );
773 $dbh->rollback if $oldAutoCommit;
777 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
783 =item suspend [ OPTION => VALUE ... ]
785 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
786 package, then suspends the package itself (sets the susp field to now).
788 Available options are:
792 =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.
794 =item date - can be set to a unix style timestamp to specify when to suspend (adjourn)
798 If there is an error, returns the error, otherwise returns false.
803 my( $self, %options ) = @_;
806 local $SIG{HUP} = 'IGNORE';
807 local $SIG{INT} = 'IGNORE';
808 local $SIG{QUIT} = 'IGNORE';
809 local $SIG{TERM} = 'IGNORE';
810 local $SIG{TSTP} = 'IGNORE';
811 local $SIG{PIPE} = 'IGNORE';
813 my $oldAutoCommit = $FS::UID::AutoCommit;
814 local $FS::UID::AutoCommit = 0;
817 my $old = $self->select_for_update;
819 my $pkgnum = $old->pkgnum;
820 if ( $old->get('cancel') || $self->get('cancel') ) {
821 dbh->rollback if $oldAutoCommit;
822 return "Can't suspend cancelled package $pkgnum";
825 if ( $old->get('susp') || $self->get('susp') ) {
826 dbh->rollback if $oldAutoCommit;
827 return ""; # no error # complain on adjourn?
830 my $date = $options{date} if $options{date}; # adjourn/suspend later
831 $date = '' if ($date && $date <= time); # complain instead?
833 if ( $date && $old->get('expire') && $old->get('expire') < $date ) {
834 dbh->rollback if $oldAutoCommit;
835 return "Package $pkgnum expires before it would be suspended.";
838 my $suspend_time = $options{'time'} || time;
840 if ( $options{'reason'} ) {
841 $error = $self->insert_reason( 'reason' => $options{'reason'},
842 'action' => $date ? 'adjourn' : 'suspend',
843 'date' => $date ? $date : $suspend_time,
844 'reason_otaker' => $options{'reason_otaker'},
847 dbh->rollback if $oldAutoCommit;
848 return "Error inserting cust_pkg_reason: $error";
856 foreach my $cust_svc (
857 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
859 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
861 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
862 $dbh->rollback if $oldAutoCommit;
863 return "Illegal svcdb value in part_svc!";
866 require "FS/$svcdb.pm";
868 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
870 $error = $svc->suspend;
872 $dbh->rollback if $oldAutoCommit;
875 my( $label, $value ) = $cust_svc->label;
876 push @labels, "$label: $value";
880 my $conf = new FS::Conf;
881 if ( $conf->config('suspend_email_admin') ) {
883 my $error = send_email(
884 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
885 #invoice_from ??? well as good as any
886 'to' => $conf->config('suspend_email_admin'),
887 'subject' => 'FREESIDE NOTIFICATION: Customer package suspended',
889 "This is an automatic message from your Freeside installation\n",
890 "informing you that the following customer package has been suspended:\n",
892 'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
893 'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
894 ( map { "Service : $_\n" } @labels ),
899 warn "WARNING: can't send suspension admin email (suspending anyway): ".
907 my %hash = $self->hash;
909 $hash{'adjourn'} = $date;
911 $hash{'susp'} = $suspend_time;
913 my $new = new FS::cust_pkg ( \%hash );
914 $error = $new->replace( $self, options => { $self->options } );
916 $dbh->rollback if $oldAutoCommit;
920 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
925 =item unsuspend [ OPTION => VALUE ... ]
927 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
928 package, then unsuspends the package itself (clears the susp field and the
929 adjourn field if it is in the past).
931 Available options are:
935 =item adjust_next_bill
937 Can be set true to adjust the next bill date forward by
938 the amount of time the account was inactive. This was set true by default
939 since 1.4.2 and 1.5.0pre6; however, starting with 1.7.0 this needs to be
940 explicitly requested. Price plans for which this makes sense (anniversary-date
941 based than prorate or subscription) could have an option to enable this
946 If there is an error, returns the error, otherwise returns false.
951 my( $self, %opt ) = @_;
954 local $SIG{HUP} = 'IGNORE';
955 local $SIG{INT} = 'IGNORE';
956 local $SIG{QUIT} = 'IGNORE';
957 local $SIG{TERM} = 'IGNORE';
958 local $SIG{TSTP} = 'IGNORE';
959 local $SIG{PIPE} = 'IGNORE';
961 my $oldAutoCommit = $FS::UID::AutoCommit;
962 local $FS::UID::AutoCommit = 0;
965 my $old = $self->select_for_update;
967 my $pkgnum = $old->pkgnum;
968 if ( $old->get('cancel') || $self->get('cancel') ) {
969 dbh->rollback if $oldAutoCommit;
970 return "Can't unsuspend cancelled package $pkgnum";
973 unless ( $old->get('susp') && $self->get('susp') ) {
974 dbh->rollback if $oldAutoCommit;
975 return ""; # no error # complain instead?
978 foreach my $cust_svc (
979 qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
981 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
983 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
984 $dbh->rollback if $oldAutoCommit;
985 return "Illegal svcdb value in part_svc!";
988 require "FS/$svcdb.pm";
990 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
992 $error = $svc->unsuspend;
994 $dbh->rollback if $oldAutoCommit;
1001 my %hash = $self->hash;
1002 my $inactive = time - $hash{'susp'};
1004 my $conf = new FS::Conf;
1006 $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive
1007 if ( $opt{'adjust_next_bill'}
1008 || $conf->exists('unsuspend-always_adjust_next_bill_date') )
1009 && $inactive > 0 && ( $hash{'bill'} || $hash{'setup'} );
1012 $hash{'adjourn'} = '' if $hash{'adjourn'} < time;
1013 my $new = new FS::cust_pkg ( \%hash );
1014 $error = $new->replace( $self, options => { $self->options } );
1016 $dbh->rollback if $oldAutoCommit;
1020 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1027 Cancels any pending suspension (sets the adjourn field to null).
1029 If there is an error, returns the error, otherwise returns false.
1034 my( $self, %options ) = @_;
1037 local $SIG{HUP} = 'IGNORE';
1038 local $SIG{INT} = 'IGNORE';
1039 local $SIG{QUIT} = 'IGNORE';
1040 local $SIG{TERM} = 'IGNORE';
1041 local $SIG{TSTP} = 'IGNORE';
1042 local $SIG{PIPE} = 'IGNORE';
1044 my $oldAutoCommit = $FS::UID::AutoCommit;
1045 local $FS::UID::AutoCommit = 0;
1048 my $old = $self->select_for_update;
1050 my $pkgnum = $old->pkgnum;
1051 if ( $old->get('cancel') || $self->get('cancel') ) {
1052 dbh->rollback if $oldAutoCommit;
1053 return "Can't unadjourn cancelled package $pkgnum";
1054 # or at least it's pointless
1057 if ( $old->get('susp') || $self->get('susp') ) {
1058 dbh->rollback if $oldAutoCommit;
1059 return "Can't unadjourn suspended package $pkgnum";
1060 # perhaps this is arbitrary
1063 unless ( $old->get('adjourn') && $self->get('adjourn') ) {
1064 dbh->rollback if $oldAutoCommit;
1065 return ""; # no error
1068 my %hash = $self->hash;
1069 $hash{'adjourn'} = '';
1070 my $new = new FS::cust_pkg ( \%hash );
1071 $error = $new->replace( $self, options => { $self->options } );
1073 $dbh->rollback if $oldAutoCommit;
1077 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1084 =item change HASHREF | OPTION => VALUE ...
1086 Changes this package: cancels it and creates a new one, with a different
1087 pkgpart or locationnum or both. All services are transferred to the new
1088 package (no change will be made if this is not possible).
1090 Options may be passed as a list of key/value pairs or as a hash reference.
1097 New locationnum, to change the location for this package.
1101 New FS::cust_location object, to create a new location and assign it
1106 New pkgpart (see L<FS::part_pkg>).
1110 New refnum (see L<FS::part_referral>).
1114 At least one option must be specified (otherwise, what's the point?)
1116 Returns either the new FS::cust_pkg object or a scalar error.
1120 my $err_or_new_cust_pkg = $old_cust_pkg->change
1124 #some false laziness w/order
1127 my $opt = ref($_[0]) ? shift : { @_ };
1129 # my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
1132 my $conf = new FS::Conf;
1134 # Transactionize this whole mess
1135 local $SIG{HUP} = 'IGNORE';
1136 local $SIG{INT} = 'IGNORE';
1137 local $SIG{QUIT} = 'IGNORE';
1138 local $SIG{TERM} = 'IGNORE';
1139 local $SIG{TSTP} = 'IGNORE';
1140 local $SIG{PIPE} = 'IGNORE';
1142 my $oldAutoCommit = $FS::UID::AutoCommit;
1143 local $FS::UID::AutoCommit = 0;
1152 #$hash{$_} = $self->$_() foreach qw( last_bill bill );
1154 #$hash{$_} = $self->$_() foreach qw( setup );
1156 $hash{'setup'} = $time if $self->setup;
1158 $hash{'change_date'} = $time;
1159 $hash{"change_$_"} = $self->$_()
1160 foreach qw( pkgnum pkgpart locationnum );
1162 if ( $opt->{'cust_location'} &&
1163 ( ! $opt->{'locationnum'} || $opt->{'locationnum'} == -1 ) ) {
1164 $error = $opt->{'cust_location'}->insert;
1166 $dbh->rollback if $oldAutoCommit;
1167 return "inserting cust_location (transaction rolled back): $error";
1169 $opt->{'locationnum'} = $opt->{'cust_location'}->locationnum;
1172 # Create the new package.
1173 my $cust_pkg = new FS::cust_pkg {
1174 custnum => $self->custnum,
1175 pkgpart => ( $opt->{'pkgpart'} || $self->pkgpart ),
1176 refnum => ( $opt->{'refnum'} || $self->refnum ),
1177 locationnum => ( $opt->{'locationnum'} || $self->locationnum ),
1181 $error = $cust_pkg->insert( 'change' => 1 );
1183 $dbh->rollback if $oldAutoCommit;
1187 # Transfer services and cancel old package.
1189 $error = $self->transfer($cust_pkg);
1190 if ($error and $error == 0) {
1191 # $old_pkg->transfer failed.
1192 $dbh->rollback if $oldAutoCommit;
1196 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1197 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1198 $error = $self->transfer($cust_pkg, 'change_svcpart'=>1 );
1199 if ($error and $error == 0) {
1200 # $old_pkg->transfer failed.
1201 $dbh->rollback if $oldAutoCommit;
1207 # Transfers were successful, but we still had services left on the old
1208 # package. We can't change the package under this circumstances, so abort.
1209 $dbh->rollback if $oldAutoCommit;
1210 return "Unable to transfer all services from package ". $self->pkgnum;
1213 #reset usage if changing pkgpart
1214 # AND usage rollover is off (otherwise adds twice, now and at package bill)
1215 if ($self->pkgpart != $cust_pkg->pkgpart) {
1216 my $part_pkg = $cust_pkg->part_pkg;
1217 $error = $part_pkg->reset_usage($cust_pkg, $part_pkg->is_prepaid
1221 if $part_pkg->can('reset_usage') && ! $part_pkg->option('usage_rollover');
1224 $dbh->rollback if $oldAutoCommit;
1225 return "Error setting usage values: $error";
1229 #Good to go, cancel old package.
1230 $error = $self->cancel( quiet=>1 );
1232 $dbh->rollback if $oldAutoCommit;
1236 if ( $conf->exists('cust_pkg-change_pkgpart-bill_now') ) {
1238 my $error = $cust_pkg->cust_main->bill( 'pkg_list' => [ $cust_pkg ] );
1240 $dbh->rollback if $oldAutoCommit;
1245 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1253 Returns the last bill date, or if there is no last bill date, the setup date.
1254 Useful for billing metered services.
1260 return $self->setfield('last_bill', $_[0]) if @_;
1261 return $self->getfield('last_bill') if $self->getfield('last_bill');
1262 my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
1263 'edate' => $self->bill, } );
1264 $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
1267 =item last_cust_pkg_reason ACTION
1269 Returns the most recent ACTION FS::cust_pkg_reason associated with the package.
1270 Returns false if there is no reason or the package is not currenly ACTION'd
1271 ACTION is one of adjourn, susp, cancel, or expire.
1275 sub last_cust_pkg_reason {
1276 my ( $self, $action ) = ( shift, shift );
1277 my $date = $self->get($action);
1279 'table' => 'cust_pkg_reason',
1280 'hashref' => { 'pkgnum' => $self->pkgnum,
1281 'action' => substr(uc($action), 0, 1),
1284 'order_by' => 'ORDER BY num DESC LIMIT 1',
1288 =item last_reason ACTION
1290 Returns the most recent ACTION FS::reason associated with the package.
1291 Returns false if there is no reason or the package is not currenly ACTION'd
1292 ACTION is one of adjourn, susp, cancel, or expire.
1297 my $cust_pkg_reason = shift->last_cust_pkg_reason(@_);
1298 $cust_pkg_reason->reason
1299 if $cust_pkg_reason;
1304 Returns the definition for this billing item, as an FS::part_pkg object (see
1311 return $self->{'_pkgpart'} if $self->{'_pkgpart'};
1312 cluck "cust_pkg->part_pkg called" if $DEBUG > 1;
1313 qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
1318 Returns the cancelled package this package was changed from, if any.
1324 return '' unless $self->change_pkgnum;
1325 qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
1330 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
1337 $self->part_pkg->calc_setup($self, @_);
1342 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
1349 $self->part_pkg->calc_recur($self, @_);
1354 Calls the I<calc_remain> of the FS::part_pkg object associated with this
1361 $self->part_pkg->calc_remain($self, @_);
1366 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
1373 $self->part_pkg->calc_cancel($self, @_);
1378 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
1384 qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
1387 =item cust_pkg_detail [ DETAILTYPE ]
1389 Returns any customer package details for this package (see
1390 L<FS::cust_pkg_detail>).
1392 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
1396 sub cust_pkg_detail {
1398 my %hash = ( 'pkgnum' => $self->pkgnum );
1399 $hash{detailtype} = shift if @_;
1401 'table' => 'cust_pkg_detail',
1402 'hashref' => \%hash,
1403 'order_by' => 'ORDER BY weight, pkgdetailnum',
1407 =item set_cust_pkg_detail DETAILTYPE [ DETAIL, DETAIL, ... ]
1409 Sets customer package details for this package (see L<FS::cust_pkg_detail>).
1411 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
1413 If there is an error, returns the error, otherwise returns false.
1417 sub set_cust_pkg_detail {
1418 my( $self, $detailtype, @details ) = @_;
1420 local $SIG{HUP} = 'IGNORE';
1421 local $SIG{INT} = 'IGNORE';
1422 local $SIG{QUIT} = 'IGNORE';
1423 local $SIG{TERM} = 'IGNORE';
1424 local $SIG{TSTP} = 'IGNORE';
1425 local $SIG{PIPE} = 'IGNORE';
1427 my $oldAutoCommit = $FS::UID::AutoCommit;
1428 local $FS::UID::AutoCommit = 0;
1431 foreach my $current ( $self->cust_pkg_detail($detailtype) ) {
1432 my $error = $current->delete;
1434 $dbh->rollback if $oldAutoCommit;
1435 return "error removing old detail: $error";
1439 foreach my $detail ( @details ) {
1440 my $cust_pkg_detail = new FS::cust_pkg_detail {
1441 'pkgnum' => $self->pkgnum,
1442 'detailtype' => $detailtype,
1443 'detail' => $detail,
1445 my $error = $cust_pkg_detail->insert;
1447 $dbh->rollback if $oldAutoCommit;
1448 return "error adding new detail: $error";
1453 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1460 Returns the new-style customer billing events (see L<FS::cust_event>) for this invoice.
1464 #false laziness w/cust_bill.pm
1468 'table' => 'cust_event',
1469 'addl_from' => 'JOIN part_event USING ( eventpart )',
1470 'hashref' => { 'tablenum' => $self->pkgnum },
1471 'extra_sql' => " AND eventtable = 'cust_pkg' ",
1475 =item num_cust_event
1477 Returns the number of new-style customer billing events (see L<FS::cust_event>) for this invoice.
1481 #false laziness w/cust_bill.pm
1482 sub num_cust_event {
1485 "SELECT COUNT(*) FROM cust_event JOIN part_event USING ( eventpart ) ".
1486 " WHERE tablenum = ? AND eventtable = 'cust_pkg'";
1487 my $sth = dbh->prepare($sql) or die dbh->errstr. " preparing $sql";
1488 $sth->execute($self->pkgnum) or die $sth->errstr. " executing $sql";
1489 $sth->fetchrow_arrayref->[0];
1492 =item cust_svc [ SVCPART ]
1494 Returns the services for this package, as FS::cust_svc objects (see
1495 L<FS::cust_svc>). If a svcpart is specified, return only the matching
1503 return () unless $self->num_cust_svc(@_);
1506 return qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum,
1507 'svcpart' => shift, } );
1510 cluck "cust_pkg->cust_svc called" if $DEBUG > 2;
1512 #if ( $self->{'_svcnum'} ) {
1513 # values %{ $self->{'_svcnum'}->cache };
1515 $self->_sort_cust_svc(
1516 [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
1522 =item overlimit [ SVCPART ]
1524 Returns the services for this package which have exceeded their
1525 usage limit as FS::cust_svc objects (see L<FS::cust_svc>). If a svcpart
1526 is specified, return only the matching services.
1532 return () unless $self->num_cust_svc(@_);
1533 grep { $_->overlimit } $self->cust_svc(@_);
1536 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ]
1538 Returns historical services for this package created before END TIMESTAMP and
1539 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
1540 (see L<FS::h_cust_svc>).
1547 $self->_sort_cust_svc(
1548 [ qsearch( 'h_cust_svc',
1549 { 'pkgnum' => $self->pkgnum, },
1550 FS::h_cust_svc->sql_h_search(@_),
1556 sub _sort_cust_svc {
1557 my( $self, $arrayref ) = @_;
1560 sub ($$) { my ($a, $b) = @_; $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] };
1565 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
1566 'svcpart' => $_->svcpart } );
1568 $pkg_svc ? $pkg_svc->primary_svc : '',
1569 $pkg_svc ? $pkg_svc->quantity : 0,
1576 =item num_cust_svc [ SVCPART ]
1578 Returns the number of provisioned services for this package. If a svcpart is
1579 specified, counts only the matching services.
1586 return $self->{'_num_cust_svc'}
1588 && exists($self->{'_num_cust_svc'})
1589 && $self->{'_num_cust_svc'} =~ /\d/;
1591 cluck "cust_pkg->num_cust_svc called, _num_cust_svc:".$self->{'_num_cust_svc'}
1594 my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
1595 $sql .= ' AND svcpart = ?' if @_;
1597 my $sth = dbh->prepare($sql) or die dbh->errstr;
1598 $sth->execute($self->pkgnum, @_) or die $sth->errstr;
1599 $sth->fetchrow_arrayref->[0];
1602 =item available_part_svc
1604 Returns a list of FS::part_svc objects representing services included in this
1605 package but not yet provisioned. Each FS::part_svc object also has an extra
1606 field, I<num_avail>, which specifies the number of available services.
1610 sub available_part_svc {
1612 grep { $_->num_avail > 0 }
1614 my $part_svc = $_->part_svc;
1615 $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
1616 $_->quantity - $self->num_cust_svc($_->svcpart);
1619 $self->part_pkg->pkg_svc;
1624 Returns a list of FS::part_svc objects representing provisioned and available
1625 services included in this package. Each FS::part_svc object also has the
1626 following extra fields:
1630 =item num_cust_svc (count)
1632 =item num_avail (quantity - count)
1634 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
1637 label -> ($cust_svc->label)[1]
1646 #XXX some sort of sort order besides numeric by svcpart...
1647 my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
1649 my $part_svc = $pkg_svc->part_svc;
1650 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1651 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
1652 $part_svc->{'Hash'}{'num_avail'} =
1653 max( 0, $pkg_svc->quantity - $num_cust_svc );
1654 $part_svc->{'Hash'}{'cust_pkg_svc'} =
1655 $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
1657 } $self->part_pkg->pkg_svc;
1660 push @part_svc, map {
1662 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1663 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
1664 $part_svc->{'Hash'}{'num_avail'} = 0; #0-$num_cust_svc ?
1665 $part_svc->{'Hash'}{'cust_pkg_svc'} =
1666 $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
1668 } $self->extra_part_svc;
1674 =item extra_part_svc
1676 Returns a list of FS::part_svc objects corresponding to services in this
1677 package which are still provisioned but not (any longer) available in the
1682 sub extra_part_svc {
1685 my $pkgnum = $self->pkgnum;
1686 my $pkgpart = $self->pkgpart;
1689 # 'table' => 'part_svc',
1692 # "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
1693 # WHERE pkg_svc.svcpart = part_svc.svcpart
1694 # AND pkg_svc.pkgpart = ?
1697 # AND 0 < ( SELECT COUNT(*) FROM cust_svc
1698 # LEFT JOIN cust_pkg USING ( pkgnum )
1699 # WHERE cust_svc.svcpart = part_svc.svcpart
1702 # 'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
1705 #seems to benchmark slightly faster...
1707 'select' => 'DISTINCT ON (svcpart) part_svc.*',
1708 'table' => 'part_svc',
1710 'LEFT JOIN pkg_svc ON ( pkg_svc.svcpart = part_svc.svcpart
1711 AND pkg_svc.pkgpart = ?
1714 LEFT JOIN cust_svc ON ( cust_svc.svcpart = part_svc.svcpart )
1715 LEFT JOIN cust_pkg USING ( pkgnum )
1718 'extra_sql' => "WHERE pkgsvcnum IS NULL AND cust_pkg.pkgnum = ? ",
1719 'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
1725 Returns a short status string for this package, currently:
1729 =item not yet billed
1731 =item one-time charge
1746 my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
1748 return 'cancelled' if $self->get('cancel');
1749 return 'suspended' if $self->susp;
1750 return 'not yet billed' unless $self->setup;
1751 return 'one-time charge' if $freq =~ /^(0|$)/;
1757 Class method that returns the list of possible status strings for packages
1758 (see L<the status method|/status>). For example:
1760 @statuses = FS::cust_pkg->statuses();
1764 tie my %statuscolor, 'Tie::IxHash',
1765 'not yet billed' => '000000',
1766 'one-time charge' => '000000',
1767 'active' => '00CC00',
1768 'suspended' => 'FF9900',
1769 'cancelled' => 'FF0000',
1773 my $self = shift; #could be class...
1774 #grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
1775 # # mayble split btw one-time vs. recur
1781 Returns a hex triplet color string for this package's status.
1787 $statuscolor{$self->status};
1792 Returns a label for this package. (Currently "pkgnum: pkg - comment" or
1793 "pkg-comment" depending on user preference).
1799 my $label = $self->part_pkg->pkg_comment( 'nopkgpart' => 1 );
1800 $label = $self->pkgnum. ": $label"
1801 if $FS::CurrentUser::CurrentUser->option('show_pkgnum');
1805 =item pkg_label_long
1807 Returns a long label for this package, adding the primary service's label to
1812 sub pkg_label_long {
1814 my $label = $self->pkg_label;
1815 my $cust_svc = $self->primary_cust_svc;
1816 $label .= ' ('. ($cust_svc->label)[1]. ')' if $cust_svc;
1820 =item primary_cust_svc
1822 Returns a primary service (as FS::cust_svc object) if one can be identified.
1826 #for labeling purposes - might not 100% match up with part_pkg->svcpart's idea
1828 sub primary_cust_svc {
1831 my @cust_svc = $self->cust_svc;
1833 return '' unless @cust_svc; #no serivces - irrelevant then
1835 return $cust_svc[0] if scalar(@cust_svc) == 1; #always return a single service
1837 # primary service as specified in the package definition
1838 # or exactly one service definition with quantity one
1839 my $svcpart = $self->part_pkg->svcpart;
1840 @cust_svc = grep { $_->svcpart == $svcpart } @cust_svc;
1841 return $cust_svc[0] if scalar(@cust_svc) == 1;
1843 #couldn't identify one thing..
1849 Returns a list of lists, calling the label method for all services
1850 (see L<FS::cust_svc>) of this billing item.
1856 map { [ $_->label ] } $self->cust_svc;
1859 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
1861 Like the labels method, but returns historical information on services that
1862 were active as of END_TIMESTAMP and (optionally) not cancelled before
1865 Returns a list of lists, calling the label method for all (historical) services
1866 (see L<FS::h_cust_svc>) of this billing item.
1872 map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
1877 Like labels, except returns a simple flat list, and shortens long
1878 (currently >5 or the cust_bill-max_same_services configuration value) lists of
1879 identical services to one line that lists the service label and the number of
1880 individual services rather than individual items.
1885 shift->_labels_short( 'labels', @_ );
1888 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
1890 Like h_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.
1897 sub h_labels_short {
1898 shift->_labels_short( 'h_labels', @_ );
1902 my( $self, $method ) = ( shift, shift );
1904 my $conf = new FS::Conf;
1905 my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
1908 #tie %labels, 'Tie::IxHash';
1909 push @{ $labels{$_->[0]} }, $_->[1]
1910 foreach $self->h_labels(@_);
1912 foreach my $label ( keys %labels ) {
1914 my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
1915 my $num = scalar(@values);
1916 if ( $num > $max_same_services ) {
1917 push @labels, "$label ($num)";
1919 if ( $conf->exists('cust_bill-consolidate_services') ) {
1920 # push @labels, "$label: ". join(', ', @values);
1922 my $detail = "$label: ";
1923 $detail .= shift(@values). ', '
1924 while @values && length($detail.$values[0]) < 78;
1926 push @labels, $detail;
1929 push @labels, map { "$label: $_" } @values;
1940 Returns the parent customer object (see L<FS::cust_main>).
1946 qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
1951 Returns the location object, if any (see L<FS::cust_location>).
1957 return '' unless $self->locationnum;
1958 qsearchs( 'cust_location', { 'locationnum' => $self->locationnum } );
1961 =item cust_location_or_main
1963 If this package is associated with a location, returns the locaiton (see
1964 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
1968 sub cust_location_or_main {
1970 $self->cust_location || $self->cust_main;
1973 =item location_label [ OPTION => VALUE ... ]
1975 Returns the label of the location object (see L<FS::cust_location>).
1979 sub location_label {
1981 my $object = $self->cust_location_or_main;
1982 $object->location_label(@_);
1985 =item seconds_since TIMESTAMP
1987 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
1988 package have been online since TIMESTAMP, according to the session monitor.
1990 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1991 L<Time::Local> and L<Date::Parse> for conversion functions.
1996 my($self, $since) = @_;
1999 foreach my $cust_svc (
2000 grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
2002 $seconds += $cust_svc->seconds_since($since);
2009 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2011 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
2012 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
2015 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2016 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2022 sub seconds_since_sqlradacct {
2023 my($self, $start, $end) = @_;
2027 foreach my $cust_svc (
2029 my $part_svc = $_->part_svc;
2030 $part_svc->svcdb eq 'svc_acct'
2031 && scalar($part_svc->part_export('sqlradius'));
2034 $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
2041 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2043 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2044 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2048 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2049 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2054 sub attribute_since_sqlradacct {
2055 my($self, $start, $end, $attrib) = @_;
2059 foreach my $cust_svc (
2061 my $part_svc = $_->part_svc;
2062 $part_svc->svcdb eq 'svc_acct'
2063 && scalar($part_svc->part_export('sqlradius'));
2066 $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
2078 my( $self, $value ) = @_;
2079 if ( defined($value) ) {
2080 $self->setfield('quantity', $value);
2082 $self->getfield('quantity') || 1;
2085 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
2087 Transfers as many services as possible from this package to another package.
2089 The destination package can be specified by pkgnum by passing an FS::cust_pkg
2090 object. The destination package must already exist.
2092 Services are moved only if the destination allows services with the correct
2093 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true. Use
2094 this option with caution! No provision is made for export differences
2095 between the old and new service definitions. Probably only should be used
2096 when your exports for all service definitions of a given svcdb are identical.
2097 (attempt a transfer without it first, to move all possible svcpart-matching
2100 Any services that can't be moved remain in the original package.
2102 Returns an error, if there is one; otherwise, returns the number of services
2103 that couldn't be moved.
2108 my ($self, $dest_pkgnum, %opt) = @_;
2114 if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
2115 $dest = $dest_pkgnum;
2116 $dest_pkgnum = $dest->pkgnum;
2118 $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
2121 return ('Package does not exist: '.$dest_pkgnum) unless $dest;
2123 foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
2124 $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
2127 foreach my $cust_svc ($dest->cust_svc) {
2128 $target{$cust_svc->svcpart}--;
2131 my %svcpart2svcparts = ();
2132 if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2133 warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
2134 foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
2135 next if exists $svcpart2svcparts{$svcpart};
2136 my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
2137 $svcpart2svcparts{$svcpart} = [
2139 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
2141 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
2142 'svcpart' => $_ } );
2144 $pkg_svc ? $pkg_svc->primary_svc : '',
2145 $pkg_svc ? $pkg_svc->quantity : 0,
2149 grep { $_ != $svcpart }
2151 qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
2153 warn "alternates for svcpart $svcpart: ".
2154 join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
2159 foreach my $cust_svc ($self->cust_svc) {
2160 if($target{$cust_svc->svcpart} > 0) {
2161 $target{$cust_svc->svcpart}--;
2162 my $new = new FS::cust_svc { $cust_svc->hash };
2163 $new->pkgnum($dest_pkgnum);
2164 my $error = $new->replace($cust_svc);
2165 return $error if $error;
2166 } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2168 warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
2169 warn "alternates to consider: ".
2170 join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
2172 my @alternate = grep {
2173 warn "considering alternate svcpart $_: ".
2174 "$target{$_} available in new package\n"
2177 } @{$svcpart2svcparts{$cust_svc->svcpart}};
2179 warn "alternate(s) found\n" if $DEBUG;
2180 my $change_svcpart = $alternate[0];
2181 $target{$change_svcpart}--;
2182 my $new = new FS::cust_svc { $cust_svc->hash };
2183 $new->svcpart($change_svcpart);
2184 $new->pkgnum($dest_pkgnum);
2185 my $error = $new->replace($cust_svc);
2186 return $error if $error;
2199 This method is deprecated. See the I<depend_jobnum> option to the insert and
2200 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
2207 local $SIG{HUP} = 'IGNORE';
2208 local $SIG{INT} = 'IGNORE';
2209 local $SIG{QUIT} = 'IGNORE';
2210 local $SIG{TERM} = 'IGNORE';
2211 local $SIG{TSTP} = 'IGNORE';
2212 local $SIG{PIPE} = 'IGNORE';
2214 my $oldAutoCommit = $FS::UID::AutoCommit;
2215 local $FS::UID::AutoCommit = 0;
2218 foreach my $cust_svc ( $self->cust_svc ) {
2219 #false laziness w/svc_Common::insert
2220 my $svc_x = $cust_svc->svc_x;
2221 foreach my $part_export ( $cust_svc->part_svc->part_export ) {
2222 my $error = $part_export->export_insert($svc_x);
2224 $dbh->rollback if $oldAutoCommit;
2230 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2237 =head1 CLASS METHODS
2243 Returns an SQL expression identifying recurring packages.
2247 sub recurring_sql { "
2248 '0' != ( select freq from part_pkg
2249 where cust_pkg.pkgpart = part_pkg.pkgpart )
2254 Returns an SQL expression identifying one-time packages.
2259 '0' = ( select freq from part_pkg
2260 where cust_pkg.pkgpart = part_pkg.pkgpart )
2265 Returns an SQL expression identifying active packages.
2270 ". $_[0]->recurring_sql(). "
2271 AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
2272 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2273 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
2276 =item not_yet_billed_sql
2278 Returns an SQL expression identifying packages which have not yet been billed.
2282 sub not_yet_billed_sql { "
2283 ( cust_pkg.setup IS NULL OR cust_pkg.setup = 0 )
2284 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2285 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
2290 Returns an SQL expression identifying inactive packages (one-time packages
2291 that are otherwise unsuspended/uncancelled).
2295 sub inactive_sql { "
2296 ". $_[0]->onetime_sql(). "
2297 AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
2298 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2299 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
2305 Returns an SQL expression identifying suspended packages.
2309 sub suspended_sql { susp_sql(@_); }
2311 #$_[0]->recurring_sql(). ' AND '.
2313 ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2314 AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0
2321 Returns an SQL exprression identifying cancelled packages.
2325 sub cancelled_sql { cancel_sql(@_); }
2327 #$_[0]->recurring_sql(). ' AND '.
2328 "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
2331 =item search HASHREF
2335 Returns a qsearch hash expression to search for parameters specified in HASHREF.
2336 Valid parameters are
2344 active, inactive, suspended, cancel (or cancelled)
2348 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
2352 boolean selects custom packages
2358 pkgpart or arrayref or hashref of pkgparts
2362 arrayref of beginning and ending epoch date
2366 arrayref of beginning and ending epoch date
2370 arrayref of beginning and ending epoch date
2374 arrayref of beginning and ending epoch date
2378 arrayref of beginning and ending epoch date
2382 arrayref of beginning and ending epoch date
2386 arrayref of beginning and ending epoch date
2390 pkgnum or APKG_pkgnum
2394 a value suited to passing to FS::UI::Web::cust_header
2398 specifies the user for agent virtualization
2405 my ($class, $params) = @_;
2412 if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2414 "cust_main.agentnum = $1";
2421 if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
2423 "cust_pkg.custnum = $1";
2430 if ( $params->{'magic'} eq 'active'
2431 || $params->{'status'} eq 'active' ) {
2433 push @where, FS::cust_pkg->active_sql();
2435 } elsif ( $params->{'magic'} =~ /^not[ _]yet[ _]billed$/
2436 || $params->{'status'} =~ /^not[ _]yet[ _]billed$/ ) {
2438 push @where, FS::cust_pkg->not_yet_billed_sql();
2440 } elsif ( $params->{'magic'} =~ /^(one-time charge|inactive)/
2441 || $params->{'status'} =~ /^(one-time charge|inactive)/ ) {
2443 push @where, FS::cust_pkg->inactive_sql();
2445 } elsif ( $params->{'magic'} eq 'suspended'
2446 || $params->{'status'} eq 'suspended' ) {
2448 push @where, FS::cust_pkg->suspended_sql();
2450 } elsif ( $params->{'magic'} =~ /^cancell?ed$/
2451 || $params->{'status'} =~ /^cancell?ed$/ ) {
2453 push @where, FS::cust_pkg->cancelled_sql();
2458 # parse package class
2461 #false lazinessish w/graph/cust_bill_pkg.cgi
2464 if ( exists($params->{'classnum'})
2465 && $params->{'classnum'} =~ /^(\d*)$/
2469 if ( $classnum ) { #a specific class
2470 push @where, "part_pkg.classnum = $classnum";
2472 #@pkg_class = ( qsearchs('pkg_class', { 'classnum' => $classnum } ) );
2473 #die "classnum $classnum not found!" unless $pkg_class[0];
2474 #$title .= $pkg_class[0]->classname.' ';
2476 } elsif ( $classnum eq '' ) { #the empty class
2478 push @where, "part_pkg.classnum IS NULL";
2479 #$title .= 'Empty class ';
2480 #@pkg_class = ( '(empty class)' );
2481 } elsif ( $classnum eq '0' ) {
2482 #@pkg_class = qsearch('pkg_class', {} ); # { 'disabled' => '' } );
2483 #push @pkg_class, '(empty class)';
2485 die "illegal classnum";
2491 # parse package report options
2494 my @report_option = ();
2495 if ( exists($params->{'report_option'})
2496 && $params->{'report_option'} =~ /^([,\d]*)$/
2499 @report_option = split(',', $1);
2502 if (@report_option) {
2503 # this will result in the empty set for the dangling comma case as it should
2505 map{ "0 < ( SELECT count(*) FROM part_pkg_option
2506 WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
2507 AND optionname = 'report_option_$_'
2508 AND optionvalue = '1' )"
2518 push @where, "part_pkg.custom = 'Y'" if $params->{custom};
2524 if ( exists($params->{'censustract'}) ) {
2525 $params->{'censustract'} =~ /^([.\d]*)$/;
2526 my $censustract = "cust_main.censustract = '$1'";
2527 $censustract .= ' OR cust_main.censustract is NULL' unless $1;
2528 push @where, "( $censustract )";
2535 if ( ref($params->{'pkgpart'}) ) {
2538 if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
2539 @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
2540 } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
2541 @pkgpart = @{ $params->{'pkgpart'} };
2543 die 'unhandled pkgpart ref '. $params->{'pkgpart'};
2546 @pkgpart = grep /^(\d+)$/, @pkgpart;
2548 push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
2550 } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
2551 push @where, "pkgpart = $1";
2560 #false laziness w/report_cust_pkg.html
2563 'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
2564 'active' => { 'susp'=>1, 'cancel'=>1 },
2565 'suspended' => { 'cancel' => 1 },
2570 foreach my $field (qw( setup last_bill bill adjourn susp expire cancel )) {
2572 next unless exists($params->{$field});
2574 my($beginning, $ending) = @{$params->{$field}};
2576 next if $beginning == 0 && $ending == 4294967295;
2579 "cust_pkg.$field IS NOT NULL",
2580 "cust_pkg.$field >= $beginning",
2581 "cust_pkg.$field <= $ending";
2583 $orderby ||= "ORDER BY cust_pkg.$field";
2587 $orderby ||= 'ORDER BY bill';
2590 # parse magic, legacy, etc.
2593 if ( $params->{'magic'} &&
2594 $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
2597 $orderby = 'ORDER BY pkgnum';
2599 if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
2600 push @where, "pkgpart = $1";
2603 } elsif ( $params->{'query'} eq 'pkgnum' ) {
2605 $orderby = 'ORDER BY pkgnum';
2607 } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
2609 $orderby = 'ORDER BY pkgnum';
2612 SELECT count(*) FROM pkg_svc
2613 WHERE pkg_svc.pkgpart = cust_pkg.pkgpart
2614 AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
2615 WHERE cust_svc.pkgnum = cust_pkg.pkgnum
2616 AND cust_svc.svcpart = pkg_svc.svcpart
2623 # setup queries, links, subs, etc. for the search
2626 # here is the agent virtualization
2627 if ($params->{CurrentUser}) {
2629 qsearchs('access_user', { username => $params->{CurrentUser} });
2632 push @where, $access_user->agentnums_sql('table'=>'cust_main');
2637 push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
2640 my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
2642 my $addl_from = 'LEFT JOIN part_pkg USING ( pkgpart ) '.
2643 'LEFT JOIN pkg_class USING ( classnum ) '.
2644 'LEFT JOIN cust_main USING ( custnum ) ';
2646 my $count_query = "SELECT COUNT(*) FROM cust_pkg $addl_from $extra_sql";
2649 'table' => 'cust_pkg',
2651 'select' => join(', ',
2653 ( map "part_pkg.$_", qw( pkg freq ) ),
2654 'pkg_class.classname',
2655 'cust_main.custnum as cust_main_custnum',
2656 FS::UI::Web::cust_sql_fields(
2657 $params->{'cust_fields'}
2660 'extra_sql' => "$extra_sql $orderby",
2661 'addl_from' => $addl_from,
2662 'count_query' => $count_query,
2669 Returns a list: the first item is an SQL fragment identifying matching
2670 packages/customers via location (taking into account shipping and package
2671 address taxation, if enabled), and subsequent items are the parameters to
2672 substitute for the placeholders in that fragment.
2677 my($class, %opt) = @_;
2678 my $ornull = $opt{'ornull'};
2680 my $conf = new FS::Conf;
2682 # '?' placeholders in _location_sql_where
2685 @bill_param = qw( county county state state state country );
2687 @bill_param = qw( county state state country );
2689 unshift @bill_param, 'county'; # unless $nec;
2693 if ( $conf->exists('tax-ship_address') ) {
2696 ( ( ship_last IS NULL OR ship_last = '' )
2697 AND ". _location_sql_where('cust_main', '', $ornull ). "
2699 OR ( ship_last IS NOT NULL AND ship_last != ''
2700 AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
2703 # AND payby != 'COMP'
2705 @main_param = ( @bill_param, @bill_param );
2709 $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
2710 @main_param = @bill_param;
2716 if ( $conf->exists('tax-pkg_address') ) {
2718 my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
2721 ( cust_pkg.locationnum IS NULL AND $main_where )
2722 OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where )
2725 @param = ( @main_param, @bill_param );
2729 $where = $main_where;
2730 @param = @main_param;
2738 #subroutine, helper for location_sql
2739 sub _location_sql_where {
2741 my $prefix = @_ ? shift : '';
2742 my $ornull = @_ ? shift : '';
2744 # $ornull = $ornull ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
2746 $ornull = $ornull ? ' OR ? IS NULL ' : '';
2748 my $or_empty_county = " OR ( ? = '' AND $table.${prefix}county IS NULL ) ";
2749 my $or_empty_state = " OR ( ? = '' AND $table.${prefix}state IS NULL ) ";
2752 ( $table.${prefix}county = ? $or_empty_county $ornull )
2753 AND ( $table.${prefix}state = ? $or_empty_state $ornull )
2754 AND $table.${prefix}country = ?
2762 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
2764 CUSTNUM is a customer (see L<FS::cust_main>)
2766 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
2767 L<FS::part_pkg>) to order for this customer. Duplicates are of course
2770 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
2771 remove for this customer. The services (see L<FS::cust_svc>) are moved to the
2772 new billing items. An error is returned if this is not possible (see
2773 L<FS::pkg_svc>). An empty arrayref is equivalent to not specifying this
2776 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
2777 newly-created cust_pkg objects.
2779 REFNUM, if specified, will specify the FS::pkg_referral record to be created
2780 and inserted. Multiple FS::pkg_referral records can be created by
2781 setting I<refnum> to an array reference of refnums or a hash reference with
2782 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
2783 record will be created corresponding to cust_main.refnum.
2788 my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
2790 my $conf = new FS::Conf;
2792 # Transactionize this whole mess
2793 local $SIG{HUP} = 'IGNORE';
2794 local $SIG{INT} = 'IGNORE';
2795 local $SIG{QUIT} = 'IGNORE';
2796 local $SIG{TERM} = 'IGNORE';
2797 local $SIG{TSTP} = 'IGNORE';
2798 local $SIG{PIPE} = 'IGNORE';
2800 my $oldAutoCommit = $FS::UID::AutoCommit;
2801 local $FS::UID::AutoCommit = 0;
2805 # my $cust_main = qsearchs('cust_main', { custnum => $custnum });
2806 # return "Customer not found: $custnum" unless $cust_main;
2808 warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
2811 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
2814 my $change = scalar(@old_cust_pkg) != 0;
2817 if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
2819 warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
2820 " to pkgpart ". $pkgparts->[0]. "\n"
2823 my $err_or_cust_pkg =
2824 $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
2825 'refnum' => $refnum,
2828 unless (ref($err_or_cust_pkg)) {
2829 $dbh->rollback if $oldAutoCommit;
2830 return $err_or_cust_pkg;
2833 push @$return_cust_pkg, $err_or_cust_pkg;
2834 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2839 # Create the new packages.
2840 foreach my $pkgpart (@$pkgparts) {
2842 warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
2844 my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
2845 pkgpart => $pkgpart,
2849 $error = $cust_pkg->insert( 'change' => $change );
2851 $dbh->rollback if $oldAutoCommit;
2854 push @$return_cust_pkg, $cust_pkg;
2856 # $return_cust_pkg now contains refs to all of the newly
2859 # Transfer services and cancel old packages.
2860 foreach my $old_pkg (@old_cust_pkg) {
2862 warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
2865 foreach my $new_pkg (@$return_cust_pkg) {
2866 $error = $old_pkg->transfer($new_pkg);
2867 if ($error and $error == 0) {
2868 # $old_pkg->transfer failed.
2869 $dbh->rollback if $oldAutoCommit;
2874 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
2875 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
2876 foreach my $new_pkg (@$return_cust_pkg) {
2877 $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
2878 if ($error and $error == 0) {
2879 # $old_pkg->transfer failed.
2880 $dbh->rollback if $oldAutoCommit;
2887 # Transfers were successful, but we went through all of the
2888 # new packages and still had services left on the old package.
2889 # We can't cancel the package under the circumstances, so abort.
2890 $dbh->rollback if $oldAutoCommit;
2891 return "Unable to transfer all services from package ".$old_pkg->pkgnum;
2893 $error = $old_pkg->cancel( quiet=>1 );
2899 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2903 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
2905 A bulk change method to change packages for multiple customers.
2907 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
2908 L<FS::part_pkg>) to order for each customer. Duplicates are of course
2911 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
2912 replace. The services (see L<FS::cust_svc>) are moved to the
2913 new billing items. An error is returned if this is not possible (see
2916 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
2917 newly-created cust_pkg objects.
2922 my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
2924 # Transactionize this whole mess
2925 local $SIG{HUP} = 'IGNORE';
2926 local $SIG{INT} = 'IGNORE';
2927 local $SIG{QUIT} = 'IGNORE';
2928 local $SIG{TERM} = 'IGNORE';
2929 local $SIG{TSTP} = 'IGNORE';
2930 local $SIG{PIPE} = 'IGNORE';
2932 my $oldAutoCommit = $FS::UID::AutoCommit;
2933 local $FS::UID::AutoCommit = 0;
2937 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
2940 while(scalar(@old_cust_pkg)) {
2942 my $custnum = $old_cust_pkg[0]->custnum;
2943 my (@remove) = map { $_->pkgnum }
2944 grep { $_->custnum == $custnum } @old_cust_pkg;
2945 @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
2947 my $error = order $custnum, $pkgparts, \@remove, \@return;
2949 push @errors, $error
2951 push @$return_cust_pkg, @return;
2954 if (scalar(@errors)) {
2955 $dbh->rollback if $oldAutoCommit;
2956 return join(' / ', @errors);
2959 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2965 Associates this package with a (suspension or cancellation) reason (see
2966 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
2969 Available options are:
2975 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.
2979 the access_user (see L<FS::access_user>) providing the reason
2987 the action (cancel, susp, adjourn, expire) associated with the reason
2991 If there is an error, returns the error, otherwise returns false.
2996 my ($self, %options) = @_;
2998 my $otaker = $options{reason_otaker} ||
2999 $FS::CurrentUser::CurrentUser->username;
3002 if ( $options{'reason'} =~ /^(\d+)$/ ) {
3006 } elsif ( ref($options{'reason'}) ) {
3008 return 'Enter a new reason (or select an existing one)'
3009 unless $options{'reason'}->{'reason'} !~ /^\s*$/;
3011 my $reason = new FS::reason({
3012 'reason_type' => $options{'reason'}->{'typenum'},
3013 'reason' => $options{'reason'}->{'reason'},
3015 my $error = $reason->insert;
3016 return $error if $error;
3018 $reasonnum = $reason->reasonnum;
3021 return "Unparsable reason: ". $options{'reason'};
3024 my $cust_pkg_reason =
3025 new FS::cust_pkg_reason({ 'pkgnum' => $self->pkgnum,
3026 'reasonnum' => $reasonnum,
3027 'otaker' => $otaker,
3028 'action' => substr(uc($options{'action'}),0,1),
3029 'date' => $options{'date'}
3034 $cust_pkg_reason->insert;
3037 =item set_usage USAGE_VALUE_HASHREF
3039 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
3040 to which they should be set (see L<FS::svc_acct>). Currently seconds,
3041 upbytes, downbytes, and totalbytes are appropriate keys.
3043 All svc_accts which are part of this package have their values reset.
3048 my ($self, $valueref, %opt) = @_;
3050 foreach my $cust_svc ($self->cust_svc){
3051 my $svc_x = $cust_svc->svc_x;
3052 $svc_x->set_usage($valueref, %opt)
3053 if $svc_x->can("set_usage");
3057 =item recharge USAGE_VALUE_HASHREF
3059 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
3060 to which they should be set (see L<FS::svc_acct>). Currently seconds,
3061 upbytes, downbytes, and totalbytes are appropriate keys.
3063 All svc_accts which are part of this package have their values incremented.
3068 my ($self, $valueref) = @_;
3070 foreach my $cust_svc ($self->cust_svc){
3071 my $svc_x = $cust_svc->svc_x;
3072 $svc_x->recharge($valueref)
3073 if $svc_x->can("recharge");
3081 sub order is not OO. Perhaps it should be moved to FS::cust_main and made so?
3083 In sub order, the @pkgparts array (passed by reference) is clobbered.
3085 Also in sub order, no money is adjusted. Once FS::part_pkg defines a standard
3086 method to pass dates to the recur_prog expression, it should do so.
3088 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
3089 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
3090 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
3091 configuration values. Probably need a subroutine which decides what to do
3092 based on whether or not we've fetched the user yet, rather than a hash. See
3093 FS::UID and the TODO.
3095 Now that things are transactional should the check in the insert method be
3100 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
3101 L<FS::pkg_svc>, schema.html from the base documentation