4 use vars qw(@ISA $disable_agentcheck $DEBUG $me);
6 use Scalar::Util qw( blessed );
7 use List::Util qw(max);
10 use FS::UID qw( getotaker dbh );
11 use FS::Misc qw( send_email );
12 use FS::Record qw( qsearch qsearchs );
14 use FS::cust_main_Mixin;
18 use FS::cust_location;
20 use FS::cust_bill_pkg;
21 use FS::cust_pkg_detail;
26 use FS::cust_pkg_reason;
28 use FS::cust_pkg_discount;
32 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
34 # because they load configuration by setting FS::UID::callback (see TODO)
40 # for sending cancel emails in sub cancel
43 @ISA = qw( FS::m2m_Common FS::cust_main_Mixin FS::option_Common FS::Record );
46 $me = '[FS::cust_pkg]';
48 $disable_agentcheck = 0;
52 my ( $hashref, $cache ) = @_;
53 #if ( $hashref->{'pkgpart'} ) {
54 if ( $hashref->{'pkg'} ) {
55 # #@{ $self->{'_pkgnum'} } = ();
56 # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
57 # $self->{'_pkgpart'} = $subcache;
58 # #push @{ $self->{'_pkgnum'} },
59 # FS::part_pkg->new_or_cached($hashref, $subcache);
60 $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
62 if ( exists $hashref->{'svcnum'} ) {
63 #@{ $self->{'_pkgnum'} } = ();
64 my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
65 $self->{'_svcnum'} = $subcache;
66 #push @{ $self->{'_pkgnum'} },
67 FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
73 FS::cust_pkg - Object methods for cust_pkg objects
79 $record = new FS::cust_pkg \%hash;
80 $record = new FS::cust_pkg { 'column' => 'value' };
82 $error = $record->insert;
84 $error = $new_record->replace($old_record);
86 $error = $record->delete;
88 $error = $record->check;
90 $error = $record->cancel;
92 $error = $record->suspend;
94 $error = $record->unsuspend;
96 $part_pkg = $record->part_pkg;
98 @labels = $record->labels;
100 $seconds = $record->seconds_since($timestamp);
102 $error = FS::cust_pkg::order( $custnum, \@pkgparts );
103 $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
107 An FS::cust_pkg object represents a customer billing item. FS::cust_pkg
108 inherits from FS::Record. The following fields are currently supported:
114 Primary key (assigned automatically for new billing items)
118 Customer (see L<FS::cust_main>)
122 Billing item definition (see L<FS::part_pkg>)
126 Optional link to package location (see L<FS::location>)
138 date (next bill date)
162 order taker (assigned automatically if null, see L<FS::UID>)
166 If this field is set to 1, disables the automatic
167 unsuspension of this package when using the B<unsuspendauto> config option.
171 If not set, defaults to 1
175 Date of change from previous package
185 =item change_locationnum
191 Note: setup, last_bill, bill, adjourn, susp, expire, cancel and change_date
192 are specified as UNIX timestamps; see L<perlfunc/"time">. Also see
193 L<Time::Local> and L<Date::Parse> for conversion functions.
201 Create a new billing item. To add the item to the database, see L<"insert">.
205 sub table { 'cust_pkg'; }
206 sub cust_linked { $_[0]->cust_main_custnum; }
207 sub cust_unlinked_msg {
209 "WARNING: can't find cust_main.custnum ". $self->custnum.
210 ' (cust_pkg.pkgnum '. $self->pkgnum. ')';
213 =item insert [ OPTION => VALUE ... ]
215 Adds this billing item to the database ("Orders" the item). If there is an
216 error, returns the error, otherwise returns false.
218 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
219 will be used to look up the package definition and agent restrictions will be
222 If the additional field I<refnum> is defined, an FS::pkg_referral record will
223 be created and inserted. Multiple FS::pkg_referral records can be created by
224 setting I<refnum> to an array reference of refnums or a hash reference with
225 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
226 record will be created corresponding to cust_main.refnum.
228 The following options are available:
234 If set true, supresses any referral credit to a referring customer.
238 cust_pkg_option records will be created
242 a ticket will be added to this customer with this subject
246 an optional queue name for ticket additions
253 my( $self, %options ) = @_;
255 local $SIG{HUP} = 'IGNORE';
256 local $SIG{INT} = 'IGNORE';
257 local $SIG{QUIT} = 'IGNORE';
258 local $SIG{TERM} = 'IGNORE';
259 local $SIG{TSTP} = 'IGNORE';
260 local $SIG{PIPE} = 'IGNORE';
262 my $oldAutoCommit = $FS::UID::AutoCommit;
263 local $FS::UID::AutoCommit = 0;
266 my $error = $self->SUPER::insert($options{options} ? %{$options{options}} : ());
268 $dbh->rollback if $oldAutoCommit;
272 $self->refnum($self->cust_main->refnum) unless $self->refnum;
273 $self->refnum( [ $self->refnum ] ) unless ref($self->refnum);
274 $self->process_m2m( 'link_table' => 'pkg_referral',
275 'target_table' => 'part_referral',
276 'params' => $self->refnum,
279 if ( $self->discountnum ) {
280 my $error = $self->insert_discount();
282 $dbh->rollback if $oldAutoCommit;
287 #if ( $self->reg_code ) {
288 # my $reg_code = qsearchs('reg_code', { 'code' => $self->reg_code } );
289 # $error = $reg_code->delete;
291 # $dbh->rollback if $oldAutoCommit;
296 my $conf = new FS::Conf;
298 if ( $conf->config('ticket_system') && $options{ticket_subject} ) {
301 # use lib ( "/opt/rt3/local/lib", "/opt/rt3/lib" );
308 use FS::TicketSystem;
309 FS::TicketSystem->init();
311 my $q = new RT::Queue($RT::SystemUser);
312 $q->Load($options{ticket_queue}) if $options{ticket_queue};
313 my $t = new RT::Ticket($RT::SystemUser);
314 my $mime = new MIME::Entity;
315 $mime->build( Type => 'text/plain', Data => $options{ticket_subject} );
316 $t->Create( $options{ticket_queue} ? (Queue => $q) : (),
317 Subject => $options{ticket_subject},
320 $t->AddLink( Type => 'MemberOf',
321 Target => 'freeside://freeside/cust_main/'. $self->custnum,
325 if ($conf->config('welcome_letter') && $self->cust_main->num_pkgs == 1) {
326 my $queue = new FS::queue {
327 'job' => 'FS::cust_main::queueable_print',
329 $error = $queue->insert(
330 'custnum' => $self->custnum,
331 'template' => 'welcome_letter',
335 warn "can't send welcome letter: $error";
340 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
347 This method now works but you probably shouldn't use it.
349 You don't want to delete billing items, because there would then be no record
350 the customer ever purchased the item. Instead, see the cancel method.
355 # return "Can't delete cust_pkg records!";
358 =item replace [ OLD_RECORD ] [ HASHREF | OPTION => VALUE ... ]
360 Replaces the OLD_RECORD with this one in the database. If there is an error,
361 returns the error, otherwise returns false.
363 Currently, custnum, setup, bill, adjourn, susp, expire, and cancel may be changed.
365 Changing pkgpart may have disasterous effects. See the order subroutine.
367 setup and bill are normally updated by calling the bill method of a customer
368 object (see L<FS::cust_main>).
370 suspend is normally updated by the suspend and unsuspend methods.
372 cancel is normally updated by the cancel method (and also the order subroutine
375 Available options are:
381 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.
385 the access_user (see L<FS::access_user>) providing the reason
389 hashref of keys and values - cust_pkg_option records will be created, updated or removed as appopriate
398 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
403 ( ref($_[0]) eq 'HASH' )
407 #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
408 return "Can't change otaker!" if $old->otaker ne $new->otaker;
411 #return "Can't change setup once it exists!"
412 # if $old->getfield('setup') &&
413 # $old->getfield('setup') != $new->getfield('setup');
415 #some logic for bill, susp, cancel?
417 local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
419 local $SIG{HUP} = 'IGNORE';
420 local $SIG{INT} = 'IGNORE';
421 local $SIG{QUIT} = 'IGNORE';
422 local $SIG{TERM} = 'IGNORE';
423 local $SIG{TSTP} = 'IGNORE';
424 local $SIG{PIPE} = 'IGNORE';
426 my $oldAutoCommit = $FS::UID::AutoCommit;
427 local $FS::UID::AutoCommit = 0;
430 foreach my $method ( qw(adjourn expire) ) { # How many reasons?
431 if ($options->{'reason'} && $new->$method && $old->$method ne $new->$method) {
432 my $error = $new->insert_reason(
433 'reason' => $options->{'reason'},
434 'date' => $new->$method,
436 'reason_otaker' => $options->{'reason_otaker'},
439 dbh->rollback if $oldAutoCommit;
440 return "Error inserting cust_pkg_reason: $error";
445 #save off and freeze RADIUS attributes for any associated svc_acct records
447 if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
449 #also check for specific exports?
450 # to avoid spurious modify export events
451 @svc_acct = map { $_->svc_x }
452 grep { $_->part_svc->svcdb eq 'svc_acct' }
455 $_->snapshot foreach @svc_acct;
459 my $error = $new->SUPER::replace($old,
460 $options->{options} ? $options->{options} : ()
463 $dbh->rollback if $oldAutoCommit;
467 #for prepaid packages,
468 #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
469 foreach my $old_svc_acct ( @svc_acct ) {
470 my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
471 my $s_error = $new_svc_acct->replace($old_svc_acct);
473 $dbh->rollback if $oldAutoCommit;
478 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
485 Checks all fields to make sure this is a valid billing item. If there is an
486 error, returns the error, otherwise returns false. Called by the insert and
494 $self->locationnum('') if !$self->locationnum || $self->locationnum == -1;
497 $self->ut_numbern('pkgnum')
498 || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
499 || $self->ut_numbern('pkgpart')
500 || $self->ut_foreign_keyn('locationnum', 'cust_location', 'locationnum')
501 || $self->ut_numbern('start_date')
502 || $self->ut_numbern('setup')
503 || $self->ut_numbern('bill')
504 || $self->ut_numbern('susp')
505 || $self->ut_numbern('cancel')
506 || $self->ut_numbern('adjourn')
507 || $self->ut_numbern('expire')
509 return $error if $error;
511 if ( $self->reg_code ) {
513 unless ( grep { $self->pkgpart == $_->pkgpart }
514 map { $_->reg_code_pkg }
515 qsearchs( 'reg_code', { 'code' => $self->reg_code,
516 'agentnum' => $self->cust_main->agentnum })
518 return "Unknown registration code";
521 } elsif ( $self->promo_code ) {
524 qsearchs('part_pkg', {
525 'pkgpart' => $self->pkgpart,
526 'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
528 return 'Unknown promotional code' unless $promo_part_pkg;
532 unless ( $disable_agentcheck ) {
534 qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
535 return "agent ". $agent->agentnum. ':'. $agent->agent.
536 " can't purchase pkgpart ". $self->pkgpart
537 unless $agent->pkgpart_hashref->{ $self->pkgpart }
538 || $agent->agentnum == $self->part_pkg->agentnum;
541 $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
542 return $error if $error;
546 $self->otaker(getotaker) unless $self->otaker;
547 $self->otaker =~ /^(\w{1,32})$/ or return "Illegal otaker";
550 if ( $self->dbdef_table->column('manual_flag') ) {
551 $self->manual_flag('') if $self->manual_flag eq ' ';
552 $self->manual_flag =~ /^([01]?)$/
553 or return "Illegal manual_flag ". $self->manual_flag;
554 $self->manual_flag($1);
560 =item cancel [ OPTION => VALUE ... ]
562 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
563 in this package, then cancels the package itself (sets the cancel field to
566 Available options are:
570 =item quiet - can be set true to supress email cancellation notices.
572 =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.
574 =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.
576 =item date - can be set to a unix style timestamp to specify when to cancel (expire)
578 =item nobill - can be set true to skip billing if it might otherwise be done.
582 If there is an error, returns the error, otherwise returns false.
587 my( $self, %options ) = @_;
590 my $conf = new FS::Conf;
592 warn "cust_pkg::cancel called with options".
593 join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
596 local $SIG{HUP} = 'IGNORE';
597 local $SIG{INT} = 'IGNORE';
598 local $SIG{QUIT} = 'IGNORE';
599 local $SIG{TERM} = 'IGNORE';
600 local $SIG{TSTP} = 'IGNORE';
601 local $SIG{PIPE} = 'IGNORE';
603 my $oldAutoCommit = $FS::UID::AutoCommit;
604 local $FS::UID::AutoCommit = 0;
607 my $old = $self->select_for_update;
609 if ( $old->get('cancel') || $self->get('cancel') ) {
610 dbh->rollback if $oldAutoCommit;
611 return ""; # no error
614 my $date = $options{date} if $options{date}; # expire/cancel later
615 $date = '' if ($date && $date <= time); # complain instead?
617 #race condition: usage could be ongoing until unprovisioned
618 #resolved by performing a change package instead (which unprovisions) and
620 if ( !$options{nobill} && !$date && $conf->exists('bill_usage_on_cancel') ) {
621 my $copy = $self->new({$self->hash});
623 $copy->cust_main->bill( pkg_list => [ $copy ], cancel => 1 );
624 warn "Error billing during cancel, custnum ".
625 #$self->cust_main->custnum. ": $error"
631 my $cancel_time = $options{'time'} || time;
633 if ( $options{'reason'} ) {
634 $error = $self->insert_reason( 'reason' => $options{'reason'},
635 'action' => $date ? 'expire' : 'cancel',
636 'date' => $date ? $date : $cancel_time,
637 'reason_otaker' => $options{'reason_otaker'},
640 dbh->rollback if $oldAutoCommit;
641 return "Error inserting cust_pkg_reason: $error";
647 foreach my $cust_svc (
650 sort { $a->[1] <=> $b->[1] }
651 map { [ $_, $_->svc_x->table_info->{'cancel_weight'} ]; }
652 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
655 my $error = $cust_svc->cancel;
658 $dbh->rollback if $oldAutoCommit;
659 return "Error cancelling cust_svc: $error";
663 # Add a credit for remaining service
664 my $remaining_value = $self->calc_remain(time=>$cancel_time);
665 if ( $remaining_value > 0 && !$options{'no_credit'} ) {
666 my $error = $self->cust_main->credit(
668 'Credit for unused time on '. $self->part_pkg->pkg,
669 'reason_type' => $conf->config('cancel_credit_type'),
672 $dbh->rollback if $oldAutoCommit;
673 return "Error crediting customer \$$remaining_value for unused time on".
674 $self->part_pkg->pkg. ": $error";
679 my %hash = $self->hash;
680 $date ? ($hash{'expire'} = $date) : ($hash{'cancel'} = $cancel_time);
681 my $new = new FS::cust_pkg ( \%hash );
682 $error = $new->replace( $self, options => { $self->options } );
684 $dbh->rollback if $oldAutoCommit;
688 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
689 return '' if $date; #no errors
691 my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
692 if ( !$options{'quiet'} && $conf->exists('emailcancel') && @invoicing_list ) {
693 my $error = send_email(
694 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
695 'to' => \@invoicing_list,
696 'subject' => ( $conf->config('cancelsubject') || 'Cancellation Notice' ),
697 'body' => [ map "$_\n", $conf->config('cancelmessage') ],
699 #should this do something on errors?
706 =item cancel_if_expired [ NOW_TIMESTAMP ]
708 Cancels this package if its expire date has been reached.
712 sub cancel_if_expired {
714 my $time = shift || time;
715 return '' unless $self->expire && $self->expire <= $time;
716 my $error = $self->cancel;
718 return "Error cancelling expired pkg ". $self->pkgnum. " for custnum ".
719 $self->custnum. ": $error";
726 Cancels any pending expiration (sets the expire field to null).
728 If there is an error, returns the error, otherwise returns false.
733 my( $self, %options ) = @_;
736 local $SIG{HUP} = 'IGNORE';
737 local $SIG{INT} = 'IGNORE';
738 local $SIG{QUIT} = 'IGNORE';
739 local $SIG{TERM} = 'IGNORE';
740 local $SIG{TSTP} = 'IGNORE';
741 local $SIG{PIPE} = 'IGNORE';
743 my $oldAutoCommit = $FS::UID::AutoCommit;
744 local $FS::UID::AutoCommit = 0;
747 my $old = $self->select_for_update;
749 my $pkgnum = $old->pkgnum;
750 if ( $old->get('cancel') || $self->get('cancel') ) {
751 dbh->rollback if $oldAutoCommit;
752 return "Can't unexpire cancelled package $pkgnum";
753 # or at least it's pointless
756 unless ( $old->get('expire') && $self->get('expire') ) {
757 dbh->rollback if $oldAutoCommit;
758 return ""; # no error
761 my %hash = $self->hash;
762 $hash{'expire'} = '';
763 my $new = new FS::cust_pkg ( \%hash );
764 $error = $new->replace( $self, options => { $self->options } );
766 $dbh->rollback if $oldAutoCommit;
770 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
776 =item suspend [ OPTION => VALUE ... ]
778 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
779 package, then suspends the package itself (sets the susp field to now).
781 Available options are:
785 =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.
787 =item date - can be set to a unix style timestamp to specify when to suspend (adjourn)
791 If there is an error, returns the error, otherwise returns false.
796 my( $self, %options ) = @_;
799 local $SIG{HUP} = 'IGNORE';
800 local $SIG{INT} = 'IGNORE';
801 local $SIG{QUIT} = 'IGNORE';
802 local $SIG{TERM} = 'IGNORE';
803 local $SIG{TSTP} = 'IGNORE';
804 local $SIG{PIPE} = 'IGNORE';
806 my $oldAutoCommit = $FS::UID::AutoCommit;
807 local $FS::UID::AutoCommit = 0;
810 my $old = $self->select_for_update;
812 my $pkgnum = $old->pkgnum;
813 if ( $old->get('cancel') || $self->get('cancel') ) {
814 dbh->rollback if $oldAutoCommit;
815 return "Can't suspend cancelled package $pkgnum";
818 if ( $old->get('susp') || $self->get('susp') ) {
819 dbh->rollback if $oldAutoCommit;
820 return ""; # no error # complain on adjourn?
823 my $date = $options{date} if $options{date}; # adjourn/suspend later
824 $date = '' if ($date && $date <= time); # complain instead?
826 if ( $date && $old->get('expire') && $old->get('expire') < $date ) {
827 dbh->rollback if $oldAutoCommit;
828 return "Package $pkgnum expires before it would be suspended.";
831 my $suspend_time = $options{'time'} || time;
833 if ( $options{'reason'} ) {
834 $error = $self->insert_reason( 'reason' => $options{'reason'},
835 'action' => $date ? 'adjourn' : 'suspend',
836 'date' => $date ? $date : $suspend_time,
837 'reason_otaker' => $options{'reason_otaker'},
840 dbh->rollback if $oldAutoCommit;
841 return "Error inserting cust_pkg_reason: $error";
849 foreach my $cust_svc (
850 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
852 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
854 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
855 $dbh->rollback if $oldAutoCommit;
856 return "Illegal svcdb value in part_svc!";
859 require "FS/$svcdb.pm";
861 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
863 $error = $svc->suspend;
865 $dbh->rollback if $oldAutoCommit;
868 my( $label, $value ) = $cust_svc->label;
869 push @labels, "$label: $value";
873 my $conf = new FS::Conf;
874 if ( $conf->config('suspend_email_admin') ) {
876 my $error = send_email(
877 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
878 #invoice_from ??? well as good as any
879 'to' => $conf->config('suspend_email_admin'),
880 'subject' => 'FREESIDE NOTIFICATION: Customer package suspended',
882 "This is an automatic message from your Freeside installation\n",
883 "informing you that the following customer package has been suspended:\n",
885 'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
886 'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
887 ( map { "Service : $_\n" } @labels ),
892 warn "WARNING: can't send suspension admin email (suspending anyway): ".
900 my %hash = $self->hash;
902 $hash{'adjourn'} = $date;
904 $hash{'susp'} = $suspend_time;
906 my $new = new FS::cust_pkg ( \%hash );
907 $error = $new->replace( $self, options => { $self->options } );
909 $dbh->rollback if $oldAutoCommit;
913 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
918 =item unsuspend [ OPTION => VALUE ... ]
920 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
921 package, then unsuspends the package itself (clears the susp field and the
922 adjourn field if it is in the past).
924 Available options are:
928 =item adjust_next_bill
930 Can be set true to adjust the next bill date forward by
931 the amount of time the account was inactive. This was set true by default
932 since 1.4.2 and 1.5.0pre6; however, starting with 1.7.0 this needs to be
933 explicitly requested. Price plans for which this makes sense (anniversary-date
934 based than prorate or subscription) could have an option to enable this
939 If there is an error, returns the error, otherwise returns false.
944 my( $self, %opt ) = @_;
947 local $SIG{HUP} = 'IGNORE';
948 local $SIG{INT} = 'IGNORE';
949 local $SIG{QUIT} = 'IGNORE';
950 local $SIG{TERM} = 'IGNORE';
951 local $SIG{TSTP} = 'IGNORE';
952 local $SIG{PIPE} = 'IGNORE';
954 my $oldAutoCommit = $FS::UID::AutoCommit;
955 local $FS::UID::AutoCommit = 0;
958 my $old = $self->select_for_update;
960 my $pkgnum = $old->pkgnum;
961 if ( $old->get('cancel') || $self->get('cancel') ) {
962 dbh->rollback if $oldAutoCommit;
963 return "Can't unsuspend cancelled package $pkgnum";
966 unless ( $old->get('susp') && $self->get('susp') ) {
967 dbh->rollback if $oldAutoCommit;
968 return ""; # no error # complain instead?
971 foreach my $cust_svc (
972 qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
974 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
976 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
977 $dbh->rollback if $oldAutoCommit;
978 return "Illegal svcdb value in part_svc!";
981 require "FS/$svcdb.pm";
983 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
985 $error = $svc->unsuspend;
987 $dbh->rollback if $oldAutoCommit;
994 my %hash = $self->hash;
995 my $inactive = time - $hash{'susp'};
997 my $conf = new FS::Conf;
999 $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive
1000 if ( $opt{'adjust_next_bill'}
1001 || $conf->exists('unsuspend-always_adjust_next_bill_date') )
1002 && $inactive > 0 && ( $hash{'bill'} || $hash{'setup'} );
1005 $hash{'adjourn'} = '' if $hash{'adjourn'} < time;
1006 my $new = new FS::cust_pkg ( \%hash );
1007 $error = $new->replace( $self, options => { $self->options } );
1009 $dbh->rollback if $oldAutoCommit;
1013 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1020 Cancels any pending suspension (sets the adjourn field to null).
1022 If there is an error, returns the error, otherwise returns false.
1027 my( $self, %options ) = @_;
1030 local $SIG{HUP} = 'IGNORE';
1031 local $SIG{INT} = 'IGNORE';
1032 local $SIG{QUIT} = 'IGNORE';
1033 local $SIG{TERM} = 'IGNORE';
1034 local $SIG{TSTP} = 'IGNORE';
1035 local $SIG{PIPE} = 'IGNORE';
1037 my $oldAutoCommit = $FS::UID::AutoCommit;
1038 local $FS::UID::AutoCommit = 0;
1041 my $old = $self->select_for_update;
1043 my $pkgnum = $old->pkgnum;
1044 if ( $old->get('cancel') || $self->get('cancel') ) {
1045 dbh->rollback if $oldAutoCommit;
1046 return "Can't unadjourn cancelled package $pkgnum";
1047 # or at least it's pointless
1050 if ( $old->get('susp') || $self->get('susp') ) {
1051 dbh->rollback if $oldAutoCommit;
1052 return "Can't unadjourn suspended package $pkgnum";
1053 # perhaps this is arbitrary
1056 unless ( $old->get('adjourn') && $self->get('adjourn') ) {
1057 dbh->rollback if $oldAutoCommit;
1058 return ""; # no error
1061 my %hash = $self->hash;
1062 $hash{'adjourn'} = '';
1063 my $new = new FS::cust_pkg ( \%hash );
1064 $error = $new->replace( $self, options => { $self->options } );
1066 $dbh->rollback if $oldAutoCommit;
1070 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1077 =item change HASHREF | OPTION => VALUE ...
1079 Changes this package: cancels it and creates a new one, with a different
1080 pkgpart or locationnum or both. All services are transferred to the new
1081 package (no change will be made if this is not possible).
1083 Options may be passed as a list of key/value pairs or as a hash reference.
1090 New locationnum, to change the location for this package.
1094 New FS::cust_location object, to create a new location and assign it
1099 New pkgpart (see L<FS::part_pkg>).
1103 New refnum (see L<FS::part_referral>).
1107 At least one option must be specified (otherwise, what's the point?)
1109 Returns either the new FS::cust_pkg object or a scalar error.
1113 my $err_or_new_cust_pkg = $old_cust_pkg->change
1117 #some false laziness w/order
1120 my $opt = ref($_[0]) ? shift : { @_ };
1122 # my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
1125 my $conf = new FS::Conf;
1127 # Transactionize this whole mess
1128 local $SIG{HUP} = 'IGNORE';
1129 local $SIG{INT} = 'IGNORE';
1130 local $SIG{QUIT} = 'IGNORE';
1131 local $SIG{TERM} = 'IGNORE';
1132 local $SIG{TSTP} = 'IGNORE';
1133 local $SIG{PIPE} = 'IGNORE';
1135 my $oldAutoCommit = $FS::UID::AutoCommit;
1136 local $FS::UID::AutoCommit = 0;
1145 #$hash{$_} = $self->$_() foreach qw( last_bill bill );
1147 #$hash{$_} = $self->$_() foreach qw( setup );
1149 $hash{'setup'} = $time if $self->setup;
1151 $hash{'change_date'} = $time;
1152 $hash{"change_$_"} = $self->$_()
1153 foreach qw( pkgnum pkgpart locationnum );
1155 if ( $opt->{'cust_location'} &&
1156 ( ! $opt->{'locationnum'} || $opt->{'locationnum'} == -1 ) ) {
1157 $error = $opt->{'cust_location'}->insert;
1159 $dbh->rollback if $oldAutoCommit;
1160 return "inserting cust_location (transaction rolled back): $error";
1162 $opt->{'locationnum'} = $opt->{'cust_location'}->locationnum;
1165 # Create the new package.
1166 my $cust_pkg = new FS::cust_pkg {
1167 custnum => $self->custnum,
1168 pkgpart => ( $opt->{'pkgpart'} || $self->pkgpart ),
1169 refnum => ( $opt->{'refnum'} || $self->refnum ),
1170 locationnum => ( $opt->{'locationnum'} || $self->locationnum ),
1174 $error = $cust_pkg->insert( 'change' => 1 );
1176 $dbh->rollback if $oldAutoCommit;
1180 # Transfer services and cancel old package.
1182 $error = $self->transfer($cust_pkg);
1183 if ($error and $error == 0) {
1184 # $old_pkg->transfer failed.
1185 $dbh->rollback if $oldAutoCommit;
1189 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1190 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1191 $error = $self->transfer($cust_pkg, 'change_svcpart'=>1 );
1192 if ($error and $error == 0) {
1193 # $old_pkg->transfer failed.
1194 $dbh->rollback if $oldAutoCommit;
1200 # Transfers were successful, but we still had services left on the old
1201 # package. We can't change the package under this circumstances, so abort.
1202 $dbh->rollback if $oldAutoCommit;
1203 return "Unable to transfer all services from package ". $self->pkgnum;
1206 #reset usage if changing pkgpart
1207 # AND usage rollover is off (otherwise adds twice, now and at package bill)
1208 if ($self->pkgpart != $cust_pkg->pkgpart) {
1209 my $part_pkg = $cust_pkg->part_pkg;
1210 $error = $part_pkg->reset_usage($cust_pkg, $part_pkg->is_prepaid
1214 if $part_pkg->can('reset_usage') && ! $part_pkg->option('usage_rollover');
1217 $dbh->rollback if $oldAutoCommit;
1218 return "Error setting usage values: $error";
1222 #Good to go, cancel old package.
1223 $error = $self->cancel( quiet=>1 );
1225 $dbh->rollback if $oldAutoCommit;
1229 if ( $conf->exists('cust_pkg-change_pkgpart-bill_now') ) {
1231 my $error = $cust_pkg->cust_main->bill( 'pkg_list' => [ $cust_pkg ] );
1233 $dbh->rollback if $oldAutoCommit;
1238 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1246 Returns the last bill date, or if there is no last bill date, the setup date.
1247 Useful for billing metered services.
1253 return $self->setfield('last_bill', $_[0]) if @_;
1254 return $self->getfield('last_bill') if $self->getfield('last_bill');
1255 my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
1256 'edate' => $self->bill, } );
1257 $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
1260 =item last_cust_pkg_reason ACTION
1262 Returns the most recent ACTION FS::cust_pkg_reason associated with the package.
1263 Returns false if there is no reason or the package is not currenly ACTION'd
1264 ACTION is one of adjourn, susp, cancel, or expire.
1268 sub last_cust_pkg_reason {
1269 my ( $self, $action ) = ( shift, shift );
1270 my $date = $self->get($action);
1272 'table' => 'cust_pkg_reason',
1273 'hashref' => { 'pkgnum' => $self->pkgnum,
1274 'action' => substr(uc($action), 0, 1),
1277 'order_by' => 'ORDER BY num DESC LIMIT 1',
1281 =item last_reason ACTION
1283 Returns the most recent ACTION FS::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.
1290 my $cust_pkg_reason = shift->last_cust_pkg_reason(@_);
1291 $cust_pkg_reason->reason
1292 if $cust_pkg_reason;
1297 Returns the definition for this billing item, as an FS::part_pkg object (see
1304 return $self->{'_pkgpart'} if $self->{'_pkgpart'};
1305 cluck "cust_pkg->part_pkg called" if $DEBUG > 1;
1306 qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
1311 Returns the cancelled package this package was changed from, if any.
1317 return '' unless $self->change_pkgnum;
1318 qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
1323 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
1330 $self->part_pkg->calc_setup($self, @_);
1335 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
1342 $self->part_pkg->calc_recur($self, @_);
1347 Calls the I<calc_remain> of the FS::part_pkg object associated with this
1354 $self->part_pkg->calc_remain($self, @_);
1359 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
1366 $self->part_pkg->calc_cancel($self, @_);
1371 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
1377 qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
1380 =item cust_pkg_detail [ DETAILTYPE ]
1382 Returns any customer package details for this package (see
1383 L<FS::cust_pkg_detail>).
1385 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
1389 sub cust_pkg_detail {
1391 my %hash = ( 'pkgnum' => $self->pkgnum );
1392 $hash{detailtype} = shift if @_;
1394 'table' => 'cust_pkg_detail',
1395 'hashref' => \%hash,
1396 'order_by' => 'ORDER BY weight, pkgdetailnum',
1400 =item set_cust_pkg_detail DETAILTYPE [ DETAIL, DETAIL, ... ]
1402 Sets customer package details for this package (see L<FS::cust_pkg_detail>).
1404 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
1406 If there is an error, returns the error, otherwise returns false.
1410 sub set_cust_pkg_detail {
1411 my( $self, $detailtype, @details ) = @_;
1413 local $SIG{HUP} = 'IGNORE';
1414 local $SIG{INT} = 'IGNORE';
1415 local $SIG{QUIT} = 'IGNORE';
1416 local $SIG{TERM} = 'IGNORE';
1417 local $SIG{TSTP} = 'IGNORE';
1418 local $SIG{PIPE} = 'IGNORE';
1420 my $oldAutoCommit = $FS::UID::AutoCommit;
1421 local $FS::UID::AutoCommit = 0;
1424 foreach my $current ( $self->cust_pkg_detail($detailtype) ) {
1425 my $error = $current->delete;
1427 $dbh->rollback if $oldAutoCommit;
1428 return "error removing old detail: $error";
1432 foreach my $detail ( @details ) {
1433 my $cust_pkg_detail = new FS::cust_pkg_detail {
1434 'pkgnum' => $self->pkgnum,
1435 'detailtype' => $detailtype,
1436 'detail' => $detail,
1438 my $error = $cust_pkg_detail->insert;
1440 $dbh->rollback if $oldAutoCommit;
1441 return "error adding new detail: $error";
1446 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1453 Returns the new-style customer billing events (see L<FS::cust_event>) for this invoice.
1457 #false laziness w/cust_bill.pm
1461 'table' => 'cust_event',
1462 'addl_from' => 'JOIN part_event USING ( eventpart )',
1463 'hashref' => { 'tablenum' => $self->pkgnum },
1464 'extra_sql' => " AND eventtable = 'cust_pkg' ",
1468 =item num_cust_event
1470 Returns the number of new-style customer billing events (see L<FS::cust_event>) for this invoice.
1474 #false laziness w/cust_bill.pm
1475 sub num_cust_event {
1478 "SELECT COUNT(*) FROM cust_event JOIN part_event USING ( eventpart ) ".
1479 " WHERE tablenum = ? AND eventtable = 'cust_pkg'";
1480 my $sth = dbh->prepare($sql) or die dbh->errstr. " preparing $sql";
1481 $sth->execute($self->pkgnum) or die $sth->errstr. " executing $sql";
1482 $sth->fetchrow_arrayref->[0];
1485 =item cust_svc [ SVCPART ]
1487 Returns the services for this package, as FS::cust_svc objects (see
1488 L<FS::cust_svc>). If a svcpart is specified, return only the matching
1496 return () unless $self->num_cust_svc(@_);
1499 return qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum,
1500 'svcpart' => shift, } );
1503 cluck "cust_pkg->cust_svc called" if $DEBUG > 2;
1505 #if ( $self->{'_svcnum'} ) {
1506 # values %{ $self->{'_svcnum'}->cache };
1508 $self->_sort_cust_svc(
1509 [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
1515 =item overlimit [ SVCPART ]
1517 Returns the services for this package which have exceeded their
1518 usage limit as FS::cust_svc objects (see L<FS::cust_svc>). If a svcpart
1519 is specified, return only the matching services.
1525 return () unless $self->num_cust_svc(@_);
1526 grep { $_->overlimit } $self->cust_svc(@_);
1529 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ]
1531 Returns historical services for this package created before END TIMESTAMP and
1532 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
1533 (see L<FS::h_cust_svc>).
1540 $self->_sort_cust_svc(
1541 [ qsearch( 'h_cust_svc',
1542 { 'pkgnum' => $self->pkgnum, },
1543 FS::h_cust_svc->sql_h_search(@_),
1549 sub _sort_cust_svc {
1550 my( $self, $arrayref ) = @_;
1553 sub ($$) { my ($a, $b) = @_; $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] };
1558 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
1559 'svcpart' => $_->svcpart } );
1561 $pkg_svc ? $pkg_svc->primary_svc : '',
1562 $pkg_svc ? $pkg_svc->quantity : 0,
1569 =item num_cust_svc [ SVCPART ]
1571 Returns the number of provisioned services for this package. If a svcpart is
1572 specified, counts only the matching services.
1579 return $self->{'_num_cust_svc'}
1581 && exists($self->{'_num_cust_svc'})
1582 && $self->{'_num_cust_svc'} =~ /\d/;
1584 cluck "cust_pkg->num_cust_svc called, _num_cust_svc:".$self->{'_num_cust_svc'}
1587 my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
1588 $sql .= ' AND svcpart = ?' if @_;
1590 my $sth = dbh->prepare($sql) or die dbh->errstr;
1591 $sth->execute($self->pkgnum, @_) or die $sth->errstr;
1592 $sth->fetchrow_arrayref->[0];
1595 =item available_part_svc
1597 Returns a list of FS::part_svc objects representing services included in this
1598 package but not yet provisioned. Each FS::part_svc object also has an extra
1599 field, I<num_avail>, which specifies the number of available services.
1603 sub available_part_svc {
1605 grep { $_->num_avail > 0 }
1607 my $part_svc = $_->part_svc;
1608 $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
1609 $_->quantity - $self->num_cust_svc($_->svcpart);
1612 $self->part_pkg->pkg_svc;
1617 Returns a list of FS::part_svc objects representing provisioned and available
1618 services included in this package. Each FS::part_svc object also has the
1619 following extra fields:
1623 =item num_cust_svc (count)
1625 =item num_avail (quantity - count)
1627 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
1630 label -> ($cust_svc->label)[1]
1639 #XXX some sort of sort order besides numeric by svcpart...
1640 my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
1642 my $part_svc = $pkg_svc->part_svc;
1643 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1644 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
1645 $part_svc->{'Hash'}{'num_avail'} =
1646 max( 0, $pkg_svc->quantity - $num_cust_svc );
1647 $part_svc->{'Hash'}{'cust_pkg_svc'} =
1648 $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
1650 } $self->part_pkg->pkg_svc;
1653 push @part_svc, map {
1655 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1656 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
1657 $part_svc->{'Hash'}{'num_avail'} = 0; #0-$num_cust_svc ?
1658 $part_svc->{'Hash'}{'cust_pkg_svc'} =
1659 $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
1661 } $self->extra_part_svc;
1667 =item extra_part_svc
1669 Returns a list of FS::part_svc objects corresponding to services in this
1670 package which are still provisioned but not (any longer) available in the
1675 sub extra_part_svc {
1678 my $pkgnum = $self->pkgnum;
1679 my $pkgpart = $self->pkgpart;
1682 # 'table' => 'part_svc',
1685 # "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
1686 # WHERE pkg_svc.svcpart = part_svc.svcpart
1687 # AND pkg_svc.pkgpart = ?
1690 # AND 0 < ( SELECT COUNT(*) FROM cust_svc
1691 # LEFT JOIN cust_pkg USING ( pkgnum )
1692 # WHERE cust_svc.svcpart = part_svc.svcpart
1695 # 'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
1698 #seems to benchmark slightly faster...
1700 'select' => 'DISTINCT ON (svcpart) part_svc.*',
1701 'table' => 'part_svc',
1703 'LEFT JOIN pkg_svc ON ( pkg_svc.svcpart = part_svc.svcpart
1704 AND pkg_svc.pkgpart = ?
1707 LEFT JOIN cust_svc ON ( cust_svc.svcpart = part_svc.svcpart )
1708 LEFT JOIN cust_pkg USING ( pkgnum )
1711 'extra_sql' => "WHERE pkgsvcnum IS NULL AND cust_pkg.pkgnum = ? ",
1712 'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
1718 Returns a short status string for this package, currently:
1722 =item not yet billed
1724 =item one-time charge
1739 my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
1741 return 'cancelled' if $self->get('cancel');
1742 return 'suspended' if $self->susp;
1743 return 'not yet billed' unless $self->setup;
1744 return 'one-time charge' if $freq =~ /^(0|$)/;
1750 Class method that returns the list of possible status strings for packages
1751 (see L<the status method|/status>). For example:
1753 @statuses = FS::cust_pkg->statuses();
1757 tie my %statuscolor, 'Tie::IxHash',
1758 'not yet billed' => '000000',
1759 'one-time charge' => '000000',
1760 'active' => '00CC00',
1761 'suspended' => 'FF9900',
1762 'cancelled' => 'FF0000',
1766 my $self = shift; #could be class...
1767 #grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
1768 # # mayble split btw one-time vs. recur
1774 Returns a hex triplet color string for this package's status.
1780 $statuscolor{$self->status};
1785 Returns a label for this package. (Currently "pkgnum: pkg - comment" or
1786 "pkg-comment" depending on user preference).
1792 my $label = $self->part_pkg->pkg_comment( 'nopkgpart' => 1 );
1793 $label = $self->pkgnum. ": $label"
1794 if $FS::CurrentUser::CurrentUser->option('show_pkgnum');
1798 =item pkg_label_long
1800 Returns a long label for this package, adding the primary service's label to
1805 sub pkg_label_long {
1807 my $label = $self->pkg_label;
1808 my $cust_svc = $self->primary_cust_svc;
1809 $label .= ' ('. ($cust_svc->label)[1]. ')' if $cust_svc;
1813 =item primary_cust_svc
1815 Returns a primary service (as FS::cust_svc object) if one can be identified.
1819 #for labeling purposes - might not 100% match up with part_pkg->svcpart's idea
1821 sub primary_cust_svc {
1824 my @cust_svc = $self->cust_svc;
1826 return '' unless @cust_svc; #no serivces - irrelevant then
1828 return $cust_svc[0] if scalar(@cust_svc) == 1; #always return a single service
1830 # primary service as specified in the package definition
1831 # or exactly one service definition with quantity one
1832 my $svcpart = $self->part_pkg->svcpart;
1833 @cust_svc = grep { $_->svcpart == $svcpart } @cust_svc;
1834 return $cust_svc[0] if scalar(@cust_svc) == 1;
1836 #couldn't identify one thing..
1842 Returns a list of lists, calling the label method for all services
1843 (see L<FS::cust_svc>) of this billing item.
1849 map { [ $_->label ] } $self->cust_svc;
1852 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
1854 Like the labels method, but returns historical information on services that
1855 were active as of END_TIMESTAMP and (optionally) not cancelled before
1858 Returns a list of lists, calling the label method for all (historical) services
1859 (see L<FS::h_cust_svc>) of this billing item.
1865 map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
1870 Like labels, except returns a simple flat list, and shortens long
1871 (currently >5 or the cust_bill-max_same_services configuration value) lists of
1872 identical services to one line that lists the service label and the number of
1873 individual services rather than individual items.
1878 shift->_labels_short( 'labels', @_ );
1881 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
1883 Like h_labels, except returns a simple flat list, and shortens long
1884 (currently >5 or the cust_bill-max_same_services configuration value) lists of
1885 identical services to one line that lists the service label and the number of
1886 individual services rather than individual items.
1890 sub h_labels_short {
1891 shift->_labels_short( 'h_labels', @_ );
1895 my( $self, $method ) = ( shift, shift );
1897 my $conf = new FS::Conf;
1898 my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
1901 #tie %labels, 'Tie::IxHash';
1902 push @{ $labels{$_->[0]} }, $_->[1]
1903 foreach $self->h_labels(@_);
1905 foreach my $label ( keys %labels ) {
1907 my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
1908 my $num = scalar(@values);
1909 if ( $num > $max_same_services ) {
1910 push @labels, "$label ($num)";
1912 if ( $conf->exists('cust_bill-consolidate_services') ) {
1913 # push @labels, "$label: ". join(', ', @values);
1915 my $detail = "$label: ";
1916 $detail .= shift(@values). ', '
1917 while @values && length($detail.$values[0]) < 78;
1919 push @labels, $detail;
1922 push @labels, map { "$label: $_" } @values;
1933 Returns the parent customer object (see L<FS::cust_main>).
1939 qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
1944 Returns the location object, if any (see L<FS::cust_location>).
1950 return '' unless $self->locationnum;
1951 qsearchs( 'cust_location', { 'locationnum' => $self->locationnum } );
1954 =item cust_location_or_main
1956 If this package is associated with a location, returns the locaiton (see
1957 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
1961 sub cust_location_or_main {
1963 $self->cust_location || $self->cust_main;
1966 =item location_label [ OPTION => VALUE ... ]
1968 Returns the label of the location object (see L<FS::cust_location>).
1972 sub location_label {
1974 my $object = $self->cust_location_or_main;
1975 $object->location_label(@_);
1978 =item seconds_since TIMESTAMP
1980 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
1981 package have been online since TIMESTAMP, according to the session monitor.
1983 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1984 L<Time::Local> and L<Date::Parse> for conversion functions.
1989 my($self, $since) = @_;
1992 foreach my $cust_svc (
1993 grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
1995 $seconds += $cust_svc->seconds_since($since);
2002 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2004 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
2005 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
2008 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2009 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2015 sub seconds_since_sqlradacct {
2016 my($self, $start, $end) = @_;
2020 foreach my $cust_svc (
2022 my $part_svc = $_->part_svc;
2023 $part_svc->svcdb eq 'svc_acct'
2024 && scalar($part_svc->part_export('sqlradius'));
2027 $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
2034 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2036 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2037 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2041 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2042 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2047 sub attribute_since_sqlradacct {
2048 my($self, $start, $end, $attrib) = @_;
2052 foreach my $cust_svc (
2054 my $part_svc = $_->part_svc;
2055 $part_svc->svcdb eq 'svc_acct'
2056 && scalar($part_svc->part_export('sqlradius'));
2059 $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
2071 my( $self, $value ) = @_;
2072 if ( defined($value) ) {
2073 $self->setfield('quantity', $value);
2075 $self->getfield('quantity') || 1;
2078 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
2080 Transfers as many services as possible from this package to another package.
2082 The destination package can be specified by pkgnum by passing an FS::cust_pkg
2083 object. The destination package must already exist.
2085 Services are moved only if the destination allows services with the correct
2086 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true. Use
2087 this option with caution! No provision is made for export differences
2088 between the old and new service definitions. Probably only should be used
2089 when your exports for all service definitions of a given svcdb are identical.
2090 (attempt a transfer without it first, to move all possible svcpart-matching
2093 Any services that can't be moved remain in the original package.
2095 Returns an error, if there is one; otherwise, returns the number of services
2096 that couldn't be moved.
2101 my ($self, $dest_pkgnum, %opt) = @_;
2107 if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
2108 $dest = $dest_pkgnum;
2109 $dest_pkgnum = $dest->pkgnum;
2111 $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
2114 return ('Package does not exist: '.$dest_pkgnum) unless $dest;
2116 foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
2117 $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
2120 foreach my $cust_svc ($dest->cust_svc) {
2121 $target{$cust_svc->svcpart}--;
2124 my %svcpart2svcparts = ();
2125 if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2126 warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
2127 foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
2128 next if exists $svcpart2svcparts{$svcpart};
2129 my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
2130 $svcpart2svcparts{$svcpart} = [
2132 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
2134 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
2135 'svcpart' => $_ } );
2137 $pkg_svc ? $pkg_svc->primary_svc : '',
2138 $pkg_svc ? $pkg_svc->quantity : 0,
2142 grep { $_ != $svcpart }
2144 qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
2146 warn "alternates for svcpart $svcpart: ".
2147 join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
2152 foreach my $cust_svc ($self->cust_svc) {
2153 if($target{$cust_svc->svcpart} > 0) {
2154 $target{$cust_svc->svcpart}--;
2155 my $new = new FS::cust_svc { $cust_svc->hash };
2156 $new->pkgnum($dest_pkgnum);
2157 my $error = $new->replace($cust_svc);
2158 return $error if $error;
2159 } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2161 warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
2162 warn "alternates to consider: ".
2163 join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
2165 my @alternate = grep {
2166 warn "considering alternate svcpart $_: ".
2167 "$target{$_} available in new package\n"
2170 } @{$svcpart2svcparts{$cust_svc->svcpart}};
2172 warn "alternate(s) found\n" if $DEBUG;
2173 my $change_svcpart = $alternate[0];
2174 $target{$change_svcpart}--;
2175 my $new = new FS::cust_svc { $cust_svc->hash };
2176 $new->svcpart($change_svcpart);
2177 $new->pkgnum($dest_pkgnum);
2178 my $error = $new->replace($cust_svc);
2179 return $error if $error;
2192 This method is deprecated. See the I<depend_jobnum> option to the insert and
2193 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
2200 local $SIG{HUP} = 'IGNORE';
2201 local $SIG{INT} = 'IGNORE';
2202 local $SIG{QUIT} = 'IGNORE';
2203 local $SIG{TERM} = 'IGNORE';
2204 local $SIG{TSTP} = 'IGNORE';
2205 local $SIG{PIPE} = 'IGNORE';
2207 my $oldAutoCommit = $FS::UID::AutoCommit;
2208 local $FS::UID::AutoCommit = 0;
2211 foreach my $cust_svc ( $self->cust_svc ) {
2212 #false laziness w/svc_Common::insert
2213 my $svc_x = $cust_svc->svc_x;
2214 foreach my $part_export ( $cust_svc->part_svc->part_export ) {
2215 my $error = $part_export->export_insert($svc_x);
2217 $dbh->rollback if $oldAutoCommit;
2223 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2230 Associates this package with a (suspension or cancellation) reason (see
2231 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
2234 Available options are:
2240 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.
2244 the access_user (see L<FS::access_user>) providing the reason
2252 the action (cancel, susp, adjourn, expire) associated with the reason
2256 If there is an error, returns the error, otherwise returns false.
2261 my ($self, %options) = @_;
2263 my $otaker = $options{reason_otaker} ||
2264 $FS::CurrentUser::CurrentUser->username;
2267 if ( $options{'reason'} =~ /^(\d+)$/ ) {
2271 } elsif ( ref($options{'reason'}) ) {
2273 return 'Enter a new reason (or select an existing one)'
2274 unless $options{'reason'}->{'reason'} !~ /^\s*$/;
2276 my $reason = new FS::reason({
2277 'reason_type' => $options{'reason'}->{'typenum'},
2278 'reason' => $options{'reason'}->{'reason'},
2280 my $error = $reason->insert;
2281 return $error if $error;
2283 $reasonnum = $reason->reasonnum;
2286 return "Unparsable reason: ". $options{'reason'};
2289 my $cust_pkg_reason =
2290 new FS::cust_pkg_reason({ 'pkgnum' => $self->pkgnum,
2291 'reasonnum' => $reasonnum,
2292 'otaker' => $otaker,
2293 'action' => substr(uc($options{'action'}),0,1),
2294 'date' => $options{'date'}
2299 $cust_pkg_reason->insert;
2302 =item insert_discount
2304 Associates this package with a discount (see L<FS::cust_pkg_discount>, possibly
2305 inserting a new discount on the fly (see L<FS::discount>).
2307 Available options are:
2315 If there is an error, returns the error, otherwise returns false.
2319 sub insert_discount {
2320 #my ($self, %options) = @_;
2323 my $cust_pkg_discount = new FS::cust_pkg_discount {
2324 'pkgnum' => $self->pkgnum,
2325 'discountnum' => $self->discountnum,
2327 'end_date' => '', #XXX
2328 'otaker' => $self->otaker,
2329 #for the create a new discount case
2330 '_type' => $self->discountnum__type,
2331 'amount' => $self->discountnum_amount,
2332 'percent' => $self->discountnum_percent,
2333 'months' => $self->discountnum_months,
2334 #'disabled' => $self->discountnum_disabled,
2337 $cust_pkg_discount->insert;
2340 =item set_usage USAGE_VALUE_HASHREF
2342 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2343 to which they should be set (see L<FS::svc_acct>). Currently seconds,
2344 upbytes, downbytes, and totalbytes are appropriate keys.
2346 All svc_accts which are part of this package have their values reset.
2351 my ($self, $valueref, %opt) = @_;
2353 foreach my $cust_svc ($self->cust_svc){
2354 my $svc_x = $cust_svc->svc_x;
2355 $svc_x->set_usage($valueref, %opt)
2356 if $svc_x->can("set_usage");
2360 =item recharge USAGE_VALUE_HASHREF
2362 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2363 to which they should be set (see L<FS::svc_acct>). Currently seconds,
2364 upbytes, downbytes, and totalbytes are appropriate keys.
2366 All svc_accts which are part of this package have their values incremented.
2371 my ($self, $valueref) = @_;
2373 foreach my $cust_svc ($self->cust_svc){
2374 my $svc_x = $cust_svc->svc_x;
2375 $svc_x->recharge($valueref)
2376 if $svc_x->can("recharge");
2380 =item cust_pkg_discount
2384 sub cust_pkg_discount {
2386 qsearch('cust_pkg_discount', { 'pkgnum' => $self->pkgnum } );
2389 =item cust_pkg_discount_active
2393 sub cust_pkg_discount_active {
2395 grep { $_->status eq 'active' } $self->cust_pkg_discount;
2400 =head1 CLASS METHODS
2406 Returns an SQL expression identifying recurring packages.
2410 sub recurring_sql { "
2411 '0' != ( select freq from part_pkg
2412 where cust_pkg.pkgpart = part_pkg.pkgpart )
2417 Returns an SQL expression identifying one-time packages.
2422 '0' = ( select freq from part_pkg
2423 where cust_pkg.pkgpart = part_pkg.pkgpart )
2428 Returns an SQL expression identifying active packages.
2433 ". $_[0]->recurring_sql(). "
2434 AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
2435 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2436 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
2439 =item not_yet_billed_sql
2441 Returns an SQL expression identifying packages which have not yet been billed.
2445 sub not_yet_billed_sql { "
2446 ( cust_pkg.setup IS NULL OR cust_pkg.setup = 0 )
2447 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2448 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
2453 Returns an SQL expression identifying inactive packages (one-time packages
2454 that are otherwise unsuspended/uncancelled).
2458 sub inactive_sql { "
2459 ". $_[0]->onetime_sql(). "
2460 AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
2461 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2462 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
2468 Returns an SQL expression identifying suspended packages.
2472 sub suspended_sql { susp_sql(@_); }
2474 #$_[0]->recurring_sql(). ' AND '.
2476 ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2477 AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0
2484 Returns an SQL exprression identifying cancelled packages.
2488 sub cancelled_sql { cancel_sql(@_); }
2490 #$_[0]->recurring_sql(). ' AND '.
2491 "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
2494 =item search HASHREF
2498 Returns a qsearch hash expression to search for parameters specified in HASHREF.
2499 Valid parameters are
2507 active, inactive, suspended, cancel (or cancelled)
2511 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
2515 boolean selects custom packages
2521 pkgpart or arrayref or hashref of pkgparts
2525 arrayref of beginning and ending epoch date
2529 arrayref of beginning and ending epoch date
2533 arrayref of beginning and ending epoch date
2537 arrayref of beginning and ending epoch date
2541 arrayref of beginning and ending epoch date
2545 arrayref of beginning and ending epoch date
2549 arrayref of beginning and ending epoch date
2553 pkgnum or APKG_pkgnum
2557 a value suited to passing to FS::UI::Web::cust_header
2561 specifies the user for agent virtualization
2568 my ($class, $params) = @_;
2575 if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2577 "cust_main.agentnum = $1";
2584 if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
2586 "cust_pkg.custnum = $1";
2593 if ( $params->{'magic'} eq 'active'
2594 || $params->{'status'} eq 'active' ) {
2596 push @where, FS::cust_pkg->active_sql();
2598 } elsif ( $params->{'magic'} =~ /^not[ _]yet[ _]billed$/
2599 || $params->{'status'} =~ /^not[ _]yet[ _]billed$/ ) {
2601 push @where, FS::cust_pkg->not_yet_billed_sql();
2603 } elsif ( $params->{'magic'} =~ /^(one-time charge|inactive)/
2604 || $params->{'status'} =~ /^(one-time charge|inactive)/ ) {
2606 push @where, FS::cust_pkg->inactive_sql();
2608 } elsif ( $params->{'magic'} eq 'suspended'
2609 || $params->{'status'} eq 'suspended' ) {
2611 push @where, FS::cust_pkg->suspended_sql();
2613 } elsif ( $params->{'magic'} =~ /^cancell?ed$/
2614 || $params->{'status'} =~ /^cancell?ed$/ ) {
2616 push @where, FS::cust_pkg->cancelled_sql();
2621 # parse package class
2624 #false lazinessish w/graph/cust_bill_pkg.cgi
2627 if ( exists($params->{'classnum'})
2628 && $params->{'classnum'} =~ /^(\d*)$/
2632 if ( $classnum ) { #a specific class
2633 push @where, "part_pkg.classnum = $classnum";
2635 #@pkg_class = ( qsearchs('pkg_class', { 'classnum' => $classnum } ) );
2636 #die "classnum $classnum not found!" unless $pkg_class[0];
2637 #$title .= $pkg_class[0]->classname.' ';
2639 } elsif ( $classnum eq '' ) { #the empty class
2641 push @where, "part_pkg.classnum IS NULL";
2642 #$title .= 'Empty class ';
2643 #@pkg_class = ( '(empty class)' );
2644 } elsif ( $classnum eq '0' ) {
2645 #@pkg_class = qsearch('pkg_class', {} ); # { 'disabled' => '' } );
2646 #push @pkg_class, '(empty class)';
2648 die "illegal classnum";
2654 # parse package report options
2657 my @report_option = ();
2658 if ( exists($params->{'report_option'})
2659 && $params->{'report_option'} =~ /^([,\d]*)$/
2662 @report_option = split(',', $1);
2665 if (@report_option) {
2666 # this will result in the empty set for the dangling comma case as it should
2668 map{ "0 < ( SELECT count(*) FROM part_pkg_option
2669 WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
2670 AND optionname = 'report_option_$_'
2671 AND optionvalue = '1' )"
2681 push @where, "part_pkg.custom = 'Y'" if $params->{custom};
2687 if ( exists($params->{'censustract'}) ) {
2688 $params->{'censustract'} =~ /^([.\d]*)$/;
2689 my $censustract = "cust_main.censustract = '$1'";
2690 $censustract .= ' OR cust_main.censustract is NULL' unless $1;
2691 push @where, "( $censustract )";
2698 if ( ref($params->{'pkgpart'}) ) {
2701 if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
2702 @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
2703 } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
2704 @pkgpart = @{ $params->{'pkgpart'} };
2706 die 'unhandled pkgpart ref '. $params->{'pkgpart'};
2709 @pkgpart = grep /^(\d+)$/, @pkgpart;
2711 push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
2713 } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
2714 push @where, "pkgpart = $1";
2723 #false laziness w/report_cust_pkg.html
2726 'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
2727 'active' => { 'susp'=>1, 'cancel'=>1 },
2728 'suspended' => { 'cancel' => 1 },
2733 foreach my $field (qw( setup last_bill bill adjourn susp expire cancel )) {
2735 next unless exists($params->{$field});
2737 my($beginning, $ending) = @{$params->{$field}};
2739 next if $beginning == 0 && $ending == 4294967295;
2742 "cust_pkg.$field IS NOT NULL",
2743 "cust_pkg.$field >= $beginning",
2744 "cust_pkg.$field <= $ending";
2746 $orderby ||= "ORDER BY cust_pkg.$field";
2750 $orderby ||= 'ORDER BY bill';
2753 # parse magic, legacy, etc.
2756 if ( $params->{'magic'} &&
2757 $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
2760 $orderby = 'ORDER BY pkgnum';
2762 if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
2763 push @where, "pkgpart = $1";
2766 } elsif ( $params->{'query'} eq 'pkgnum' ) {
2768 $orderby = 'ORDER BY pkgnum';
2770 } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
2772 $orderby = 'ORDER BY pkgnum';
2775 SELECT count(*) FROM pkg_svc
2776 WHERE pkg_svc.pkgpart = cust_pkg.pkgpart
2777 AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
2778 WHERE cust_svc.pkgnum = cust_pkg.pkgnum
2779 AND cust_svc.svcpart = pkg_svc.svcpart
2786 # setup queries, links, subs, etc. for the search
2789 # here is the agent virtualization
2790 if ($params->{CurrentUser}) {
2792 qsearchs('access_user', { username => $params->{CurrentUser} });
2795 push @where, $access_user->agentnums_sql('table'=>'cust_main');
2800 push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
2803 my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
2805 my $addl_from = 'LEFT JOIN cust_main USING ( custnum ) '.
2806 'LEFT JOIN part_pkg USING ( pkgpart ) '.
2807 'LEFT JOIN pkg_class ON ( part_pkg.classnum = pkg_class.classnum ) ';
2809 my $count_query = "SELECT COUNT(*) FROM cust_pkg $addl_from $extra_sql";
2812 'table' => 'cust_pkg',
2814 'select' => join(', ',
2816 ( map "part_pkg.$_", qw( pkg freq ) ),
2817 'pkg_class.classname',
2818 'cust_main.custnum AS cust_main_custnum',
2819 FS::UI::Web::cust_sql_fields(
2820 $params->{'cust_fields'}
2823 'extra_sql' => "$extra_sql $orderby",
2824 'addl_from' => $addl_from,
2825 'count_query' => $count_query,
2832 Returns a list: the first item is an SQL fragment identifying matching
2833 packages/customers via location (taking into account shipping and package
2834 address taxation, if enabled), and subsequent items are the parameters to
2835 substitute for the placeholders in that fragment.
2840 my($class, %opt) = @_;
2841 my $ornull = $opt{'ornull'};
2843 my $conf = new FS::Conf;
2845 # '?' placeholders in _location_sql_where
2846 my $x = $ornull ? 3 : 2;
2847 my @bill_param = ( ('city')x3, ('county')x$x, ('state')x$x, 'country' );
2851 if ( $conf->exists('tax-ship_address') ) {
2854 ( ( ship_last IS NULL OR ship_last = '' )
2855 AND ". _location_sql_where('cust_main', '', $ornull ). "
2857 OR ( ship_last IS NOT NULL AND ship_last != ''
2858 AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
2861 # AND payby != 'COMP'
2863 @main_param = ( @bill_param, @bill_param );
2867 $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
2868 @main_param = @bill_param;
2874 if ( $conf->exists('tax-pkg_address') ) {
2876 my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
2879 ( cust_pkg.locationnum IS NULL AND $main_where )
2880 OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where )
2883 @param = ( @main_param, @bill_param );
2887 $where = $main_where;
2888 @param = @main_param;
2896 #subroutine, helper for location_sql
2897 sub _location_sql_where {
2899 my $prefix = @_ ? shift : '';
2900 my $ornull = @_ ? shift : '';
2902 # $ornull = $ornull ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
2904 $ornull = $ornull ? ' OR ? IS NULL ' : '';
2906 my $or_empty_city = " OR ( ? = '' AND $table.${prefix}city IS NULL ) ";
2907 my $or_empty_county = " OR ( ? = '' AND $table.${prefix}county IS NULL ) ";
2908 my $or_empty_state = " OR ( ? = '' AND $table.${prefix}state IS NULL ) ";
2910 # ( $table.${prefix}city = ? $or_empty_city $ornull )
2912 ( $table.${prefix}city = ? OR ? = '' OR CAST(? AS text) IS NULL )
2913 AND ( $table.${prefix}county = ? $or_empty_county $ornull )
2914 AND ( $table.${prefix}state = ? $or_empty_state $ornull )
2915 AND $table.${prefix}country = ?
2923 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
2925 CUSTNUM is a customer (see L<FS::cust_main>)
2927 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
2928 L<FS::part_pkg>) to order for this customer. Duplicates are of course
2931 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
2932 remove for this customer. The services (see L<FS::cust_svc>) are moved to the
2933 new billing items. An error is returned if this is not possible (see
2934 L<FS::pkg_svc>). An empty arrayref is equivalent to not specifying this
2937 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
2938 newly-created cust_pkg objects.
2940 REFNUM, if specified, will specify the FS::pkg_referral record to be created
2941 and inserted. Multiple FS::pkg_referral records can be created by
2942 setting I<refnum> to an array reference of refnums or a hash reference with
2943 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
2944 record will be created corresponding to cust_main.refnum.
2949 my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
2951 my $conf = new FS::Conf;
2953 # Transactionize this whole mess
2954 local $SIG{HUP} = 'IGNORE';
2955 local $SIG{INT} = 'IGNORE';
2956 local $SIG{QUIT} = 'IGNORE';
2957 local $SIG{TERM} = 'IGNORE';
2958 local $SIG{TSTP} = 'IGNORE';
2959 local $SIG{PIPE} = 'IGNORE';
2961 my $oldAutoCommit = $FS::UID::AutoCommit;
2962 local $FS::UID::AutoCommit = 0;
2966 # my $cust_main = qsearchs('cust_main', { custnum => $custnum });
2967 # return "Customer not found: $custnum" unless $cust_main;
2969 warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
2972 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
2975 my $change = scalar(@old_cust_pkg) != 0;
2978 if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
2980 warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
2981 " to pkgpart ". $pkgparts->[0]. "\n"
2984 my $err_or_cust_pkg =
2985 $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
2986 'refnum' => $refnum,
2989 unless (ref($err_or_cust_pkg)) {
2990 $dbh->rollback if $oldAutoCommit;
2991 return $err_or_cust_pkg;
2994 push @$return_cust_pkg, $err_or_cust_pkg;
2995 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3000 # Create the new packages.
3001 foreach my $pkgpart (@$pkgparts) {
3003 warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
3005 my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
3006 pkgpart => $pkgpart,
3010 $error = $cust_pkg->insert( 'change' => $change );
3012 $dbh->rollback if $oldAutoCommit;
3015 push @$return_cust_pkg, $cust_pkg;
3017 # $return_cust_pkg now contains refs to all of the newly
3020 # Transfer services and cancel old packages.
3021 foreach my $old_pkg (@old_cust_pkg) {
3023 warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
3026 foreach my $new_pkg (@$return_cust_pkg) {
3027 $error = $old_pkg->transfer($new_pkg);
3028 if ($error and $error == 0) {
3029 # $old_pkg->transfer failed.
3030 $dbh->rollback if $oldAutoCommit;
3035 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
3036 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
3037 foreach my $new_pkg (@$return_cust_pkg) {
3038 $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
3039 if ($error and $error == 0) {
3040 # $old_pkg->transfer failed.
3041 $dbh->rollback if $oldAutoCommit;
3048 # Transfers were successful, but we went through all of the
3049 # new packages and still had services left on the old package.
3050 # We can't cancel the package under the circumstances, so abort.
3051 $dbh->rollback if $oldAutoCommit;
3052 return "Unable to transfer all services from package ".$old_pkg->pkgnum;
3054 $error = $old_pkg->cancel( quiet=>1 );
3060 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3064 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
3066 A bulk change method to change packages for multiple customers.
3068 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
3069 L<FS::part_pkg>) to order for each customer. Duplicates are of course
3072 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
3073 replace. The services (see L<FS::cust_svc>) are moved to the
3074 new billing items. An error is returned if this is not possible (see
3077 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
3078 newly-created cust_pkg objects.
3083 my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
3085 # Transactionize this whole mess
3086 local $SIG{HUP} = 'IGNORE';
3087 local $SIG{INT} = 'IGNORE';
3088 local $SIG{QUIT} = 'IGNORE';
3089 local $SIG{TERM} = 'IGNORE';
3090 local $SIG{TSTP} = 'IGNORE';
3091 local $SIG{PIPE} = 'IGNORE';
3093 my $oldAutoCommit = $FS::UID::AutoCommit;
3094 local $FS::UID::AutoCommit = 0;
3098 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
3101 while(scalar(@old_cust_pkg)) {
3103 my $custnum = $old_cust_pkg[0]->custnum;
3104 my (@remove) = map { $_->pkgnum }
3105 grep { $_->custnum == $custnum } @old_cust_pkg;
3106 @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
3108 my $error = order $custnum, $pkgparts, \@remove, \@return;
3110 push @errors, $error
3112 push @$return_cust_pkg, @return;
3115 if (scalar(@errors)) {
3116 $dbh->rollback if $oldAutoCommit;
3117 return join(' / ', @errors);
3120 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3128 sub order is not OO. Perhaps it should be moved to FS::cust_main and made so?
3130 In sub order, the @pkgparts array (passed by reference) is clobbered.
3132 Also in sub order, no money is adjusted. Once FS::part_pkg defines a standard
3133 method to pass dates to the recur_prog expression, it should do so.
3135 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
3136 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
3137 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
3138 configuration values. Probably need a subroutine which decides what to do
3139 based on whether or not we've fetched the user yet, rather than a hash. See
3140 FS::UID and the TODO.
3142 Now that things are transactional should the check in the insert method be
3147 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
3148 L<FS::pkg_svc>, schema.html from the base documentation