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;
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
44 @ISA = qw( FS::m2m_Common FS::cust_main_Mixin FS::option_Common FS::Record );
47 $me = '[FS::cust_pkg]';
49 $disable_agentcheck = 0;
53 my ( $hashref, $cache ) = @_;
54 #if ( $hashref->{'pkgpart'} ) {
55 if ( $hashref->{'pkg'} ) {
56 # #@{ $self->{'_pkgnum'} } = ();
57 # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
58 # $self->{'_pkgpart'} = $subcache;
59 # #push @{ $self->{'_pkgnum'} },
60 # FS::part_pkg->new_or_cached($hashref, $subcache);
61 $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
63 if ( exists $hashref->{'svcnum'} ) {
64 #@{ $self->{'_pkgnum'} } = ();
65 my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
66 $self->{'_svcnum'} = $subcache;
67 #push @{ $self->{'_pkgnum'} },
68 FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
74 FS::cust_pkg - Object methods for cust_pkg objects
80 $record = new FS::cust_pkg \%hash;
81 $record = new FS::cust_pkg { 'column' => 'value' };
83 $error = $record->insert;
85 $error = $new_record->replace($old_record);
87 $error = $record->delete;
89 $error = $record->check;
91 $error = $record->cancel;
93 $error = $record->suspend;
95 $error = $record->unsuspend;
97 $part_pkg = $record->part_pkg;
99 @labels = $record->labels;
101 $seconds = $record->seconds_since($timestamp);
103 $error = FS::cust_pkg::order( $custnum, \@pkgparts );
104 $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
108 An FS::cust_pkg object represents a customer billing item. FS::cust_pkg
109 inherits from FS::Record. The following fields are currently supported:
115 Primary key (assigned automatically for new billing items)
119 Customer (see L<FS::cust_main>)
123 Billing item definition (see L<FS::part_pkg>)
127 Optional link to package location (see L<FS::location>)
139 date (next bill date)
163 order taker (assigned automatically if null, see L<FS::UID>)
167 If this field is set to 1, disables the automatic
168 unsuspension of this package when using the B<unsuspendauto> config option.
172 If not set, defaults to 1
176 Date of change from previous package
186 =item change_locationnum
192 Note: setup, last_bill, bill, adjourn, susp, expire, cancel and change_date
193 are specified as UNIX timestamps; see L<perlfunc/"time">. Also see
194 L<Time::Local> and L<Date::Parse> for conversion functions.
202 Create a new billing item. To add the item to the database, see L<"insert">.
206 sub table { 'cust_pkg'; }
207 sub cust_linked { $_[0]->cust_main_custnum; }
208 sub cust_unlinked_msg {
210 "WARNING: can't find cust_main.custnum ". $self->custnum.
211 ' (cust_pkg.pkgnum '. $self->pkgnum. ')';
214 =item insert [ OPTION => VALUE ... ]
216 Adds this billing item to the database ("Orders" the item). If there is an
217 error, returns the error, otherwise returns false.
219 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
220 will be used to look up the package definition and agent restrictions will be
223 If the additional field I<refnum> is defined, an FS::pkg_referral record will
224 be created and inserted. Multiple FS::pkg_referral records can be created by
225 setting I<refnum> to an array reference of refnums or a hash reference with
226 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
227 record will be created corresponding to cust_main.refnum.
229 The following options are available:
235 If set true, supresses any referral credit to a referring customer.
239 cust_pkg_option records will be created
243 a ticket will be added to this customer with this subject
247 an optional queue name for ticket additions
254 my( $self, %options ) = @_;
256 local $SIG{HUP} = 'IGNORE';
257 local $SIG{INT} = 'IGNORE';
258 local $SIG{QUIT} = 'IGNORE';
259 local $SIG{TERM} = 'IGNORE';
260 local $SIG{TSTP} = 'IGNORE';
261 local $SIG{PIPE} = 'IGNORE';
263 my $oldAutoCommit = $FS::UID::AutoCommit;
264 local $FS::UID::AutoCommit = 0;
267 my $error = $self->SUPER::insert($options{options} ? %{$options{options}} : ());
269 $dbh->rollback if $oldAutoCommit;
273 $self->refnum($self->cust_main->refnum) unless $self->refnum;
274 $self->refnum( [ $self->refnum ] ) unless ref($self->refnum);
275 $self->process_m2m( 'link_table' => 'pkg_referral',
276 'target_table' => 'part_referral',
277 'params' => $self->refnum,
280 if ( $self->discountnum ) {
281 my $error = $self->insert_discount();
283 $dbh->rollback if $oldAutoCommit;
288 #if ( $self->reg_code ) {
289 # my $reg_code = qsearchs('reg_code', { 'code' => $self->reg_code } );
290 # $error = $reg_code->delete;
292 # $dbh->rollback if $oldAutoCommit;
297 my $conf = new FS::Conf;
299 if ( $conf->config('ticket_system') && $options{ticket_subject} ) {
302 # use lib ( "/opt/rt3/local/lib", "/opt/rt3/lib" );
309 use FS::TicketSystem;
310 FS::TicketSystem->init();
312 my $q = new RT::Queue($RT::SystemUser);
313 $q->Load($options{ticket_queue}) if $options{ticket_queue};
314 my $t = new RT::Ticket($RT::SystemUser);
315 my $mime = new MIME::Entity;
316 $mime->build( Type => 'text/plain', Data => $options{ticket_subject} );
317 $t->Create( $options{ticket_queue} ? (Queue => $q) : (),
318 Subject => $options{ticket_subject},
321 $t->AddLink( Type => 'MemberOf',
322 Target => 'freeside://freeside/cust_main/'. $self->custnum,
326 if ($conf->config('welcome_letter') && $self->cust_main->num_pkgs == 1) {
327 my $queue = new FS::queue {
328 'job' => 'FS::cust_main::queueable_print',
330 $error = $queue->insert(
331 'custnum' => $self->custnum,
332 'template' => 'welcome_letter',
336 warn "can't send welcome letter: $error";
341 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
348 This method now works but you probably shouldn't use it.
350 You don't want to delete billing items, because there would then be no record
351 the customer ever purchased the item. Instead, see the cancel method.
356 # return "Can't delete cust_pkg records!";
359 =item replace [ OLD_RECORD ] [ HASHREF | OPTION => VALUE ... ]
361 Replaces the OLD_RECORD with this one in the database. If there is an error,
362 returns the error, otherwise returns false.
364 Currently, custnum, setup, bill, adjourn, susp, expire, and cancel may be changed.
366 Changing pkgpart may have disasterous effects. See the order subroutine.
368 setup and bill are normally updated by calling the bill method of a customer
369 object (see L<FS::cust_main>).
371 suspend is normally updated by the suspend and unsuspend methods.
373 cancel is normally updated by the cancel method (and also the order subroutine
376 Available options are:
382 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.
386 the access_user (see L<FS::access_user>) providing the reason
390 hashref of keys and values - cust_pkg_option records will be created, updated or removed as appopriate
399 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
404 ( ref($_[0]) eq 'HASH' )
408 #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
409 return "Can't change otaker!" if $old->otaker ne $new->otaker;
412 #return "Can't change setup once it exists!"
413 # if $old->getfield('setup') &&
414 # $old->getfield('setup') != $new->getfield('setup');
416 #some logic for bill, susp, cancel?
418 local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
420 local $SIG{HUP} = 'IGNORE';
421 local $SIG{INT} = 'IGNORE';
422 local $SIG{QUIT} = 'IGNORE';
423 local $SIG{TERM} = 'IGNORE';
424 local $SIG{TSTP} = 'IGNORE';
425 local $SIG{PIPE} = 'IGNORE';
427 my $oldAutoCommit = $FS::UID::AutoCommit;
428 local $FS::UID::AutoCommit = 0;
431 foreach my $method ( qw(adjourn expire) ) { # How many reasons?
432 if ($options->{'reason'} && $new->$method && $old->$method ne $new->$method) {
433 my $error = $new->insert_reason(
434 'reason' => $options->{'reason'},
435 'date' => $new->$method,
437 'reason_otaker' => $options->{'reason_otaker'},
440 dbh->rollback if $oldAutoCommit;
441 return "Error inserting cust_pkg_reason: $error";
446 #save off and freeze RADIUS attributes for any associated svc_acct records
448 if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
450 #also check for specific exports?
451 # to avoid spurious modify export events
452 @svc_acct = map { $_->svc_x }
453 grep { $_->part_svc->svcdb eq 'svc_acct' }
456 $_->snapshot foreach @svc_acct;
460 my $error = $new->SUPER::replace($old,
461 $options->{options} ? $options->{options} : ()
464 $dbh->rollback if $oldAutoCommit;
468 #for prepaid packages,
469 #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
470 foreach my $old_svc_acct ( @svc_acct ) {
471 my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
472 my $s_error = $new_svc_acct->replace($old_svc_acct);
474 $dbh->rollback if $oldAutoCommit;
479 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
486 Checks all fields to make sure this is a valid billing item. If there is an
487 error, returns the error, otherwise returns false. Called by the insert and
495 $self->locationnum('') if !$self->locationnum || $self->locationnum == -1;
498 $self->ut_numbern('pkgnum')
499 || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
500 || $self->ut_numbern('pkgpart')
501 || $self->ut_foreign_keyn('locationnum', 'cust_location', 'locationnum')
502 || $self->ut_numbern('start_date')
503 || $self->ut_numbern('setup')
504 || $self->ut_numbern('bill')
505 || $self->ut_numbern('susp')
506 || $self->ut_numbern('cancel')
507 || $self->ut_numbern('adjourn')
508 || $self->ut_numbern('expire')
510 return $error if $error;
512 if ( $self->reg_code ) {
514 unless ( grep { $self->pkgpart == $_->pkgpart }
515 map { $_->reg_code_pkg }
516 qsearchs( 'reg_code', { 'code' => $self->reg_code,
517 'agentnum' => $self->cust_main->agentnum })
519 return "Unknown registration code";
522 } elsif ( $self->promo_code ) {
525 qsearchs('part_pkg', {
526 'pkgpart' => $self->pkgpart,
527 'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
529 return 'Unknown promotional code' unless $promo_part_pkg;
533 unless ( $disable_agentcheck ) {
535 qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
536 return "agent ". $agent->agentnum. ':'. $agent->agent.
537 " can't purchase pkgpart ". $self->pkgpart
538 unless $agent->pkgpart_hashref->{ $self->pkgpart }
539 || $agent->agentnum == $self->part_pkg->agentnum;
542 $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
543 return $error if $error;
547 if ( $self->part_pkg->option('start_1st') && !$self->start_date ) {
548 my ($sec,$min,$hour,$mday,$mon,$year) = (localtime(time) )[0,1,2,3,4,5];
549 $mon += 1 unless $mday == 1;
550 until ( $mon < 12 ) { $mon -= 12; $year++; }
551 $self->start_date( timelocal_nocheck(0,0,0,1,$mon,$year) );
554 my $expire_months = $self->part_pkg->option('expire_months');
555 if ( $expire_months && !$self->expire ) {
556 my $start = $self->start_date || $self->setup || time;
558 #false laziness w/part_pkg::add_freq
559 my ($sec,$min,$hour,$mday,$mon,$year) = (localtime($start) )[0,1,2,3,4,5];
560 $mon += $expire_months;
561 until ( $mon < 12 ) { $mon -= 12; $year++; }
563 #$self->expire( timelocal_nocheck($sec,$min,$hour,$mday,$mon,$year) );
564 $self->expire( timelocal_nocheck(0,0,0,$mday,$mon,$year) );
567 $self->otaker(getotaker) unless $self->otaker;
568 $self->otaker =~ /^(\w{1,32})$/ or return "Illegal otaker";
571 if ( $self->dbdef_table->column('manual_flag') ) {
572 $self->manual_flag('') if $self->manual_flag eq ' ';
573 $self->manual_flag =~ /^([01]?)$/
574 or return "Illegal manual_flag ". $self->manual_flag;
575 $self->manual_flag($1);
581 =item cancel [ OPTION => VALUE ... ]
583 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
584 in this package, then cancels the package itself (sets the cancel field to
587 Available options are:
591 =item quiet - can be set true to supress email cancellation notices.
593 =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.
595 =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.
597 =item date - can be set to a unix style timestamp to specify when to cancel (expire)
599 =item nobill - can be set true to skip billing if it might otherwise be done.
603 If there is an error, returns the error, otherwise returns false.
608 my( $self, %options ) = @_;
611 my $conf = new FS::Conf;
613 warn "cust_pkg::cancel called with options".
614 join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
617 local $SIG{HUP} = 'IGNORE';
618 local $SIG{INT} = 'IGNORE';
619 local $SIG{QUIT} = 'IGNORE';
620 local $SIG{TERM} = 'IGNORE';
621 local $SIG{TSTP} = 'IGNORE';
622 local $SIG{PIPE} = 'IGNORE';
624 my $oldAutoCommit = $FS::UID::AutoCommit;
625 local $FS::UID::AutoCommit = 0;
628 my $old = $self->select_for_update;
630 if ( $old->get('cancel') || $self->get('cancel') ) {
631 dbh->rollback if $oldAutoCommit;
632 return ""; # no error
635 my $date = $options{date} if $options{date}; # expire/cancel later
636 $date = '' if ($date && $date <= time); # complain instead?
638 #race condition: usage could be ongoing until unprovisioned
639 #resolved by performing a change package instead (which unprovisions) and
641 if ( !$options{nobill} && !$date && $conf->exists('bill_usage_on_cancel') ) {
642 my $copy = $self->new({$self->hash});
644 $copy->cust_main->bill( pkg_list => [ $copy ], cancel => 1 );
645 warn "Error billing during cancel, custnum ".
646 #$self->cust_main->custnum. ": $error"
652 my $cancel_time = $options{'time'} || time;
654 if ( $options{'reason'} ) {
655 $error = $self->insert_reason( 'reason' => $options{'reason'},
656 'action' => $date ? 'expire' : 'cancel',
657 'date' => $date ? $date : $cancel_time,
658 'reason_otaker' => $options{'reason_otaker'},
661 dbh->rollback if $oldAutoCommit;
662 return "Error inserting cust_pkg_reason: $error";
668 foreach my $cust_svc (
671 sort { $a->[1] <=> $b->[1] }
672 map { [ $_, $_->svc_x->table_info->{'cancel_weight'} ]; }
673 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
676 my $error = $cust_svc->cancel;
679 $dbh->rollback if $oldAutoCommit;
680 return "Error cancelling cust_svc: $error";
684 # Add a credit for remaining service
685 my $remaining_value = $self->calc_remain(time=>$cancel_time);
686 if ( $remaining_value > 0 && !$options{'no_credit'} ) {
687 my $error = $self->cust_main->credit(
689 'Credit for unused time on '. $self->part_pkg->pkg,
690 'reason_type' => $conf->config('cancel_credit_type'),
693 $dbh->rollback if $oldAutoCommit;
694 return "Error crediting customer \$$remaining_value for unused time on".
695 $self->part_pkg->pkg. ": $error";
700 my %hash = $self->hash;
701 $date ? ($hash{'expire'} = $date) : ($hash{'cancel'} = $cancel_time);
702 my $new = new FS::cust_pkg ( \%hash );
703 $error = $new->replace( $self, options => { $self->options } );
705 $dbh->rollback if $oldAutoCommit;
709 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
710 return '' if $date; #no errors
712 my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
713 if ( !$options{'quiet'} && $conf->exists('emailcancel') && @invoicing_list ) {
714 my $error = send_email(
715 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
716 'to' => \@invoicing_list,
717 'subject' => ( $conf->config('cancelsubject') || 'Cancellation Notice' ),
718 'body' => [ map "$_\n", $conf->config('cancelmessage') ],
720 #should this do something on errors?
727 =item cancel_if_expired [ NOW_TIMESTAMP ]
729 Cancels this package if its expire date has been reached.
733 sub cancel_if_expired {
735 my $time = shift || time;
736 return '' unless $self->expire && $self->expire <= $time;
737 my $error = $self->cancel;
739 return "Error cancelling expired pkg ". $self->pkgnum. " for custnum ".
740 $self->custnum. ": $error";
747 Cancels any pending expiration (sets the expire field to null).
749 If there is an error, returns the error, otherwise returns false.
754 my( $self, %options ) = @_;
757 local $SIG{HUP} = 'IGNORE';
758 local $SIG{INT} = 'IGNORE';
759 local $SIG{QUIT} = 'IGNORE';
760 local $SIG{TERM} = 'IGNORE';
761 local $SIG{TSTP} = 'IGNORE';
762 local $SIG{PIPE} = 'IGNORE';
764 my $oldAutoCommit = $FS::UID::AutoCommit;
765 local $FS::UID::AutoCommit = 0;
768 my $old = $self->select_for_update;
770 my $pkgnum = $old->pkgnum;
771 if ( $old->get('cancel') || $self->get('cancel') ) {
772 dbh->rollback if $oldAutoCommit;
773 return "Can't unexpire cancelled package $pkgnum";
774 # or at least it's pointless
777 unless ( $old->get('expire') && $self->get('expire') ) {
778 dbh->rollback if $oldAutoCommit;
779 return ""; # no error
782 my %hash = $self->hash;
783 $hash{'expire'} = '';
784 my $new = new FS::cust_pkg ( \%hash );
785 $error = $new->replace( $self, options => { $self->options } );
787 $dbh->rollback if $oldAutoCommit;
791 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
797 =item suspend [ OPTION => VALUE ... ]
799 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
800 package, then suspends the package itself (sets the susp field to now).
802 Available options are:
806 =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.
808 =item date - can be set to a unix style timestamp to specify when to suspend (adjourn)
812 If there is an error, returns the error, otherwise returns false.
817 my( $self, %options ) = @_;
820 local $SIG{HUP} = 'IGNORE';
821 local $SIG{INT} = 'IGNORE';
822 local $SIG{QUIT} = 'IGNORE';
823 local $SIG{TERM} = 'IGNORE';
824 local $SIG{TSTP} = 'IGNORE';
825 local $SIG{PIPE} = 'IGNORE';
827 my $oldAutoCommit = $FS::UID::AutoCommit;
828 local $FS::UID::AutoCommit = 0;
831 my $old = $self->select_for_update;
833 my $pkgnum = $old->pkgnum;
834 if ( $old->get('cancel') || $self->get('cancel') ) {
835 dbh->rollback if $oldAutoCommit;
836 return "Can't suspend cancelled package $pkgnum";
839 if ( $old->get('susp') || $self->get('susp') ) {
840 dbh->rollback if $oldAutoCommit;
841 return ""; # no error # complain on adjourn?
844 my $date = $options{date} if $options{date}; # adjourn/suspend later
845 $date = '' if ($date && $date <= time); # complain instead?
847 if ( $date && $old->get('expire') && $old->get('expire') < $date ) {
848 dbh->rollback if $oldAutoCommit;
849 return "Package $pkgnum expires before it would be suspended.";
852 my $suspend_time = $options{'time'} || time;
854 if ( $options{'reason'} ) {
855 $error = $self->insert_reason( 'reason' => $options{'reason'},
856 'action' => $date ? 'adjourn' : 'suspend',
857 'date' => $date ? $date : $suspend_time,
858 'reason_otaker' => $options{'reason_otaker'},
861 dbh->rollback if $oldAutoCommit;
862 return "Error inserting cust_pkg_reason: $error";
870 foreach my $cust_svc (
871 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
873 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
875 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
876 $dbh->rollback if $oldAutoCommit;
877 return "Illegal svcdb value in part_svc!";
880 require "FS/$svcdb.pm";
882 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
884 $error = $svc->suspend;
886 $dbh->rollback if $oldAutoCommit;
889 my( $label, $value ) = $cust_svc->label;
890 push @labels, "$label: $value";
894 my $conf = new FS::Conf;
895 if ( $conf->config('suspend_email_admin') ) {
897 my $error = send_email(
898 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
899 #invoice_from ??? well as good as any
900 'to' => $conf->config('suspend_email_admin'),
901 'subject' => 'FREESIDE NOTIFICATION: Customer package suspended',
903 "This is an automatic message from your Freeside installation\n",
904 "informing you that the following customer package has been suspended:\n",
906 'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
907 'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
908 ( map { "Service : $_\n" } @labels ),
913 warn "WARNING: can't send suspension admin email (suspending anyway): ".
921 my %hash = $self->hash;
923 $hash{'adjourn'} = $date;
925 $hash{'susp'} = $suspend_time;
927 my $new = new FS::cust_pkg ( \%hash );
928 $error = $new->replace( $self, options => { $self->options } );
930 $dbh->rollback if $oldAutoCommit;
934 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
939 =item unsuspend [ OPTION => VALUE ... ]
941 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
942 package, then unsuspends the package itself (clears the susp field and the
943 adjourn field if it is in the past).
945 Available options are:
949 =item adjust_next_bill
951 Can be set true to adjust the next bill date forward by
952 the amount of time the account was inactive. This was set true by default
953 since 1.4.2 and 1.5.0pre6; however, starting with 1.7.0 this needs to be
954 explicitly requested. Price plans for which this makes sense (anniversary-date
955 based than prorate or subscription) could have an option to enable this
960 If there is an error, returns the error, otherwise returns false.
965 my( $self, %opt ) = @_;
968 local $SIG{HUP} = 'IGNORE';
969 local $SIG{INT} = 'IGNORE';
970 local $SIG{QUIT} = 'IGNORE';
971 local $SIG{TERM} = 'IGNORE';
972 local $SIG{TSTP} = 'IGNORE';
973 local $SIG{PIPE} = 'IGNORE';
975 my $oldAutoCommit = $FS::UID::AutoCommit;
976 local $FS::UID::AutoCommit = 0;
979 my $old = $self->select_for_update;
981 my $pkgnum = $old->pkgnum;
982 if ( $old->get('cancel') || $self->get('cancel') ) {
983 dbh->rollback if $oldAutoCommit;
984 return "Can't unsuspend cancelled package $pkgnum";
987 unless ( $old->get('susp') && $self->get('susp') ) {
988 dbh->rollback if $oldAutoCommit;
989 return ""; # no error # complain instead?
992 foreach my $cust_svc (
993 qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
995 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
997 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
998 $dbh->rollback if $oldAutoCommit;
999 return "Illegal svcdb value in part_svc!";
1002 require "FS/$svcdb.pm";
1004 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
1006 $error = $svc->unsuspend;
1008 $dbh->rollback if $oldAutoCommit;
1015 my %hash = $self->hash;
1016 my $inactive = time - $hash{'susp'};
1018 my $conf = new FS::Conf;
1020 $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive
1021 if ( $opt{'adjust_next_bill'}
1022 || $conf->exists('unsuspend-always_adjust_next_bill_date') )
1023 && $inactive > 0 && ( $hash{'bill'} || $hash{'setup'} );
1026 $hash{'adjourn'} = '' if $hash{'adjourn'} < time;
1027 my $new = new FS::cust_pkg ( \%hash );
1028 $error = $new->replace( $self, options => { $self->options } );
1030 $dbh->rollback if $oldAutoCommit;
1034 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1041 Cancels any pending suspension (sets the adjourn field to null).
1043 If there is an error, returns the error, otherwise returns false.
1048 my( $self, %options ) = @_;
1051 local $SIG{HUP} = 'IGNORE';
1052 local $SIG{INT} = 'IGNORE';
1053 local $SIG{QUIT} = 'IGNORE';
1054 local $SIG{TERM} = 'IGNORE';
1055 local $SIG{TSTP} = 'IGNORE';
1056 local $SIG{PIPE} = 'IGNORE';
1058 my $oldAutoCommit = $FS::UID::AutoCommit;
1059 local $FS::UID::AutoCommit = 0;
1062 my $old = $self->select_for_update;
1064 my $pkgnum = $old->pkgnum;
1065 if ( $old->get('cancel') || $self->get('cancel') ) {
1066 dbh->rollback if $oldAutoCommit;
1067 return "Can't unadjourn cancelled package $pkgnum";
1068 # or at least it's pointless
1071 if ( $old->get('susp') || $self->get('susp') ) {
1072 dbh->rollback if $oldAutoCommit;
1073 return "Can't unadjourn suspended package $pkgnum";
1074 # perhaps this is arbitrary
1077 unless ( $old->get('adjourn') && $self->get('adjourn') ) {
1078 dbh->rollback if $oldAutoCommit;
1079 return ""; # no error
1082 my %hash = $self->hash;
1083 $hash{'adjourn'} = '';
1084 my $new = new FS::cust_pkg ( \%hash );
1085 $error = $new->replace( $self, options => { $self->options } );
1087 $dbh->rollback if $oldAutoCommit;
1091 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1098 =item change HASHREF | OPTION => VALUE ...
1100 Changes this package: cancels it and creates a new one, with a different
1101 pkgpart or locationnum or both. All services are transferred to the new
1102 package (no change will be made if this is not possible).
1104 Options may be passed as a list of key/value pairs or as a hash reference.
1111 New locationnum, to change the location for this package.
1115 New FS::cust_location object, to create a new location and assign it
1120 New pkgpart (see L<FS::part_pkg>).
1124 New refnum (see L<FS::part_referral>).
1128 At least one option must be specified (otherwise, what's the point?)
1130 Returns either the new FS::cust_pkg object or a scalar error.
1134 my $err_or_new_cust_pkg = $old_cust_pkg->change
1138 #some false laziness w/order
1141 my $opt = ref($_[0]) ? shift : { @_ };
1143 # my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
1146 my $conf = new FS::Conf;
1148 # Transactionize this whole mess
1149 local $SIG{HUP} = 'IGNORE';
1150 local $SIG{INT} = 'IGNORE';
1151 local $SIG{QUIT} = 'IGNORE';
1152 local $SIG{TERM} = 'IGNORE';
1153 local $SIG{TSTP} = 'IGNORE';
1154 local $SIG{PIPE} = 'IGNORE';
1156 my $oldAutoCommit = $FS::UID::AutoCommit;
1157 local $FS::UID::AutoCommit = 0;
1166 #$hash{$_} = $self->$_() foreach qw( last_bill bill );
1168 #$hash{$_} = $self->$_() foreach qw( setup );
1170 $hash{'setup'} = $time if $self->setup;
1172 $hash{'change_date'} = $time;
1173 $hash{"change_$_"} = $self->$_()
1174 foreach qw( pkgnum pkgpart locationnum );
1176 if ( $opt->{'cust_location'} &&
1177 ( ! $opt->{'locationnum'} || $opt->{'locationnum'} == -1 ) ) {
1178 $error = $opt->{'cust_location'}->insert;
1180 $dbh->rollback if $oldAutoCommit;
1181 return "inserting cust_location (transaction rolled back): $error";
1183 $opt->{'locationnum'} = $opt->{'cust_location'}->locationnum;
1186 # Create the new package.
1187 my $cust_pkg = new FS::cust_pkg {
1188 custnum => $self->custnum,
1189 pkgpart => ( $opt->{'pkgpart'} || $self->pkgpart ),
1190 refnum => ( $opt->{'refnum'} || $self->refnum ),
1191 locationnum => ( $opt->{'locationnum'} || $self->locationnum ),
1195 $error = $cust_pkg->insert( 'change' => 1 );
1197 $dbh->rollback if $oldAutoCommit;
1201 # Transfer services and cancel old package.
1203 $error = $self->transfer($cust_pkg);
1204 if ($error and $error == 0) {
1205 # $old_pkg->transfer failed.
1206 $dbh->rollback if $oldAutoCommit;
1210 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1211 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1212 $error = $self->transfer($cust_pkg, 'change_svcpart'=>1 );
1213 if ($error and $error == 0) {
1214 # $old_pkg->transfer failed.
1215 $dbh->rollback if $oldAutoCommit;
1221 # Transfers were successful, but we still had services left on the old
1222 # package. We can't change the package under this circumstances, so abort.
1223 $dbh->rollback if $oldAutoCommit;
1224 return "Unable to transfer all services from package ". $self->pkgnum;
1227 #reset usage if changing pkgpart
1228 # AND usage rollover is off (otherwise adds twice, now and at package bill)
1229 if ($self->pkgpart != $cust_pkg->pkgpart) {
1230 my $part_pkg = $cust_pkg->part_pkg;
1231 $error = $part_pkg->reset_usage($cust_pkg, $part_pkg->is_prepaid
1235 if $part_pkg->can('reset_usage') && ! $part_pkg->option('usage_rollover');
1238 $dbh->rollback if $oldAutoCommit;
1239 return "Error setting usage values: $error";
1243 #Good to go, cancel old package.
1244 $error = $self->cancel( quiet=>1 );
1246 $dbh->rollback if $oldAutoCommit;
1250 if ( $conf->exists('cust_pkg-change_pkgpart-bill_now') ) {
1252 my $error = $cust_pkg->cust_main->bill( 'pkg_list' => [ $cust_pkg ] );
1254 $dbh->rollback if $oldAutoCommit;
1259 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1267 Returns the last bill date, or if there is no last bill date, the setup date.
1268 Useful for billing metered services.
1274 return $self->setfield('last_bill', $_[0]) if @_;
1275 return $self->getfield('last_bill') if $self->getfield('last_bill');
1276 my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
1277 'edate' => $self->bill, } );
1278 $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
1281 =item last_cust_pkg_reason ACTION
1283 Returns the most recent ACTION FS::cust_pkg_reason associated with the package.
1284 Returns false if there is no reason or the package is not currenly ACTION'd
1285 ACTION is one of adjourn, susp, cancel, or expire.
1289 sub last_cust_pkg_reason {
1290 my ( $self, $action ) = ( shift, shift );
1291 my $date = $self->get($action);
1293 'table' => 'cust_pkg_reason',
1294 'hashref' => { 'pkgnum' => $self->pkgnum,
1295 'action' => substr(uc($action), 0, 1),
1298 'order_by' => 'ORDER BY num DESC LIMIT 1',
1302 =item last_reason ACTION
1304 Returns the most recent ACTION FS::reason associated with the package.
1305 Returns false if there is no reason or the package is not currenly ACTION'd
1306 ACTION is one of adjourn, susp, cancel, or expire.
1311 my $cust_pkg_reason = shift->last_cust_pkg_reason(@_);
1312 $cust_pkg_reason->reason
1313 if $cust_pkg_reason;
1318 Returns the definition for this billing item, as an FS::part_pkg object (see
1325 return $self->{'_pkgpart'} if $self->{'_pkgpart'};
1326 cluck "cust_pkg->part_pkg called" if $DEBUG > 1;
1327 qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
1332 Returns the cancelled package this package was changed from, if any.
1338 return '' unless $self->change_pkgnum;
1339 qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
1344 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
1351 $self->part_pkg->calc_setup($self, @_);
1356 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
1363 $self->part_pkg->calc_recur($self, @_);
1368 Calls the I<calc_remain> of the FS::part_pkg object associated with this
1375 $self->part_pkg->calc_remain($self, @_);
1380 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
1387 $self->part_pkg->calc_cancel($self, @_);
1392 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
1398 qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
1401 =item cust_pkg_detail [ DETAILTYPE ]
1403 Returns any customer package details for this package (see
1404 L<FS::cust_pkg_detail>).
1406 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
1410 sub cust_pkg_detail {
1412 my %hash = ( 'pkgnum' => $self->pkgnum );
1413 $hash{detailtype} = shift if @_;
1415 'table' => 'cust_pkg_detail',
1416 'hashref' => \%hash,
1417 'order_by' => 'ORDER BY weight, pkgdetailnum',
1421 =item set_cust_pkg_detail DETAILTYPE [ DETAIL, DETAIL, ... ]
1423 Sets customer package details for this package (see L<FS::cust_pkg_detail>).
1425 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
1427 If there is an error, returns the error, otherwise returns false.
1431 sub set_cust_pkg_detail {
1432 my( $self, $detailtype, @details ) = @_;
1434 local $SIG{HUP} = 'IGNORE';
1435 local $SIG{INT} = 'IGNORE';
1436 local $SIG{QUIT} = 'IGNORE';
1437 local $SIG{TERM} = 'IGNORE';
1438 local $SIG{TSTP} = 'IGNORE';
1439 local $SIG{PIPE} = 'IGNORE';
1441 my $oldAutoCommit = $FS::UID::AutoCommit;
1442 local $FS::UID::AutoCommit = 0;
1445 foreach my $current ( $self->cust_pkg_detail($detailtype) ) {
1446 my $error = $current->delete;
1448 $dbh->rollback if $oldAutoCommit;
1449 return "error removing old detail: $error";
1453 foreach my $detail ( @details ) {
1454 my $cust_pkg_detail = new FS::cust_pkg_detail {
1455 'pkgnum' => $self->pkgnum,
1456 'detailtype' => $detailtype,
1457 'detail' => $detail,
1459 my $error = $cust_pkg_detail->insert;
1461 $dbh->rollback if $oldAutoCommit;
1462 return "error adding new detail: $error";
1467 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1474 Returns the new-style customer billing events (see L<FS::cust_event>) for this invoice.
1478 #false laziness w/cust_bill.pm
1482 'table' => 'cust_event',
1483 'addl_from' => 'JOIN part_event USING ( eventpart )',
1484 'hashref' => { 'tablenum' => $self->pkgnum },
1485 'extra_sql' => " AND eventtable = 'cust_pkg' ",
1489 =item num_cust_event
1491 Returns the number of new-style customer billing events (see L<FS::cust_event>) for this invoice.
1495 #false laziness w/cust_bill.pm
1496 sub num_cust_event {
1499 "SELECT COUNT(*) FROM cust_event JOIN part_event USING ( eventpart ) ".
1500 " WHERE tablenum = ? AND eventtable = 'cust_pkg'";
1501 my $sth = dbh->prepare($sql) or die dbh->errstr. " preparing $sql";
1502 $sth->execute($self->pkgnum) or die $sth->errstr. " executing $sql";
1503 $sth->fetchrow_arrayref->[0];
1506 =item cust_svc [ SVCPART ]
1508 Returns the services for this package, as FS::cust_svc objects (see
1509 L<FS::cust_svc>). If a svcpart is specified, return only the matching
1517 return () unless $self->num_cust_svc(@_);
1520 return qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum,
1521 'svcpart' => shift, } );
1524 cluck "cust_pkg->cust_svc called" if $DEBUG > 2;
1526 #if ( $self->{'_svcnum'} ) {
1527 # values %{ $self->{'_svcnum'}->cache };
1529 $self->_sort_cust_svc(
1530 [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
1536 =item overlimit [ SVCPART ]
1538 Returns the services for this package which have exceeded their
1539 usage limit as FS::cust_svc objects (see L<FS::cust_svc>). If a svcpart
1540 is specified, return only the matching services.
1546 return () unless $self->num_cust_svc(@_);
1547 grep { $_->overlimit } $self->cust_svc(@_);
1550 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ]
1552 Returns historical services for this package created before END TIMESTAMP and
1553 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
1554 (see L<FS::h_cust_svc>).
1561 $self->_sort_cust_svc(
1562 [ qsearch( 'h_cust_svc',
1563 { 'pkgnum' => $self->pkgnum, },
1564 FS::h_cust_svc->sql_h_search(@_),
1570 sub _sort_cust_svc {
1571 my( $self, $arrayref ) = @_;
1574 sub ($$) { my ($a, $b) = @_; $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] };
1579 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
1580 'svcpart' => $_->svcpart } );
1582 $pkg_svc ? $pkg_svc->primary_svc : '',
1583 $pkg_svc ? $pkg_svc->quantity : 0,
1590 =item num_cust_svc [ SVCPART ]
1592 Returns the number of provisioned services for this package. If a svcpart is
1593 specified, counts only the matching services.
1600 return $self->{'_num_cust_svc'}
1602 && exists($self->{'_num_cust_svc'})
1603 && $self->{'_num_cust_svc'} =~ /\d/;
1605 cluck "cust_pkg->num_cust_svc called, _num_cust_svc:".$self->{'_num_cust_svc'}
1608 my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
1609 $sql .= ' AND svcpart = ?' if @_;
1611 my $sth = dbh->prepare($sql) or die dbh->errstr;
1612 $sth->execute($self->pkgnum, @_) or die $sth->errstr;
1613 $sth->fetchrow_arrayref->[0];
1616 =item available_part_svc
1618 Returns a list of FS::part_svc objects representing services included in this
1619 package but not yet provisioned. Each FS::part_svc object also has an extra
1620 field, I<num_avail>, which specifies the number of available services.
1624 sub available_part_svc {
1626 grep { $_->num_avail > 0 }
1628 my $part_svc = $_->part_svc;
1629 $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
1630 $_->quantity - $self->num_cust_svc($_->svcpart);
1633 $self->part_pkg->pkg_svc;
1638 Returns a list of FS::part_svc objects representing provisioned and available
1639 services included in this package. Each FS::part_svc object also has the
1640 following extra fields:
1644 =item num_cust_svc (count)
1646 =item num_avail (quantity - count)
1648 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
1651 label -> ($cust_svc->label)[1]
1660 #XXX some sort of sort order besides numeric by svcpart...
1661 my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
1663 my $part_svc = $pkg_svc->part_svc;
1664 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1665 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
1666 $part_svc->{'Hash'}{'num_avail'} =
1667 max( 0, $pkg_svc->quantity - $num_cust_svc );
1668 $part_svc->{'Hash'}{'cust_pkg_svc'} =
1669 $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
1671 } $self->part_pkg->pkg_svc;
1674 push @part_svc, map {
1676 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1677 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
1678 $part_svc->{'Hash'}{'num_avail'} = 0; #0-$num_cust_svc ?
1679 $part_svc->{'Hash'}{'cust_pkg_svc'} =
1680 $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
1682 } $self->extra_part_svc;
1688 =item extra_part_svc
1690 Returns a list of FS::part_svc objects corresponding to services in this
1691 package which are still provisioned but not (any longer) available in the
1696 sub extra_part_svc {
1699 my $pkgnum = $self->pkgnum;
1700 my $pkgpart = $self->pkgpart;
1703 # 'table' => 'part_svc',
1706 # "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
1707 # WHERE pkg_svc.svcpart = part_svc.svcpart
1708 # AND pkg_svc.pkgpart = ?
1711 # AND 0 < ( SELECT COUNT(*) FROM cust_svc
1712 # LEFT JOIN cust_pkg USING ( pkgnum )
1713 # WHERE cust_svc.svcpart = part_svc.svcpart
1716 # 'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
1719 #seems to benchmark slightly faster...
1721 'select' => 'DISTINCT ON (svcpart) part_svc.*',
1722 'table' => 'part_svc',
1724 'LEFT JOIN pkg_svc ON ( pkg_svc.svcpart = part_svc.svcpart
1725 AND pkg_svc.pkgpart = ?
1728 LEFT JOIN cust_svc ON ( cust_svc.svcpart = part_svc.svcpart )
1729 LEFT JOIN cust_pkg USING ( pkgnum )
1732 'extra_sql' => "WHERE pkgsvcnum IS NULL AND cust_pkg.pkgnum = ? ",
1733 'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
1739 Returns a short status string for this package, currently:
1743 =item not yet billed
1745 =item one-time charge
1760 my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
1762 return 'cancelled' if $self->get('cancel');
1763 return 'suspended' if $self->susp;
1764 return 'not yet billed' unless $self->setup;
1765 return 'one-time charge' if $freq =~ /^(0|$)/;
1771 Class method that returns the list of possible status strings for packages
1772 (see L<the status method|/status>). For example:
1774 @statuses = FS::cust_pkg->statuses();
1778 tie my %statuscolor, 'Tie::IxHash',
1779 'not yet billed' => '000000',
1780 'one-time charge' => '000000',
1781 'active' => '00CC00',
1782 'suspended' => 'FF9900',
1783 'cancelled' => 'FF0000',
1787 my $self = shift; #could be class...
1788 #grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
1789 # # mayble split btw one-time vs. recur
1795 Returns a hex triplet color string for this package's status.
1801 $statuscolor{$self->status};
1806 Returns a label for this package. (Currently "pkgnum: pkg - comment" or
1807 "pkg-comment" depending on user preference).
1813 my $label = $self->part_pkg->pkg_comment( 'nopkgpart' => 1 );
1814 $label = $self->pkgnum. ": $label"
1815 if $FS::CurrentUser::CurrentUser->option('show_pkgnum');
1819 =item pkg_label_long
1821 Returns a long label for this package, adding the primary service's label to
1826 sub pkg_label_long {
1828 my $label = $self->pkg_label;
1829 my $cust_svc = $self->primary_cust_svc;
1830 $label .= ' ('. ($cust_svc->label)[1]. ')' if $cust_svc;
1834 =item primary_cust_svc
1836 Returns a primary service (as FS::cust_svc object) if one can be identified.
1840 #for labeling purposes - might not 100% match up with part_pkg->svcpart's idea
1842 sub primary_cust_svc {
1845 my @cust_svc = $self->cust_svc;
1847 return '' unless @cust_svc; #no serivces - irrelevant then
1849 return $cust_svc[0] if scalar(@cust_svc) == 1; #always return a single service
1851 # primary service as specified in the package definition
1852 # or exactly one service definition with quantity one
1853 my $svcpart = $self->part_pkg->svcpart;
1854 @cust_svc = grep { $_->svcpart == $svcpart } @cust_svc;
1855 return $cust_svc[0] if scalar(@cust_svc) == 1;
1857 #couldn't identify one thing..
1863 Returns a list of lists, calling the label method for all services
1864 (see L<FS::cust_svc>) of this billing item.
1870 map { [ $_->label ] } $self->cust_svc;
1873 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
1875 Like the labels method, but returns historical information on services that
1876 were active as of END_TIMESTAMP and (optionally) not cancelled before
1879 Returns a list of lists, calling the label method for all (historical) services
1880 (see L<FS::h_cust_svc>) of this billing item.
1886 map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
1891 Like labels, except returns a simple flat list, and shortens long
1892 (currently >5 or the cust_bill-max_same_services configuration value) lists of
1893 identical services to one line that lists the service label and the number of
1894 individual services rather than individual items.
1899 shift->_labels_short( 'labels', @_ );
1902 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
1904 Like h_labels, except returns a simple flat list, and shortens long
1905 (currently >5 or the cust_bill-max_same_services configuration value) lists of
1906 identical services to one line that lists the service label and the number of
1907 individual services rather than individual items.
1911 sub h_labels_short {
1912 shift->_labels_short( 'h_labels', @_ );
1916 my( $self, $method ) = ( shift, shift );
1918 my $conf = new FS::Conf;
1919 my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
1922 #tie %labels, 'Tie::IxHash';
1923 push @{ $labels{$_->[0]} }, $_->[1]
1924 foreach $self->h_labels(@_);
1926 foreach my $label ( keys %labels ) {
1928 my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
1929 my $num = scalar(@values);
1930 if ( $num > $max_same_services ) {
1931 push @labels, "$label ($num)";
1933 if ( $conf->exists('cust_bill-consolidate_services') ) {
1934 # push @labels, "$label: ". join(', ', @values);
1936 my $detail = "$label: ";
1937 $detail .= shift(@values). ', '
1938 while @values && length($detail.$values[0]) < 78;
1940 push @labels, $detail;
1943 push @labels, map { "$label: $_" } @values;
1954 Returns the parent customer object (see L<FS::cust_main>).
1960 qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
1965 Returns the location object, if any (see L<FS::cust_location>).
1971 return '' unless $self->locationnum;
1972 qsearchs( 'cust_location', { 'locationnum' => $self->locationnum } );
1975 =item cust_location_or_main
1977 If this package is associated with a location, returns the locaiton (see
1978 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
1982 sub cust_location_or_main {
1984 $self->cust_location || $self->cust_main;
1987 =item location_label [ OPTION => VALUE ... ]
1989 Returns the label of the location object (see L<FS::cust_location>).
1993 sub location_label {
1995 my $object = $self->cust_location_or_main;
1996 $object->location_label(@_);
1999 =item seconds_since TIMESTAMP
2001 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
2002 package have been online since TIMESTAMP, according to the session monitor.
2004 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
2005 L<Time::Local> and L<Date::Parse> for conversion functions.
2010 my($self, $since) = @_;
2013 foreach my $cust_svc (
2014 grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
2016 $seconds += $cust_svc->seconds_since($since);
2023 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2025 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
2026 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
2029 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2030 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2036 sub seconds_since_sqlradacct {
2037 my($self, $start, $end) = @_;
2041 foreach my $cust_svc (
2043 my $part_svc = $_->part_svc;
2044 $part_svc->svcdb eq 'svc_acct'
2045 && scalar($part_svc->part_export('sqlradius'));
2048 $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
2055 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2057 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2058 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2062 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2063 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2068 sub attribute_since_sqlradacct {
2069 my($self, $start, $end, $attrib) = @_;
2073 foreach my $cust_svc (
2075 my $part_svc = $_->part_svc;
2076 $part_svc->svcdb eq 'svc_acct'
2077 && scalar($part_svc->part_export('sqlradius'));
2080 $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
2092 my( $self, $value ) = @_;
2093 if ( defined($value) ) {
2094 $self->setfield('quantity', $value);
2096 $self->getfield('quantity') || 1;
2099 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
2101 Transfers as many services as possible from this package to another package.
2103 The destination package can be specified by pkgnum by passing an FS::cust_pkg
2104 object. The destination package must already exist.
2106 Services are moved only if the destination allows services with the correct
2107 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true. Use
2108 this option with caution! No provision is made for export differences
2109 between the old and new service definitions. Probably only should be used
2110 when your exports for all service definitions of a given svcdb are identical.
2111 (attempt a transfer without it first, to move all possible svcpart-matching
2114 Any services that can't be moved remain in the original package.
2116 Returns an error, if there is one; otherwise, returns the number of services
2117 that couldn't be moved.
2122 my ($self, $dest_pkgnum, %opt) = @_;
2128 if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
2129 $dest = $dest_pkgnum;
2130 $dest_pkgnum = $dest->pkgnum;
2132 $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
2135 return ('Package does not exist: '.$dest_pkgnum) unless $dest;
2137 foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
2138 $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
2141 foreach my $cust_svc ($dest->cust_svc) {
2142 $target{$cust_svc->svcpart}--;
2145 my %svcpart2svcparts = ();
2146 if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2147 warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
2148 foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
2149 next if exists $svcpart2svcparts{$svcpart};
2150 my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
2151 $svcpart2svcparts{$svcpart} = [
2153 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
2155 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
2156 'svcpart' => $_ } );
2158 $pkg_svc ? $pkg_svc->primary_svc : '',
2159 $pkg_svc ? $pkg_svc->quantity : 0,
2163 grep { $_ != $svcpart }
2165 qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
2167 warn "alternates for svcpart $svcpart: ".
2168 join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
2173 foreach my $cust_svc ($self->cust_svc) {
2174 if($target{$cust_svc->svcpart} > 0) {
2175 $target{$cust_svc->svcpart}--;
2176 my $new = new FS::cust_svc { $cust_svc->hash };
2177 $new->pkgnum($dest_pkgnum);
2178 my $error = $new->replace($cust_svc);
2179 return $error if $error;
2180 } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2182 warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
2183 warn "alternates to consider: ".
2184 join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
2186 my @alternate = grep {
2187 warn "considering alternate svcpart $_: ".
2188 "$target{$_} available in new package\n"
2191 } @{$svcpart2svcparts{$cust_svc->svcpart}};
2193 warn "alternate(s) found\n" if $DEBUG;
2194 my $change_svcpart = $alternate[0];
2195 $target{$change_svcpart}--;
2196 my $new = new FS::cust_svc { $cust_svc->hash };
2197 $new->svcpart($change_svcpart);
2198 $new->pkgnum($dest_pkgnum);
2199 my $error = $new->replace($cust_svc);
2200 return $error if $error;
2213 This method is deprecated. See the I<depend_jobnum> option to the insert and
2214 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
2221 local $SIG{HUP} = 'IGNORE';
2222 local $SIG{INT} = 'IGNORE';
2223 local $SIG{QUIT} = 'IGNORE';
2224 local $SIG{TERM} = 'IGNORE';
2225 local $SIG{TSTP} = 'IGNORE';
2226 local $SIG{PIPE} = 'IGNORE';
2228 my $oldAutoCommit = $FS::UID::AutoCommit;
2229 local $FS::UID::AutoCommit = 0;
2232 foreach my $cust_svc ( $self->cust_svc ) {
2233 #false laziness w/svc_Common::insert
2234 my $svc_x = $cust_svc->svc_x;
2235 foreach my $part_export ( $cust_svc->part_svc->part_export ) {
2236 my $error = $part_export->export_insert($svc_x);
2238 $dbh->rollback if $oldAutoCommit;
2244 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2251 Associates this package with a (suspension or cancellation) reason (see
2252 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
2255 Available options are:
2261 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.
2265 the access_user (see L<FS::access_user>) providing the reason
2273 the action (cancel, susp, adjourn, expire) associated with the reason
2277 If there is an error, returns the error, otherwise returns false.
2282 my ($self, %options) = @_;
2284 my $otaker = $options{reason_otaker} ||
2285 $FS::CurrentUser::CurrentUser->username;
2288 if ( $options{'reason'} =~ /^(\d+)$/ ) {
2292 } elsif ( ref($options{'reason'}) ) {
2294 return 'Enter a new reason (or select an existing one)'
2295 unless $options{'reason'}->{'reason'} !~ /^\s*$/;
2297 my $reason = new FS::reason({
2298 'reason_type' => $options{'reason'}->{'typenum'},
2299 'reason' => $options{'reason'}->{'reason'},
2301 my $error = $reason->insert;
2302 return $error if $error;
2304 $reasonnum = $reason->reasonnum;
2307 return "Unparsable reason: ". $options{'reason'};
2310 my $cust_pkg_reason =
2311 new FS::cust_pkg_reason({ 'pkgnum' => $self->pkgnum,
2312 'reasonnum' => $reasonnum,
2313 'otaker' => $otaker,
2314 'action' => substr(uc($options{'action'}),0,1),
2315 'date' => $options{'date'}
2320 $cust_pkg_reason->insert;
2323 =item insert_discount
2325 Associates this package with a discount (see L<FS::cust_pkg_discount>, possibly
2326 inserting a new discount on the fly (see L<FS::discount>).
2328 Available options are:
2336 If there is an error, returns the error, otherwise returns false.
2340 sub insert_discount {
2341 #my ($self, %options) = @_;
2344 my $cust_pkg_discount = new FS::cust_pkg_discount {
2345 'pkgnum' => $self->pkgnum,
2346 'discountnum' => $self->discountnum,
2348 'end_date' => '', #XXX
2349 'otaker' => $self->otaker,
2350 #for the create a new discount case
2351 '_type' => $self->discountnum__type,
2352 'amount' => $self->discountnum_amount,
2353 'percent' => $self->discountnum_percent,
2354 'months' => $self->discountnum_months,
2355 #'disabled' => $self->discountnum_disabled,
2358 $cust_pkg_discount->insert;
2361 =item set_usage USAGE_VALUE_HASHREF
2363 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2364 to which they should be set (see L<FS::svc_acct>). Currently seconds,
2365 upbytes, downbytes, and totalbytes are appropriate keys.
2367 All svc_accts which are part of this package have their values reset.
2372 my ($self, $valueref, %opt) = @_;
2374 foreach my $cust_svc ($self->cust_svc){
2375 my $svc_x = $cust_svc->svc_x;
2376 $svc_x->set_usage($valueref, %opt)
2377 if $svc_x->can("set_usage");
2381 =item recharge USAGE_VALUE_HASHREF
2383 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2384 to which they should be set (see L<FS::svc_acct>). Currently seconds,
2385 upbytes, downbytes, and totalbytes are appropriate keys.
2387 All svc_accts which are part of this package have their values incremented.
2392 my ($self, $valueref) = @_;
2394 foreach my $cust_svc ($self->cust_svc){
2395 my $svc_x = $cust_svc->svc_x;
2396 $svc_x->recharge($valueref)
2397 if $svc_x->can("recharge");
2401 =item cust_pkg_discount
2405 sub cust_pkg_discount {
2407 qsearch('cust_pkg_discount', { 'pkgnum' => $self->pkgnum } );
2410 =item cust_pkg_discount_active
2414 sub cust_pkg_discount_active {
2416 grep { $_->status eq 'active' } $self->cust_pkg_discount;
2421 =head1 CLASS METHODS
2427 Returns an SQL expression identifying recurring packages.
2431 sub recurring_sql { "
2432 '0' != ( select freq from part_pkg
2433 where cust_pkg.pkgpart = part_pkg.pkgpart )
2438 Returns an SQL expression identifying one-time packages.
2443 '0' = ( select freq from part_pkg
2444 where cust_pkg.pkgpart = part_pkg.pkgpart )
2449 Returns an SQL expression identifying active packages.
2454 ". $_[0]->recurring_sql(). "
2455 AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
2456 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2457 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
2460 =item not_yet_billed_sql
2462 Returns an SQL expression identifying packages which have not yet been billed.
2466 sub not_yet_billed_sql { "
2467 ( cust_pkg.setup IS NULL OR cust_pkg.setup = 0 )
2468 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2469 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
2474 Returns an SQL expression identifying inactive packages (one-time packages
2475 that are otherwise unsuspended/uncancelled).
2479 sub inactive_sql { "
2480 ". $_[0]->onetime_sql(). "
2481 AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
2482 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2483 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
2489 Returns an SQL expression identifying suspended packages.
2493 sub suspended_sql { susp_sql(@_); }
2495 #$_[0]->recurring_sql(). ' AND '.
2497 ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2498 AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0
2505 Returns an SQL exprression identifying cancelled packages.
2509 sub cancelled_sql { cancel_sql(@_); }
2511 #$_[0]->recurring_sql(). ' AND '.
2512 "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
2515 =item search HASHREF
2519 Returns a qsearch hash expression to search for parameters specified in HASHREF.
2520 Valid parameters are
2528 active, inactive, suspended, cancel (or cancelled)
2532 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
2536 boolean selects custom packages
2542 pkgpart or arrayref or hashref of pkgparts
2546 arrayref of beginning and ending epoch date
2550 arrayref of beginning and ending epoch date
2554 arrayref of beginning and ending epoch date
2558 arrayref of beginning and ending epoch date
2562 arrayref of beginning and ending epoch date
2566 arrayref of beginning and ending epoch date
2570 arrayref of beginning and ending epoch date
2574 pkgnum or APKG_pkgnum
2578 a value suited to passing to FS::UI::Web::cust_header
2582 specifies the user for agent virtualization
2589 my ($class, $params) = @_;
2596 if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2598 "cust_main.agentnum = $1";
2605 if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
2607 "cust_pkg.custnum = $1";
2614 if ( $params->{'magic'} eq 'active'
2615 || $params->{'status'} eq 'active' ) {
2617 push @where, FS::cust_pkg->active_sql();
2619 } elsif ( $params->{'magic'} =~ /^not[ _]yet[ _]billed$/
2620 || $params->{'status'} =~ /^not[ _]yet[ _]billed$/ ) {
2622 push @where, FS::cust_pkg->not_yet_billed_sql();
2624 } elsif ( $params->{'magic'} =~ /^(one-time charge|inactive)/
2625 || $params->{'status'} =~ /^(one-time charge|inactive)/ ) {
2627 push @where, FS::cust_pkg->inactive_sql();
2629 } elsif ( $params->{'magic'} eq 'suspended'
2630 || $params->{'status'} eq 'suspended' ) {
2632 push @where, FS::cust_pkg->suspended_sql();
2634 } elsif ( $params->{'magic'} =~ /^cancell?ed$/
2635 || $params->{'status'} =~ /^cancell?ed$/ ) {
2637 push @where, FS::cust_pkg->cancelled_sql();
2642 # parse package class
2645 #false lazinessish w/graph/cust_bill_pkg.cgi
2648 if ( exists($params->{'classnum'})
2649 && $params->{'classnum'} =~ /^(\d*)$/
2653 if ( $classnum ) { #a specific class
2654 push @where, "part_pkg.classnum = $classnum";
2656 #@pkg_class = ( qsearchs('pkg_class', { 'classnum' => $classnum } ) );
2657 #die "classnum $classnum not found!" unless $pkg_class[0];
2658 #$title .= $pkg_class[0]->classname.' ';
2660 } elsif ( $classnum eq '' ) { #the empty class
2662 push @where, "part_pkg.classnum IS NULL";
2663 #$title .= 'Empty class ';
2664 #@pkg_class = ( '(empty class)' );
2665 } elsif ( $classnum eq '0' ) {
2666 #@pkg_class = qsearch('pkg_class', {} ); # { 'disabled' => '' } );
2667 #push @pkg_class, '(empty class)';
2669 die "illegal classnum";
2675 # parse package report options
2678 my @report_option = ();
2679 if ( exists($params->{'report_option'})
2680 && $params->{'report_option'} =~ /^([,\d]*)$/
2683 @report_option = split(',', $1);
2686 if (@report_option) {
2687 # this will result in the empty set for the dangling comma case as it should
2689 map{ "0 < ( SELECT count(*) FROM part_pkg_option
2690 WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
2691 AND optionname = 'report_option_$_'
2692 AND optionvalue = '1' )"
2702 push @where, "part_pkg.custom = 'Y'" if $params->{custom};
2708 if ( exists($params->{'censustract'}) ) {
2709 $params->{'censustract'} =~ /^([.\d]*)$/;
2710 my $censustract = "cust_main.censustract = '$1'";
2711 $censustract .= ' OR cust_main.censustract is NULL' unless $1;
2712 push @where, "( $censustract )";
2719 if ( ref($params->{'pkgpart'}) ) {
2722 if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
2723 @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
2724 } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
2725 @pkgpart = @{ $params->{'pkgpart'} };
2727 die 'unhandled pkgpart ref '. $params->{'pkgpart'};
2730 @pkgpart = grep /^(\d+)$/, @pkgpart;
2732 push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
2734 } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
2735 push @where, "pkgpart = $1";
2744 #false laziness w/report_cust_pkg.html
2747 'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
2748 'active' => { 'susp'=>1, 'cancel'=>1 },
2749 'suspended' => { 'cancel' => 1 },
2754 foreach my $field (qw( setup last_bill bill adjourn susp expire cancel )) {
2756 next unless exists($params->{$field});
2758 my($beginning, $ending) = @{$params->{$field}};
2760 next if $beginning == 0 && $ending == 4294967295;
2763 "cust_pkg.$field IS NOT NULL",
2764 "cust_pkg.$field >= $beginning",
2765 "cust_pkg.$field <= $ending";
2767 $orderby ||= "ORDER BY cust_pkg.$field";
2771 $orderby ||= 'ORDER BY bill';
2774 # parse magic, legacy, etc.
2777 if ( $params->{'magic'} &&
2778 $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
2781 $orderby = 'ORDER BY pkgnum';
2783 if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
2784 push @where, "pkgpart = $1";
2787 } elsif ( $params->{'query'} eq 'pkgnum' ) {
2789 $orderby = 'ORDER BY pkgnum';
2791 } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
2793 $orderby = 'ORDER BY pkgnum';
2796 SELECT count(*) FROM pkg_svc
2797 WHERE pkg_svc.pkgpart = cust_pkg.pkgpart
2798 AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
2799 WHERE cust_svc.pkgnum = cust_pkg.pkgnum
2800 AND cust_svc.svcpart = pkg_svc.svcpart
2807 # setup queries, links, subs, etc. for the search
2810 # here is the agent virtualization
2811 if ($params->{CurrentUser}) {
2813 qsearchs('access_user', { username => $params->{CurrentUser} });
2816 push @where, $access_user->agentnums_sql('table'=>'cust_main');
2821 push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
2824 my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
2826 my $addl_from = 'LEFT JOIN cust_main USING ( custnum ) '.
2827 'LEFT JOIN part_pkg USING ( pkgpart ) '.
2828 'LEFT JOIN pkg_class ON ( part_pkg.classnum = pkg_class.classnum ) ';
2830 my $count_query = "SELECT COUNT(*) FROM cust_pkg $addl_from $extra_sql";
2833 'table' => 'cust_pkg',
2835 'select' => join(', ',
2837 ( map "part_pkg.$_", qw( pkg freq ) ),
2838 'pkg_class.classname',
2839 'cust_main.custnum AS cust_main_custnum',
2840 FS::UI::Web::cust_sql_fields(
2841 $params->{'cust_fields'}
2844 'extra_sql' => "$extra_sql $orderby",
2845 'addl_from' => $addl_from,
2846 'count_query' => $count_query,
2853 Returns a list: the first item is an SQL fragment identifying matching
2854 packages/customers via location (taking into account shipping and package
2855 address taxation, if enabled), and subsequent items are the parameters to
2856 substitute for the placeholders in that fragment.
2861 my($class, %opt) = @_;
2862 my $ornull = $opt{'ornull'};
2864 my $conf = new FS::Conf;
2866 # '?' placeholders in _location_sql_where
2867 my $x = $ornull ? 3 : 2;
2868 my @bill_param = ( ('city')x3, ('county')x$x, ('state')x$x, 'country' );
2872 if ( $conf->exists('tax-ship_address') ) {
2875 ( ( ship_last IS NULL OR ship_last = '' )
2876 AND ". _location_sql_where('cust_main', '', $ornull ). "
2878 OR ( ship_last IS NOT NULL AND ship_last != ''
2879 AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
2882 # AND payby != 'COMP'
2884 @main_param = ( @bill_param, @bill_param );
2888 $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
2889 @main_param = @bill_param;
2895 if ( $conf->exists('tax-pkg_address') ) {
2897 my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
2900 ( cust_pkg.locationnum IS NULL AND $main_where )
2901 OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where )
2904 @param = ( @main_param, @bill_param );
2908 $where = $main_where;
2909 @param = @main_param;
2917 #subroutine, helper for location_sql
2918 sub _location_sql_where {
2920 my $prefix = @_ ? shift : '';
2921 my $ornull = @_ ? shift : '';
2923 # $ornull = $ornull ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
2925 $ornull = $ornull ? ' OR ? IS NULL ' : '';
2927 my $or_empty_city = " OR ( ? = '' AND $table.${prefix}city IS NULL ) ";
2928 my $or_empty_county = " OR ( ? = '' AND $table.${prefix}county IS NULL ) ";
2929 my $or_empty_state = " OR ( ? = '' AND $table.${prefix}state IS NULL ) ";
2931 # ( $table.${prefix}city = ? $or_empty_city $ornull )
2933 ( $table.${prefix}city = ? OR ? = '' OR CAST(? AS text) IS NULL )
2934 AND ( $table.${prefix}county = ? $or_empty_county $ornull )
2935 AND ( $table.${prefix}state = ? $or_empty_state $ornull )
2936 AND $table.${prefix}country = ?
2944 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
2946 CUSTNUM is a customer (see L<FS::cust_main>)
2948 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
2949 L<FS::part_pkg>) to order for this customer. Duplicates are of course
2952 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
2953 remove for this customer. The services (see L<FS::cust_svc>) are moved to the
2954 new billing items. An error is returned if this is not possible (see
2955 L<FS::pkg_svc>). An empty arrayref is equivalent to not specifying this
2958 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
2959 newly-created cust_pkg objects.
2961 REFNUM, if specified, will specify the FS::pkg_referral record to be created
2962 and inserted. Multiple FS::pkg_referral records can be created by
2963 setting I<refnum> to an array reference of refnums or a hash reference with
2964 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
2965 record will be created corresponding to cust_main.refnum.
2970 my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
2972 my $conf = new FS::Conf;
2974 # Transactionize this whole mess
2975 local $SIG{HUP} = 'IGNORE';
2976 local $SIG{INT} = 'IGNORE';
2977 local $SIG{QUIT} = 'IGNORE';
2978 local $SIG{TERM} = 'IGNORE';
2979 local $SIG{TSTP} = 'IGNORE';
2980 local $SIG{PIPE} = 'IGNORE';
2982 my $oldAutoCommit = $FS::UID::AutoCommit;
2983 local $FS::UID::AutoCommit = 0;
2987 # my $cust_main = qsearchs('cust_main', { custnum => $custnum });
2988 # return "Customer not found: $custnum" unless $cust_main;
2990 warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
2993 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
2996 my $change = scalar(@old_cust_pkg) != 0;
2999 if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
3001 warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
3002 " to pkgpart ". $pkgparts->[0]. "\n"
3005 my $err_or_cust_pkg =
3006 $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
3007 'refnum' => $refnum,
3010 unless (ref($err_or_cust_pkg)) {
3011 $dbh->rollback if $oldAutoCommit;
3012 return $err_or_cust_pkg;
3015 push @$return_cust_pkg, $err_or_cust_pkg;
3016 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3021 # Create the new packages.
3022 foreach my $pkgpart (@$pkgparts) {
3024 warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
3026 my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
3027 pkgpart => $pkgpart,
3031 $error = $cust_pkg->insert( 'change' => $change );
3033 $dbh->rollback if $oldAutoCommit;
3036 push @$return_cust_pkg, $cust_pkg;
3038 # $return_cust_pkg now contains refs to all of the newly
3041 # Transfer services and cancel old packages.
3042 foreach my $old_pkg (@old_cust_pkg) {
3044 warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
3047 foreach my $new_pkg (@$return_cust_pkg) {
3048 $error = $old_pkg->transfer($new_pkg);
3049 if ($error and $error == 0) {
3050 # $old_pkg->transfer failed.
3051 $dbh->rollback if $oldAutoCommit;
3056 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
3057 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
3058 foreach my $new_pkg (@$return_cust_pkg) {
3059 $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
3060 if ($error and $error == 0) {
3061 # $old_pkg->transfer failed.
3062 $dbh->rollback if $oldAutoCommit;
3069 # Transfers were successful, but we went through all of the
3070 # new packages and still had services left on the old package.
3071 # We can't cancel the package under the circumstances, so abort.
3072 $dbh->rollback if $oldAutoCommit;
3073 return "Unable to transfer all services from package ".$old_pkg->pkgnum;
3075 $error = $old_pkg->cancel( quiet=>1 );
3081 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3085 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
3087 A bulk change method to change packages for multiple customers.
3089 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
3090 L<FS::part_pkg>) to order for each customer. Duplicates are of course
3093 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
3094 replace. The services (see L<FS::cust_svc>) are moved to the
3095 new billing items. An error is returned if this is not possible (see
3098 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
3099 newly-created cust_pkg objects.
3104 my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
3106 # Transactionize this whole mess
3107 local $SIG{HUP} = 'IGNORE';
3108 local $SIG{INT} = 'IGNORE';
3109 local $SIG{QUIT} = 'IGNORE';
3110 local $SIG{TERM} = 'IGNORE';
3111 local $SIG{TSTP} = 'IGNORE';
3112 local $SIG{PIPE} = 'IGNORE';
3114 my $oldAutoCommit = $FS::UID::AutoCommit;
3115 local $FS::UID::AutoCommit = 0;
3119 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
3122 while(scalar(@old_cust_pkg)) {
3124 my $custnum = $old_cust_pkg[0]->custnum;
3125 my (@remove) = map { $_->pkgnum }
3126 grep { $_->custnum == $custnum } @old_cust_pkg;
3127 @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
3129 my $error = order $custnum, $pkgparts, \@remove, \@return;
3131 push @errors, $error
3133 push @$return_cust_pkg, @return;
3136 if (scalar(@errors)) {
3137 $dbh->rollback if $oldAutoCommit;
3138 return join(' / ', @errors);
3141 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3149 sub order is not OO. Perhaps it should be moved to FS::cust_main and made so?
3151 In sub order, the @pkgparts array (passed by reference) is clobbered.
3153 Also in sub order, no money is adjusted. Once FS::part_pkg defines a standard
3154 method to pass dates to the recur_prog expression, it should do so.
3156 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
3157 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
3158 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
3159 configuration values. Probably need a subroutine which decides what to do
3160 based on whether or not we've fetched the user yet, rather than a hash. See
3161 FS::UID and the TODO.
3163 Now that things are transactional should the check in the insert method be
3168 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
3169 L<FS::pkg_svc>, schema.html from the base documentation