4 use vars qw(@ISA $disable_agentcheck $DEBUG);
5 use List::Util qw(max);
7 use FS::UID qw( getotaker dbh );
8 use FS::Misc qw( send_email );
9 use FS::Record qw( qsearch qsearchs );
11 use FS::cust_main_Mixin;
17 use FS::cust_bill_pkg;
22 use FS::cust_pkg_reason;
26 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
28 # because they load configuration by setting FS::UID::callback (see TODO)
34 # for sending cancel emails in sub cancel
37 @ISA = qw( FS::m2m_Common FS::cust_main_Mixin FS::option_Common FS::Record );
41 $disable_agentcheck = 0;
45 my ( $hashref, $cache ) = @_;
46 #if ( $hashref->{'pkgpart'} ) {
47 if ( $hashref->{'pkg'} ) {
48 # #@{ $self->{'_pkgnum'} } = ();
49 # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
50 # $self->{'_pkgpart'} = $subcache;
51 # #push @{ $self->{'_pkgnum'} },
52 # FS::part_pkg->new_or_cached($hashref, $subcache);
53 $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
55 if ( exists $hashref->{'svcnum'} ) {
56 #@{ $self->{'_pkgnum'} } = ();
57 my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
58 $self->{'_svcnum'} = $subcache;
59 #push @{ $self->{'_pkgnum'} },
60 FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
66 FS::cust_pkg - Object methods for cust_pkg objects
72 $record = new FS::cust_pkg \%hash;
73 $record = new FS::cust_pkg { 'column' => 'value' };
75 $error = $record->insert;
77 $error = $new_record->replace($old_record);
79 $error = $record->delete;
81 $error = $record->check;
83 $error = $record->cancel;
85 $error = $record->suspend;
87 $error = $record->unsuspend;
89 $part_pkg = $record->part_pkg;
91 @labels = $record->labels;
93 $seconds = $record->seconds_since($timestamp);
95 $error = FS::cust_pkg::order( $custnum, \@pkgparts );
96 $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
100 An FS::cust_pkg object represents a customer billing item. FS::cust_pkg
101 inherits from FS::Record. The following fields are currently supported:
105 =item pkgnum - primary key (assigned automatically for new billing items)
107 =item custnum - Customer (see L<FS::cust_main>)
109 =item pkgpart - Billing item definition (see L<FS::part_pkg>)
113 =item bill - date (next bill date)
115 =item last_bill - last bill date
125 =item otaker - order taker (assigned automatically if null, see L<FS::UID>)
127 =item manual_flag - If this field is set to 1, disables the automatic
128 unsuspension of this package when using the B<unsuspendauto> config file.
132 Note: setup, bill, adjourn, susp, expire and cancel are specified as UNIX timestamps;
133 see L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for
134 conversion functions.
142 Create a new billing item. To add the item to the database, see L<"insert">.
146 sub table { 'cust_pkg'; }
147 sub cust_linked { $_[0]->cust_main_custnum; }
148 sub cust_unlinked_msg {
150 "WARNING: can't find cust_main.custnum ". $self->custnum.
151 ' (cust_pkg.pkgnum '. $self->pkgnum. ')';
154 =item insert [ OPTION => VALUE ... ]
156 Adds this billing item to the database ("Orders" the item). If there is an
157 error, returns the error, otherwise returns false.
159 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
160 will be used to look up the package definition and agent restrictions will be
163 If the additional field I<refnum> is defined, an FS::pkg_referral record will
164 be created and inserted. Multiple FS::pkg_referral records can be created by
165 setting I<refnum> to an array reference of refnums or a hash reference with
166 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
167 record will be created corresponding to cust_main.refnum.
169 The following options are available: I<change>
171 I<change>, if set true, supresses any referral credit to a referring customer.
176 my( $self, %options ) = @_;
178 local $SIG{HUP} = 'IGNORE';
179 local $SIG{INT} = 'IGNORE';
180 local $SIG{QUIT} = 'IGNORE';
181 local $SIG{TERM} = 'IGNORE';
182 local $SIG{TSTP} = 'IGNORE';
183 local $SIG{PIPE} = 'IGNORE';
185 my $oldAutoCommit = $FS::UID::AutoCommit;
186 local $FS::UID::AutoCommit = 0;
189 my $error = $self->SUPER::insert($options{options} ? %{$options{options}} : ());
191 $dbh->rollback if $oldAutoCommit;
195 $self->refnum($self->cust_main->refnum) unless $self->refnum;
196 $self->refnum( [ $self->refnum ] ) unless ref($self->refnum);
197 $self->process_m2m( 'link_table' => 'pkg_referral',
198 'target_table' => 'part_referral',
199 'params' => $self->refnum,
202 #if ( $self->reg_code ) {
203 # my $reg_code = qsearchs('reg_code', { 'code' => $self->reg_code } );
204 # $error = $reg_code->delete;
206 # $dbh->rollback if $oldAutoCommit;
211 my $conf = new FS::Conf;
212 my $cust_main = $self->cust_main;
213 my $part_pkg = $self->part_pkg;
214 if ( $conf->exists('referral_credit')
215 && $cust_main->referral_custnum
216 && ! $options{'change'}
217 && $part_pkg->freq !~ /^0\D?$/
220 my $referring_cust_main = $cust_main->referring_cust_main;
221 if ( $referring_cust_main->status ne 'cancelled' ) {
223 if ( $part_pkg->freq !~ /^\d+$/ ) {
224 warn 'WARNING: Not crediting customer '. $cust_main->referral_custnum.
225 ' for package '. $self->pkgnum.
226 ' ( customer '. $self->custnum. ')'.
227 ' - One-time referral credits not (yet) available for '.
228 ' packages with '. $part_pkg->freq_pretty. ' frequency';
231 my $amount = sprintf( "%.2f", $part_pkg->base_recur / $part_pkg->freq );
233 $referring_cust_main->
235 'Referral credit for '.$cust_main->name,
236 'reason_type' => $conf->config('referral_credit_type')
239 $dbh->rollback if $oldAutoCommit;
240 return "Error crediting customer ". $cust_main->referral_custnum.
241 " for referral: $error";
249 if ($conf->config('welcome_letter') && $self->cust_main->num_pkgs == 1) {
250 my $queue = new FS::queue {
251 'job' => 'FS::cust_main::queueable_print',
253 $error = $queue->insert(
254 'custnum' => $self->custnum,
255 'template' => 'welcome_letter',
259 warn "can't send welcome letter: $error";
264 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
271 This method now works but you probably shouldn't use it.
273 You don't want to delete billing items, because there would then be no record
274 the customer ever purchased the item. Instead, see the cancel method.
279 # return "Can't delete cust_pkg records!";
282 =item replace OLD_RECORD
284 Replaces the OLD_RECORD with this one in the database. If there is an error,
285 returns the error, otherwise returns false.
287 Currently, custnum, setup, bill, adjourn, susp, expire, and cancel may be changed.
289 Changing pkgpart may have disasterous effects. See the order subroutine.
291 setup and bill are normally updated by calling the bill method of a customer
292 object (see L<FS::cust_main>).
294 suspend is normally updated by the suspend and unsuspend methods.
296 cancel is normally updated by the cancel method (and also the order subroutine
304 my( $new, $old, %options ) = @_;
306 # We absolutely have to have an old vs. new record to make this work.
307 if (!defined($old)) {
308 $old = qsearchs( 'cust_pkg', { 'pkgnum' => $new->pkgnum } );
310 #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
311 return "Can't change otaker!" if $old->otaker ne $new->otaker;
314 #return "Can't change setup once it exists!"
315 # if $old->getfield('setup') &&
316 # $old->getfield('setup') != $new->getfield('setup');
318 #some logic for bill, susp, cancel?
320 local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
322 local $SIG{HUP} = 'IGNORE';
323 local $SIG{INT} = 'IGNORE';
324 local $SIG{QUIT} = 'IGNORE';
325 local $SIG{TERM} = 'IGNORE';
326 local $SIG{TSTP} = 'IGNORE';
327 local $SIG{PIPE} = 'IGNORE';
329 my $oldAutoCommit = $FS::UID::AutoCommit;
330 local $FS::UID::AutoCommit = 0;
333 foreach my $method ( qw(adjourn expire) ) { # How many reasons?
334 if ($options{'reason'} && $new->$method && $old->$method ne $new->$method) {
335 my $error = $new->insert_reason( 'reason' => $options{'reason'},
336 'date' => $new->$method,
339 dbh->rollback if $oldAutoCommit;
340 return "Error inserting cust_pkg_reason: $error";
345 #save off and freeze RADIUS attributes for any associated svc_acct records
347 if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
349 #also check for specific exports?
350 # to avoid spurious modify export events
351 @svc_acct = map { $_->svc_x }
352 grep { $_->part_svc->svcdb eq 'svc_acct' }
355 $_->snapshot foreach @svc_acct;
359 my $error = $new->SUPER::replace($old,
360 $options{options} ? ${options{options}} : ()
363 $dbh->rollback if $oldAutoCommit;
367 #for prepaid packages,
368 #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
369 foreach my $old_svc_acct ( @svc_acct ) {
370 my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
371 my $s_error = $new_svc_acct->replace($old_svc_acct);
373 $dbh->rollback if $oldAutoCommit;
378 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
385 Checks all fields to make sure this is a valid billing item. If there is an
386 error, returns the error, otherwise returns false. Called by the insert and
395 $self->ut_numbern('pkgnum')
396 || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
397 || $self->ut_numbern('pkgpart')
398 || $self->ut_numbern('setup')
399 || $self->ut_numbern('bill')
400 || $self->ut_numbern('susp')
401 || $self->ut_numbern('cancel')
402 || $self->ut_numbern('adjourn')
403 || $self->ut_numbern('expire')
405 return $error if $error;
407 if ( $self->reg_code ) {
409 unless ( grep { $self->pkgpart == $_->pkgpart }
410 map { $_->reg_code_pkg }
411 qsearchs( 'reg_code', { 'code' => $self->reg_code,
412 'agentnum' => $self->cust_main->agentnum })
414 return "Unknown registration code";
417 } elsif ( $self->promo_code ) {
420 qsearchs('part_pkg', {
421 'pkgpart' => $self->pkgpart,
422 'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
424 return 'Unknown promotional code' unless $promo_part_pkg;
428 unless ( $disable_agentcheck ) {
430 qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
431 my $pkgpart_href = $agent->pkgpart_hashref;
432 return "agent ". $agent->agentnum.
433 " can't purchase pkgpart ". $self->pkgpart
434 unless $pkgpart_href->{ $self->pkgpart };
437 $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
438 return $error if $error;
442 $self->otaker(getotaker) unless $self->otaker;
443 $self->otaker =~ /^(\w{1,32})$/ or return "Illegal otaker";
446 if ( $self->dbdef_table->column('manual_flag') ) {
447 $self->manual_flag('') if $self->manual_flag eq ' ';
448 $self->manual_flag =~ /^([01]?)$/
449 or return "Illegal manual_flag ". $self->manual_flag;
450 $self->manual_flag($1);
456 =item cancel [ OPTION => VALUE ... ]
458 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
459 in this package, then cancels the package itself (sets the cancel field to
462 Available options are:
466 =item quiet - can be set true to supress email cancellation notices.
468 =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.
470 =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.
474 If there is an error, returns the error, otherwise returns false.
479 my( $self, %options ) = @_;
481 warn "cust_pkg::cancel called with options".
482 join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
485 local $SIG{HUP} = 'IGNORE';
486 local $SIG{INT} = 'IGNORE';
487 local $SIG{QUIT} = 'IGNORE';
488 local $SIG{TERM} = 'IGNORE';
489 local $SIG{TSTP} = 'IGNORE';
490 local $SIG{PIPE} = 'IGNORE';
492 my $oldAutoCommit = $FS::UID::AutoCommit;
493 local $FS::UID::AutoCommit = 0;
496 my $cancel_time = $options{'time'} || time;
500 if ( $options{'reason'} ) {
501 $error = $self->insert_reason( 'reason' => $options{'reason'} );
503 dbh->rollback if $oldAutoCommit;
504 return "Error inserting cust_pkg_reason: $error";
509 foreach my $cust_svc (
512 sort { $a->[1] <=> $b->[1] }
513 map { [ $_, $_->svc_x->table_info->{'cancel_weight'} ]; }
514 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
517 my $error = $cust_svc->cancel;
520 $dbh->rollback if $oldAutoCommit;
521 return "Error cancelling cust_svc: $error";
525 unless ( $self->getfield('cancel') ) {
526 # Add a credit for remaining service
527 my $remaining_value = $self->calc_remain(time=>$cancel_time);
528 if ( $remaining_value > 0 && !$options{'no_credit'} ) {
529 my $conf = new FS::Conf;
530 my $error = $self->cust_main->credit(
532 'Credit for unused time on '. $self->part_pkg->pkg,
533 'reason_type' => $conf->config('cancel_credit_type'),
536 $dbh->rollback if $oldAutoCommit;
537 return "Error crediting customer \$$remaining_value for unused time on".
538 $self->part_pkg->pkg. ": $error";
541 my %hash = $self->hash;
542 $hash{'cancel'} = $cancel_time;
543 my $new = new FS::cust_pkg ( \%hash );
544 $error = $new->replace( $self, options => { $self->options } );
546 $dbh->rollback if $oldAutoCommit;
551 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
553 my $conf = new FS::Conf;
554 my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
555 if ( !$options{'quiet'} && $conf->exists('emailcancel') && @invoicing_list ) {
556 my $conf = new FS::Conf;
557 my $error = send_email(
558 'from' => $conf->config('invoice_from'),
559 'to' => \@invoicing_list,
560 'subject' => ( $conf->config('cancelsubject') || 'Cancellation Notice' ),
561 'body' => [ map "$_\n", $conf->config('cancelmessage') ],
563 #should this do something on errors?
570 =item cancel_if_expired [ NOW_TIMESTAMP ]
572 Cancels this package if its expire date has been reached.
576 sub cancel_if_expired {
578 my $time = shift || time;
579 return '' unless $self->expire && $self->expire <= $time;
580 my $error = $self->cancel;
582 return "Error cancelling expired pkg ". $self->pkgnum. " for custnum ".
583 $self->custnum. ": $error";
588 =item suspend [ OPTION => VALUE ... ]
590 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
591 package, then suspends the package itself (sets the susp field to now).
593 Available options are:
597 =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.
601 If there is an error, returns the error, otherwise returns false.
606 my( $self, %options ) = @_;
608 local $SIG{HUP} = 'IGNORE';
609 local $SIG{INT} = 'IGNORE';
610 local $SIG{QUIT} = 'IGNORE';
611 local $SIG{TERM} = 'IGNORE';
612 local $SIG{TSTP} = 'IGNORE';
613 local $SIG{PIPE} = 'IGNORE';
615 my $oldAutoCommit = $FS::UID::AutoCommit;
616 local $FS::UID::AutoCommit = 0;
621 if ( $options{'reason'} ) {
622 $error = $self->insert_reason( 'reason' => $options{'reason'} );
624 dbh->rollback if $oldAutoCommit;
625 return "Error inserting cust_pkg_reason: $error";
629 foreach my $cust_svc (
630 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
632 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
634 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
635 $dbh->rollback if $oldAutoCommit;
636 return "Illegal svcdb value in part_svc!";
639 require "FS/$svcdb.pm";
641 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
643 $error = $svc->suspend;
645 $dbh->rollback if $oldAutoCommit;
652 unless ( $self->getfield('susp') ) {
653 my %hash = $self->hash;
654 $hash{'susp'} = time;
655 my $new = new FS::cust_pkg ( \%hash );
656 $error = $new->replace( $self, options => { $self->options } );
658 $dbh->rollback if $oldAutoCommit;
663 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
668 =item unsuspend [ OPTION => VALUE ... ]
670 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
671 package, then unsuspends the package itself (clears the susp field and the
672 adjourn field if it is in the past).
674 Available options are: I<adjust_next_bill>.
676 I<adjust_next_bill> can be set true to adjust the next bill date forward by
677 the amount of time the account was inactive. This was set true by default
678 since 1.4.2 and 1.5.0pre6; however, starting with 1.7.0 this needs to be
679 explicitly requested. Price plans for which this makes sense (anniversary-date
680 based than prorate or subscription) could have an option to enable this
683 If there is an error, returns the error, otherwise returns false.
688 my( $self, %opt ) = @_;
691 local $SIG{HUP} = 'IGNORE';
692 local $SIG{INT} = 'IGNORE';
693 local $SIG{QUIT} = 'IGNORE';
694 local $SIG{TERM} = 'IGNORE';
695 local $SIG{TSTP} = 'IGNORE';
696 local $SIG{PIPE} = 'IGNORE';
698 my $oldAutoCommit = $FS::UID::AutoCommit;
699 local $FS::UID::AutoCommit = 0;
702 foreach my $cust_svc (
703 qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
705 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
707 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
708 $dbh->rollback if $oldAutoCommit;
709 return "Illegal svcdb value in part_svc!";
712 require "FS/$svcdb.pm";
714 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
716 $error = $svc->unsuspend;
718 $dbh->rollback if $oldAutoCommit;
725 unless ( ! $self->getfield('susp') ) {
726 my %hash = $self->hash;
727 my $inactive = time - $hash{'susp'};
729 my $conf = new FS::Conf;
731 $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive
732 if ( $opt{'adjust_next_bill'}
733 || $conf->config('unsuspend-always_adjust_next_bill_date') )
734 && $inactive > 0 && ( $hash{'bill'} || $hash{'setup'} );
737 $hash{'adjourn'} = '' if $hash{'adjourn'} < time;
738 my $new = new FS::cust_pkg ( \%hash );
739 $error = $new->replace( $self, options => { $self->options } );
741 $dbh->rollback if $oldAutoCommit;
746 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
753 Returns the last bill date, or if there is no last bill date, the setup date.
754 Useful for billing metered services.
760 if ( $self->dbdef_table->column('last_bill') ) {
761 return $self->setfield('last_bill', $_[0]) if @_;
762 return $self->getfield('last_bill') if $self->getfield('last_bill');
764 my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
765 'edate' => $self->bill, } );
766 $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
771 Returns the most recent FS::reason associated with the package.
777 my $cust_pkg_reason = qsearchs( {
778 'table' => 'cust_pkg_reason',
779 'hashref' => { 'pkgnum' => $self->pkgnum, },
780 'extra_sql'=> 'ORDER BY date DESC LIMIT 1',
782 qsearchs ( 'reason', { 'reasonnum' => $cust_pkg_reason->reasonnum } )
788 Returns the definition for this billing item, as an FS::part_pkg object (see
795 #exists( $self->{'_pkgpart'} )
797 ? $self->{'_pkgpart'}
798 : qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
803 Returns the cancelled package this package was changed from, if any.
809 return '' unless $self->change_pkgnum;
810 qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
815 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
822 $self->part_pkg->calc_setup($self, @_);
827 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
834 $self->part_pkg->calc_recur($self, @_);
839 Calls the I<calc_remain> of the FS::part_pkg object associated with this
846 $self->part_pkg->calc_remain($self, @_);
851 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
858 $self->part_pkg->calc_cancel($self, @_);
863 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
869 qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
874 Returns the new-style customer billing events (see L<FS::cust_event>) for this invoice.
878 #false laziness w/cust_bill.pm
882 'table' => 'cust_event',
883 'addl_from' => 'JOIN part_event USING ( eventpart )',
884 'hashref' => { 'tablenum' => $self->pkgnum },
885 'extra_sql' => " AND eventtable = 'cust_pkg' ",
891 Returns the number of new-style customer billing events (see L<FS::cust_event>) for this invoice.
895 #false laziness w/cust_bill.pm
899 "SELECT COUNT(*) FROM cust_event JOIN part_event USING ( eventpart ) ".
900 " WHERE tablenum = ? AND eventtable = 'cust_pkg'";
901 my $sth = dbh->prepare($sql) or die dbh->errstr. " preparing $sql";
902 $sth->execute($self->pkgnum) or die $sth->errstr. " executing $sql";
903 $sth->fetchrow_arrayref->[0];
906 =item cust_svc [ SVCPART ]
908 Returns the services for this package, as FS::cust_svc objects (see
909 L<FS::cust_svc>). If a svcpart is specified, return only the matching
918 return qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum,
919 'svcpart' => shift, } );
922 #if ( $self->{'_svcnum'} ) {
923 # values %{ $self->{'_svcnum'}->cache };
925 $self->_sort_cust_svc(
926 [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
932 =item overlimit [ SVCPART ]
934 Returns the services for this package which have exceeded their
935 usage limit as FS::cust_svc objects (see L<FS::cust_svc>). If a svcpart
936 is specified, return only the matching services.
942 grep { $_->overlimit } $self->cust_svc;
945 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ]
947 Returns historical services for this package created before END TIMESTAMP and
948 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
949 (see L<FS::h_cust_svc>).
956 $self->_sort_cust_svc(
957 [ qsearch( 'h_cust_svc',
958 { 'pkgnum' => $self->pkgnum, },
959 FS::h_cust_svc->sql_h_search(@_),
966 my( $self, $arrayref ) = @_;
969 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
971 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
972 'svcpart' => $_->svcpart } );
974 $pkg_svc ? $pkg_svc->primary_svc : '',
975 $pkg_svc ? $pkg_svc->quantity : 0,
982 =item num_cust_svc [ SVCPART ]
984 Returns the number of provisioned services for this package. If a svcpart is
985 specified, counts only the matching services.
991 my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
992 $sql .= ' AND svcpart = ?' if @_;
993 my $sth = dbh->prepare($sql) or die dbh->errstr;
994 $sth->execute($self->pkgnum, @_) or die $sth->errstr;
995 $sth->fetchrow_arrayref->[0];
998 =item available_part_svc
1000 Returns a list of FS::part_svc objects representing services included in this
1001 package but not yet provisioned. Each FS::part_svc object also has an extra
1002 field, I<num_avail>, which specifies the number of available services.
1006 sub available_part_svc {
1008 grep { $_->num_avail > 0 }
1010 my $part_svc = $_->part_svc;
1011 $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
1012 $_->quantity - $self->num_cust_svc($_->svcpart);
1015 $self->part_pkg->pkg_svc;
1020 Returns a list of FS::part_svc objects representing provisioned and available
1021 services included in this package. Each FS::part_svc object also has the
1022 following extra fields:
1026 =item num_cust_svc (count)
1028 =item num_avail (quantity - count)
1030 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
1033 label -> ($cust_svc->label)[1]
1042 #XXX some sort of sort order besides numeric by svcpart...
1043 my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
1045 my $part_svc = $pkg_svc->part_svc;
1046 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1047 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
1048 $part_svc->{'Hash'}{'num_avail'} =
1049 max( 0, $pkg_svc->quantity - $num_cust_svc );
1050 $part_svc->{'Hash'}{'cust_pkg_svc'} = [ $self->cust_svc($part_svc->svcpart) ];
1052 } $self->part_pkg->pkg_svc;
1055 push @part_svc, map {
1057 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1058 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
1059 $part_svc->{'Hash'}{'num_avail'} = 0; #0-$num_cust_svc ?
1060 $part_svc->{'Hash'}{'cust_pkg_svc'} = [ $self->cust_svc($part_svc->svcpart) ];
1062 } $self->extra_part_svc;
1068 =item extra_part_svc
1070 Returns a list of FS::part_svc objects corresponding to services in this
1071 package which are still provisioned but not (any longer) available in the
1076 sub extra_part_svc {
1079 my $pkgnum = $self->pkgnum;
1080 my $pkgpart = $self->pkgpart;
1083 'table' => 'part_svc',
1085 'extra_sql' => "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
1086 WHERE pkg_svc.svcpart = part_svc.svcpart
1087 AND pkg_svc.pkgpart = $pkgpart
1090 AND 0 < ( SELECT count(*)
1092 LEFT JOIN cust_pkg using ( pkgnum )
1093 WHERE cust_svc.svcpart = part_svc.svcpart
1094 AND pkgnum = $pkgnum
1101 Returns a short status string for this package, currently:
1105 =item not yet billed
1107 =item one-time charge
1122 my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
1124 return 'cancelled' if $self->get('cancel');
1125 return 'suspended' if $self->susp;
1126 return 'not yet billed' unless $self->setup;
1127 return 'one-time charge' if $freq =~ /^(0|$)/;
1133 Class method that returns the list of possible status strings for packages
1134 (see L<the status method|/status>). For example:
1136 @statuses = FS::cust_pkg->statuses();
1140 tie my %statuscolor, 'Tie::IxHash',
1141 'not yet billed' => '000000',
1142 'one-time charge' => '000000',
1143 'active' => '00CC00',
1144 'suspended' => 'FF9900',
1145 'cancelled' => 'FF0000',
1149 my $self = shift; #could be class...
1150 grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
1151 # mayble split btw one-time vs. recur
1157 Returns a hex triplet color string for this package's status.
1163 $statuscolor{$self->status};
1168 Returns a list of lists, calling the label method for all services
1169 (see L<FS::cust_svc>) of this billing item.
1175 map { [ $_->label ] } $self->cust_svc;
1178 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
1180 Like the labels method, but returns historical information on services that
1181 were active as of END_TIMESTAMP and (optionally) not cancelled before
1184 Returns a list of lists, calling the label method for all (historical) services
1185 (see L<FS::h_cust_svc>) of this billing item.
1191 map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
1194 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
1196 Like h_labels, except returns a simple flat list, and shortens long
1197 (currently >5) lists of identical services to one line that lists the service
1198 label and the number of individual services rather than individual items.
1202 sub h_labels_short {
1206 #tie %labels, 'Tie::IxHash';
1207 push @{ $labels{$_->[0]} }, $_->[1]
1208 foreach $self->h_labels(@_);
1210 foreach my $label ( keys %labels ) {
1211 my @values = @{ $labels{$label} };
1212 my $num = scalar(@values);
1214 push @labels, "$label ($num)";
1216 push @labels, map { "$label: $_" } @values;
1226 Returns the parent customer object (see L<FS::cust_main>).
1232 qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
1235 =item seconds_since TIMESTAMP
1237 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
1238 package have been online since TIMESTAMP, according to the session monitor.
1240 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1241 L<Time::Local> and L<Date::Parse> for conversion functions.
1246 my($self, $since) = @_;
1249 foreach my $cust_svc (
1250 grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
1252 $seconds += $cust_svc->seconds_since($since);
1259 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1261 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
1262 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
1265 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1266 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1272 sub seconds_since_sqlradacct {
1273 my($self, $start, $end) = @_;
1277 foreach my $cust_svc (
1279 my $part_svc = $_->part_svc;
1280 $part_svc->svcdb eq 'svc_acct'
1281 && scalar($part_svc->part_export('sqlradius'));
1284 $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
1291 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1293 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1294 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1298 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1299 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1304 sub attribute_since_sqlradacct {
1305 my($self, $start, $end, $attrib) = @_;
1309 foreach my $cust_svc (
1311 my $part_svc = $_->part_svc;
1312 $part_svc->svcdb eq 'svc_acct'
1313 && scalar($part_svc->part_export('sqlradius'));
1316 $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
1323 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
1325 Transfers as many services as possible from this package to another package.
1327 The destination package can be specified by pkgnum by passing an FS::cust_pkg
1328 object. The destination package must already exist.
1330 Services are moved only if the destination allows services with the correct
1331 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true. Use
1332 this option with caution! No provision is made for export differences
1333 between the old and new service definitions. Probably only should be used
1334 when your exports for all service definitions of a given svcdb are identical.
1335 (attempt a transfer without it first, to move all possible svcpart-matching
1338 Any services that can't be moved remain in the original package.
1340 Returns an error, if there is one; otherwise, returns the number of services
1341 that couldn't be moved.
1346 my ($self, $dest_pkgnum, %opt) = @_;
1352 if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
1353 $dest = $dest_pkgnum;
1354 $dest_pkgnum = $dest->pkgnum;
1356 $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
1359 return ('Package does not exist: '.$dest_pkgnum) unless $dest;
1361 foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
1362 $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
1365 foreach my $cust_svc ($dest->cust_svc) {
1366 $target{$cust_svc->svcpart}--;
1369 my %svcpart2svcparts = ();
1370 if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1371 warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
1372 foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
1373 next if exists $svcpart2svcparts{$svcpart};
1374 my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
1375 $svcpart2svcparts{$svcpart} = [
1377 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
1379 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
1380 'svcpart' => $_ } );
1382 $pkg_svc ? $pkg_svc->primary_svc : '',
1383 $pkg_svc ? $pkg_svc->quantity : 0,
1387 grep { $_ != $svcpart }
1389 qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
1391 warn "alternates for svcpart $svcpart: ".
1392 join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
1397 foreach my $cust_svc ($self->cust_svc) {
1398 if($target{$cust_svc->svcpart} > 0) {
1399 $target{$cust_svc->svcpart}--;
1400 my $new = new FS::cust_svc { $cust_svc->hash };
1401 $new->pkgnum($dest_pkgnum);
1402 my $error = $new->replace($cust_svc);
1403 return $error if $error;
1404 } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1406 warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
1407 warn "alternates to consider: ".
1408 join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
1410 my @alternate = grep {
1411 warn "considering alternate svcpart $_: ".
1412 "$target{$_} available in new package\n"
1415 } @{$svcpart2svcparts{$cust_svc->svcpart}};
1417 warn "alternate(s) found\n" if $DEBUG;
1418 my $change_svcpart = $alternate[0];
1419 $target{$change_svcpart}--;
1420 my $new = new FS::cust_svc { $cust_svc->hash };
1421 $new->svcpart($change_svcpart);
1422 $new->pkgnum($dest_pkgnum);
1423 my $error = $new->replace($cust_svc);
1424 return $error if $error;
1437 This method is deprecated. See the I<depend_jobnum> option to the insert and
1438 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
1445 local $SIG{HUP} = 'IGNORE';
1446 local $SIG{INT} = 'IGNORE';
1447 local $SIG{QUIT} = 'IGNORE';
1448 local $SIG{TERM} = 'IGNORE';
1449 local $SIG{TSTP} = 'IGNORE';
1450 local $SIG{PIPE} = 'IGNORE';
1452 my $oldAutoCommit = $FS::UID::AutoCommit;
1453 local $FS::UID::AutoCommit = 0;
1456 foreach my $cust_svc ( $self->cust_svc ) {
1457 #false laziness w/svc_Common::insert
1458 my $svc_x = $cust_svc->svc_x;
1459 foreach my $part_export ( $cust_svc->part_svc->part_export ) {
1460 my $error = $part_export->export_insert($svc_x);
1462 $dbh->rollback if $oldAutoCommit;
1468 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1475 =head1 CLASS METHODS
1481 Returns an SQL expression identifying recurring packages.
1485 sub recurring_sql { "
1486 '0' != ( select freq from part_pkg
1487 where cust_pkg.pkgpart = part_pkg.pkgpart )
1492 Returns an SQL expression identifying one-time packages.
1497 '0' = ( select freq from part_pkg
1498 where cust_pkg.pkgpart = part_pkg.pkgpart )
1503 Returns an SQL expression identifying active packages.
1508 ". $_[0]->recurring_sql(). "
1509 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1510 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
1515 Returns an SQL expression identifying inactive packages (one-time packages
1516 that are otherwise unsuspended/uncancelled).
1520 sub inactive_sql { "
1521 ". $_[0]->onetime_sql(). "
1522 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1523 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
1529 Returns an SQL expression identifying suspended packages.
1533 sub suspended_sql { susp_sql(@_); }
1535 #$_[0]->recurring_sql(). ' AND '.
1537 ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1538 AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0
1545 Returns an SQL exprression identifying cancelled packages.
1549 sub cancelled_sql { cancel_sql(@_); }
1551 #$_[0]->recurring_sql(). ' AND '.
1552 "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
1555 =item search_sql HREF
1557 Returns a qsearch hash expression to search for parameters specified in HREF.
1558 Valid parameters are
1562 =item magic - /^(active|inactive|suspended|cancell?ed)$/
1563 =item status - /^(active|inactive|suspended|one-time charge|inactive|cancell?ed)$/
1565 =item pkgpart - list specified how?
1566 =item setup - arrayref of beginning and ending epoch date
1567 =item last_bill - arrayref of beginning and ending epoch date
1568 =item bill - arrayref of beginning and ending epoch date
1569 =item adjourn - arrayref of beginning and ending epoch date
1570 =item susp - arrayref of beginning and ending epoch date
1571 =item expire - arrayref of beginning and ending epoch date
1572 =item cancel - arrayref of beginning and ending epoch date
1573 =item query - /^(pkgnum/APKG_pkgnum)$/
1574 =item cust_fields - a value suited to passing to FS::UI::Web::cust_header
1575 =item CurrentUser - specifies the user for agent virtualization
1581 my ($class, $params) = @_;
1588 if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
1590 "cust_main.agentnum = $1";
1597 if ( $params->{'magic'} eq 'active'
1598 || $params->{'status'} eq 'active' ) {
1600 push @where, FS::cust_pkg->active_sql();
1602 } elsif ( $params->{'magic'} eq 'inactive'
1603 || $params->{'status'} eq 'inactive' ) {
1605 push @where, FS::cust_pkg->inactive_sql();
1607 } elsif ( $params->{'magic'} eq 'suspended'
1608 || $params->{'status'} eq 'suspended' ) {
1610 push @where, FS::cust_pkg->suspended_sql();
1612 } elsif ( $params->{'magic'} =~ /^cancell?ed$/
1613 || $params->{'status'} =~ /^cancell?ed$/ ) {
1615 push @where, FS::cust_pkg->cancelled_sql();
1617 } elsif ( $params->{'status'} =~ /^(one-time charge|inactive)$/ ) {
1619 push @where, FS::cust_pkg->inactive_sql();
1624 # parse package class
1627 #false lazinessish w/graph/cust_bill_pkg.cgi
1630 if ( exists($params->{'classnum'})
1631 && $params->{'classnum'} =~ /^(\d*)$/
1635 if ( $classnum ) { #a specific class
1636 push @where, "classnum = $classnum";
1638 #@pkg_class = ( qsearchs('pkg_class', { 'classnum' => $classnum } ) );
1639 #die "classnum $classnum not found!" unless $pkg_class[0];
1640 #$title .= $pkg_class[0]->classname.' ';
1642 } elsif ( $classnum eq '' ) { #the empty class
1644 push @where, "classnum IS NULL";
1645 #$title .= 'Empty class ';
1646 #@pkg_class = ( '(empty class)' );
1647 } elsif ( $classnum eq '0' ) {
1648 #@pkg_class = qsearch('pkg_class', {} ); # { 'disabled' => '' } );
1649 #push @pkg_class, '(empty class)';
1651 die "illegal classnum";
1660 my $pkgpart = join (' OR pkgpart=',
1661 grep {$_} map { /^(\d+)$/; } ($params->{'pkgpart'}));
1662 push @where, '(pkgpart=' . $pkgpart . ')' if $pkgpart;
1670 #false laziness w/report_cust_pkg.html
1673 'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
1674 'active' => { 'susp'=>1, 'cancel'=>1 },
1675 'suspended' => { 'cancel' => 1 },
1680 foreach my $field (qw( setup last_bill bill adjourn susp expire cancel )) {
1682 next unless exists($params->{$field});
1684 my($beginning, $ending) = @{$params->{$field}};
1686 next if $beginning == 0 && $ending == 4294967295;
1689 "cust_pkg.$field IS NOT NULL",
1690 "cust_pkg.$field >= $beginning",
1691 "cust_pkg.$field <= $ending";
1693 $orderby ||= "ORDER BY cust_pkg.$field";
1697 $orderby ||= 'ORDER BY bill';
1700 # parse magic, legacy, etc.
1703 if ( $params->{'magic'} &&
1704 $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
1707 $orderby = 'ORDER BY pkgnum';
1709 if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
1710 push @where, "pkgpart = $1";
1713 } elsif ( $params->{'query'} eq 'pkgnum' ) {
1715 $orderby = 'ORDER BY pkgnum';
1717 } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
1719 $orderby = 'ORDER BY pkgnum';
1722 SELECT count(*) FROM pkg_svc
1723 WHERE pkg_svc.pkgpart = cust_pkg.pkgpart
1724 AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
1725 WHERE cust_svc.pkgnum = cust_pkg.pkgnum
1726 AND cust_svc.svcpart = pkg_svc.svcpart
1733 # setup queries, links, subs, etc. for the search
1736 # here is the agent virtualization
1737 if ($params->{CurrentUser}) {
1739 qsearchs('access_user', { username => $params->{CurrentUser} });
1742 push @where, $access_user->agentnums_sql('table'=>'cust_main');
1747 push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
1750 my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
1752 my $addl_from = 'LEFT JOIN cust_main USING ( custnum ) '.
1753 'LEFT JOIN part_pkg USING ( pkgpart ) '.
1754 'LEFT JOIN pkg_class USING ( classnum ) ';
1756 my $count_query = "SELECT COUNT(*) FROM cust_pkg $addl_from $extra_sql";
1759 'table' => 'cust_pkg',
1761 'select' => join(', ',
1763 ( map "part_pkg.$_", qw( pkg freq ) ),
1764 'pkg_class.classname',
1765 'cust_main.custnum as cust_main_custnum',
1766 FS::UI::Web::cust_sql_fields(
1767 $params->{'cust_fields'}
1770 'extra_sql' => "$extra_sql $orderby",
1771 'addl_from' => $addl_from,
1772 'count_query' => $count_query,
1781 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
1783 CUSTNUM is a customer (see L<FS::cust_main>)
1785 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
1786 L<FS::part_pkg>) to order for this customer. Duplicates are of course
1789 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
1790 remove for this customer. The services (see L<FS::cust_svc>) are moved to the
1791 new billing items. An error is returned if this is not possible (see
1792 L<FS::pkg_svc>). An empty arrayref is equivalent to not specifying this
1795 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
1796 newly-created cust_pkg objects.
1798 REFNUM, if specified, will specify the FS::pkg_referral record to be created
1799 and inserted. Multiple FS::pkg_referral records can be created by
1800 setting I<refnum> to an array reference of refnums or a hash reference with
1801 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
1802 record will be created corresponding to cust_main.refnum.
1807 my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
1809 my $conf = new FS::Conf;
1811 # Transactionize this whole mess
1812 local $SIG{HUP} = 'IGNORE';
1813 local $SIG{INT} = 'IGNORE';
1814 local $SIG{QUIT} = 'IGNORE';
1815 local $SIG{TERM} = 'IGNORE';
1816 local $SIG{TSTP} = 'IGNORE';
1817 local $SIG{PIPE} = 'IGNORE';
1819 my $oldAutoCommit = $FS::UID::AutoCommit;
1820 local $FS::UID::AutoCommit = 0;
1824 my $cust_main = qsearchs('cust_main', { custnum => $custnum });
1825 return "Customer not found: $custnum" unless $cust_main;
1827 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
1830 my $change = scalar(@old_cust_pkg) != 0;
1833 if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
1837 #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( last_bill bill );
1839 #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( setup );
1840 $hash{'setup'} = $time if $old_cust_pkg[0]->setup;
1842 $hash{'change_date'} = $time;
1843 $hash{"change_$_"} = $old_cust_pkg[0]->$_() foreach qw( pkgnum pkgpart );
1846 # Create the new packages.
1847 foreach my $pkgpart (@$pkgparts) {
1848 my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
1849 pkgpart => $pkgpart,
1853 $error = $cust_pkg->insert( 'change' => $change );
1855 $dbh->rollback if $oldAutoCommit;
1858 push @$return_cust_pkg, $cust_pkg;
1860 # $return_cust_pkg now contains refs to all of the newly
1863 # Transfer services and cancel old packages.
1864 foreach my $old_pkg (@old_cust_pkg) {
1866 foreach my $new_pkg (@$return_cust_pkg) {
1867 $error = $old_pkg->transfer($new_pkg);
1868 if ($error and $error == 0) {
1869 # $old_pkg->transfer failed.
1870 $dbh->rollback if $oldAutoCommit;
1875 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1876 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1877 foreach my $new_pkg (@$return_cust_pkg) {
1878 $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
1879 if ($error and $error == 0) {
1880 # $old_pkg->transfer failed.
1881 $dbh->rollback if $oldAutoCommit;
1888 # Transfers were successful, but we went through all of the
1889 # new packages and still had services left on the old package.
1890 # We can't cancel the package under the circumstances, so abort.
1891 $dbh->rollback if $oldAutoCommit;
1892 return "Unable to transfer all services from package ".$old_pkg->pkgnum;
1894 $error = $old_pkg->cancel( quiet=>1 );
1900 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1906 Associates this package with a (suspension or cancellation) reason (see
1907 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
1910 Available options are:
1914 =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.
1920 If there is an error, returns the error, otherwise returns false.
1924 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
1926 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
1927 L<FS::part_pkg>) to order for this customer. Duplicates are of course
1930 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
1931 replace. The services (see L<FS::cust_svc>) are moved to the
1932 new billing items. An error is returned if this is not possible (see
1935 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
1936 newly-created cust_pkg objects.
1941 my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
1943 # Transactionize this whole mess
1944 local $SIG{HUP} = 'IGNORE';
1945 local $SIG{INT} = 'IGNORE';
1946 local $SIG{QUIT} = 'IGNORE';
1947 local $SIG{TERM} = 'IGNORE';
1948 local $SIG{TSTP} = 'IGNORE';
1949 local $SIG{PIPE} = 'IGNORE';
1951 my $oldAutoCommit = $FS::UID::AutoCommit;
1952 local $FS::UID::AutoCommit = 0;
1956 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
1959 while(scalar(@old_cust_pkg)) {
1961 my $custnum = $old_cust_pkg[0]->custnum;
1962 my (@remove) = map { $_->pkgnum }
1963 grep { $_->custnum == $custnum } @old_cust_pkg;
1964 @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
1966 my $error = order $custnum, $pkgparts, \@remove, \@return;
1968 push @errors, $error
1970 push @$return_cust_pkg, @return;
1973 if (scalar(@errors)) {
1974 $dbh->rollback if $oldAutoCommit;
1975 return join(' / ', @errors);
1978 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1983 my ($self, %options) = @_;
1985 my $otaker = $FS::CurrentUser::CurrentUser->username;
1988 if ( $options{'reason'} =~ /^(\d+)$/ ) {
1992 } elsif ( ref($options{'reason'}) ) {
1994 return 'Enter a new reason (or select an existing one)'
1995 unless $options{'reason'}->{'reason'} !~ /^\s*$/;
1997 my $reason = new FS::reason({
1998 'reason_type' => $options{'reason'}->{'typenum'},
1999 'reason' => $options{'reason'}->{'reason'},
2001 my $error = $reason->insert;
2002 return $error if $error;
2004 $reasonnum = $reason->reasonnum;
2007 return "Unparsable reason: ". $options{'reason'};
2010 my $cust_pkg_reason =
2011 new FS::cust_pkg_reason({ 'pkgnum' => $self->pkgnum,
2012 'reasonnum' => $reasonnum,
2013 'otaker' => $otaker,
2014 'date' => $options{'date'}
2019 $cust_pkg_reason->insert;
2022 =item set_usage USAGE_VALUE_HASHREF
2024 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2025 to which they should be set (see L<FS::svc_acct>). Currently seconds,
2026 upbytes, downbytes, and totalbytes are appropriate keys.
2028 All svc_accts which are part of this package have their values reset.
2033 my ($self, $valueref) = @_;
2035 foreach my $cust_svc ($self->cust_svc){
2036 my $svc_x = $cust_svc->svc_x;
2037 $svc_x->set_usage($valueref)
2038 if $svc_x->can("set_usage");
2042 =item recharge USAGE_VALUE_HASHREF
2044 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2045 to which they should be set (see L<FS::svc_acct>). Currently seconds,
2046 upbytes, downbytes, and totalbytes are appropriate keys.
2048 All svc_accts which are part of this package have their values incremented.
2053 my ($self, $valueref) = @_;
2055 foreach my $cust_svc ($self->cust_svc){
2056 my $svc_x = $cust_svc->svc_x;
2057 $svc_x->recharge($valueref)
2058 if $svc_x->can("recharge");
2066 sub order is not OO. Perhaps it should be moved to FS::cust_main and made so?
2068 In sub order, the @pkgparts array (passed by reference) is clobbered.
2070 Also in sub order, no money is adjusted. Once FS::part_pkg defines a standard
2071 method to pass dates to the recur_prog expression, it should do so.
2073 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
2074 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
2075 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
2076 configuration values. Probably need a subroutine which decides what to do
2077 based on whether or not we've fetched the user yet, rather than a hash. See
2078 FS::UID and the TODO.
2080 Now that things are transactional should the check in the insert method be
2085 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
2086 L<FS::pkg_svc>, schema.html from the base documentation