X-Git-Url: http://git.freeside.biz/gitweb/?a=blobdiff_plain;f=FS%2FFS%2Fcust_pkg.pm;h=074746579d4d371365e488a06a22e9c75d5e0fdc;hb=a54f127b4decc976d91a3ce7fbb66edbef9bdc87;hp=55ee37d9d4ef39742eb2583a08f3fd21ed2c5336;hpb=acfb0f48c226a5cba64fbe391677391128a6cbf7;p=freeside.git diff --git a/FS/FS/cust_pkg.pm b/FS/FS/cust_pkg.pm index 55ee37d9d..074746579 100644 --- a/FS/FS/cust_pkg.pm +++ b/FS/FS/cust_pkg.pm @@ -1,25 +1,42 @@ package FS::cust_pkg; use strict; -use vars qw(@ISA); +use vars qw(@ISA $disable_agentcheck $DEBUG); +use List::Util qw(max); +use Tie::IxHash; use FS::UID qw( getotaker dbh ); +use FS::Misc qw( send_email ); use FS::Record qw( qsearch qsearchs ); +use FS::cust_main_Mixin; use FS::cust_svc; use FS::part_pkg; use FS::cust_main; use FS::type_pkgs; use FS::pkg_svc; use FS::cust_bill_pkg; +use FS::h_cust_svc; +use FS::reg_code; +use FS::part_svc; +use FS::cust_pkg_reason; +use FS::reason; +use FS::UI::Web; # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend, # setup } -# because they load configuraion by setting FS::UID::callback (see TODO) +# because they load configuration by setting FS::UID::callback (see TODO) use FS::svc_acct; use FS::svc_domain; use FS::svc_www; use FS::svc_forward; -@ISA = qw( FS::Record ); +# for sending cancel emails in sub cancel +use FS::Conf; + +@ISA = qw( FS::cust_main_Mixin FS::option_Common FS::Record ); + +$DEBUG = 0; + +$disable_agentcheck = 0; sub _cache { my $self = shift; @@ -93,6 +110,10 @@ inherits from FS::Record. The following fields are currently supported: =item bill - date (next bill date) +=item last_bill - last bill date + +=item adjourn - date + =item susp - date =item expire - date @@ -104,9 +125,11 @@ inherits from FS::Record. The following fields are currently supported: =item manual_flag - If this field is set to 1, disables the automatic unsuspension of this package when using the B config file. +=item quantity - If not set, defaults to 1 + =back -Note: setup, bill, susp, expire and cancel are specified as UNIX timestamps; +Note: setup, bill, adjourn, susp, expire and cancel are specified as UNIX timestamps; see L. Also see L and L for conversion functions. @@ -121,33 +144,112 @@ Create a new billing item. To add the item to the database, see L<"insert">. =cut sub table { 'cust_pkg'; } +sub cust_linked { $_[0]->cust_main_custnum; } +sub cust_unlinked_msg { + my $self = shift; + "WARNING: can't find cust_main.custnum ". $self->custnum. + ' (cust_pkg.pkgnum '. $self->pkgnum. ')'; +} -=item insert +=item insert [ OPTION => VALUE ... ] Adds this billing item to the database ("Orders" the item). If there is an error, returns the error, otherwise returns false. +If the additional field I is defined instead of I, it +will be used to look up the package definition and agent restrictions will be +ignored. + +The following options are available: I + +I, if set true, supresses any referral credit to a referring customer. + =cut sub insert { - my $self = shift; + my( $self, %options ) = @_; + + local $SIG{HUP} = 'IGNORE'; + local $SIG{INT} = 'IGNORE'; + local $SIG{QUIT} = 'IGNORE'; + local $SIG{TERM} = 'IGNORE'; + local $SIG{TSTP} = 'IGNORE'; + local $SIG{PIPE} = 'IGNORE'; - # custnum might not have have been defined in sub check (for one-shot new - # customers), so check it here instead - # (is this still necessary with transactions?) + my $oldAutoCommit = $FS::UID::AutoCommit; + local $FS::UID::AutoCommit = 0; + my $dbh = dbh; - my $error = $self->ut_number('custnum'); - return $error if $error; + my $error = $self->SUPER::insert($options{options} ? %{$options{options}} : ()); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + + #if ( $self->reg_code ) { + # my $reg_code = qsearchs('reg_code', { 'code' => $self->reg_code } ); + # $error = $reg_code->delete; + # if ( $error ) { + # $dbh->rollback if $oldAutoCommit; + # return $error; + # } + #} + my $conf = new FS::Conf; my $cust_main = $self->cust_main; - return "Unknown customer ". $self->custnum unless $cust_main; + my $part_pkg = $self->part_pkg; + if ( $conf->exists('referral_credit') + && $cust_main->referral_custnum + && ! $options{'change'} + && $part_pkg->freq !~ /^0\D?$/ + ) + { + my $referring_cust_main = $cust_main->referring_cust_main; + if ( $referring_cust_main->status ne 'cancelled' ) { + my $error; + if ( $part_pkg->freq !~ /^\d+$/ ) { + warn 'WARNING: Not crediting customer '. $cust_main->referral_custnum. + ' for package '. $self->pkgnum. + ' ( customer '. $self->custnum. ')'. + ' - One-time referral credits not (yet) available for '. + ' packages with '. $part_pkg->freq_pretty. ' frequency'; + } else { + + my $amount = sprintf( "%.2f", $part_pkg->base_recur / $part_pkg->freq ); + my $error = + $referring_cust_main-> + credit( $amount, + 'Referral credit for '.$cust_main->name, + 'reason_type' => $conf->config('referral_credit_type') + ); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "Error crediting customer ". $cust_main->referral_custnum. + " for referral: $error"; + } + + } + + } + } + + if ($conf->config('welcome_letter') && $self->cust_main->num_pkgs == 1) { + my $queue = new FS::queue { + 'job' => 'FS::cust_main::queueable_print', + }; + $error = $queue->insert( + 'custnum' => $self->custnum, + 'template' => 'welcome_letter', + ); + + if ($error) { + warn "can't send welcome letter: $error"; + } - my $agent = qsearchs( 'agent', { 'agentnum' => $cust_main->agentnum } ); - my $pkgpart_href = $agent->pkgpart_hashref; - return "agent ". $agent->agentnum. " can't purchase pkgpart ". $self->pkgpart - unless $pkgpart_href->{ $self->pkgpart }; + } - $self->SUPER::insert; + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + ''; } @@ -169,7 +271,7 @@ the customer ever purchased the item. Instead, see the cancel method. Replaces the OLD_RECORD with this one in the database. If there is an error, returns the error, otherwise returns false. -Currently, custnum, setup, bill, susp, expire, and cancel may be changed. +Currently, custnum, setup, bill, adjourn, susp, expire, and cancel may be changed. Changing pkgpart may have disasterous effects. See the order subroutine. @@ -181,11 +283,17 @@ suspend is normally updated by the suspend and unsuspend methods. cancel is normally updated by the cancel method (and also the order subroutine in some cases). +Calls + =cut sub replace { - my( $new, $old ) = ( shift, shift ); + my( $new, $old, %options ) = @_; + # We absolutely have to have an old vs. new record to make this work. + if (!defined($old)) { + $old = qsearchs( 'cust_pkg', { 'pkgnum' => $new->pkgnum } ); + } #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart; return "Can't change otaker!" if $old->otaker ne $new->otaker; @@ -196,7 +304,67 @@ sub replace { #some logic for bill, susp, cancel? - $new->SUPER::replace($old); + local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart; + + local $SIG{HUP} = 'IGNORE'; + local $SIG{INT} = 'IGNORE'; + local $SIG{QUIT} = 'IGNORE'; + local $SIG{TERM} = 'IGNORE'; + local $SIG{TSTP} = 'IGNORE'; + local $SIG{PIPE} = 'IGNORE'; + + my $oldAutoCommit = $FS::UID::AutoCommit; + local $FS::UID::AutoCommit = 0; + my $dbh = dbh; + + foreach my $method ( qw(adjourn expire) ) { # How many reasons? + if ($options{'reason'} && $new->$method && $old->$method ne $new->$method) { + my $error = $new->insert_reason( 'reason' => $options{'reason'}, + 'date' => $new->$method, + ); + if ( $error ) { + dbh->rollback if $oldAutoCommit; + return "Error inserting cust_pkg_reason: $error"; + } + } + } + + #save off and freeze RADIUS attributes for any associated svc_acct records + my @svc_acct = (); + if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) { + + #also check for specific exports? + # to avoid spurious modify export events + @svc_acct = map { $_->svc_x } + grep { $_->part_svc->svcdb eq 'svc_acct' } + $old->cust_svc; + + $_->snapshot foreach @svc_acct; + + } + + my $error = $new->SUPER::replace($old, + $options{options} ? ${options{options}} : () + ); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + + #for prepaid packages, + #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes + foreach my $old_svc_acct ( @svc_acct ) { + my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash }; + my $s_error = $new_svc_acct->replace($old_svc_acct); + if ( $s_error ) { + $dbh->rollback if $oldAutoCommit; + return $s_error; + } + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + ''; + } =item check @@ -212,46 +380,82 @@ sub check { my $error = $self->ut_numbern('pkgnum') - || $self->ut_numbern('custnum') - || $self->ut_number('pkgpart') + || $self->ut_foreign_key('custnum', 'cust_main', 'custnum') + || $self->ut_numbern('pkgpart') || $self->ut_numbern('setup') || $self->ut_numbern('bill') || $self->ut_numbern('susp') || $self->ut_numbern('cancel') + || $self->ut_numbern('adjourn') + || $self->ut_numbern('expire') ; return $error if $error; - if ( $self->custnum ) { - return "Unknown customer ". $self->custnum unless $self->cust_main; - } + if ( $self->reg_code ) { + + unless ( grep { $self->pkgpart == $_->pkgpart } + map { $_->reg_code_pkg } + qsearchs( 'reg_code', { 'code' => $self->reg_code, + 'agentnum' => $self->cust_main->agentnum }) + ) { + return "Unknown registration code"; + } + + } elsif ( $self->promo_code ) { + + my $promo_part_pkg = + qsearchs('part_pkg', { + 'pkgpart' => $self->pkgpart, + 'promo_code' => { op=>'ILIKE', value=>$self->promo_code }, + } ); + return 'Unknown promotional code' unless $promo_part_pkg; + + } else { - return "Unknown pkgpart: ". $self->pkgpart - unless qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } ); + unless ( $disable_agentcheck ) { + my $agent = + qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } ); + my $pkgpart_href = $agent->pkgpart_hashref; + return "agent ". $agent->agentnum. + " can't purchase pkgpart ". $self->pkgpart + unless $pkgpart_href->{ $self->pkgpart }; + } + + $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' ); + return $error if $error; + + } $self->otaker(getotaker) unless $self->otaker; - $self->otaker =~ /^([\w\.\-]{0,16})$/ or return "Illegal otaker"; + $self->otaker =~ /^(\w{1,32})$/ or return "Illegal otaker"; $self->otaker($1); if ( $self->dbdef_table->column('manual_flag') ) { - $self->manual_flag =~ /^([01]?)$/ or return "Illegal manual_flag"; + $self->manual_flag('') if $self->manual_flag eq ' '; + $self->manual_flag =~ /^([01]?)$/ + or return "Illegal manual_flag ". $self->manual_flag; $self->manual_flag($1); } - ''; #no error + $self->SUPER::check; } -=item cancel +=item cancel [ OPTION => VALUE ... ] Cancels and removes all services (see L and L) in this package, then cancels the package itself (sets the cancel field to now). +Available options are: I + +I can be set true to supress email cancellation notices. + If there is an error, returns the error, otherwise returns false. =cut sub cancel { - my $self = shift; + my( $self, %options ) = @_; my $error; local $SIG{HUP} = 'IGNORE'; @@ -265,23 +469,52 @@ sub cancel { local $FS::UID::AutoCommit = 0; my $dbh = dbh; + if ($options{'reason'}) { + $error = $self->insert_reason( 'reason' => $options{'reason'} ); + if ( $error ) { + dbh->rollback if $oldAutoCommit; + return "Error inserting cust_pkg_reason: $error"; + } + } + + my %svc; foreach my $cust_svc ( + #schwartz + map { $_->[0] } + sort { $a->[1] <=> $b->[1] } + map { [ $_, $_->svc_x->table_info->{'cancel_weight'} ]; } qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ) { + my $error = $cust_svc->cancel; if ( $error ) { $dbh->rollback if $oldAutoCommit; return "Error cancelling cust_svc: $error"; } - } + # Add a credit for remaining service + my $remaining_value = $self->calc_remain(); + if ( $remaining_value > 0 ) { + my $conf = new FS::Conf; + my $error = $self->cust_main->credit( + $remaining_value, + 'Credit for unused time on '. $self->part_pkg->pkg, + 'reason_type' => $conf->config('cancel_credit_type'), + ); + if ($error) { + $dbh->rollback if $oldAutoCommit; + return "Error crediting customer \$$remaining_value for unused time on". + $self->part_pkg->pkg. ": $error"; + } + } + unless ( $self->getfield('cancel') ) { my %hash = $self->hash; $hash{'cancel'} = time; my $new = new FS::cust_pkg ( \%hash ); - $error = $new->replace($self); + $error = $new->replace( $self, options => { $self->options } ); if ( $error ) { $dbh->rollback if $oldAutoCommit; return $error; @@ -290,7 +523,21 @@ sub cancel { $dbh->commit or die $dbh->errstr if $oldAutoCommit; + my $conf = new FS::Conf; + my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list; + if ( !$options{'quiet'} && $conf->exists('emailcancel') && @invoicing_list ) { + my $conf = new FS::Conf; + my $error = send_email( + 'from' => $conf->config('invoice_from'), + 'to' => \@invoicing_list, + 'subject' => ( $conf->config('cancelsubject') || 'Cancellation Notice' ), + 'body' => [ map "$_\n", $conf->config('cancelmessage') ], + ); + #should this do something on errors? + } + ''; #no errors + } =item suspend @@ -303,7 +550,7 @@ If there is an error, returns the error, otherwise returns false. =cut sub suspend { - my $self = shift; + my( $self, %options ) = @_; my $error ; local $SIG{HUP} = 'IGNORE'; @@ -317,6 +564,14 @@ sub suspend { local $FS::UID::AutoCommit = 0; my $dbh = dbh; + if ($options{'reason'}) { + $error = $self->insert_reason( 'reason' => $options{'reason'} ); + if ( $error ) { + dbh->rollback if $oldAutoCommit; + return "Error inserting cust_pkg_reason: $error"; + } + } + foreach my $cust_svc ( qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ) { @@ -344,7 +599,7 @@ sub suspend { my %hash = $self->hash; $hash{'susp'} = time; my $new = new FS::cust_pkg ( \%hash ); - $error = $new->replace($self); + $error = $new->replace( $self, options => { $self->options } ); if ( $error ) { $dbh->rollback if $oldAutoCommit; return $error; @@ -356,18 +611,28 @@ sub suspend { ''; #no errors } -=item unsuspend +=item unsuspend [ OPTION => VALUE ... ] Unsuspends all services (see L and L) in this -package, then unsuspends the package itself (clears the susp field). +package, then unsuspends the package itself (clears the susp field and the +adjourn field if it is in the past). + +Available options are: I. + +I can be set true to adjust the next bill date forward by +the amount of time the account was inactive. This was set true by default +since 1.4.2 and 1.5.0pre6; however, starting with 1.7.0 this needs to be +explicitly requested. Price plans for which this makes sense (anniversary-date +based than prorate or subscription) could have an option to enable this +behaviour? If there is an error, returns the error, otherwise returns false. =cut sub unsuspend { - my $self = shift; - my($error); + my( $self, %opt ) = @_; + my $error; local $SIG{HUP} = 'IGNORE'; local $SIG{INT} = 'IGNORE'; @@ -405,9 +670,19 @@ sub unsuspend { unless ( ! $self->getfield('susp') ) { my %hash = $self->hash; + my $inactive = time - $hash{'susp'}; + + my $conf = new FS::Conf; + + $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive + if ( $opt{'adjust_next_bill'} + || $conf->config('unsuspend-always_adjust_next_bill_date') ) + && $inactive > 0 && ( $hash{'bill'} || $hash{'setup'} ); + $hash{'susp'} = ''; + $hash{'adjourn'} = '' if $hash{'adjourn'} < time; my $new = new FS::cust_pkg ( \%hash ); - $error = $new->replace($self); + $error = $new->replace( $self, options => { $self->options } ); if ( $error ) { $dbh->rollback if $oldAutoCommit; return $error; @@ -428,11 +703,43 @@ Useful for billing metered services. sub last_bill { my $self = shift; + if ( $self->dbdef_table->column('last_bill') ) { + return $self->setfield('last_bill', $_[0]) if @_; + return $self->getfield('last_bill') if $self->getfield('last_bill'); + } my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum, 'edate' => $self->bill, } ); $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0; } +=item last_cust_pkg_reason + +Returns the most recent FS::reason associated with the package. + +=cut + +sub last_cust_pkg_reason { + my $self = shift; + qsearchs( { + 'table' => 'cust_pkg_reason', + 'hashref' => { 'pkgnum' => $self->pkgnum, }, + 'extra_sql'=> "AND date <= ". time, + 'order_by' => 'ORDER BY date DESC LIMIT 1', + } ); +} + +=item last_reason + +Returns the most recent FS::reason associated with the package. + +=cut + +sub last_reason { + my $cust_pkg_reason = shift->last_cust_pkg_reason; + $cust_pkg_reason->reason + if $cust_pkg_reason; +} + =item part_pkg Returns the definition for this billing item, as an FS::part_pkg object (see @@ -448,280 +755,1219 @@ sub part_pkg { : qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } ); } -=item cust_svc +=item old_cust_pkg -Returns the services for this package, as FS::cust_svc objects (see -L) +Returns the cancelled package this package was changed from, if any. =cut -sub cust_svc { +sub old_cust_pkg { my $self = shift; - if ( $self->{'_svcnum'} ) { - values %{ $self->{'_svcnum'}->cache }; - } else { - qsearch ( 'cust_svc', { 'pkgnum' => $self->pkgnum } ); - } + return '' unless $self->change_pkgnum; + qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } ); } -=item labels +=item calc_setup -Returns a list of lists, calling the label method for all services -(see L) of this billing item. +Calls the I of the FS::part_pkg object associated with this billing +item. =cut -sub labels { +sub calc_setup { my $self = shift; - map { [ $_->label ] } $self->cust_svc; + $self->part_pkg->calc_setup($self, @_); } -=item cust_main +=item calc_recur -Returns the parent customer object (see L). +Calls the I of the FS::part_pkg object associated with this billing +item. =cut -sub cust_main { +sub calc_recur { my $self = shift; - qsearchs( 'cust_main', { 'custnum' => $self->custnum } ); + $self->part_pkg->calc_recur($self, @_); } -=item seconds_since TIMESTAMP - -Returns the number of seconds all accounts (see L) in this -package have been online since TIMESTAMP, according to the session monitor. +=item calc_remain -TIMESTAMP is specified as a UNIX timestamp; see L. Also see -L and L for conversion functions. +Calls the I of the FS::part_pkg object associated with this +billing item. =cut -sub seconds_since { - my($self, $since) = @_; - my $seconds = 0; +sub calc_remain { + my $self = shift; + $self->part_pkg->calc_remain($self, @_); +} - foreach my $cust_svc ( - grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc - ) { - $seconds += $cust_svc->seconds_since($since); - } +=item calc_cancel - $seconds; +Calls the I of the FS::part_pkg object associated with this +billing item. + +=cut +sub calc_cancel { + my $self = shift; + $self->part_pkg->calc_cancel($self, @_); } -=item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END +=item cust_bill_pkg -Returns the numbers of seconds all accounts (see L) in this -package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END -(exclusive). +Returns any invoice line items for this package (see L). -TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see -L. Also see L and L for conversion -functions. +=cut +sub cust_bill_pkg { + my $self = shift; + qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } ); +} -=cut +=item cust_svc [ SVCPART ] -sub seconds_since_sqlradacct { - my($self, $start, $end) = @_; +Returns the services for this package, as FS::cust_svc objects (see +L). If a svcpart is specified, return only the matching +services. - my $seconds = 0; +=cut - foreach my $cust_svc ( - grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc - ) { - $seconds += $cust_svc->seconds_since_sqlradacct($start, $end); +sub cust_svc { + my $self = shift; + + if ( @_ ) { + return qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum, + 'svcpart' => shift, } ); } - $seconds; + #if ( $self->{'_svcnum'} ) { + # values %{ $self->{'_svcnum'}->cache }; + #} else { + $self->_sort_cust_svc( + [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ] + ); + #} } -=back - -=head1 SUBROUTINES - -=over 4 +=item overlimit [ SVCPART ] -=item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ] ] +Returns the services for this package which have exceeded their +usage limit as FS::cust_svc objects (see L). If a svcpart +is specified, return only the matching services. -CUSTNUM is a customer (see L) +=cut -PKGPARTS is a list of pkgparts specifying the the billing item definitions (see -L) to order for this customer. Duplicates are of course -permitted. +sub overlimit { + my $self = shift; + grep { $_->overlimit } $self->cust_svc; +} -REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to -remove for this customer. The services (see L) are moved to the -new billing items. An error is returned if this is not possible (see -L). An empty arrayref is equivalent to not specifying this -parameter. +=item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ] -RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the -newly-created cust_pkg objects. +Returns historical services for this package created before END TIMESTAMP and +(optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects +(see L). =cut -sub order { - my($custnum, $pkgparts, $remove_pkgnums, $return_cust_pkg) = @_; - $remove_pkgnums = [] unless defined($remove_pkgnums); +sub h_cust_svc { + my $self = shift; - my $oldAutoCommit = $FS::UID::AutoCommit; - local $FS::UID::AutoCommit = 0; - my $dbh = dbh; + $self->_sort_cust_svc( + [ qsearch( 'h_cust_svc', + { 'pkgnum' => $self->pkgnum, }, + FS::h_cust_svc->sql_h_search(@_), + ) + ] + ); +} - # generate %part_pkg - # $part_pkg{$pkgpart} is true iff $custnum may purchase $pkgpart - # - my($cust_main)=qsearchs('cust_main',{'custnum'=>$custnum}); - my($agent)=qsearchs('agent',{'agentnum'=> $cust_main->agentnum }); - my %part_pkg = %{ $agent->pkgpart_hashref }; - - my(%svcnum); - # generate %svcnum - # for those packages being removed: - #@{ $svcnum{$svcpart} } goes from a svcpart to a list of FS::cust_svc objects - my($pkgnum); - foreach $pkgnum ( @{$remove_pkgnums} ) { - foreach my $cust_svc (qsearch('cust_svc',{'pkgnum'=>$pkgnum})) { - push @{ $svcnum{$cust_svc->getfield('svcpart')} }, $cust_svc; - } - } - - my @cust_svc; - #generate @cust_svc - # for those packages the customer is purchasing: - # @{$pkgparts} is a list of said packages, by pkgpart - # @cust_svc is a corresponding list of lists of FS::Record objects - foreach my $pkgpart ( @{$pkgparts} ) { - unless ( $part_pkg{$pkgpart} ) { - $dbh->rollback if $oldAutoCommit; - return "Customer not permitted to purchase pkgpart $pkgpart!"; - } - push @cust_svc, [ - map { - ( $svcnum{$_} && @{ $svcnum{$_} } ) ? shift @{ $svcnum{$_} } : (); - } map { $_->svcpart } - qsearch('pkg_svc', { pkgpart => $pkgpart, - quantity => { op=>'>', value=>'0', } } ) - ]; - } - - #special-case until this can be handled better - # move services to new svcparts - even if the svcparts don't match (svcdb - # needs to...) - # looks like they're moved in no particular order, ewwwwwwww - # and looks like just one of each svcpart can be moved... o well - - #start with still-leftover services - #foreach my $svcpart ( grep { scalar(@{ $svcnum{$_} }) } keys %svcnum ) { - foreach my $svcpart ( keys %svcnum ) { - next unless @{ $svcnum{$svcpart} }; - - my $svcdb = $svcnum{$svcpart}->[0]->part_svc->svcdb; - - #find an empty place to put one - my $i = 0; - foreach my $pkgpart ( @{$pkgparts} ) { - my @pkg_svc = - qsearch('pkg_svc', { pkgpart => $pkgpart, - quantity => { op=>'>', value=>'0', } } ); - #my @pkg_svc = - # grep { $_->quantity > 0 } qsearch('pkg_svc', { pkgpart=>$pkgpart } ); - if ( ! @{$cust_svc[$i]} #find an empty place to put them with - && grep { $svcdb eq $_->part_svc->svcdb } #with appropriate svcdb - @pkg_svc - ) { - my $new_svcpart = - ( grep { $svcdb eq $_->part_svc->svcdb } @pkg_svc )[0]->svcpart; - my $cust_svc = shift @{$svcnum{$svcpart}}; - $cust_svc->svcpart($new_svcpart); - #warn "changing from $svcpart to $new_svcpart!!!\n"; - $cust_svc[$i] = [ $cust_svc ]; +sub _sort_cust_svc { + my( $self, $arrayref ) = @_; + + map { $_->[0] } + sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] } + map { + my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart, + 'svcpart' => $_->svcpart } ); + [ $_, + $pkg_svc ? $pkg_svc->primary_svc : '', + $pkg_svc ? $pkg_svc->quantity : 0, + ]; } - $i++; - } + @$arrayref; - } - - #check for leftover services - foreach (keys %svcnum) { - next unless @{ $svcnum{$_} }; - $dbh->rollback if $oldAutoCommit; - return "Leftover services, svcpart $_: svcnum ". - join(', ', map { $_->svcnum } @{ $svcnum{$_} } ); - } +} - #no leftover services, let's make changes. - - local $SIG{HUP} = 'IGNORE'; - local $SIG{INT} = 'IGNORE'; - local $SIG{QUIT} = 'IGNORE'; - local $SIG{TERM} = 'IGNORE'; - local $SIG{TSTP} = 'IGNORE'; - local $SIG{PIPE} = 'IGNORE'; +=item num_cust_svc [ SVCPART ] - #first cancel old packages - foreach my $pkgnum ( @{$remove_pkgnums} ) { - my($old) = qsearchs('cust_pkg',{'pkgnum'=>$pkgnum}); - unless ( $old ) { - $dbh->rollback if $oldAutoCommit; - return "Package $pkgnum not found to remove!"; - } - my(%hash) = $old->hash; - $hash{'cancel'}=time; - my($new) = new FS::cust_pkg ( \%hash ); - my($error)=$new->replace($old); - if ( $error ) { - $dbh->rollback if $oldAutoCommit; - return "Couldn't update package $pkgnum: $error"; - } - } +Returns the number of provisioned services for this package. If a svcpart is +specified, counts only the matching services. - #now add new packages, changing cust_svc records if necessary - my $pkgpart; - while ($pkgpart=shift @{$pkgparts} ) { - - my $new = new FS::cust_pkg { - 'custnum' => $custnum, - 'pkgpart' => $pkgpart, - }; - my $error = $new->insert; - if ( $error ) { - $dbh->rollback if $oldAutoCommit; - return "Couldn't insert new cust_pkg record: $error"; - } - push @{$return_cust_pkg}, $new if $return_cust_pkg; - my $pkgnum = $new->pkgnum; - - foreach my $cust_svc ( @{ shift @cust_svc } ) { - my(%hash) = $cust_svc->hash; - $hash{'pkgnum'}=$pkgnum; - my $new = new FS::cust_svc ( \%hash ); - - #avoid Record diffing missing changed svcpart field from above. - my $old = qsearchs('cust_svc', { 'svcnum' => $cust_svc->svcnum } ); - - my $error = $new->replace($old); - if ( $error ) { - $dbh->rollback if $oldAutoCommit; - return "Couldn't link old service to new package: $error"; - } - } - } +=cut - $dbh->commit or die $dbh->errstr if $oldAutoCommit; +sub num_cust_svc { + my $self = shift; + my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?'; + $sql .= ' AND svcpart = ?' if @_; + my $sth = dbh->prepare($sql) or die dbh->errstr; + $sth->execute($self->pkgnum, @_) or die $sth->errstr; + $sth->fetchrow_arrayref->[0]; +} - ''; #no errors +=item available_part_svc + +Returns a list of FS::part_svc objects representing services included in this +package but not yet provisioned. Each FS::part_svc object also has an extra +field, I, which specifies the number of available services. + +=cut + +sub available_part_svc { + my $self = shift; + grep { $_->num_avail > 0 } + map { + my $part_svc = $_->part_svc; + $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking + $_->quantity - $self->num_cust_svc($_->svcpart); + $part_svc; + } + $self->part_pkg->pkg_svc; } +=item part_svc + +Returns a list of FS::part_svc objects representing provisioned and available +services included in this package. Each FS::part_svc object also has the +following extra fields: + +=over 4 + +=item num_cust_svc (count) + +=item num_avail (quantity - count) + +=item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects + +svcnum +label -> ($cust_svc->label)[1] + =back -=head1 VERSION +=cut + +sub part_svc { + my $self = shift; + + #XXX some sort of sort order besides numeric by svcpart... + my @part_svc = sort { $a->svcpart <=> $b->svcpart } map { + my $pkg_svc = $_; + my $part_svc = $pkg_svc->part_svc; + my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart); + $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil + $part_svc->{'Hash'}{'num_avail'} = + max( 0, $pkg_svc->quantity - $num_cust_svc ); + $part_svc->{'Hash'}{'cust_pkg_svc'} = [ $self->cust_svc($part_svc->svcpart) ]; + $part_svc; + } $self->part_pkg->pkg_svc; + + #extras + push @part_svc, map { + my $part_svc = $_; + my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart); + $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail + $part_svc->{'Hash'}{'num_avail'} = 0; #0-$num_cust_svc ? + $part_svc->{'Hash'}{'cust_pkg_svc'} = [ $self->cust_svc($part_svc->svcpart) ]; + $part_svc; + } $self->extra_part_svc; + + @part_svc; -$Id: cust_pkg.pm,v 1.27 2002-10-17 14:16:17 ivan Exp $ +} + +=item extra_part_svc + +Returns a list of FS::part_svc objects corresponding to services in this +package which are still provisioned but not (any longer) available in the +package definition. + +=cut + +sub extra_part_svc { + my $self = shift; + + my $pkgnum = $self->pkgnum; + my $pkgpart = $self->pkgpart; + + qsearch( { + 'table' => 'part_svc', + 'hashref' => {}, + 'extra_sql' => "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc + WHERE pkg_svc.svcpart = part_svc.svcpart + AND pkg_svc.pkgpart = $pkgpart + AND quantity > 0 + ) + AND 0 < ( SELECT count(*) + FROM cust_svc + LEFT JOIN cust_pkg using ( pkgnum ) + WHERE cust_svc.svcpart = part_svc.svcpart + AND pkgnum = $pkgnum + )", + } ); +} + +=item status + +Returns a short status string for this package, currently: + +=over 4 + +=item not yet billed + +=item one-time charge + +=item active + +=item suspended + +=item cancelled + +=back + +=cut + +sub status { + my $self = shift; + + my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq; + + return 'cancelled' if $self->get('cancel'); + return 'suspended' if $self->susp; + return 'not yet billed' unless $self->setup; + return 'one-time charge' if $freq =~ /^(0|$)/; + return 'active'; +} + +=item statuses + +Class method that returns the list of possible status strings for pacakges +(see L). For example: + + @statuses = FS::cust_pkg->statuses(); + +=cut + +tie my %statuscolor, 'Tie::IxHash', + 'not yet billed' => '000000', + 'one-time charge' => '000000', + 'active' => '00CC00', + 'suspended' => 'FF9900', + 'cancelled' => 'FF0000', +; + +sub statuses { + my $self = shift; #could be class... + grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway + # mayble split btw one-time vs. recur + keys %statuscolor; +} + +=item statuscolor + +Returns a hex triplet color string for this package's status. + +=cut + +sub statuscolor { + my $self = shift; + $statuscolor{$self->status}; +} + +=item labels + +Returns a list of lists, calling the label method for all services +(see L) of this billing item. + +=cut + +sub labels { + my $self = shift; + map { [ $_->label ] } $self->cust_svc; +} + +=item h_labels END_TIMESTAMP [ START_TIMESTAMP ] + +Like the labels method, but returns historical information on services that +were active as of END_TIMESTAMP and (optionally) not cancelled before +START_TIMESTAMP. + +Returns a list of lists, calling the label method for all (historical) services +(see L) of this billing item. + +=cut + +sub h_labels { + my $self = shift; + map { [ $_->label(@_) ] } $self->h_cust_svc(@_); +} + +=item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ] + +Like h_labels, except returns a simple flat list, and shortens long +(currently >5) lists of identical services to one line that lists the service +label and the number of individual services rather than individual items. + +=cut + +sub h_labels_short { + my $self = shift; + + my %labels; + #tie %labels, 'Tie::IxHash'; + push @{ $labels{$_->[0]} }, $_->[1] + foreach $self->h_labels(@_); + my @labels; + foreach my $label ( keys %labels ) { + my @values = @{ $labels{$label} }; + my $num = scalar(@values); + if ( $num > 5 ) { + push @labels, "$label ($num)"; + } else { + push @labels, map { "$label: $_" } @values; + } + } + + @labels; + +} + +=item cust_main + +Returns the parent customer object (see L). + +=cut + +sub cust_main { + my $self = shift; + qsearchs( 'cust_main', { 'custnum' => $self->custnum } ); +} + +=item seconds_since TIMESTAMP + +Returns the number of seconds all accounts (see L) in this +package have been online since TIMESTAMP, according to the session monitor. + +TIMESTAMP is specified as a UNIX timestamp; see L. Also see +L and L for conversion functions. + +=cut + +sub seconds_since { + my($self, $since) = @_; + my $seconds = 0; + + foreach my $cust_svc ( + grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc + ) { + $seconds += $cust_svc->seconds_since($since); + } + + $seconds; + +} + +=item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END + +Returns the numbers of seconds all accounts (see L) in this +package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END +(exclusive). + +TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see +L. Also see L and L for conversion +functions. + + +=cut + +sub seconds_since_sqlradacct { + my($self, $start, $end) = @_; + + my $seconds = 0; + + foreach my $cust_svc ( + grep { + my $part_svc = $_->part_svc; + $part_svc->svcdb eq 'svc_acct' + && scalar($part_svc->part_export('sqlradius')); + } $self->cust_svc + ) { + $seconds += $cust_svc->seconds_since_sqlradacct($start, $end); + } + + $seconds; + +} + +=item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE + +Returns the sum of the given attribute for all accounts (see L) +in this package for sessions ending between TIMESTAMP_START (inclusive) and +TIMESTAMP_END +(exclusive). + +TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see +L. Also see L and L for conversion +functions. + +=cut + +sub attribute_since_sqlradacct { + my($self, $start, $end, $attrib) = @_; + + my $sum = 0; + + foreach my $cust_svc ( + grep { + my $part_svc = $_->part_svc; + $part_svc->svcdb eq 'svc_acct' + && scalar($part_svc->part_export('sqlradius')); + } $self->cust_svc + ) { + $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib); + } + + $sum; + +} + +=item quantity + +=cut + +sub quantity { + my( $self, $value ) = @_; + if ( defined($value) ) { + $self->setfield('quantity', $value); + } + $self->getfield('quantity') || 1; +} + +=item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ] + +Transfers as many services as possible from this package to another package. + +The destination package can be specified by pkgnum by passing an FS::cust_pkg +object. The destination package must already exist. + +Services are moved only if the destination allows services with the correct +I (not svcdb), unless the B option is set true. Use +this option with caution! No provision is made for export differences +between the old and new service definitions. Probably only should be used +when your exports for all service definitions of a given svcdb are identical. +(attempt a transfer without it first, to move all possible svcpart-matching +services) + +Any services that can't be moved remain in the original package. + +Returns an error, if there is one; otherwise, returns the number of services +that couldn't be moved. + +=cut + +sub transfer { + my ($self, $dest_pkgnum, %opt) = @_; + + my $remaining = 0; + my $dest; + my %target; + + if (ref ($dest_pkgnum) eq 'FS::cust_pkg') { + $dest = $dest_pkgnum; + $dest_pkgnum = $dest->pkgnum; + } else { + $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum }); + } + + return ('Package does not exist: '.$dest_pkgnum) unless $dest; + + foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) { + $target{$pkg_svc->svcpart} = $pkg_svc->quantity; + } + + foreach my $cust_svc ($dest->cust_svc) { + $target{$cust_svc->svcpart}--; + } + + my %svcpart2svcparts = (); + if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) { + warn "change_svcpart option received, creating alternates list\n" if $DEBUG; + foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) { + next if exists $svcpart2svcparts{$svcpart}; + my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } ); + $svcpart2svcparts{$svcpart} = [ + map { $_->[0] } + sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] } + map { + my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart, + 'svcpart' => $_ } ); + [ $_, + $pkg_svc ? $pkg_svc->primary_svc : '', + $pkg_svc ? $pkg_svc->quantity : 0, + ]; + } + + grep { $_ != $svcpart } + map { $_->svcpart } + qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } ) + ]; + warn "alternates for svcpart $svcpart: ". + join(', ', @{$svcpart2svcparts{$svcpart}}). "\n" + if $DEBUG; + } + } + + foreach my $cust_svc ($self->cust_svc) { + if($target{$cust_svc->svcpart} > 0) { + $target{$cust_svc->svcpart}--; + my $new = new FS::cust_svc { $cust_svc->hash }; + $new->pkgnum($dest_pkgnum); + my $error = $new->replace($cust_svc); + return $error if $error; + } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) { + if ( $DEBUG ) { + warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n"; + warn "alternates to consider: ". + join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n"; + } + my @alternate = grep { + warn "considering alternate svcpart $_: ". + "$target{$_} available in new package\n" + if $DEBUG; + $target{$_} > 0; + } @{$svcpart2svcparts{$cust_svc->svcpart}}; + if ( @alternate ) { + warn "alternate(s) found\n" if $DEBUG; + my $change_svcpart = $alternate[0]; + $target{$change_svcpart}--; + my $new = new FS::cust_svc { $cust_svc->hash }; + $new->svcpart($change_svcpart); + $new->pkgnum($dest_pkgnum); + my $error = $new->replace($cust_svc); + return $error if $error; + } else { + $remaining++; + } + } else { + $remaining++ + } + } + return $remaining; +} + +=item reexport + +This method is deprecated. See the I option to the insert and +order_pkgs methods in FS::cust_main for a better way to defer provisioning. + +=cut + +sub reexport { + my $self = shift; + + local $SIG{HUP} = 'IGNORE'; + local $SIG{INT} = 'IGNORE'; + local $SIG{QUIT} = 'IGNORE'; + local $SIG{TERM} = 'IGNORE'; + local $SIG{TSTP} = 'IGNORE'; + local $SIG{PIPE} = 'IGNORE'; + + my $oldAutoCommit = $FS::UID::AutoCommit; + local $FS::UID::AutoCommit = 0; + my $dbh = dbh; + + foreach my $cust_svc ( $self->cust_svc ) { + #false laziness w/svc_Common::insert + my $svc_x = $cust_svc->svc_x; + foreach my $part_export ( $cust_svc->part_svc->part_export ) { + my $error = $part_export->export_insert($svc_x); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + } + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + ''; + +} + +=back + +=head1 CLASS METHODS + +=over 4 + +=item recurring_sql + +Returns an SQL expression identifying recurring packages. + +=cut + +sub recurring_sql { " + '0' != ( select freq from part_pkg + where cust_pkg.pkgpart = part_pkg.pkgpart ) +"; } + +=item onetime_sql + +Returns an SQL expression identifying one-time packages. + +=cut + +sub onetime_sql { " + '0' = ( select freq from part_pkg + where cust_pkg.pkgpart = part_pkg.pkgpart ) +"; } + +=item active_sql + +Returns an SQL expression identifying active packages. + +=cut + +sub active_sql { " + ". $_[0]->recurring_sql(). " + AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 ) + AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 ) +"; } + +=item inactive_sql + +Returns an SQL expression identifying inactive packages (one-time packages +that are otherwise unsuspended/uncancelled). + +=cut + +sub inactive_sql { " + ". $_[0]->onetime_sql(). " + AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 ) + AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 ) +"; } + +=item susp_sql +=item suspended_sql + +Returns an SQL expression identifying suspended packages. + +=cut + +sub suspended_sql { susp_sql(@_); } +sub susp_sql { + #$_[0]->recurring_sql(). ' AND '. + " + ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 ) + AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0 + "; +} + +=item cancel_sql +=item cancelled_sql + +Returns an SQL exprression identifying cancelled packages. + +=cut + +sub cancelled_sql { cancel_sql(@_); } +sub cancel_sql { + #$_[0]->recurring_sql(). ' AND '. + "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0"; +} + +=item search_sql HASHREF + +(Class method) + +Returns a qsearch hash expression to search for parameters specified in HASHREF. +Valid parameters are + +=over 4 + +=item agentnum + +=item magic + +active, inactive, suspended, cancel (or cancelled) + +=item status + +active, inactive, suspended, one-time charge, inactive, cancel (or cancelled) + +=item classnum + +=item pkgpart + +list specified how? + +=item setup + +arrayref of beginning and ending epoch date + +=item last_bill + +arrayref of beginning and ending epoch date + +=item bill + +arrayref of beginning and ending epoch date + +=item adjourn + +arrayref of beginning and ending epoch date + +=item susp + +arrayref of beginning and ending epoch date + +=item expire + +arrayref of beginning and ending epoch date + +=item cancel + +arrayref of beginning and ending epoch date + +=item query + +pkgnum or APKG_pkgnum + +=item cust_fields + +a value suited to passing to FS::UI::Web::cust_header + +=item CurrentUser + +specifies the user for agent virtualization + +=back + +=cut + +sub search_sql { + my ($class, $params) = @_; + my @where = (); + + ## + # parse agent + ## + + if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) { + push @where, + "agentnum = $1"; + } + + ## + # parse status + ## + + if ( $params->{'magic'} eq 'active' + || $params->{'status'} eq 'active' ) { + + push @where, FS::cust_pkg->active_sql(); + + } elsif ( $params->{'magic'} eq 'inactive' + || $params->{'status'} eq 'inactive' ) { + + push @where, FS::cust_pkg->inactive_sql(); + + } elsif ( $params->{'magic'} eq 'suspended' + || $params->{'status'} eq 'suspended' ) { + + push @where, FS::cust_pkg->suspended_sql(); + + } elsif ( $params->{'magic'} =~ /^cancell?ed$/ + || $params->{'status'} =~ /^cancell?ed$/ ) { + + push @where, FS::cust_pkg->cancelled_sql(); + + } elsif ( $params->{'status'} =~ /^(one-time charge|inactive)$/ ) { + + push @where, FS::cust_pkg->inactive_sql(); + + } + + ### + # parse package class + ### + + #false lazinessish w/graph/cust_bill_pkg.cgi + my $classnum = 0; + my @pkg_class = (); + if ( exists($params->{'classnum'}) + && $params->{'classnum'} =~ /^(\d*)$/ + ) + { + $classnum = $1; + if ( $classnum ) { #a specific class + push @where, "classnum = $classnum"; + + #@pkg_class = ( qsearchs('pkg_class', { 'classnum' => $classnum } ) ); + #die "classnum $classnum not found!" unless $pkg_class[0]; + #$title .= $pkg_class[0]->classname.' '; + + } elsif ( $classnum eq '' ) { #the empty class + + push @where, "classnum IS NULL"; + #$title .= 'Empty class '; + #@pkg_class = ( '(empty class)' ); + } elsif ( $classnum eq '0' ) { + #@pkg_class = qsearch('pkg_class', {} ); # { 'disabled' => '' } ); + #push @pkg_class, '(empty class)'; + } else { + die "illegal classnum"; + } + } + #eslaf + + ### + # parse part_pkg + ### + + my $pkgpart = join (' OR pkgpart=', + grep {$_} map { /^(\d+)$/; } ($params->{'pkgpart'})); + push @where, '(pkgpart=' . $pkgpart . ')' if $pkgpart; + + ### + # parse dates + ### + + my $orderby = ''; + + #false laziness w/report_cust_pkg.html + my %disable = ( + 'all' => {}, + 'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, }, + 'active' => { 'susp'=>1, 'cancel'=>1 }, + 'suspended' => { 'cancel' => 1 }, + 'cancelled' => {}, + '' => {}, + ); + + foreach my $field (qw( setup last_bill bill adjourn susp expire cancel )) { + + next unless exists($params->{$field}); + + my($beginning, $ending) = @{$params->{$field}}; + + next if $beginning == 0 && $ending == 4294967295; + + push @where, + "cust_pkg.$field IS NOT NULL", + "cust_pkg.$field >= $beginning", + "cust_pkg.$field <= $ending"; + + $orderby ||= "ORDER BY cust_pkg.$field"; + + } + + $orderby ||= 'ORDER BY bill'; + + ### + # parse magic, legacy, etc. + ### + + if ( $params->{'magic'} && + $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/ + ) { + + $orderby = 'ORDER BY pkgnum'; + + if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) { + push @where, "pkgpart = $1"; + } + + } elsif ( $params->{'query'} eq 'pkgnum' ) { + + $orderby = 'ORDER BY pkgnum'; + + } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) { + + $orderby = 'ORDER BY pkgnum'; + + push @where, '0 < ( + SELECT count(*) FROM pkg_svc + WHERE pkg_svc.pkgpart = cust_pkg.pkgpart + AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc + WHERE cust_svc.pkgnum = cust_pkg.pkgnum + AND cust_svc.svcpart = pkg_svc.svcpart + ) + )'; + + } + + ## + # setup queries, links, subs, etc. for the search + ## + + # here is the agent virtualization + if ($params->{CurrentUser}) { + my $access_user = + qsearchs('access_user', { username => $params->{CurrentUser} }); + + if ($access_user) { + push @where, $access_user->agentnums_sql; + }else{ + push @where, "1=0"; + } + }else{ + push @where, $FS::CurrentUser::CurrentUser->agentnums_sql; + } + + my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : ''; + + my $addl_from = 'LEFT JOIN cust_main USING ( custnum ) '. + 'LEFT JOIN part_pkg USING ( pkgpart ) '. + 'LEFT JOIN pkg_class USING ( classnum ) '; + + my $count_query = "SELECT COUNT(*) FROM cust_pkg $addl_from $extra_sql"; + + my $sql_query = { + 'table' => 'cust_pkg', + 'hashref' => {}, + 'select' => join(', ', + 'cust_pkg.*', + ( map "part_pkg.$_", qw( pkg freq ) ), + 'pkg_class.classname', + 'cust_main.custnum as cust_main_custnum', + FS::UI::Web::cust_sql_fields( + $params->{'cust_fields'} + ), + ), + 'extra_sql' => "$extra_sql $orderby", + 'addl_from' => $addl_from, + 'count_query' => $count_query, + }; + +} + +=head1 SUBROUTINES + +=over 4 + +=item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ] ] + +CUSTNUM is a customer (see L) + +PKGPARTS is a list of pkgparts specifying the the billing item definitions (see +L) to order for this customer. Duplicates are of course +permitted. + +REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to +remove for this customer. The services (see L) are moved to the +new billing items. An error is returned if this is not possible (see +L). An empty arrayref is equivalent to not specifying this +parameter. + +RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the +newly-created cust_pkg objects. + +=cut + +sub order { + my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg) = @_; + + my $conf = new FS::Conf; + + # Transactionize this whole mess + local $SIG{HUP} = 'IGNORE'; + local $SIG{INT} = 'IGNORE'; + local $SIG{QUIT} = 'IGNORE'; + local $SIG{TERM} = 'IGNORE'; + local $SIG{TSTP} = 'IGNORE'; + local $SIG{PIPE} = 'IGNORE'; + + my $oldAutoCommit = $FS::UID::AutoCommit; + local $FS::UID::AutoCommit = 0; + my $dbh = dbh; + + my $error; + my $cust_main = qsearchs('cust_main', { custnum => $custnum }); + return "Customer not found: $custnum" unless $cust_main; + + my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) } + @$remove_pkgnum; + + my $change = scalar(@old_cust_pkg) != 0; + + my %hash = (); + if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) { + + my $time = time; + + #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( last_bill bill ); + + #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( setup ); + $hash{'setup'} = $time if $old_cust_pkg[0]->setup; + + $hash{'change_date'} = $time; + $hash{"change_$_"} = $old_cust_pkg[0]->$_() foreach qw( pkgnum pkgpart ); + } + + # Create the new packages. + foreach my $pkgpart (@$pkgparts) { + my $cust_pkg = new FS::cust_pkg { custnum => $custnum, + pkgpart => $pkgpart, + %hash, + }; + $error = $cust_pkg->insert( 'change' => $change ); + if ($error) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + push @$return_cust_pkg, $cust_pkg; + } + # $return_cust_pkg now contains refs to all of the newly + # created packages. + + # Transfer services and cancel old packages. + foreach my $old_pkg (@old_cust_pkg) { + + foreach my $new_pkg (@$return_cust_pkg) { + $error = $old_pkg->transfer($new_pkg); + if ($error and $error == 0) { + # $old_pkg->transfer failed. + $dbh->rollback if $oldAutoCommit; + return $error; + } + } + + if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) { + warn "trying transfer again with change_svcpart option\n" if $DEBUG; + foreach my $new_pkg (@$return_cust_pkg) { + $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 ); + if ($error and $error == 0) { + # $old_pkg->transfer failed. + $dbh->rollback if $oldAutoCommit; + return $error; + } + } + } + + if ($error > 0) { + # Transfers were successful, but we went through all of the + # new packages and still had services left on the old package. + # We can't cancel the package under the circumstances, so abort. + $dbh->rollback if $oldAutoCommit; + return "Unable to transfer all services from package ".$old_pkg->pkgnum; + } + $error = $old_pkg->cancel( quiet=>1 ); + if ($error) { + $dbh->rollback; + return $error; + } + } + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + ''; +} + +=item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ] + +PKGPARTS is a list of pkgparts specifying the the billing item definitions (see +L) to order for this customer. Duplicates are of course +permitted. + +REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to +replace. The services (see L) are moved to the +new billing items. An error is returned if this is not possible (see +L). + +RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the +newly-created cust_pkg objects. + +=cut + +sub bulk_change { + my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_; + + # Transactionize this whole mess + local $SIG{HUP} = 'IGNORE'; + local $SIG{INT} = 'IGNORE'; + local $SIG{QUIT} = 'IGNORE'; + local $SIG{TERM} = 'IGNORE'; + local $SIG{TSTP} = 'IGNORE'; + local $SIG{PIPE} = 'IGNORE'; + + my $oldAutoCommit = $FS::UID::AutoCommit; + local $FS::UID::AutoCommit = 0; + my $dbh = dbh; + + my @errors; + my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) } + @$remove_pkgnum; + + while(scalar(@old_cust_pkg)) { + my @return = (); + my $custnum = $old_cust_pkg[0]->custnum; + my (@remove) = map { $_->pkgnum } + grep { $_->custnum == $custnum } @old_cust_pkg; + @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg; + + my $error = order $custnum, $pkgparts, \@remove, \@return; + + push @errors, $error + if $error; + push @$return_cust_pkg, @return; + } + + if (scalar(@errors)) { + $dbh->rollback if $oldAutoCommit; + return join(' / ', @errors); + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + ''; +} + +sub insert_reason { + my ($self, %options) = @_; + + my $otaker = $FS::CurrentUser::CurrentUser->username; + + my $cust_pkg_reason = + new FS::cust_pkg_reason({ 'pkgnum' => $self->pkgnum, + 'reasonnum' => $options{'reason'}, + 'otaker' => $otaker, + 'date' => $options{'date'} + ? $options{'date'} + : time, + }); + return $cust_pkg_reason->insert; +} + +=item set_usage USAGE_VALUE_HASHREF + +USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts +to which they should be set (see L). Currently seconds, +upbytes, downbytes, and totalbytes are appropriate keys. + +All svc_accts which are part of this package have their values reset. + +=cut + +sub set_usage { + my ($self, $valueref) = @_; + + foreach my $cust_svc ($self->cust_svc){ + my $svc_x = $cust_svc->svc_x; + $svc_x->set_usage($valueref) + if $svc_x->can("set_usage"); + } +} + +=back =head1 BUGS @@ -732,12 +1978,12 @@ In sub order, the @pkgparts array (passed by reference) is clobbered. Also in sub order, no money is adjusted. Once FS::part_pkg defines a standard method to pass dates to the recur_prog expression, it should do so. -FS::svc_acct, FS::svc_domain, FS::svc_www and FS::svc_forward are loaded via -'use' at compile time, rather than via 'require' in sub -{ setup, suspend, unsuspend, cancel } because they use %FS::UID::callback to -load configuration values. Probably need a subroutine which decides what to -do based on whether or not we've fetched the user yet, rather than a hash. -See FS::UID and the TODO. +FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are +loaded via 'use' at compile time, rather than via 'require' in sub { setup, +suspend, unsuspend, cancel } because they use %FS::UID::callback to load +configuration values. Probably need a subroutine which decides what to do +based on whether or not we've fetched the user yet, rather than a hash. See +FS::UID and the TODO. Now that things are transactional should the check in the insert method be moved to check ?