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.
131 =item quantity - If not set, defaults to 1
135 Note: setup, bill, adjourn, susp, expire and cancel are specified as UNIX timestamps;
136 see L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for
137 conversion functions.
145 Create a new billing item. To add the item to the database, see L<"insert">.
149 sub table { 'cust_pkg'; }
150 sub cust_linked { $_[0]->cust_main_custnum; }
151 sub cust_unlinked_msg {
153 "WARNING: can't find cust_main.custnum ". $self->custnum.
154 ' (cust_pkg.pkgnum '. $self->pkgnum. ')';
157 =item insert [ OPTION => VALUE ... ]
159 Adds this billing item to the database ("Orders" the item). If there is an
160 error, returns the error, otherwise returns false.
162 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
163 will be used to look up the package definition and agent restrictions will be
166 If the additional field I<refnum> is defined, an FS::pkg_referral record will
167 be created and inserted. Multiple FS::pkg_referral records can be created by
168 setting I<refnum> to an array reference of refnums or a hash reference with
169 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
170 record will be created corresponding to cust_main.refnum.
172 The following options are available: I<change>
174 I<change>, if set true, supresses any referral credit to a referring customer.
179 my( $self, %options ) = @_;
181 local $SIG{HUP} = 'IGNORE';
182 local $SIG{INT} = 'IGNORE';
183 local $SIG{QUIT} = 'IGNORE';
184 local $SIG{TERM} = 'IGNORE';
185 local $SIG{TSTP} = 'IGNORE';
186 local $SIG{PIPE} = 'IGNORE';
188 my $oldAutoCommit = $FS::UID::AutoCommit;
189 local $FS::UID::AutoCommit = 0;
192 my $error = $self->SUPER::insert($options{options} ? %{$options{options}} : ());
194 $dbh->rollback if $oldAutoCommit;
198 $self->refnum($self->cust_main->refnum) unless $self->refnum;
199 $self->refnum( [ $self->refnum ] ) unless ref($self->refnum);
200 $self->process_m2m( 'link_table' => 'pkg_referral',
201 'target_table' => 'part_referral',
202 'params' => $self->refnum,
205 #if ( $self->reg_code ) {
206 # my $reg_code = qsearchs('reg_code', { 'code' => $self->reg_code } );
207 # $error = $reg_code->delete;
209 # $dbh->rollback if $oldAutoCommit;
214 my $conf = new FS::Conf;
215 my $cust_main = $self->cust_main;
216 my $part_pkg = $self->part_pkg;
217 if ( $conf->exists('referral_credit')
218 && $cust_main->referral_custnum
219 && ! $options{'change'}
220 && $part_pkg->freq !~ /^0\D?$/
223 my $referring_cust_main = $cust_main->referring_cust_main;
224 if ( $referring_cust_main->status ne 'cancelled' ) {
226 if ( $part_pkg->freq !~ /^\d+$/ ) {
227 warn 'WARNING: Not crediting customer '. $cust_main->referral_custnum.
228 ' for package '. $self->pkgnum.
229 ' ( customer '. $self->custnum. ')'.
230 ' - One-time referral credits not (yet) available for '.
231 ' packages with '. $part_pkg->freq_pretty. ' frequency';
234 my $amount = sprintf( "%.2f", $part_pkg->base_recur / $part_pkg->freq );
236 $referring_cust_main->
238 'Referral credit for '.$cust_main->name,
239 'reason_type' => $conf->config('referral_credit_type')
242 $dbh->rollback if $oldAutoCommit;
243 return "Error crediting customer ". $cust_main->referral_custnum.
244 " for referral: $error";
252 if ($conf->config('welcome_letter') && $self->cust_main->num_pkgs == 1) {
253 my $queue = new FS::queue {
254 'job' => 'FS::cust_main::queueable_print',
256 $error = $queue->insert(
257 'custnum' => $self->custnum,
258 'template' => 'welcome_letter',
262 warn "can't send welcome letter: $error";
267 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
274 This method now works but you probably shouldn't use it.
276 You don't want to delete billing items, because there would then be no record
277 the customer ever purchased the item. Instead, see the cancel method.
282 # return "Can't delete cust_pkg records!";
285 =item replace OLD_RECORD
287 Replaces the OLD_RECORD with this one in the database. If there is an error,
288 returns the error, otherwise returns false.
290 Currently, custnum, setup, bill, adjourn, susp, expire, and cancel may be changed.
292 Changing pkgpart may have disasterous effects. See the order subroutine.
294 setup and bill are normally updated by calling the bill method of a customer
295 object (see L<FS::cust_main>).
297 suspend is normally updated by the suspend and unsuspend methods.
299 cancel is normally updated by the cancel method (and also the order subroutine
309 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
314 ( ref($_[0]) eq 'HASH' )
318 #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
319 return "Can't change otaker!" if $old->otaker ne $new->otaker;
322 #return "Can't change setup once it exists!"
323 # if $old->getfield('setup') &&
324 # $old->getfield('setup') != $new->getfield('setup');
326 #some logic for bill, susp, cancel?
328 local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
330 local $SIG{HUP} = 'IGNORE';
331 local $SIG{INT} = 'IGNORE';
332 local $SIG{QUIT} = 'IGNORE';
333 local $SIG{TERM} = 'IGNORE';
334 local $SIG{TSTP} = 'IGNORE';
335 local $SIG{PIPE} = 'IGNORE';
337 my $oldAutoCommit = $FS::UID::AutoCommit;
338 local $FS::UID::AutoCommit = 0;
341 foreach my $method ( qw(adjourn expire) ) { # How many reasons?
342 if ($options->{'reason'} && $new->$method && $old->$method ne $new->$method) {
343 my $error = $new->insert_reason( 'reason' => $options->{'reason'},
344 'date' => $new->$method,
347 dbh->rollback if $oldAutoCommit;
348 return "Error inserting cust_pkg_reason: $error";
353 #save off and freeze RADIUS attributes for any associated svc_acct records
355 if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
357 #also check for specific exports?
358 # to avoid spurious modify export events
359 @svc_acct = map { $_->svc_x }
360 grep { $_->part_svc->svcdb eq 'svc_acct' }
363 $_->snapshot foreach @svc_acct;
367 my $error = $new->SUPER::replace($old,
368 $options->{options} ? $options->{options} : ()
371 $dbh->rollback if $oldAutoCommit;
375 #for prepaid packages,
376 #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
377 foreach my $old_svc_acct ( @svc_acct ) {
378 my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
379 my $s_error = $new_svc_acct->replace($old_svc_acct);
381 $dbh->rollback if $oldAutoCommit;
386 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
393 Checks all fields to make sure this is a valid billing item. If there is an
394 error, returns the error, otherwise returns false. Called by the insert and
403 $self->ut_numbern('pkgnum')
404 || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
405 || $self->ut_numbern('pkgpart')
406 || $self->ut_numbern('setup')
407 || $self->ut_numbern('bill')
408 || $self->ut_numbern('susp')
409 || $self->ut_numbern('cancel')
410 || $self->ut_numbern('adjourn')
411 || $self->ut_numbern('expire')
413 return $error if $error;
415 if ( $self->reg_code ) {
417 unless ( grep { $self->pkgpart == $_->pkgpart }
418 map { $_->reg_code_pkg }
419 qsearchs( 'reg_code', { 'code' => $self->reg_code,
420 'agentnum' => $self->cust_main->agentnum })
422 return "Unknown registration code";
425 } elsif ( $self->promo_code ) {
428 qsearchs('part_pkg', {
429 'pkgpart' => $self->pkgpart,
430 'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
432 return 'Unknown promotional code' unless $promo_part_pkg;
436 unless ( $disable_agentcheck ) {
438 qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
439 my $pkgpart_href = $agent->pkgpart_hashref;
440 return "agent ". $agent->agentnum.
441 " can't purchase pkgpart ". $self->pkgpart
442 unless $pkgpart_href->{ $self->pkgpart };
445 $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
446 return $error if $error;
450 $self->otaker(getotaker) unless $self->otaker;
451 $self->otaker =~ /^(\w{1,32})$/ or return "Illegal otaker";
454 if ( $self->dbdef_table->column('manual_flag') ) {
455 $self->manual_flag('') if $self->manual_flag eq ' ';
456 $self->manual_flag =~ /^([01]?)$/
457 or return "Illegal manual_flag ". $self->manual_flag;
458 $self->manual_flag($1);
464 =item cancel [ OPTION => VALUE ... ]
466 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
467 in this package, then cancels the package itself (sets the cancel field to
470 Available options are:
474 =item quiet - can be set true to supress email cancellation notices.
476 =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.
478 =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.
482 If there is an error, returns the error, otherwise returns false.
487 my( $self, %options ) = @_;
489 warn "cust_pkg::cancel called with options".
490 join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
493 local $SIG{HUP} = 'IGNORE';
494 local $SIG{INT} = 'IGNORE';
495 local $SIG{QUIT} = 'IGNORE';
496 local $SIG{TERM} = 'IGNORE';
497 local $SIG{TSTP} = 'IGNORE';
498 local $SIG{PIPE} = 'IGNORE';
500 my $oldAutoCommit = $FS::UID::AutoCommit;
501 local $FS::UID::AutoCommit = 0;
504 my $cancel_time = $options{'time'} || time;
508 if ( $options{'reason'} ) {
509 $error = $self->insert_reason( 'reason' => $options{'reason'} );
511 dbh->rollback if $oldAutoCommit;
512 return "Error inserting cust_pkg_reason: $error";
517 foreach my $cust_svc (
520 sort { $a->[1] <=> $b->[1] }
521 map { [ $_, $_->svc_x->table_info->{'cancel_weight'} ]; }
522 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
525 my $error = $cust_svc->cancel;
528 $dbh->rollback if $oldAutoCommit;
529 return "Error cancelling cust_svc: $error";
533 unless ( $self->getfield('cancel') ) {
534 # Add a credit for remaining service
535 my $remaining_value = $self->calc_remain(time=>$cancel_time);
536 if ( $remaining_value > 0 && !$options{'no_credit'} ) {
537 my $conf = new FS::Conf;
538 my $error = $self->cust_main->credit(
540 'Credit for unused time on '. $self->part_pkg->pkg,
541 'reason_type' => $conf->config('cancel_credit_type'),
544 $dbh->rollback if $oldAutoCommit;
545 return "Error crediting customer \$$remaining_value for unused time on".
546 $self->part_pkg->pkg. ": $error";
549 my %hash = $self->hash;
550 $hash{'cancel'} = $cancel_time;
551 my $new = new FS::cust_pkg ( \%hash );
552 $error = $new->replace( $self, options => { $self->options } );
554 $dbh->rollback if $oldAutoCommit;
559 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
561 my $conf = new FS::Conf;
562 my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
563 if ( !$options{'quiet'} && $conf->exists('emailcancel') && @invoicing_list ) {
564 my $conf = new FS::Conf;
565 my $error = send_email(
566 'from' => $conf->config('invoice_from'),
567 'to' => \@invoicing_list,
568 'subject' => ( $conf->config('cancelsubject') || 'Cancellation Notice' ),
569 'body' => [ map "$_\n", $conf->config('cancelmessage') ],
571 #should this do something on errors?
578 =item cancel_if_expired [ NOW_TIMESTAMP ]
580 Cancels this package if its expire date has been reached.
584 sub cancel_if_expired {
586 my $time = shift || time;
587 return '' unless $self->expire && $self->expire <= $time;
588 my $error = $self->cancel;
590 return "Error cancelling expired pkg ". $self->pkgnum. " for custnum ".
591 $self->custnum. ": $error";
596 =item suspend [ OPTION => VALUE ... ]
598 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
599 package, then suspends the package itself (sets the susp field to now).
601 Available options are:
605 =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.
609 If there is an error, returns the error, otherwise returns false.
614 my( $self, %options ) = @_;
616 local $SIG{HUP} = 'IGNORE';
617 local $SIG{INT} = 'IGNORE';
618 local $SIG{QUIT} = 'IGNORE';
619 local $SIG{TERM} = 'IGNORE';
620 local $SIG{TSTP} = 'IGNORE';
621 local $SIG{PIPE} = 'IGNORE';
623 my $oldAutoCommit = $FS::UID::AutoCommit;
624 local $FS::UID::AutoCommit = 0;
629 if ( $options{'reason'} ) {
630 $error = $self->insert_reason( 'reason' => $options{'reason'} );
632 dbh->rollback if $oldAutoCommit;
633 return "Error inserting cust_pkg_reason: $error";
637 foreach my $cust_svc (
638 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
640 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
642 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
643 $dbh->rollback if $oldAutoCommit;
644 return "Illegal svcdb value in part_svc!";
647 require "FS/$svcdb.pm";
649 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
651 $error = $svc->suspend;
653 $dbh->rollback if $oldAutoCommit;
660 unless ( $self->getfield('susp') ) {
661 my %hash = $self->hash;
662 $hash{'susp'} = time;
663 my $new = new FS::cust_pkg ( \%hash );
664 $error = $new->replace( $self, options => { $self->options } );
666 $dbh->rollback if $oldAutoCommit;
671 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
676 =item unsuspend [ OPTION => VALUE ... ]
678 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
679 package, then unsuspends the package itself (clears the susp field and the
680 adjourn field if it is in the past).
682 Available options are: I<adjust_next_bill>.
684 I<adjust_next_bill> can be set true to adjust the next bill date forward by
685 the amount of time the account was inactive. This was set true by default
686 since 1.4.2 and 1.5.0pre6; however, starting with 1.7.0 this needs to be
687 explicitly requested. Price plans for which this makes sense (anniversary-date
688 based than prorate or subscription) could have an option to enable this
691 If there is an error, returns the error, otherwise returns false.
696 my( $self, %opt ) = @_;
699 local $SIG{HUP} = 'IGNORE';
700 local $SIG{INT} = 'IGNORE';
701 local $SIG{QUIT} = 'IGNORE';
702 local $SIG{TERM} = 'IGNORE';
703 local $SIG{TSTP} = 'IGNORE';
704 local $SIG{PIPE} = 'IGNORE';
706 my $oldAutoCommit = $FS::UID::AutoCommit;
707 local $FS::UID::AutoCommit = 0;
710 foreach my $cust_svc (
711 qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
713 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
715 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
716 $dbh->rollback if $oldAutoCommit;
717 return "Illegal svcdb value in part_svc!";
720 require "FS/$svcdb.pm";
722 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
724 $error = $svc->unsuspend;
726 $dbh->rollback if $oldAutoCommit;
733 unless ( ! $self->getfield('susp') ) {
734 my %hash = $self->hash;
735 my $inactive = time - $hash{'susp'};
737 my $conf = new FS::Conf;
739 $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive
740 if ( $opt{'adjust_next_bill'}
741 || $conf->config('unsuspend-always_adjust_next_bill_date') )
742 && $inactive > 0 && ( $hash{'bill'} || $hash{'setup'} );
745 $hash{'adjourn'} = '' if $hash{'adjourn'} < time;
746 my $new = new FS::cust_pkg ( \%hash );
747 $error = $new->replace( $self, options => { $self->options } );
749 $dbh->rollback if $oldAutoCommit;
754 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
761 Returns the last bill date, or if there is no last bill date, the setup date.
762 Useful for billing metered services.
768 return $self->setfield('last_bill', $_[0]) if @_;
769 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);
1345 my( $self, $value ) = @_;
1346 if ( defined($value) ) {
1347 $self->setfield('quantity', $value);
1349 $self->getfield('quantity') || 1;
1352 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
1354 Transfers as many services as possible from this package to another package.
1356 The destination package can be specified by pkgnum by passing an FS::cust_pkg
1357 object. The destination package must already exist.
1359 Services are moved only if the destination allows services with the correct
1360 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true. Use
1361 this option with caution! No provision is made for export differences
1362 between the old and new service definitions. Probably only should be used
1363 when your exports for all service definitions of a given svcdb are identical.
1364 (attempt a transfer without it first, to move all possible svcpart-matching
1367 Any services that can't be moved remain in the original package.
1369 Returns an error, if there is one; otherwise, returns the number of services
1370 that couldn't be moved.
1375 my ($self, $dest_pkgnum, %opt) = @_;
1381 if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
1382 $dest = $dest_pkgnum;
1383 $dest_pkgnum = $dest->pkgnum;
1385 $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
1388 return ('Package does not exist: '.$dest_pkgnum) unless $dest;
1390 foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
1391 $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
1394 foreach my $cust_svc ($dest->cust_svc) {
1395 $target{$cust_svc->svcpart}--;
1398 my %svcpart2svcparts = ();
1399 if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1400 warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
1401 foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
1402 next if exists $svcpart2svcparts{$svcpart};
1403 my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
1404 $svcpart2svcparts{$svcpart} = [
1406 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
1408 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
1409 'svcpart' => $_ } );
1411 $pkg_svc ? $pkg_svc->primary_svc : '',
1412 $pkg_svc ? $pkg_svc->quantity : 0,
1416 grep { $_ != $svcpart }
1418 qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
1420 warn "alternates for svcpart $svcpart: ".
1421 join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
1426 foreach my $cust_svc ($self->cust_svc) {
1427 if($target{$cust_svc->svcpart} > 0) {
1428 $target{$cust_svc->svcpart}--;
1429 my $new = new FS::cust_svc { $cust_svc->hash };
1430 $new->pkgnum($dest_pkgnum);
1431 my $error = $new->replace($cust_svc);
1432 return $error if $error;
1433 } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1435 warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
1436 warn "alternates to consider: ".
1437 join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
1439 my @alternate = grep {
1440 warn "considering alternate svcpart $_: ".
1441 "$target{$_} available in new package\n"
1444 } @{$svcpart2svcparts{$cust_svc->svcpart}};
1446 warn "alternate(s) found\n" if $DEBUG;
1447 my $change_svcpart = $alternate[0];
1448 $target{$change_svcpart}--;
1449 my $new = new FS::cust_svc { $cust_svc->hash };
1450 $new->svcpart($change_svcpart);
1451 $new->pkgnum($dest_pkgnum);
1452 my $error = $new->replace($cust_svc);
1453 return $error if $error;
1466 This method is deprecated. See the I<depend_jobnum> option to the insert and
1467 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
1474 local $SIG{HUP} = 'IGNORE';
1475 local $SIG{INT} = 'IGNORE';
1476 local $SIG{QUIT} = 'IGNORE';
1477 local $SIG{TERM} = 'IGNORE';
1478 local $SIG{TSTP} = 'IGNORE';
1479 local $SIG{PIPE} = 'IGNORE';
1481 my $oldAutoCommit = $FS::UID::AutoCommit;
1482 local $FS::UID::AutoCommit = 0;
1485 foreach my $cust_svc ( $self->cust_svc ) {
1486 #false laziness w/svc_Common::insert
1487 my $svc_x = $cust_svc->svc_x;
1488 foreach my $part_export ( $cust_svc->part_svc->part_export ) {
1489 my $error = $part_export->export_insert($svc_x);
1491 $dbh->rollback if $oldAutoCommit;
1497 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1504 =head1 CLASS METHODS
1510 Returns an SQL expression identifying recurring packages.
1514 sub recurring_sql { "
1515 '0' != ( select freq from part_pkg
1516 where cust_pkg.pkgpart = part_pkg.pkgpart )
1521 Returns an SQL expression identifying one-time packages.
1526 '0' = ( select freq from part_pkg
1527 where cust_pkg.pkgpart = part_pkg.pkgpart )
1532 Returns an SQL expression identifying active packages.
1537 ". $_[0]->recurring_sql(). "
1538 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1539 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
1544 Returns an SQL expression identifying inactive packages (one-time packages
1545 that are otherwise unsuspended/uncancelled).
1549 sub inactive_sql { "
1550 ". $_[0]->onetime_sql(). "
1551 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1552 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
1558 Returns an SQL expression identifying suspended packages.
1562 sub suspended_sql { susp_sql(@_); }
1564 #$_[0]->recurring_sql(). ' AND '.
1566 ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1567 AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0
1574 Returns an SQL exprression identifying cancelled packages.
1578 sub cancelled_sql { cancel_sql(@_); }
1580 #$_[0]->recurring_sql(). ' AND '.
1581 "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
1584 =item search_sql HASHREF
1588 Returns a qsearch hash expression to search for parameters specified in HASHREF.
1589 Valid parameters are
1597 active, inactive, suspended, cancel (or cancelled)
1601 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
1611 arrayref of beginning and ending epoch date
1615 arrayref of beginning and ending epoch date
1619 arrayref of beginning and ending epoch date
1623 arrayref of beginning and ending epoch date
1627 arrayref of beginning and ending epoch date
1631 arrayref of beginning and ending epoch date
1635 arrayref of beginning and ending epoch date
1639 pkgnum or APKG_pkgnum
1643 a value suited to passing to FS::UI::Web::cust_header
1647 specifies the user for agent virtualization
1654 my ($class, $params) = @_;
1661 if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
1663 "cust_main.agentnum = $1";
1670 if ( $params->{'magic'} eq 'active'
1671 || $params->{'status'} eq 'active' ) {
1673 push @where, FS::cust_pkg->active_sql();
1675 } elsif ( $params->{'magic'} eq 'inactive'
1676 || $params->{'status'} eq 'inactive' ) {
1678 push @where, FS::cust_pkg->inactive_sql();
1680 } elsif ( $params->{'magic'} eq 'suspended'
1681 || $params->{'status'} eq 'suspended' ) {
1683 push @where, FS::cust_pkg->suspended_sql();
1685 } elsif ( $params->{'magic'} =~ /^cancell?ed$/
1686 || $params->{'status'} =~ /^cancell?ed$/ ) {
1688 push @where, FS::cust_pkg->cancelled_sql();
1690 } elsif ( $params->{'status'} =~ /^(one-time charge|inactive)$/ ) {
1692 push @where, FS::cust_pkg->inactive_sql();
1697 # parse package class
1700 #false lazinessish w/graph/cust_bill_pkg.cgi
1703 if ( exists($params->{'classnum'})
1704 && $params->{'classnum'} =~ /^(\d*)$/
1708 if ( $classnum ) { #a specific class
1709 push @where, "classnum = $classnum";
1711 #@pkg_class = ( qsearchs('pkg_class', { 'classnum' => $classnum } ) );
1712 #die "classnum $classnum not found!" unless $pkg_class[0];
1713 #$title .= $pkg_class[0]->classname.' ';
1715 } elsif ( $classnum eq '' ) { #the empty class
1717 push @where, "classnum IS NULL";
1718 #$title .= 'Empty class ';
1719 #@pkg_class = ( '(empty class)' );
1720 } elsif ( $classnum eq '0' ) {
1721 #@pkg_class = qsearch('pkg_class', {} ); # { 'disabled' => '' } );
1722 #push @pkg_class, '(empty class)';
1724 die "illegal classnum";
1733 my $pkgpart = join (' OR pkgpart=',
1734 grep {$_} map { /^(\d+)$/; } ($params->{'pkgpart'}));
1735 push @where, '(pkgpart=' . $pkgpart . ')' if $pkgpart;
1743 #false laziness w/report_cust_pkg.html
1746 'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
1747 'active' => { 'susp'=>1, 'cancel'=>1 },
1748 'suspended' => { 'cancel' => 1 },
1753 foreach my $field (qw( setup last_bill bill adjourn susp expire cancel )) {
1755 next unless exists($params->{$field});
1757 my($beginning, $ending) = @{$params->{$field}};
1759 next if $beginning == 0 && $ending == 4294967295;
1762 "cust_pkg.$field IS NOT NULL",
1763 "cust_pkg.$field >= $beginning",
1764 "cust_pkg.$field <= $ending";
1766 $orderby ||= "ORDER BY cust_pkg.$field";
1770 $orderby ||= 'ORDER BY bill';
1773 # parse magic, legacy, etc.
1776 if ( $params->{'magic'} &&
1777 $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
1780 $orderby = 'ORDER BY pkgnum';
1782 if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
1783 push @where, "pkgpart = $1";
1786 } elsif ( $params->{'query'} eq 'pkgnum' ) {
1788 $orderby = 'ORDER BY pkgnum';
1790 } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
1792 $orderby = 'ORDER BY pkgnum';
1795 SELECT count(*) FROM pkg_svc
1796 WHERE pkg_svc.pkgpart = cust_pkg.pkgpart
1797 AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
1798 WHERE cust_svc.pkgnum = cust_pkg.pkgnum
1799 AND cust_svc.svcpart = pkg_svc.svcpart
1806 # setup queries, links, subs, etc. for the search
1809 # here is the agent virtualization
1810 if ($params->{CurrentUser}) {
1812 qsearchs('access_user', { username => $params->{CurrentUser} });
1815 push @where, $access_user->agentnums_sql('table'=>'cust_main');
1820 push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
1823 my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
1825 my $addl_from = 'LEFT JOIN cust_main USING ( custnum ) '.
1826 'LEFT JOIN part_pkg USING ( pkgpart ) '.
1827 'LEFT JOIN pkg_class USING ( classnum ) ';
1829 my $count_query = "SELECT COUNT(*) FROM cust_pkg $addl_from $extra_sql";
1832 'table' => 'cust_pkg',
1834 'select' => join(', ',
1836 ( map "part_pkg.$_", qw( pkg freq ) ),
1837 'pkg_class.classname',
1838 'cust_main.custnum as cust_main_custnum',
1839 FS::UI::Web::cust_sql_fields(
1840 $params->{'cust_fields'}
1843 'extra_sql' => "$extra_sql $orderby",
1844 'addl_from' => $addl_from,
1845 'count_query' => $count_query,
1854 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
1856 CUSTNUM is a customer (see L<FS::cust_main>)
1858 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
1859 L<FS::part_pkg>) to order for this customer. Duplicates are of course
1862 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
1863 remove for this customer. The services (see L<FS::cust_svc>) are moved to the
1864 new billing items. An error is returned if this is not possible (see
1865 L<FS::pkg_svc>). An empty arrayref is equivalent to not specifying this
1868 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
1869 newly-created cust_pkg objects.
1871 REFNUM, if specified, will specify the FS::pkg_referral record to be created
1872 and inserted. Multiple FS::pkg_referral records can be created by
1873 setting I<refnum> to an array reference of refnums or a hash reference with
1874 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
1875 record will be created corresponding to cust_main.refnum.
1880 my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
1882 my $conf = new FS::Conf;
1884 # Transactionize this whole mess
1885 local $SIG{HUP} = 'IGNORE';
1886 local $SIG{INT} = 'IGNORE';
1887 local $SIG{QUIT} = 'IGNORE';
1888 local $SIG{TERM} = 'IGNORE';
1889 local $SIG{TSTP} = 'IGNORE';
1890 local $SIG{PIPE} = 'IGNORE';
1892 my $oldAutoCommit = $FS::UID::AutoCommit;
1893 local $FS::UID::AutoCommit = 0;
1897 my $cust_main = qsearchs('cust_main', { custnum => $custnum });
1898 return "Customer not found: $custnum" unless $cust_main;
1900 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
1903 my $change = scalar(@old_cust_pkg) != 0;
1906 if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
1910 #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( last_bill bill );
1912 #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( setup );
1913 $hash{'setup'} = $time if $old_cust_pkg[0]->setup;
1915 $hash{'change_date'} = $time;
1916 $hash{"change_$_"} = $old_cust_pkg[0]->$_() foreach qw( pkgnum pkgpart );
1919 # Create the new packages.
1920 foreach my $pkgpart (@$pkgparts) {
1921 my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
1922 pkgpart => $pkgpart,
1926 $error = $cust_pkg->insert( 'change' => $change );
1928 $dbh->rollback if $oldAutoCommit;
1931 push @$return_cust_pkg, $cust_pkg;
1933 # $return_cust_pkg now contains refs to all of the newly
1936 # Transfer services and cancel old packages.
1937 foreach my $old_pkg (@old_cust_pkg) {
1939 foreach my $new_pkg (@$return_cust_pkg) {
1940 $error = $old_pkg->transfer($new_pkg);
1941 if ($error and $error == 0) {
1942 # $old_pkg->transfer failed.
1943 $dbh->rollback if $oldAutoCommit;
1948 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1949 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1950 foreach my $new_pkg (@$return_cust_pkg) {
1951 $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
1952 if ($error and $error == 0) {
1953 # $old_pkg->transfer failed.
1954 $dbh->rollback if $oldAutoCommit;
1961 # Transfers were successful, but we went through all of the
1962 # new packages and still had services left on the old package.
1963 # We can't cancel the package under the circumstances, so abort.
1964 $dbh->rollback if $oldAutoCommit;
1965 return "Unable to transfer all services from package ".$old_pkg->pkgnum;
1967 $error = $old_pkg->cancel( quiet=>1 );
1973 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1979 Associates this package with a (suspension or cancellation) reason (see
1980 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
1983 Available options are:
1987 =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.
1993 If there is an error, returns the error, otherwise returns false.
1997 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
1999 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
2000 L<FS::part_pkg>) to order for this customer. Duplicates are of course
2003 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
2004 replace. The services (see L<FS::cust_svc>) are moved to the
2005 new billing items. An error is returned if this is not possible (see
2008 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
2009 newly-created cust_pkg objects.
2014 my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
2016 # Transactionize this whole mess
2017 local $SIG{HUP} = 'IGNORE';
2018 local $SIG{INT} = 'IGNORE';
2019 local $SIG{QUIT} = 'IGNORE';
2020 local $SIG{TERM} = 'IGNORE';
2021 local $SIG{TSTP} = 'IGNORE';
2022 local $SIG{PIPE} = 'IGNORE';
2024 my $oldAutoCommit = $FS::UID::AutoCommit;
2025 local $FS::UID::AutoCommit = 0;
2029 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
2032 while(scalar(@old_cust_pkg)) {
2034 my $custnum = $old_cust_pkg[0]->custnum;
2035 my (@remove) = map { $_->pkgnum }
2036 grep { $_->custnum == $custnum } @old_cust_pkg;
2037 @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
2039 my $error = order $custnum, $pkgparts, \@remove, \@return;
2041 push @errors, $error
2043 push @$return_cust_pkg, @return;
2046 if (scalar(@errors)) {
2047 $dbh->rollback if $oldAutoCommit;
2048 return join(' / ', @errors);
2051 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2056 my ($self, %options) = @_;
2058 my $otaker = $FS::CurrentUser::CurrentUser->username;
2061 if ( $options{'reason'} =~ /^(\d+)$/ ) {
2065 } elsif ( ref($options{'reason'}) ) {
2067 return 'Enter a new reason (or select an existing one)'
2068 unless $options{'reason'}->{'reason'} !~ /^\s*$/;
2070 my $reason = new FS::reason({
2071 'reason_type' => $options{'reason'}->{'typenum'},
2072 'reason' => $options{'reason'}->{'reason'},
2074 my $error = $reason->insert;
2075 return $error if $error;
2077 $reasonnum = $reason->reasonnum;
2080 return "Unparsable reason: ". $options{'reason'};
2083 my $cust_pkg_reason =
2084 new FS::cust_pkg_reason({ 'pkgnum' => $self->pkgnum,
2085 'reasonnum' => $reasonnum,
2086 'otaker' => $otaker,
2087 'date' => $options{'date'}
2092 $cust_pkg_reason->insert;
2095 =item set_usage USAGE_VALUE_HASHREF
2097 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2098 to which they should be set (see L<FS::svc_acct>). Currently seconds,
2099 upbytes, downbytes, and totalbytes are appropriate keys.
2101 All svc_accts which are part of this package have their values reset.
2106 my ($self, $valueref) = @_;
2108 foreach my $cust_svc ($self->cust_svc){
2109 my $svc_x = $cust_svc->svc_x;
2110 $svc_x->set_usage($valueref)
2111 if $svc_x->can("set_usage");
2115 =item recharge USAGE_VALUE_HASHREF
2117 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2118 to which they should be set (see L<FS::svc_acct>). Currently seconds,
2119 upbytes, downbytes, and totalbytes are appropriate keys.
2121 All svc_accts which are part of this package have their values incremented.
2126 my ($self, $valueref) = @_;
2128 foreach my $cust_svc ($self->cust_svc){
2129 my $svc_x = $cust_svc->svc_x;
2130 $svc_x->recharge($valueref)
2131 if $svc_x->can("recharge");
2139 sub order is not OO. Perhaps it should be moved to FS::cust_main and made so?
2141 In sub order, the @pkgparts array (passed by reference) is clobbered.
2143 Also in sub order, no money is adjusted. Once FS::part_pkg defines a standard
2144 method to pass dates to the recur_prog expression, it should do so.
2146 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
2147 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
2148 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
2149 configuration values. Probably need a subroutine which decides what to do
2150 based on whether or not we've fetched the user yet, rather than a hash. See
2151 FS::UID and the TODO.
2153 Now that things are transactional should the check in the insert method be
2158 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
2159 L<FS::pkg_svc>, schema.html from the base documentation