4 use vars qw(@ISA $disable_agentcheck $DEBUG);
5 use Scalar::Util qw( blessed );
6 use List::Util qw(max);
8 use FS::UID qw( getotaker dbh );
9 use FS::Misc qw( send_email );
10 use FS::Record qw( qsearch qsearchs );
12 use FS::cust_main_Mixin;
18 use FS::cust_bill_pkg;
23 use FS::cust_pkg_reason;
27 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
29 # because they load configuration by setting FS::UID::callback (see TODO)
35 # for sending cancel emails in sub cancel
38 @ISA = qw( FS::m2m_Common FS::cust_main_Mixin FS::option_Common FS::Record );
42 $disable_agentcheck = 0;
46 my ( $hashref, $cache ) = @_;
47 #if ( $hashref->{'pkgpart'} ) {
48 if ( $hashref->{'pkg'} ) {
49 # #@{ $self->{'_pkgnum'} } = ();
50 # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
51 # $self->{'_pkgpart'} = $subcache;
52 # #push @{ $self->{'_pkgnum'} },
53 # FS::part_pkg->new_or_cached($hashref, $subcache);
54 $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
56 if ( exists $hashref->{'svcnum'} ) {
57 #@{ $self->{'_pkgnum'} } = ();
58 my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
59 $self->{'_svcnum'} = $subcache;
60 #push @{ $self->{'_pkgnum'} },
61 FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
67 FS::cust_pkg - Object methods for cust_pkg objects
73 $record = new FS::cust_pkg \%hash;
74 $record = new FS::cust_pkg { 'column' => 'value' };
76 $error = $record->insert;
78 $error = $new_record->replace($old_record);
80 $error = $record->delete;
82 $error = $record->check;
84 $error = $record->cancel;
86 $error = $record->suspend;
88 $error = $record->unsuspend;
90 $part_pkg = $record->part_pkg;
92 @labels = $record->labels;
94 $seconds = $record->seconds_since($timestamp);
96 $error = FS::cust_pkg::order( $custnum, \@pkgparts );
97 $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
101 An FS::cust_pkg object represents a customer billing item. FS::cust_pkg
102 inherits from FS::Record. The following fields are currently supported:
106 =item pkgnum - primary key (assigned automatically for new billing items)
108 =item custnum - Customer (see L<FS::cust_main>)
110 =item pkgpart - Billing item definition (see L<FS::part_pkg>)
114 =item bill - date (next bill date)
116 =item last_bill - last bill date
126 =item otaker - order taker (assigned automatically if null, see L<FS::UID>)
128 =item manual_flag - If this field is set to 1, disables the automatic
129 unsuspension of this package when using the B<unsuspendauto> config file.
133 Note: setup, bill, adjourn, susp, expire and cancel are specified as UNIX timestamps;
134 see L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for
135 conversion functions.
143 Create a new billing item. To add the item to the database, see L<"insert">.
147 sub table { 'cust_pkg'; }
148 sub cust_linked { $_[0]->cust_main_custnum; }
149 sub cust_unlinked_msg {
151 "WARNING: can't find cust_main.custnum ". $self->custnum.
152 ' (cust_pkg.pkgnum '. $self->pkgnum. ')';
155 =item insert [ OPTION => VALUE ... ]
157 Adds this billing item to the database ("Orders" the item). If there is an
158 error, returns the error, otherwise returns false.
160 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
161 will be used to look up the package definition and agent restrictions will be
164 If the additional field I<refnum> is defined, an FS::pkg_referral record will
165 be created and inserted. Multiple FS::pkg_referral records can be created by
166 setting I<refnum> to an array reference of refnums or a hash reference with
167 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
168 record will be created corresponding to cust_main.refnum.
170 The following options are available: I<change>
172 I<change>, if set true, supresses any referral credit to a referring customer.
177 my( $self, %options ) = @_;
179 local $SIG{HUP} = 'IGNORE';
180 local $SIG{INT} = 'IGNORE';
181 local $SIG{QUIT} = 'IGNORE';
182 local $SIG{TERM} = 'IGNORE';
183 local $SIG{TSTP} = 'IGNORE';
184 local $SIG{PIPE} = 'IGNORE';
186 my $oldAutoCommit = $FS::UID::AutoCommit;
187 local $FS::UID::AutoCommit = 0;
190 my $error = $self->SUPER::insert($options{options} ? %{$options{options}} : ());
192 $dbh->rollback if $oldAutoCommit;
196 $self->refnum($self->cust_main->refnum) unless $self->refnum;
197 $self->refnum( [ $self->refnum ] ) unless ref($self->refnum);
198 $self->process_m2m( 'link_table' => 'pkg_referral',
199 'target_table' => 'part_referral',
200 'params' => $self->refnum,
203 #if ( $self->reg_code ) {
204 # my $reg_code = qsearchs('reg_code', { 'code' => $self->reg_code } );
205 # $error = $reg_code->delete;
207 # $dbh->rollback if $oldAutoCommit;
212 my $conf = new FS::Conf;
213 my $cust_main = $self->cust_main;
214 my $part_pkg = $self->part_pkg;
215 if ( $conf->exists('referral_credit')
216 && $cust_main->referral_custnum
217 && ! $options{'change'}
218 && $part_pkg->freq !~ /^0\D?$/
221 my $referring_cust_main = $cust_main->referring_cust_main;
222 if ( $referring_cust_main->status ne 'cancelled' ) {
224 if ( $part_pkg->freq !~ /^\d+$/ ) {
225 warn 'WARNING: Not crediting customer '. $cust_main->referral_custnum.
226 ' for package '. $self->pkgnum.
227 ' ( customer '. $self->custnum. ')'.
228 ' - One-time referral credits not (yet) available for '.
229 ' packages with '. $part_pkg->freq_pretty. ' frequency';
232 my $amount = sprintf( "%.2f", $part_pkg->base_recur / $part_pkg->freq );
234 $referring_cust_main->
236 'Referral credit for '.$cust_main->name,
237 'reason_type' => $conf->config('referral_credit_type')
240 $dbh->rollback if $oldAutoCommit;
241 return "Error crediting customer ". $cust_main->referral_custnum.
242 " for referral: $error";
250 if ($conf->config('welcome_letter') && $self->cust_main->num_pkgs == 1) {
251 my $queue = new FS::queue {
252 'job' => 'FS::cust_main::queueable_print',
254 $error = $queue->insert(
255 'custnum' => $self->custnum,
256 'template' => 'welcome_letter',
260 warn "can't send welcome letter: $error";
265 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
272 This method now works but you probably shouldn't use it.
274 You don't want to delete billing items, because there would then be no record
275 the customer ever purchased the item. Instead, see the cancel method.
280 # return "Can't delete cust_pkg records!";
283 =item replace OLD_RECORD
285 Replaces the OLD_RECORD with this one in the database. If there is an error,
286 returns the error, otherwise returns false.
288 Currently, custnum, setup, bill, adjourn, susp, expire, and cancel may be changed.
290 Changing pkgpart may have disasterous effects. See the order subroutine.
292 setup and bill are normally updated by calling the bill method of a customer
293 object (see L<FS::cust_main>).
295 suspend is normally updated by the suspend and unsuspend methods.
297 cancel is normally updated by the cancel method (and also the order subroutine
307 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
312 ( ref($_[0]) eq 'HASH' )
316 #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
317 return "Can't change otaker!" if $old->otaker ne $new->otaker;
320 #return "Can't change setup once it exists!"
321 # if $old->getfield('setup') &&
322 # $old->getfield('setup') != $new->getfield('setup');
324 #some logic for bill, susp, cancel?
326 local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
328 local $SIG{HUP} = 'IGNORE';
329 local $SIG{INT} = 'IGNORE';
330 local $SIG{QUIT} = 'IGNORE';
331 local $SIG{TERM} = 'IGNORE';
332 local $SIG{TSTP} = 'IGNORE';
333 local $SIG{PIPE} = 'IGNORE';
335 my $oldAutoCommit = $FS::UID::AutoCommit;
336 local $FS::UID::AutoCommit = 0;
339 foreach my $method ( qw(adjourn expire) ) { # How many reasons?
340 if ($options->{'reason'} && $new->$method && $old->$method ne $new->$method) {
341 my $error = $new->insert_reason( 'reason' => $options->{'reason'},
342 'date' => $new->$method,
345 dbh->rollback if $oldAutoCommit;
346 return "Error inserting cust_pkg_reason: $error";
351 #save off and freeze RADIUS attributes for any associated svc_acct records
353 if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
355 #also check for specific exports?
356 # to avoid spurious modify export events
357 @svc_acct = map { $_->svc_x }
358 grep { $_->part_svc->svcdb eq 'svc_acct' }
361 $_->snapshot foreach @svc_acct;
365 my $error = $new->SUPER::replace($old,
366 $options->{options} ? $options->{options} : ()
369 $dbh->rollback if $oldAutoCommit;
373 #for prepaid packages,
374 #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
375 foreach my $old_svc_acct ( @svc_acct ) {
376 my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
377 my $s_error = $new_svc_acct->replace($old_svc_acct);
379 $dbh->rollback if $oldAutoCommit;
384 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
391 Checks all fields to make sure this is a valid billing item. If there is an
392 error, returns the error, otherwise returns false. Called by the insert and
401 $self->ut_numbern('pkgnum')
402 || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
403 || $self->ut_numbern('pkgpart')
404 || $self->ut_numbern('setup')
405 || $self->ut_numbern('bill')
406 || $self->ut_numbern('susp')
407 || $self->ut_numbern('cancel')
408 || $self->ut_numbern('adjourn')
409 || $self->ut_numbern('expire')
411 return $error if $error;
413 if ( $self->reg_code ) {
415 unless ( grep { $self->pkgpart == $_->pkgpart }
416 map { $_->reg_code_pkg }
417 qsearchs( 'reg_code', { 'code' => $self->reg_code,
418 'agentnum' => $self->cust_main->agentnum })
420 return "Unknown registration code";
423 } elsif ( $self->promo_code ) {
426 qsearchs('part_pkg', {
427 'pkgpart' => $self->pkgpart,
428 'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
430 return 'Unknown promotional code' unless $promo_part_pkg;
434 unless ( $disable_agentcheck ) {
436 qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
437 my $pkgpart_href = $agent->pkgpart_hashref;
438 return "agent ". $agent->agentnum.
439 " can't purchase pkgpart ". $self->pkgpart
440 unless $pkgpart_href->{ $self->pkgpart };
443 $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
444 return $error if $error;
448 $self->otaker(getotaker) unless $self->otaker;
449 $self->otaker =~ /^(\w{1,32})$/ or return "Illegal otaker";
452 if ( $self->dbdef_table->column('manual_flag') ) {
453 $self->manual_flag('') if $self->manual_flag eq ' ';
454 $self->manual_flag =~ /^([01]?)$/
455 or return "Illegal manual_flag ". $self->manual_flag;
456 $self->manual_flag($1);
462 =item cancel [ OPTION => VALUE ... ]
464 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
465 in this package, then cancels the package itself (sets the cancel field to
468 Available options are:
472 =item quiet - can be set true to supress email cancellation notices.
474 =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.
476 =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.
480 If there is an error, returns the error, otherwise returns false.
485 my( $self, %options ) = @_;
487 warn "cust_pkg::cancel called with options".
488 join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
491 local $SIG{HUP} = 'IGNORE';
492 local $SIG{INT} = 'IGNORE';
493 local $SIG{QUIT} = 'IGNORE';
494 local $SIG{TERM} = 'IGNORE';
495 local $SIG{TSTP} = 'IGNORE';
496 local $SIG{PIPE} = 'IGNORE';
498 my $oldAutoCommit = $FS::UID::AutoCommit;
499 local $FS::UID::AutoCommit = 0;
502 my $cancel_time = $options{'time'} || time;
506 if ( $options{'reason'} ) {
507 $error = $self->insert_reason( 'reason' => $options{'reason'} );
509 dbh->rollback if $oldAutoCommit;
510 return "Error inserting cust_pkg_reason: $error";
515 foreach my $cust_svc (
518 sort { $a->[1] <=> $b->[1] }
519 map { [ $_, $_->svc_x->table_info->{'cancel_weight'} ]; }
520 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
523 my $error = $cust_svc->cancel;
526 $dbh->rollback if $oldAutoCommit;
527 return "Error cancelling cust_svc: $error";
531 unless ( $self->getfield('cancel') ) {
532 # Add a credit for remaining service
533 my $remaining_value = $self->calc_remain(time=>$cancel_time);
534 if ( $remaining_value > 0 && !$options{'no_credit'} ) {
535 my $conf = new FS::Conf;
536 my $error = $self->cust_main->credit(
538 'Credit for unused time on '. $self->part_pkg->pkg,
539 'reason_type' => $conf->config('cancel_credit_type'),
542 $dbh->rollback if $oldAutoCommit;
543 return "Error crediting customer \$$remaining_value for unused time on".
544 $self->part_pkg->pkg. ": $error";
547 my %hash = $self->hash;
548 $hash{'cancel'} = $cancel_time;
549 my $new = new FS::cust_pkg ( \%hash );
550 $error = $new->replace( $self, options => { $self->options } );
552 $dbh->rollback if $oldAutoCommit;
557 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
559 my $conf = new FS::Conf;
560 my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
561 if ( !$options{'quiet'} && $conf->exists('emailcancel') && @invoicing_list ) {
562 my $conf = new FS::Conf;
563 my $error = send_email(
564 'from' => $conf->config('invoice_from'),
565 'to' => \@invoicing_list,
566 'subject' => ( $conf->config('cancelsubject') || 'Cancellation Notice' ),
567 'body' => [ map "$_\n", $conf->config('cancelmessage') ],
569 #should this do something on errors?
576 =item cancel_if_expired [ NOW_TIMESTAMP ]
578 Cancels this package if its expire date has been reached.
582 sub cancel_if_expired {
584 my $time = shift || time;
585 return '' unless $self->expire && $self->expire <= $time;
586 my $error = $self->cancel;
588 return "Error cancelling expired pkg ". $self->pkgnum. " for custnum ".
589 $self->custnum. ": $error";
594 =item suspend [ OPTION => VALUE ... ]
596 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
597 package, then suspends the package itself (sets the susp field to now).
599 Available options are:
603 =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.
607 If there is an error, returns the error, otherwise returns false.
612 my( $self, %options ) = @_;
614 local $SIG{HUP} = 'IGNORE';
615 local $SIG{INT} = 'IGNORE';
616 local $SIG{QUIT} = 'IGNORE';
617 local $SIG{TERM} = 'IGNORE';
618 local $SIG{TSTP} = 'IGNORE';
619 local $SIG{PIPE} = 'IGNORE';
621 my $oldAutoCommit = $FS::UID::AutoCommit;
622 local $FS::UID::AutoCommit = 0;
627 if ( $options{'reason'} ) {
628 $error = $self->insert_reason( 'reason' => $options{'reason'} );
630 dbh->rollback if $oldAutoCommit;
631 return "Error inserting cust_pkg_reason: $error";
635 foreach my $cust_svc (
636 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
638 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
640 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
641 $dbh->rollback if $oldAutoCommit;
642 return "Illegal svcdb value in part_svc!";
645 require "FS/$svcdb.pm";
647 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
649 $error = $svc->suspend;
651 $dbh->rollback if $oldAutoCommit;
658 unless ( $self->getfield('susp') ) {
659 my %hash = $self->hash;
660 $hash{'susp'} = time;
661 my $new = new FS::cust_pkg ( \%hash );
662 $error = $new->replace( $self, options => { $self->options } );
664 $dbh->rollback if $oldAutoCommit;
669 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
674 =item unsuspend [ OPTION => VALUE ... ]
676 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
677 package, then unsuspends the package itself (clears the susp field and the
678 adjourn field if it is in the past).
680 Available options are: I<adjust_next_bill>.
682 I<adjust_next_bill> can be set true to adjust the next bill date forward by
683 the amount of time the account was inactive. This was set true by default
684 since 1.4.2 and 1.5.0pre6; however, starting with 1.7.0 this needs to be
685 explicitly requested. Price plans for which this makes sense (anniversary-date
686 based than prorate or subscription) could have an option to enable this
689 If there is an error, returns the error, otherwise returns false.
694 my( $self, %opt ) = @_;
697 local $SIG{HUP} = 'IGNORE';
698 local $SIG{INT} = 'IGNORE';
699 local $SIG{QUIT} = 'IGNORE';
700 local $SIG{TERM} = 'IGNORE';
701 local $SIG{TSTP} = 'IGNORE';
702 local $SIG{PIPE} = 'IGNORE';
704 my $oldAutoCommit = $FS::UID::AutoCommit;
705 local $FS::UID::AutoCommit = 0;
708 foreach my $cust_svc (
709 qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
711 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
713 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
714 $dbh->rollback if $oldAutoCommit;
715 return "Illegal svcdb value in part_svc!";
718 require "FS/$svcdb.pm";
720 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
722 $error = $svc->unsuspend;
724 $dbh->rollback if $oldAutoCommit;
731 unless ( ! $self->getfield('susp') ) {
732 my %hash = $self->hash;
733 my $inactive = time - $hash{'susp'};
735 my $conf = new FS::Conf;
737 $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive
738 if ( $opt{'adjust_next_bill'}
739 || $conf->config('unsuspend-always_adjust_next_bill_date') )
740 && $inactive > 0 && ( $hash{'bill'} || $hash{'setup'} );
743 $hash{'adjourn'} = '' if $hash{'adjourn'} < time;
744 my $new = new FS::cust_pkg ( \%hash );
745 $error = $new->replace( $self, options => { $self->options } );
747 $dbh->rollback if $oldAutoCommit;
752 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
759 Returns the last bill date, or if there is no last bill date, the setup date.
760 Useful for billing metered services.
766 if ( $self->dbdef_table->column('last_bill') ) {
767 return $self->setfield('last_bill', $_[0]) if @_;
768 return $self->getfield('last_bill') if $self->getfield('last_bill');
770 my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
771 'edate' => $self->bill, } );
772 $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
775 =item last_cust_pkg_reason
777 Returns the most recent FS::reason associated with the package.
781 sub last_cust_pkg_reason {
784 'table' => 'cust_pkg_reason',
785 'hashref' => { 'pkgnum' => $self->pkgnum, },
786 'extra_sql'=> "AND date <= ". time,
787 'order_by' => 'ORDER BY date DESC LIMIT 1',
793 Returns the most recent FS::reason associated with the package.
798 my $cust_pkg_reason = shift->last_cust_pkg_reason;
799 $cust_pkg_reason->reason
805 Returns the definition for this billing item, as an FS::part_pkg object (see
812 #exists( $self->{'_pkgpart'} )
814 ? $self->{'_pkgpart'}
815 : qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
820 Returns the cancelled package this package was changed from, if any.
826 return '' unless $self->change_pkgnum;
827 qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
832 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
839 $self->part_pkg->calc_setup($self, @_);
844 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
851 $self->part_pkg->calc_recur($self, @_);
856 Calls the I<calc_remain> of the FS::part_pkg object associated with this
863 $self->part_pkg->calc_remain($self, @_);
868 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
875 $self->part_pkg->calc_cancel($self, @_);
880 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
886 qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
891 Returns the new-style customer billing events (see L<FS::cust_event>) for this invoice.
895 #false laziness w/cust_bill.pm
899 'table' => 'cust_event',
900 'addl_from' => 'JOIN part_event USING ( eventpart )',
901 'hashref' => { 'tablenum' => $self->pkgnum },
902 'extra_sql' => " AND eventtable = 'cust_pkg' ",
908 Returns the number of new-style customer billing events (see L<FS::cust_event>) for this invoice.
912 #false laziness w/cust_bill.pm
916 "SELECT COUNT(*) FROM cust_event JOIN part_event USING ( eventpart ) ".
917 " WHERE tablenum = ? AND eventtable = 'cust_pkg'";
918 my $sth = dbh->prepare($sql) or die dbh->errstr. " preparing $sql";
919 $sth->execute($self->pkgnum) or die $sth->errstr. " executing $sql";
920 $sth->fetchrow_arrayref->[0];
923 =item cust_svc [ SVCPART ]
925 Returns the services for this package, as FS::cust_svc objects (see
926 L<FS::cust_svc>). If a svcpart is specified, return only the matching
935 return qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum,
936 'svcpart' => shift, } );
939 #if ( $self->{'_svcnum'} ) {
940 # values %{ $self->{'_svcnum'}->cache };
942 $self->_sort_cust_svc(
943 [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
949 =item overlimit [ SVCPART ]
951 Returns the services for this package which have exceeded their
952 usage limit as FS::cust_svc objects (see L<FS::cust_svc>). If a svcpart
953 is specified, return only the matching services.
959 grep { $_->overlimit } $self->cust_svc;
962 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ]
964 Returns historical services for this package created before END TIMESTAMP and
965 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
966 (see L<FS::h_cust_svc>).
973 $self->_sort_cust_svc(
974 [ qsearch( 'h_cust_svc',
975 { 'pkgnum' => $self->pkgnum, },
976 FS::h_cust_svc->sql_h_search(@_),
983 my( $self, $arrayref ) = @_;
986 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
988 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
989 'svcpart' => $_->svcpart } );
991 $pkg_svc ? $pkg_svc->primary_svc : '',
992 $pkg_svc ? $pkg_svc->quantity : 0,
999 =item num_cust_svc [ SVCPART ]
1001 Returns the number of provisioned services for this package. If a svcpart is
1002 specified, counts only the matching services.
1008 my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
1009 $sql .= ' AND svcpart = ?' if @_;
1010 my $sth = dbh->prepare($sql) or die dbh->errstr;
1011 $sth->execute($self->pkgnum, @_) or die $sth->errstr;
1012 $sth->fetchrow_arrayref->[0];
1015 =item available_part_svc
1017 Returns a list of FS::part_svc objects representing services included in this
1018 package but not yet provisioned. Each FS::part_svc object also has an extra
1019 field, I<num_avail>, which specifies the number of available services.
1023 sub available_part_svc {
1025 grep { $_->num_avail > 0 }
1027 my $part_svc = $_->part_svc;
1028 $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
1029 $_->quantity - $self->num_cust_svc($_->svcpart);
1032 $self->part_pkg->pkg_svc;
1037 Returns a list of FS::part_svc objects representing provisioned and available
1038 services included in this package. Each FS::part_svc object also has the
1039 following extra fields:
1043 =item num_cust_svc (count)
1045 =item num_avail (quantity - count)
1047 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
1050 label -> ($cust_svc->label)[1]
1059 #XXX some sort of sort order besides numeric by svcpart...
1060 my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
1062 my $part_svc = $pkg_svc->part_svc;
1063 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1064 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
1065 $part_svc->{'Hash'}{'num_avail'} =
1066 max( 0, $pkg_svc->quantity - $num_cust_svc );
1067 $part_svc->{'Hash'}{'cust_pkg_svc'} = [ $self->cust_svc($part_svc->svcpart) ];
1069 } $self->part_pkg->pkg_svc;
1072 push @part_svc, map {
1074 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1075 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
1076 $part_svc->{'Hash'}{'num_avail'} = 0; #0-$num_cust_svc ?
1077 $part_svc->{'Hash'}{'cust_pkg_svc'} = [ $self->cust_svc($part_svc->svcpart) ];
1079 } $self->extra_part_svc;
1085 =item extra_part_svc
1087 Returns a list of FS::part_svc objects corresponding to services in this
1088 package which are still provisioned but not (any longer) available in the
1093 sub extra_part_svc {
1096 my $pkgnum = $self->pkgnum;
1097 my $pkgpart = $self->pkgpart;
1100 'table' => 'part_svc',
1102 'extra_sql' => "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
1103 WHERE pkg_svc.svcpart = part_svc.svcpart
1104 AND pkg_svc.pkgpart = $pkgpart
1107 AND 0 < ( SELECT count(*)
1109 LEFT JOIN cust_pkg using ( pkgnum )
1110 WHERE cust_svc.svcpart = part_svc.svcpart
1111 AND pkgnum = $pkgnum
1118 Returns a short status string for this package, currently:
1122 =item not yet billed
1124 =item one-time charge
1139 my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
1141 return 'cancelled' if $self->get('cancel');
1142 return 'suspended' if $self->susp;
1143 return 'not yet billed' unless $self->setup;
1144 return 'one-time charge' if $freq =~ /^(0|$)/;
1150 Class method that returns the list of possible status strings for packages
1151 (see L<the status method|/status>). For example:
1153 @statuses = FS::cust_pkg->statuses();
1157 tie my %statuscolor, 'Tie::IxHash',
1158 'not yet billed' => '000000',
1159 'one-time charge' => '000000',
1160 'active' => '00CC00',
1161 'suspended' => 'FF9900',
1162 'cancelled' => 'FF0000',
1166 my $self = shift; #could be class...
1167 grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
1168 # mayble split btw one-time vs. recur
1174 Returns a hex triplet color string for this package's status.
1180 $statuscolor{$self->status};
1185 Returns a list of lists, calling the label method for all services
1186 (see L<FS::cust_svc>) of this billing item.
1192 map { [ $_->label ] } $self->cust_svc;
1195 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
1197 Like the labels method, but returns historical information on services that
1198 were active as of END_TIMESTAMP and (optionally) not cancelled before
1201 Returns a list of lists, calling the label method for all (historical) services
1202 (see L<FS::h_cust_svc>) of this billing item.
1208 map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
1211 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
1213 Like h_labels, except returns a simple flat list, and shortens long
1214 (currently >5) lists of identical services to one line that lists the service
1215 label and the number of individual services rather than individual items.
1219 sub h_labels_short {
1223 #tie %labels, 'Tie::IxHash';
1224 push @{ $labels{$_->[0]} }, $_->[1]
1225 foreach $self->h_labels(@_);
1227 foreach my $label ( keys %labels ) {
1228 my @values = @{ $labels{$label} };
1229 my $num = scalar(@values);
1231 push @labels, "$label ($num)";
1233 push @labels, map { "$label: $_" } @values;
1243 Returns the parent customer object (see L<FS::cust_main>).
1249 qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
1252 =item seconds_since TIMESTAMP
1254 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
1255 package have been online since TIMESTAMP, according to the session monitor.
1257 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1258 L<Time::Local> and L<Date::Parse> for conversion functions.
1263 my($self, $since) = @_;
1266 foreach my $cust_svc (
1267 grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
1269 $seconds += $cust_svc->seconds_since($since);
1276 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1278 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
1279 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
1282 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1283 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1289 sub seconds_since_sqlradacct {
1290 my($self, $start, $end) = @_;
1294 foreach my $cust_svc (
1296 my $part_svc = $_->part_svc;
1297 $part_svc->svcdb eq 'svc_acct'
1298 && scalar($part_svc->part_export('sqlradius'));
1301 $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
1308 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1310 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1311 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1315 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1316 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1321 sub attribute_since_sqlradacct {
1322 my($self, $start, $end, $attrib) = @_;
1326 foreach my $cust_svc (
1328 my $part_svc = $_->part_svc;
1329 $part_svc->svcdb eq 'svc_acct'
1330 && scalar($part_svc->part_export('sqlradius'));
1333 $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
1340 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
1342 Transfers as many services as possible from this package to another package.
1344 The destination package can be specified by pkgnum by passing an FS::cust_pkg
1345 object. The destination package must already exist.
1347 Services are moved only if the destination allows services with the correct
1348 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true. Use
1349 this option with caution! No provision is made for export differences
1350 between the old and new service definitions. Probably only should be used
1351 when your exports for all service definitions of a given svcdb are identical.
1352 (attempt a transfer without it first, to move all possible svcpart-matching
1355 Any services that can't be moved remain in the original package.
1357 Returns an error, if there is one; otherwise, returns the number of services
1358 that couldn't be moved.
1363 my ($self, $dest_pkgnum, %opt) = @_;
1369 if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
1370 $dest = $dest_pkgnum;
1371 $dest_pkgnum = $dest->pkgnum;
1373 $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
1376 return ('Package does not exist: '.$dest_pkgnum) unless $dest;
1378 foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
1379 $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
1382 foreach my $cust_svc ($dest->cust_svc) {
1383 $target{$cust_svc->svcpart}--;
1386 my %svcpart2svcparts = ();
1387 if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1388 warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
1389 foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
1390 next if exists $svcpart2svcparts{$svcpart};
1391 my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
1392 $svcpart2svcparts{$svcpart} = [
1394 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
1396 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
1397 'svcpart' => $_ } );
1399 $pkg_svc ? $pkg_svc->primary_svc : '',
1400 $pkg_svc ? $pkg_svc->quantity : 0,
1404 grep { $_ != $svcpart }
1406 qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
1408 warn "alternates for svcpart $svcpart: ".
1409 join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
1414 foreach my $cust_svc ($self->cust_svc) {
1415 if($target{$cust_svc->svcpart} > 0) {
1416 $target{$cust_svc->svcpart}--;
1417 my $new = new FS::cust_svc { $cust_svc->hash };
1418 $new->pkgnum($dest_pkgnum);
1419 my $error = $new->replace($cust_svc);
1420 return $error if $error;
1421 } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1423 warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
1424 warn "alternates to consider: ".
1425 join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
1427 my @alternate = grep {
1428 warn "considering alternate svcpart $_: ".
1429 "$target{$_} available in new package\n"
1432 } @{$svcpart2svcparts{$cust_svc->svcpart}};
1434 warn "alternate(s) found\n" if $DEBUG;
1435 my $change_svcpart = $alternate[0];
1436 $target{$change_svcpart}--;
1437 my $new = new FS::cust_svc { $cust_svc->hash };
1438 $new->svcpart($change_svcpart);
1439 $new->pkgnum($dest_pkgnum);
1440 my $error = $new->replace($cust_svc);
1441 return $error if $error;
1454 This method is deprecated. See the I<depend_jobnum> option to the insert and
1455 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
1462 local $SIG{HUP} = 'IGNORE';
1463 local $SIG{INT} = 'IGNORE';
1464 local $SIG{QUIT} = 'IGNORE';
1465 local $SIG{TERM} = 'IGNORE';
1466 local $SIG{TSTP} = 'IGNORE';
1467 local $SIG{PIPE} = 'IGNORE';
1469 my $oldAutoCommit = $FS::UID::AutoCommit;
1470 local $FS::UID::AutoCommit = 0;
1473 foreach my $cust_svc ( $self->cust_svc ) {
1474 #false laziness w/svc_Common::insert
1475 my $svc_x = $cust_svc->svc_x;
1476 foreach my $part_export ( $cust_svc->part_svc->part_export ) {
1477 my $error = $part_export->export_insert($svc_x);
1479 $dbh->rollback if $oldAutoCommit;
1485 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1492 =head1 CLASS METHODS
1498 Returns an SQL expression identifying recurring packages.
1502 sub recurring_sql { "
1503 '0' != ( select freq from part_pkg
1504 where cust_pkg.pkgpart = part_pkg.pkgpart )
1509 Returns an SQL expression identifying one-time packages.
1514 '0' = ( select freq from part_pkg
1515 where cust_pkg.pkgpart = part_pkg.pkgpart )
1520 Returns an SQL expression identifying active packages.
1525 ". $_[0]->recurring_sql(). "
1526 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1527 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
1532 Returns an SQL expression identifying inactive packages (one-time packages
1533 that are otherwise unsuspended/uncancelled).
1537 sub inactive_sql { "
1538 ". $_[0]->onetime_sql(). "
1539 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1540 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
1546 Returns an SQL expression identifying suspended packages.
1550 sub suspended_sql { susp_sql(@_); }
1552 #$_[0]->recurring_sql(). ' AND '.
1554 ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1555 AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0
1562 Returns an SQL exprression identifying cancelled packages.
1566 sub cancelled_sql { cancel_sql(@_); }
1568 #$_[0]->recurring_sql(). ' AND '.
1569 "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
1572 =item search_sql HREF
1574 Returns a qsearch hash expression to search for parameters specified in HREF.
1575 Valid parameters are
1579 =item magic - /^(active|inactive|suspended|cancell?ed)$/
1580 =item status - /^(active|inactive|suspended|one-time charge|inactive|cancell?ed)$/
1582 =item pkgpart - list specified how?
1583 =item setup - arrayref of beginning and ending epoch date
1584 =item last_bill - arrayref of beginning and ending epoch date
1585 =item bill - arrayref of beginning and ending epoch date
1586 =item adjourn - arrayref of beginning and ending epoch date
1587 =item susp - arrayref of beginning and ending epoch date
1588 =item expire - arrayref of beginning and ending epoch date
1589 =item cancel - arrayref of beginning and ending epoch date
1590 =item query - /^(pkgnum/APKG_pkgnum)$/
1591 =item cust_fields - a value suited to passing to FS::UI::Web::cust_header
1592 =item CurrentUser - specifies the user for agent virtualization
1598 my ($class, $params) = @_;
1605 if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
1607 "cust_main.agentnum = $1";
1614 if ( $params->{'magic'} eq 'active'
1615 || $params->{'status'} eq 'active' ) {
1617 push @where, FS::cust_pkg->active_sql();
1619 } elsif ( $params->{'magic'} eq 'inactive'
1620 || $params->{'status'} eq 'inactive' ) {
1622 push @where, FS::cust_pkg->inactive_sql();
1624 } elsif ( $params->{'magic'} eq 'suspended'
1625 || $params->{'status'} eq 'suspended' ) {
1627 push @where, FS::cust_pkg->suspended_sql();
1629 } elsif ( $params->{'magic'} =~ /^cancell?ed$/
1630 || $params->{'status'} =~ /^cancell?ed$/ ) {
1632 push @where, FS::cust_pkg->cancelled_sql();
1634 } elsif ( $params->{'status'} =~ /^(one-time charge|inactive)$/ ) {
1636 push @where, FS::cust_pkg->inactive_sql();
1641 # parse package class
1644 #false lazinessish w/graph/cust_bill_pkg.cgi
1647 if ( exists($params->{'classnum'})
1648 && $params->{'classnum'} =~ /^(\d*)$/
1652 if ( $classnum ) { #a specific class
1653 push @where, "classnum = $classnum";
1655 #@pkg_class = ( qsearchs('pkg_class', { 'classnum' => $classnum } ) );
1656 #die "classnum $classnum not found!" unless $pkg_class[0];
1657 #$title .= $pkg_class[0]->classname.' ';
1659 } elsif ( $classnum eq '' ) { #the empty class
1661 push @where, "classnum IS NULL";
1662 #$title .= 'Empty class ';
1663 #@pkg_class = ( '(empty class)' );
1664 } elsif ( $classnum eq '0' ) {
1665 #@pkg_class = qsearch('pkg_class', {} ); # { 'disabled' => '' } );
1666 #push @pkg_class, '(empty class)';
1668 die "illegal classnum";
1677 my $pkgpart = join (' OR pkgpart=',
1678 grep {$_} map { /^(\d+)$/; } ($params->{'pkgpart'}));
1679 push @where, '(pkgpart=' . $pkgpart . ')' if $pkgpart;
1687 #false laziness w/report_cust_pkg.html
1690 'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
1691 'active' => { 'susp'=>1, 'cancel'=>1 },
1692 'suspended' => { 'cancel' => 1 },
1697 foreach my $field (qw( setup last_bill bill adjourn susp expire cancel )) {
1699 next unless exists($params->{$field});
1701 my($beginning, $ending) = @{$params->{$field}};
1703 next if $beginning == 0 && $ending == 4294967295;
1706 "cust_pkg.$field IS NOT NULL",
1707 "cust_pkg.$field >= $beginning",
1708 "cust_pkg.$field <= $ending";
1710 $orderby ||= "ORDER BY cust_pkg.$field";
1714 $orderby ||= 'ORDER BY bill';
1717 # parse magic, legacy, etc.
1720 if ( $params->{'magic'} &&
1721 $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
1724 $orderby = 'ORDER BY pkgnum';
1726 if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
1727 push @where, "pkgpart = $1";
1730 } elsif ( $params->{'query'} eq 'pkgnum' ) {
1732 $orderby = 'ORDER BY pkgnum';
1734 } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
1736 $orderby = 'ORDER BY pkgnum';
1739 SELECT count(*) FROM pkg_svc
1740 WHERE pkg_svc.pkgpart = cust_pkg.pkgpart
1741 AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
1742 WHERE cust_svc.pkgnum = cust_pkg.pkgnum
1743 AND cust_svc.svcpart = pkg_svc.svcpart
1750 # setup queries, links, subs, etc. for the search
1753 # here is the agent virtualization
1754 if ($params->{CurrentUser}) {
1756 qsearchs('access_user', { username => $params->{CurrentUser} });
1759 push @where, $access_user->agentnums_sql('table'=>'cust_main');
1764 push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
1767 my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
1769 my $addl_from = 'LEFT JOIN cust_main USING ( custnum ) '.
1770 'LEFT JOIN part_pkg USING ( pkgpart ) '.
1771 'LEFT JOIN pkg_class USING ( classnum ) ';
1773 my $count_query = "SELECT COUNT(*) FROM cust_pkg $addl_from $extra_sql";
1776 'table' => 'cust_pkg',
1778 'select' => join(', ',
1780 ( map "part_pkg.$_", qw( pkg freq ) ),
1781 'pkg_class.classname',
1782 'cust_main.custnum as cust_main_custnum',
1783 FS::UI::Web::cust_sql_fields(
1784 $params->{'cust_fields'}
1787 'extra_sql' => "$extra_sql $orderby",
1788 'addl_from' => $addl_from,
1789 'count_query' => $count_query,
1798 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
1800 CUSTNUM is a customer (see L<FS::cust_main>)
1802 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
1803 L<FS::part_pkg>) to order for this customer. Duplicates are of course
1806 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
1807 remove for this customer. The services (see L<FS::cust_svc>) are moved to the
1808 new billing items. An error is returned if this is not possible (see
1809 L<FS::pkg_svc>). An empty arrayref is equivalent to not specifying this
1812 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
1813 newly-created cust_pkg objects.
1815 REFNUM, if specified, will specify the FS::pkg_referral record to be created
1816 and inserted. Multiple FS::pkg_referral records can be created by
1817 setting I<refnum> to an array reference of refnums or a hash reference with
1818 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
1819 record will be created corresponding to cust_main.refnum.
1824 my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
1826 my $conf = new FS::Conf;
1828 # Transactionize this whole mess
1829 local $SIG{HUP} = 'IGNORE';
1830 local $SIG{INT} = 'IGNORE';
1831 local $SIG{QUIT} = 'IGNORE';
1832 local $SIG{TERM} = 'IGNORE';
1833 local $SIG{TSTP} = 'IGNORE';
1834 local $SIG{PIPE} = 'IGNORE';
1836 my $oldAutoCommit = $FS::UID::AutoCommit;
1837 local $FS::UID::AutoCommit = 0;
1841 my $cust_main = qsearchs('cust_main', { custnum => $custnum });
1842 return "Customer not found: $custnum" unless $cust_main;
1844 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
1847 my $change = scalar(@old_cust_pkg) != 0;
1850 if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
1854 #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( last_bill bill );
1856 #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( setup );
1857 $hash{'setup'} = $time if $old_cust_pkg[0]->setup;
1859 $hash{'change_date'} = $time;
1860 $hash{"change_$_"} = $old_cust_pkg[0]->$_() foreach qw( pkgnum pkgpart );
1863 # Create the new packages.
1864 foreach my $pkgpart (@$pkgparts) {
1865 my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
1866 pkgpart => $pkgpart,
1870 $error = $cust_pkg->insert( 'change' => $change );
1872 $dbh->rollback if $oldAutoCommit;
1875 push @$return_cust_pkg, $cust_pkg;
1877 # $return_cust_pkg now contains refs to all of the newly
1880 # Transfer services and cancel old packages.
1881 foreach my $old_pkg (@old_cust_pkg) {
1883 foreach my $new_pkg (@$return_cust_pkg) {
1884 $error = $old_pkg->transfer($new_pkg);
1885 if ($error and $error == 0) {
1886 # $old_pkg->transfer failed.
1887 $dbh->rollback if $oldAutoCommit;
1892 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1893 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1894 foreach my $new_pkg (@$return_cust_pkg) {
1895 $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
1896 if ($error and $error == 0) {
1897 # $old_pkg->transfer failed.
1898 $dbh->rollback if $oldAutoCommit;
1905 # Transfers were successful, but we went through all of the
1906 # new packages and still had services left on the old package.
1907 # We can't cancel the package under the circumstances, so abort.
1908 $dbh->rollback if $oldAutoCommit;
1909 return "Unable to transfer all services from package ".$old_pkg->pkgnum;
1911 $error = $old_pkg->cancel( quiet=>1 );
1917 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1923 Associates this package with a (suspension or cancellation) reason (see
1924 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
1927 Available options are:
1931 =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.
1937 If there is an error, returns the error, otherwise returns false.
1941 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
1943 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
1944 L<FS::part_pkg>) to order for this customer. Duplicates are of course
1947 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
1948 replace. The services (see L<FS::cust_svc>) are moved to the
1949 new billing items. An error is returned if this is not possible (see
1952 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
1953 newly-created cust_pkg objects.
1958 my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
1960 # Transactionize this whole mess
1961 local $SIG{HUP} = 'IGNORE';
1962 local $SIG{INT} = 'IGNORE';
1963 local $SIG{QUIT} = 'IGNORE';
1964 local $SIG{TERM} = 'IGNORE';
1965 local $SIG{TSTP} = 'IGNORE';
1966 local $SIG{PIPE} = 'IGNORE';
1968 my $oldAutoCommit = $FS::UID::AutoCommit;
1969 local $FS::UID::AutoCommit = 0;
1973 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
1976 while(scalar(@old_cust_pkg)) {
1978 my $custnum = $old_cust_pkg[0]->custnum;
1979 my (@remove) = map { $_->pkgnum }
1980 grep { $_->custnum == $custnum } @old_cust_pkg;
1981 @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
1983 my $error = order $custnum, $pkgparts, \@remove, \@return;
1985 push @errors, $error
1987 push @$return_cust_pkg, @return;
1990 if (scalar(@errors)) {
1991 $dbh->rollback if $oldAutoCommit;
1992 return join(' / ', @errors);
1995 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2000 my ($self, %options) = @_;
2002 my $otaker = $FS::CurrentUser::CurrentUser->username;
2005 if ( $options{'reason'} =~ /^(\d+)$/ ) {
2009 } elsif ( ref($options{'reason'}) ) {
2011 return 'Enter a new reason (or select an existing one)'
2012 unless $options{'reason'}->{'reason'} !~ /^\s*$/;
2014 my $reason = new FS::reason({
2015 'reason_type' => $options{'reason'}->{'typenum'},
2016 'reason' => $options{'reason'}->{'reason'},
2018 my $error = $reason->insert;
2019 return $error if $error;
2021 $reasonnum = $reason->reasonnum;
2024 return "Unparsable reason: ". $options{'reason'};
2027 my $cust_pkg_reason =
2028 new FS::cust_pkg_reason({ 'pkgnum' => $self->pkgnum,
2029 'reasonnum' => $reasonnum,
2030 'otaker' => $otaker,
2031 'date' => $options{'date'}
2036 $cust_pkg_reason->insert;
2039 =item set_usage USAGE_VALUE_HASHREF
2041 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2042 to which they should be set (see L<FS::svc_acct>). Currently seconds,
2043 upbytes, downbytes, and totalbytes are appropriate keys.
2045 All svc_accts which are part of this package have their values reset.
2050 my ($self, $valueref) = @_;
2052 foreach my $cust_svc ($self->cust_svc){
2053 my $svc_x = $cust_svc->svc_x;
2054 $svc_x->set_usage($valueref)
2055 if $svc_x->can("set_usage");
2059 =item recharge USAGE_VALUE_HASHREF
2061 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2062 to which they should be set (see L<FS::svc_acct>). Currently seconds,
2063 upbytes, downbytes, and totalbytes are appropriate keys.
2065 All svc_accts which are part of this package have their values incremented.
2070 my ($self, $valueref) = @_;
2072 foreach my $cust_svc ($self->cust_svc){
2073 my $svc_x = $cust_svc->svc_x;
2074 $svc_x->recharge($valueref)
2075 if $svc_x->can("recharge");
2083 sub order is not OO. Perhaps it should be moved to FS::cust_main and made so?
2085 In sub order, the @pkgparts array (passed by reference) is clobbered.
2087 Also in sub order, no money is adjusted. Once FS::part_pkg defines a standard
2088 method to pass dates to the recur_prog expression, it should do so.
2090 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
2091 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
2092 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
2093 configuration values. Probably need a subroutine which decides what to do
2094 based on whether or not we've fetched the user yet, rather than a hash. See
2095 FS::UID and the TODO.
2097 Now that things are transactional should the check in the insert method be
2102 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
2103 L<FS::pkg_svc>, schema.html from the base documentation