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 return $self->setfield('last_bill', $_[0]) if @_;
767 return $self->getfield('last_bill') if $self->getfield('last_bill');
768 my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
769 'edate' => $self->bill, } );
770 $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
773 =item last_cust_pkg_reason
775 Returns the most recent FS::reason associated with the package.
779 sub last_cust_pkg_reason {
782 'table' => 'cust_pkg_reason',
783 'hashref' => { 'pkgnum' => $self->pkgnum, },
784 'extra_sql'=> "AND date <= ". time,
785 'order_by' => 'ORDER BY date DESC LIMIT 1',
791 Returns the most recent FS::reason associated with the package.
796 my $cust_pkg_reason = shift->last_cust_pkg_reason;
797 $cust_pkg_reason->reason
803 Returns the definition for this billing item, as an FS::part_pkg object (see
810 #exists( $self->{'_pkgpart'} )
812 ? $self->{'_pkgpart'}
813 : qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
818 Returns the cancelled package this package was changed from, if any.
824 return '' unless $self->change_pkgnum;
825 qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
830 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
837 $self->part_pkg->calc_setup($self, @_);
842 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
849 $self->part_pkg->calc_recur($self, @_);
854 Calls the I<calc_remain> of the FS::part_pkg object associated with this
861 $self->part_pkg->calc_remain($self, @_);
866 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
873 $self->part_pkg->calc_cancel($self, @_);
878 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
884 qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
889 Returns the new-style customer billing events (see L<FS::cust_event>) for this invoice.
893 #false laziness w/cust_bill.pm
897 'table' => 'cust_event',
898 'addl_from' => 'JOIN part_event USING ( eventpart )',
899 'hashref' => { 'tablenum' => $self->pkgnum },
900 'extra_sql' => " AND eventtable = 'cust_pkg' ",
906 Returns the number of new-style customer billing events (see L<FS::cust_event>) for this invoice.
910 #false laziness w/cust_bill.pm
914 "SELECT COUNT(*) FROM cust_event JOIN part_event USING ( eventpart ) ".
915 " WHERE tablenum = ? AND eventtable = 'cust_pkg'";
916 my $sth = dbh->prepare($sql) or die dbh->errstr. " preparing $sql";
917 $sth->execute($self->pkgnum) or die $sth->errstr. " executing $sql";
918 $sth->fetchrow_arrayref->[0];
921 =item cust_svc [ SVCPART ]
923 Returns the services for this package, as FS::cust_svc objects (see
924 L<FS::cust_svc>). If a svcpart is specified, return only the matching
933 return qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum,
934 'svcpart' => shift, } );
937 #if ( $self->{'_svcnum'} ) {
938 # values %{ $self->{'_svcnum'}->cache };
940 $self->_sort_cust_svc(
941 [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
947 =item overlimit [ SVCPART ]
949 Returns the services for this package which have exceeded their
950 usage limit as FS::cust_svc objects (see L<FS::cust_svc>). If a svcpart
951 is specified, return only the matching services.
957 grep { $_->overlimit } $self->cust_svc;
960 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ]
962 Returns historical services for this package created before END TIMESTAMP and
963 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
964 (see L<FS::h_cust_svc>).
971 $self->_sort_cust_svc(
972 [ qsearch( 'h_cust_svc',
973 { 'pkgnum' => $self->pkgnum, },
974 FS::h_cust_svc->sql_h_search(@_),
981 my( $self, $arrayref ) = @_;
984 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
986 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
987 'svcpart' => $_->svcpart } );
989 $pkg_svc ? $pkg_svc->primary_svc : '',
990 $pkg_svc ? $pkg_svc->quantity : 0,
997 =item num_cust_svc [ SVCPART ]
999 Returns the number of provisioned services for this package. If a svcpart is
1000 specified, counts only the matching services.
1006 my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
1007 $sql .= ' AND svcpart = ?' if @_;
1008 my $sth = dbh->prepare($sql) or die dbh->errstr;
1009 $sth->execute($self->pkgnum, @_) or die $sth->errstr;
1010 $sth->fetchrow_arrayref->[0];
1013 =item available_part_svc
1015 Returns a list of FS::part_svc objects representing services included in this
1016 package but not yet provisioned. Each FS::part_svc object also has an extra
1017 field, I<num_avail>, which specifies the number of available services.
1021 sub available_part_svc {
1023 grep { $_->num_avail > 0 }
1025 my $part_svc = $_->part_svc;
1026 $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
1027 $_->quantity - $self->num_cust_svc($_->svcpart);
1030 $self->part_pkg->pkg_svc;
1035 Returns a list of FS::part_svc objects representing provisioned and available
1036 services included in this package. Each FS::part_svc object also has the
1037 following extra fields:
1041 =item num_cust_svc (count)
1043 =item num_avail (quantity - count)
1045 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
1048 label -> ($cust_svc->label)[1]
1057 #XXX some sort of sort order besides numeric by svcpart...
1058 my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
1060 my $part_svc = $pkg_svc->part_svc;
1061 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1062 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
1063 $part_svc->{'Hash'}{'num_avail'} =
1064 max( 0, $pkg_svc->quantity - $num_cust_svc );
1065 $part_svc->{'Hash'}{'cust_pkg_svc'} = [ $self->cust_svc($part_svc->svcpart) ];
1067 } $self->part_pkg->pkg_svc;
1070 push @part_svc, map {
1072 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1073 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
1074 $part_svc->{'Hash'}{'num_avail'} = 0; #0-$num_cust_svc ?
1075 $part_svc->{'Hash'}{'cust_pkg_svc'} = [ $self->cust_svc($part_svc->svcpart) ];
1077 } $self->extra_part_svc;
1083 =item extra_part_svc
1085 Returns a list of FS::part_svc objects corresponding to services in this
1086 package which are still provisioned but not (any longer) available in the
1091 sub extra_part_svc {
1094 my $pkgnum = $self->pkgnum;
1095 my $pkgpart = $self->pkgpart;
1098 'table' => 'part_svc',
1100 'extra_sql' => "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
1101 WHERE pkg_svc.svcpart = part_svc.svcpart
1102 AND pkg_svc.pkgpart = $pkgpart
1105 AND 0 < ( SELECT count(*)
1107 LEFT JOIN cust_pkg using ( pkgnum )
1108 WHERE cust_svc.svcpart = part_svc.svcpart
1109 AND pkgnum = $pkgnum
1116 Returns a short status string for this package, currently:
1120 =item not yet billed
1122 =item one-time charge
1137 my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
1139 return 'cancelled' if $self->get('cancel');
1140 return 'suspended' if $self->susp;
1141 return 'not yet billed' unless $self->setup;
1142 return 'one-time charge' if $freq =~ /^(0|$)/;
1148 Class method that returns the list of possible status strings for packages
1149 (see L<the status method|/status>). For example:
1151 @statuses = FS::cust_pkg->statuses();
1155 tie my %statuscolor, 'Tie::IxHash',
1156 'not yet billed' => '000000',
1157 'one-time charge' => '000000',
1158 'active' => '00CC00',
1159 'suspended' => 'FF9900',
1160 'cancelled' => 'FF0000',
1164 my $self = shift; #could be class...
1165 grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
1166 # mayble split btw one-time vs. recur
1172 Returns a hex triplet color string for this package's status.
1178 $statuscolor{$self->status};
1183 Returns a list of lists, calling the label method for all services
1184 (see L<FS::cust_svc>) of this billing item.
1190 map { [ $_->label ] } $self->cust_svc;
1193 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
1195 Like the labels method, but returns historical information on services that
1196 were active as of END_TIMESTAMP and (optionally) not cancelled before
1199 Returns a list of lists, calling the label method for all (historical) services
1200 (see L<FS::h_cust_svc>) of this billing item.
1206 map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
1209 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
1211 Like h_labels, except returns a simple flat list, and shortens long
1212 (currently >5) lists of identical services to one line that lists the service
1213 label and the number of individual services rather than individual items.
1217 sub h_labels_short {
1221 #tie %labels, 'Tie::IxHash';
1222 push @{ $labels{$_->[0]} }, $_->[1]
1223 foreach $self->h_labels(@_);
1225 foreach my $label ( keys %labels ) {
1226 my @values = @{ $labels{$label} };
1227 my $num = scalar(@values);
1229 push @labels, "$label ($num)";
1231 push @labels, map { "$label: $_" } @values;
1241 Returns the parent customer object (see L<FS::cust_main>).
1247 qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
1250 =item seconds_since TIMESTAMP
1252 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
1253 package have been online since TIMESTAMP, according to the session monitor.
1255 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1256 L<Time::Local> and L<Date::Parse> for conversion functions.
1261 my($self, $since) = @_;
1264 foreach my $cust_svc (
1265 grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
1267 $seconds += $cust_svc->seconds_since($since);
1274 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1276 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
1277 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
1280 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1281 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1287 sub seconds_since_sqlradacct {
1288 my($self, $start, $end) = @_;
1292 foreach my $cust_svc (
1294 my $part_svc = $_->part_svc;
1295 $part_svc->svcdb eq 'svc_acct'
1296 && scalar($part_svc->part_export('sqlradius'));
1299 $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
1306 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1308 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1309 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1313 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1314 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1319 sub attribute_since_sqlradacct {
1320 my($self, $start, $end, $attrib) = @_;
1324 foreach my $cust_svc (
1326 my $part_svc = $_->part_svc;
1327 $part_svc->svcdb eq 'svc_acct'
1328 && scalar($part_svc->part_export('sqlradius'));
1331 $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
1338 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
1340 Transfers as many services as possible from this package to another package.
1342 The destination package can be specified by pkgnum by passing an FS::cust_pkg
1343 object. The destination package must already exist.
1345 Services are moved only if the destination allows services with the correct
1346 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true. Use
1347 this option with caution! No provision is made for export differences
1348 between the old and new service definitions. Probably only should be used
1349 when your exports for all service definitions of a given svcdb are identical.
1350 (attempt a transfer without it first, to move all possible svcpart-matching
1353 Any services that can't be moved remain in the original package.
1355 Returns an error, if there is one; otherwise, returns the number of services
1356 that couldn't be moved.
1361 my ($self, $dest_pkgnum, %opt) = @_;
1367 if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
1368 $dest = $dest_pkgnum;
1369 $dest_pkgnum = $dest->pkgnum;
1371 $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
1374 return ('Package does not exist: '.$dest_pkgnum) unless $dest;
1376 foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
1377 $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
1380 foreach my $cust_svc ($dest->cust_svc) {
1381 $target{$cust_svc->svcpart}--;
1384 my %svcpart2svcparts = ();
1385 if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1386 warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
1387 foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
1388 next if exists $svcpart2svcparts{$svcpart};
1389 my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
1390 $svcpart2svcparts{$svcpart} = [
1392 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
1394 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
1395 'svcpart' => $_ } );
1397 $pkg_svc ? $pkg_svc->primary_svc : '',
1398 $pkg_svc ? $pkg_svc->quantity : 0,
1402 grep { $_ != $svcpart }
1404 qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
1406 warn "alternates for svcpart $svcpart: ".
1407 join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
1412 foreach my $cust_svc ($self->cust_svc) {
1413 if($target{$cust_svc->svcpart} > 0) {
1414 $target{$cust_svc->svcpart}--;
1415 my $new = new FS::cust_svc { $cust_svc->hash };
1416 $new->pkgnum($dest_pkgnum);
1417 my $error = $new->replace($cust_svc);
1418 return $error if $error;
1419 } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1421 warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
1422 warn "alternates to consider: ".
1423 join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
1425 my @alternate = grep {
1426 warn "considering alternate svcpart $_: ".
1427 "$target{$_} available in new package\n"
1430 } @{$svcpart2svcparts{$cust_svc->svcpart}};
1432 warn "alternate(s) found\n" if $DEBUG;
1433 my $change_svcpart = $alternate[0];
1434 $target{$change_svcpart}--;
1435 my $new = new FS::cust_svc { $cust_svc->hash };
1436 $new->svcpart($change_svcpart);
1437 $new->pkgnum($dest_pkgnum);
1438 my $error = $new->replace($cust_svc);
1439 return $error if $error;
1452 This method is deprecated. See the I<depend_jobnum> option to the insert and
1453 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
1460 local $SIG{HUP} = 'IGNORE';
1461 local $SIG{INT} = 'IGNORE';
1462 local $SIG{QUIT} = 'IGNORE';
1463 local $SIG{TERM} = 'IGNORE';
1464 local $SIG{TSTP} = 'IGNORE';
1465 local $SIG{PIPE} = 'IGNORE';
1467 my $oldAutoCommit = $FS::UID::AutoCommit;
1468 local $FS::UID::AutoCommit = 0;
1471 foreach my $cust_svc ( $self->cust_svc ) {
1472 #false laziness w/svc_Common::insert
1473 my $svc_x = $cust_svc->svc_x;
1474 foreach my $part_export ( $cust_svc->part_svc->part_export ) {
1475 my $error = $part_export->export_insert($svc_x);
1477 $dbh->rollback if $oldAutoCommit;
1483 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1490 =head1 CLASS METHODS
1496 Returns an SQL expression identifying recurring packages.
1500 sub recurring_sql { "
1501 '0' != ( select freq from part_pkg
1502 where cust_pkg.pkgpart = part_pkg.pkgpart )
1507 Returns an SQL expression identifying one-time packages.
1512 '0' = ( select freq from part_pkg
1513 where cust_pkg.pkgpart = part_pkg.pkgpart )
1518 Returns an SQL expression identifying active packages.
1523 ". $_[0]->recurring_sql(). "
1524 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1525 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
1530 Returns an SQL expression identifying inactive packages (one-time packages
1531 that are otherwise unsuspended/uncancelled).
1535 sub inactive_sql { "
1536 ". $_[0]->onetime_sql(). "
1537 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1538 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
1544 Returns an SQL expression identifying suspended packages.
1548 sub suspended_sql { susp_sql(@_); }
1550 #$_[0]->recurring_sql(). ' AND '.
1552 ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1553 AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0
1560 Returns an SQL exprression identifying cancelled packages.
1564 sub cancelled_sql { cancel_sql(@_); }
1566 #$_[0]->recurring_sql(). ' AND '.
1567 "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
1570 =item search_sql HREF
1572 Returns a qsearch hash expression to search for parameters specified in HREF.
1573 Valid parameters are
1577 =item magic - /^(active|inactive|suspended|cancell?ed)$/
1578 =item status - /^(active|inactive|suspended|one-time charge|inactive|cancell?ed)$/
1580 =item pkgpart - list specified how?
1581 =item setup - arrayref of beginning and ending epoch date
1582 =item last_bill - arrayref of beginning and ending epoch date
1583 =item bill - arrayref of beginning and ending epoch date
1584 =item adjourn - arrayref of beginning and ending epoch date
1585 =item susp - arrayref of beginning and ending epoch date
1586 =item expire - arrayref of beginning and ending epoch date
1587 =item cancel - arrayref of beginning and ending epoch date
1588 =item query - /^(pkgnum/APKG_pkgnum)$/
1589 =item cust_fields - a value suited to passing to FS::UI::Web::cust_header
1590 =item CurrentUser - specifies the user for agent virtualization
1596 my ($class, $params) = @_;
1603 if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
1605 "cust_main.agentnum = $1";
1612 if ( $params->{'magic'} eq 'active'
1613 || $params->{'status'} eq 'active' ) {
1615 push @where, FS::cust_pkg->active_sql();
1617 } elsif ( $params->{'magic'} eq 'inactive'
1618 || $params->{'status'} eq 'inactive' ) {
1620 push @where, FS::cust_pkg->inactive_sql();
1622 } elsif ( $params->{'magic'} eq 'suspended'
1623 || $params->{'status'} eq 'suspended' ) {
1625 push @where, FS::cust_pkg->suspended_sql();
1627 } elsif ( $params->{'magic'} =~ /^cancell?ed$/
1628 || $params->{'status'} =~ /^cancell?ed$/ ) {
1630 push @where, FS::cust_pkg->cancelled_sql();
1632 } elsif ( $params->{'status'} =~ /^(one-time charge|inactive)$/ ) {
1634 push @where, FS::cust_pkg->inactive_sql();
1639 # parse package class
1642 #false lazinessish w/graph/cust_bill_pkg.cgi
1645 if ( exists($params->{'classnum'})
1646 && $params->{'classnum'} =~ /^(\d*)$/
1650 if ( $classnum ) { #a specific class
1651 push @where, "classnum = $classnum";
1653 #@pkg_class = ( qsearchs('pkg_class', { 'classnum' => $classnum } ) );
1654 #die "classnum $classnum not found!" unless $pkg_class[0];
1655 #$title .= $pkg_class[0]->classname.' ';
1657 } elsif ( $classnum eq '' ) { #the empty class
1659 push @where, "classnum IS NULL";
1660 #$title .= 'Empty class ';
1661 #@pkg_class = ( '(empty class)' );
1662 } elsif ( $classnum eq '0' ) {
1663 #@pkg_class = qsearch('pkg_class', {} ); # { 'disabled' => '' } );
1664 #push @pkg_class, '(empty class)';
1666 die "illegal classnum";
1675 my $pkgpart = join (' OR pkgpart=',
1676 grep {$_} map { /^(\d+)$/; } ($params->{'pkgpart'}));
1677 push @where, '(pkgpart=' . $pkgpart . ')' if $pkgpart;
1685 #false laziness w/report_cust_pkg.html
1688 'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
1689 'active' => { 'susp'=>1, 'cancel'=>1 },
1690 'suspended' => { 'cancel' => 1 },
1695 foreach my $field (qw( setup last_bill bill adjourn susp expire cancel )) {
1697 next unless exists($params->{$field});
1699 my($beginning, $ending) = @{$params->{$field}};
1701 next if $beginning == 0 && $ending == 4294967295;
1704 "cust_pkg.$field IS NOT NULL",
1705 "cust_pkg.$field >= $beginning",
1706 "cust_pkg.$field <= $ending";
1708 $orderby ||= "ORDER BY cust_pkg.$field";
1712 $orderby ||= 'ORDER BY bill';
1715 # parse magic, legacy, etc.
1718 if ( $params->{'magic'} &&
1719 $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
1722 $orderby = 'ORDER BY pkgnum';
1724 if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
1725 push @where, "pkgpart = $1";
1728 } elsif ( $params->{'query'} eq 'pkgnum' ) {
1730 $orderby = 'ORDER BY pkgnum';
1732 } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
1734 $orderby = 'ORDER BY pkgnum';
1737 SELECT count(*) FROM pkg_svc
1738 WHERE pkg_svc.pkgpart = cust_pkg.pkgpart
1739 AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
1740 WHERE cust_svc.pkgnum = cust_pkg.pkgnum
1741 AND cust_svc.svcpart = pkg_svc.svcpart
1748 # setup queries, links, subs, etc. for the search
1751 # here is the agent virtualization
1752 if ($params->{CurrentUser}) {
1754 qsearchs('access_user', { username => $params->{CurrentUser} });
1757 push @where, $access_user->agentnums_sql('table'=>'cust_main');
1762 push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
1765 my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
1767 my $addl_from = 'LEFT JOIN cust_main USING ( custnum ) '.
1768 'LEFT JOIN part_pkg USING ( pkgpart ) '.
1769 'LEFT JOIN pkg_class USING ( classnum ) ';
1771 my $count_query = "SELECT COUNT(*) FROM cust_pkg $addl_from $extra_sql";
1774 'table' => 'cust_pkg',
1776 'select' => join(', ',
1778 ( map "part_pkg.$_", qw( pkg freq ) ),
1779 'pkg_class.classname',
1780 'cust_main.custnum as cust_main_custnum',
1781 FS::UI::Web::cust_sql_fields(
1782 $params->{'cust_fields'}
1785 'extra_sql' => "$extra_sql $orderby",
1786 'addl_from' => $addl_from,
1787 'count_query' => $count_query,
1796 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
1798 CUSTNUM is a customer (see L<FS::cust_main>)
1800 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
1801 L<FS::part_pkg>) to order for this customer. Duplicates are of course
1804 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
1805 remove for this customer. The services (see L<FS::cust_svc>) are moved to the
1806 new billing items. An error is returned if this is not possible (see
1807 L<FS::pkg_svc>). An empty arrayref is equivalent to not specifying this
1810 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
1811 newly-created cust_pkg objects.
1813 REFNUM, if specified, will specify the FS::pkg_referral record to be created
1814 and inserted. Multiple FS::pkg_referral records can be created by
1815 setting I<refnum> to an array reference of refnums or a hash reference with
1816 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
1817 record will be created corresponding to cust_main.refnum.
1822 my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
1824 my $conf = new FS::Conf;
1826 # Transactionize this whole mess
1827 local $SIG{HUP} = 'IGNORE';
1828 local $SIG{INT} = 'IGNORE';
1829 local $SIG{QUIT} = 'IGNORE';
1830 local $SIG{TERM} = 'IGNORE';
1831 local $SIG{TSTP} = 'IGNORE';
1832 local $SIG{PIPE} = 'IGNORE';
1834 my $oldAutoCommit = $FS::UID::AutoCommit;
1835 local $FS::UID::AutoCommit = 0;
1839 my $cust_main = qsearchs('cust_main', { custnum => $custnum });
1840 return "Customer not found: $custnum" unless $cust_main;
1842 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
1845 my $change = scalar(@old_cust_pkg) != 0;
1848 if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
1852 #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( last_bill bill );
1854 #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( setup );
1855 $hash{'setup'} = $time if $old_cust_pkg[0]->setup;
1857 $hash{'change_date'} = $time;
1858 $hash{"change_$_"} = $old_cust_pkg[0]->$_() foreach qw( pkgnum pkgpart );
1861 # Create the new packages.
1862 foreach my $pkgpart (@$pkgparts) {
1863 my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
1864 pkgpart => $pkgpart,
1868 $error = $cust_pkg->insert( 'change' => $change );
1870 $dbh->rollback if $oldAutoCommit;
1873 push @$return_cust_pkg, $cust_pkg;
1875 # $return_cust_pkg now contains refs to all of the newly
1878 # Transfer services and cancel old packages.
1879 foreach my $old_pkg (@old_cust_pkg) {
1881 foreach my $new_pkg (@$return_cust_pkg) {
1882 $error = $old_pkg->transfer($new_pkg);
1883 if ($error and $error == 0) {
1884 # $old_pkg->transfer failed.
1885 $dbh->rollback if $oldAutoCommit;
1890 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1891 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1892 foreach my $new_pkg (@$return_cust_pkg) {
1893 $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
1894 if ($error and $error == 0) {
1895 # $old_pkg->transfer failed.
1896 $dbh->rollback if $oldAutoCommit;
1903 # Transfers were successful, but we went through all of the
1904 # new packages and still had services left on the old package.
1905 # We can't cancel the package under the circumstances, so abort.
1906 $dbh->rollback if $oldAutoCommit;
1907 return "Unable to transfer all services from package ".$old_pkg->pkgnum;
1909 $error = $old_pkg->cancel( quiet=>1 );
1915 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1921 Associates this package with a (suspension or cancellation) reason (see
1922 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
1925 Available options are:
1929 =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.
1935 If there is an error, returns the error, otherwise returns false.
1939 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
1941 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
1942 L<FS::part_pkg>) to order for this customer. Duplicates are of course
1945 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
1946 replace. The services (see L<FS::cust_svc>) are moved to the
1947 new billing items. An error is returned if this is not possible (see
1950 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
1951 newly-created cust_pkg objects.
1956 my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
1958 # Transactionize this whole mess
1959 local $SIG{HUP} = 'IGNORE';
1960 local $SIG{INT} = 'IGNORE';
1961 local $SIG{QUIT} = 'IGNORE';
1962 local $SIG{TERM} = 'IGNORE';
1963 local $SIG{TSTP} = 'IGNORE';
1964 local $SIG{PIPE} = 'IGNORE';
1966 my $oldAutoCommit = $FS::UID::AutoCommit;
1967 local $FS::UID::AutoCommit = 0;
1971 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
1974 while(scalar(@old_cust_pkg)) {
1976 my $custnum = $old_cust_pkg[0]->custnum;
1977 my (@remove) = map { $_->pkgnum }
1978 grep { $_->custnum == $custnum } @old_cust_pkg;
1979 @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
1981 my $error = order $custnum, $pkgparts, \@remove, \@return;
1983 push @errors, $error
1985 push @$return_cust_pkg, @return;
1988 if (scalar(@errors)) {
1989 $dbh->rollback if $oldAutoCommit;
1990 return join(' / ', @errors);
1993 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1998 my ($self, %options) = @_;
2000 my $otaker = $FS::CurrentUser::CurrentUser->username;
2003 if ( $options{'reason'} =~ /^(\d+)$/ ) {
2007 } elsif ( ref($options{'reason'}) ) {
2009 return 'Enter a new reason (or select an existing one)'
2010 unless $options{'reason'}->{'reason'} !~ /^\s*$/;
2012 my $reason = new FS::reason({
2013 'reason_type' => $options{'reason'}->{'typenum'},
2014 'reason' => $options{'reason'}->{'reason'},
2016 my $error = $reason->insert;
2017 return $error if $error;
2019 $reasonnum = $reason->reasonnum;
2022 return "Unparsable reason: ". $options{'reason'};
2025 my $cust_pkg_reason =
2026 new FS::cust_pkg_reason({ 'pkgnum' => $self->pkgnum,
2027 'reasonnum' => $reasonnum,
2028 'otaker' => $otaker,
2029 'date' => $options{'date'}
2034 $cust_pkg_reason->insert;
2037 =item set_usage USAGE_VALUE_HASHREF
2039 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2040 to which they should be set (see L<FS::svc_acct>). Currently seconds,
2041 upbytes, downbytes, and totalbytes are appropriate keys.
2043 All svc_accts which are part of this package have their values reset.
2048 my ($self, $valueref) = @_;
2050 foreach my $cust_svc ($self->cust_svc){
2051 my $svc_x = $cust_svc->svc_x;
2052 $svc_x->set_usage($valueref)
2053 if $svc_x->can("set_usage");
2057 =item recharge USAGE_VALUE_HASHREF
2059 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2060 to which they should be set (see L<FS::svc_acct>). Currently seconds,
2061 upbytes, downbytes, and totalbytes are appropriate keys.
2063 All svc_accts which are part of this package have their values incremented.
2068 my ($self, $valueref) = @_;
2070 foreach my $cust_svc ($self->cust_svc){
2071 my $svc_x = $cust_svc->svc_x;
2072 $svc_x->recharge($valueref)
2073 if $svc_x->can("recharge");
2081 sub order is not OO. Perhaps it should be moved to FS::cust_main and made so?
2083 In sub order, the @pkgparts array (passed by reference) is clobbered.
2085 Also in sub order, no money is adjusted. Once FS::part_pkg defines a standard
2086 method to pass dates to the recur_prog expression, it should do so.
2088 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
2089 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
2090 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
2091 configuration values. Probably need a subroutine which decides what to do
2092 based on whether or not we've fetched the user yet, rather than a hash. See
2093 FS::UID and the TODO.
2095 Now that things are transactional should the check in the insert method be
2100 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
2101 L<FS::pkg_svc>, schema.html from the base documentation