X-Git-Url: http://git.freeside.biz/gitweb/?p=freeside.git;a=blobdiff_plain;f=FS%2FFS%2Fcust_pkg.pm;h=5dc3f4e4ac3956b965374c0b47ecda3cf95bcd60;hp=876a6255c5559474f4fa054aed7cc437b67517b4;hb=17a8b72b78ba455b58d53731fe557a471e0f2947;hpb=a8d1f57eba87ab0f00ce5cd3ba8ef0cef956f68f diff --git a/FS/FS/cust_pkg.pm b/FS/FS/cust_pkg.pm index 876a6255c..5dc3f4e4a 100644 --- a/FS/FS/cust_pkg.pm +++ b/FS/FS/cust_pkg.pm @@ -1,5 +1,5 @@ package FS::cust_pkg; -use base qw( FS::otaker_Mixin FS::cust_main_Mixin FS::Sales_Mixin +use base qw( FS::cust_pkg::API FS::otaker_Mixin FS::cust_main_Mixin FS::Sales_Mixin FS::contact_Mixin FS::location_Mixin FS::m2m_Common FS::option_Common ); @@ -7,7 +7,7 @@ use strict; use vars qw( $disable_agentcheck $DEBUG $me $upgrade ); use Carp qw(cluck); use Scalar::Util qw( blessed ); -use List::Util qw(min max); +use List::Util qw(min max sum); use Tie::IxHash; use Time::Local qw( timelocal timelocal_nocheck ); use MIME::Entity; @@ -143,7 +143,7 @@ Billing item definition (see L) =item locationnum -Optional link to package location (see L) +Optional link to package location (see L) =item order_date @@ -554,7 +554,7 @@ Available options are: =item reason -can be set to a cancellation reason (see L), 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, reason - Text of the new reason. +can be set to a cancellation reason (see L), 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, reason - Text of the new reason. =item reason_otaker @@ -815,9 +815,13 @@ the date. You are PROBABLY looking to expire the account instead of using this. =item reason - can be set to a cancellation reason (see L), -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, reason - Text of the new reason. +either a reasonnum of an existing reason, or a hashref to create +a new reason. The hashref should have the following keys: +typenum - Reason type (see L +reason - Text of the new reason. + +If this argument isn't given or is a false value, then the package will be +canceled with no reason. =item date - can be set to a unix style timestamp to specify when to cancel (expire) @@ -1044,18 +1048,23 @@ sub cancel { $dbh->commit or die $dbh->errstr if $oldAutoCommit; return '' if $date; #no errors - my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list; - if ( !$options{'quiet'} && - $conf->exists('emailcancel', $self->cust_main->agentnum) && - @invoicing_list ) { - my $msgnum = $conf->config('cancel_msgnum', $self->cust_main->agentnum); + my $cust_main = $self->cust_main; + + my @invoicing_list = $cust_main->invoicing_list_emailonly; + if ( !$options{'quiet'} + && $conf->config_bool('emailcancel', $cust_main->agentnum) + && @invoicing_list + ) + { + my $msgnum = $conf->config('cancel_msgnum', $cust_main->agentnum); my $error = ''; if ( $msgnum ) { my $msg_template = qsearchs('msg_template', { msgnum => $msgnum }); - $error = $msg_template->send( 'cust_main' => $self->cust_main, - 'object' => $self ); - } - else { + $error = $msg_template->send( + 'cust_main' => $cust_main, + 'object' => $self, + ); + } else { $error = send_email( 'from' => $conf->invoice_from_full( $self->cust_main->agentnum ), 'to' => \@invoicing_list, @@ -1068,6 +1077,23 @@ sub cancel { #should this do something on errors? } + my %pkg_class = map { $_=>1 } + $conf->config('cancel_msgnum-referring_cust-pkg_class'); + my $ref_msgnum = $conf->config('cancel_msgnum-referring_cust'); + if ( !$options{'quiet'} + && $cust_main->referral_custnum + && $pkg_class{ $self->classnum } + && $ref_msgnum + ) + { + my $msg_template = qsearchs('msg_template', { msgnum => $ref_msgnum }); + my $error = $msg_template->send( + 'cust_main' => $cust_main->referring_cust_main, + 'object' => $self, + ); + #should this do something on errors? + } + ''; #no errors } @@ -1078,6 +1104,10 @@ Cancels this package if its expire date has been reached. =cut +# XXX should look for an expire reason +# but seems to be unused; this is now handled more holistically in +# cust_main::Billing + sub cancel_if_expired { my $self = shift; my $time = shift || time; @@ -1090,6 +1120,166 @@ sub cancel_if_expired { ''; } +=item uncancel_svc_x + +For cancelled cust_pkg, returns a list of new, uninserted FS::svc_X records +for services that would be inserted by L. Returned objects also +include the field _h_svc_x, which contains the service history object. + +Set pkgnum before inserting. + +Accepts the following options: + +only_svcnum - arrayref of svcnum, only returns objects for these svcnum +(and only if they would otherwise be returned by this) + +=cut + +sub uncancel_svc_x { + my ($self, %opt) = @_; + + die 'uncancel_svc_x called on a non-cancelled cust_pkg' unless $self->get('cancel'); + + #find historical services within this timeframe before the package cancel + # (incompatible with "time" option to cust_pkg->cancel?) + my $fuzz = 2 * 60; #2 minutes? too much? (might catch separate unprovision) + # too little? (unprovisioing export delay?) + my($end, $start) = ( $self->get('cancel'), $self->get('cancel') - $fuzz ); + my @h_cust_svc = $self->h_cust_svc( $end, $start ); + + my @svc_x; + foreach my $h_cust_svc (@h_cust_svc) { + next if $opt{'only_svcnum'} && !(grep { $_ == $h_cust_svc->svcnum } @{$opt{'only_svcnum'}}); + # filter out services that still exist on this package (ie preserved svcs) + # but keep services that have since been provisioned on another package (for informational purposes) + next if qsearchs('cust_svc',{ 'svcnum' => $h_cust_svc->svcnum, 'pkgnum' => $self->pkgnum }); + my $h_svc_x = $h_cust_svc->h_svc_x( $end, $start ); + next unless $h_svc_x; # this probably doesn't happen, but just in case + (my $table = $h_svc_x->table) =~ s/^h_//; + require "FS/$table.pm"; + my $class = "FS::$table"; + my $svc_x = $class->new( { + 'svcpart' => $h_cust_svc->svcpart, + '_h_svc_x' => $h_svc_x, + map { $_ => $h_svc_x->get($_) } fields($table) + } ); + + # radius_usergroup + if ( $h_svc_x->isa('FS::h_svc_Radius_Mixin') ) { + $svc_x->usergroup( [ $h_svc_x->h_usergroup($end, $start) ] ); + } + + #these are pretty rare, but should handle them + # - dsl_device (mac addresses) + # - phone_device (mac addresses) + # - dsl_note (ikano notes) + # - domain_record (i.e. restore DNS information w/domains) + # - inventory_item(?) (inventory w/un-cancelling service?) + # - nas (svc_broaband nas stuff) + #this stuff is unused in the wild afaik + # - mailinglistmember + # - router.svcnum? + # - svc_domain.parent_svcnum? + # - acct_snarf (ancient mail fetching config) + # - cgp_rule (communigate) + # - cust_svc_option (used by our Tron stuff) + # - acct_rt_transaction (used by our time worked stuff) + + push @svc_x, $svc_x; + } + return @svc_x; +} + +=item uncancel_svc_summary + +Returns an array of hashrefs, one for each service that could +potentially be reprovisioned by L, with the following keys: + +svcpart + +svc + +uncancel_svcnum + +label - from history table if not currently calculable, undefined if it can't be loaded + +reprovisionable - 1 if test reprovision succeeded, otherwise 0 + +num_cust_svc - number of svcs for this svcpart, only if summarizing (see below) + +Cannot be run from within a transaction. Performs inserts +to test the results, and then rolls back the transaction. +Does not perform exports, so does not catch if export would fail. + +Also accepts the following options: + +no_test_reprovision - skip the test inserts (reprovisionable field will not exist) + +summarize_size - if true, returns a single summary record for svcparts with at +least this many svcs, will have key num_cust_svc but not uncancel_svcnum, label or reprovisionable + +=cut + +sub uncancel_svc_summary { + my ($self, %opt) = @_; + + die 'uncancel_svc_summary called on a non-cancelled cust_pkg' unless $self->get('cancel'); + die 'uncancel_svc_summary called from within a transaction' unless $FS::UID::AutoCommit; + + local $FS::svc_Common::noexport_hack = 1; # very important not to run exports!!! + local $FS::UID::AutoCommit = 0; + + # sort by svcpart, to check summarize_size + my $uncancel_svc_x = {}; + foreach my $svc_x (sort { $a->{'svcpart'} <=> $b->{'svcpart'} } $self->uncancel_svc_x) { + $uncancel_svc_x->{$svc_x->svcpart} = [] unless $uncancel_svc_x->{$svc_x->svcpart}; + push @{$uncancel_svc_x->{$svc_x->svcpart}}, $svc_x; + } + + my @out; + foreach my $svcpart (keys %$uncancel_svc_x) { + my @svcpart_svc_x = @{$uncancel_svc_x->{$svcpart}}; + if ($opt{'summarize_size'} && (@svcpart_svc_x >= $opt{'summarize_size'})) { + my $svc_x = $svcpart_svc_x[0]; #grab first one for access to $part_svc + my $part_svc = $svc_x->part_svc; + push @out, { + 'svcpart' => $part_svc->svcpart, + 'svc' => $part_svc->svc, + 'num_cust_svc' => scalar(@svcpart_svc_x), + }; + } else { + foreach my $svc_x (@svcpart_svc_x) { + my $part_svc = $svc_x->part_svc; + my $out = { + 'svcpart' => $part_svc->svcpart, + 'svc' => $part_svc->svc, + 'uncancel_svcnum' => $svc_x->get('_h_svc_x')->svcnum, + }; + $svc_x->pkgnum($self->pkgnum); # provisioning services on a canceled package, will be rolled back + my $insert_error; + unless ($opt{'no_test_reprovision'}) { + # avoid possibly fatal errors from missing linked records + eval { $insert_error = $svc_x->insert }; + $insert_error ||= $@; + } + if ($opt{'no_test_reprovision'} or $insert_error) { + # avoid possibly fatal errors from missing linked records + eval { $out->{'label'} = $svc_x->label }; + eval { $out->{'label'} = $svc_x->get('_h_svc_x')->label } unless defined($out->{'label'}); + $out->{'reprovisionable'} = 0 unless $opt{'no_test_reprovision'}; + } else { + $out->{'label'} = $svc_x->label; + $out->{'reprovisionable'} = 1; + } + push @out, $out; + } + } + } + + dbh->rollback; + return @out; +} + =item uncancel "Un-cancels" this package: Orders a new package with the same custnum, pkgpart, @@ -1102,6 +1292,8 @@ svc_fatal: service provisioning errors are fatal svc_errors: pass an array reference, will be filled in with any provisioning errors +only_svcnum: arrayref, only attempt to re-provision these cancelled services + main_pkgnum: link the package as a supplemental package of this one. For internal use only. @@ -1165,32 +1357,12 @@ sub uncancel { # insert services ## - #find historical services within this timeframe before the package cancel - # (incompatible with "time" option to cust_pkg->cancel?) - my $fuzz = 2 * 60; #2 minutes? too much? (might catch separate unprovision) - # too little? (unprovisioing export delay?) - my($end, $start) = ( $self->get('cancel'), $self->get('cancel') - $fuzz ); - my @h_cust_svc = $self->h_cust_svc( $end, $start ); - my @svc_errors; - foreach my $h_cust_svc (@h_cust_svc) { - my $h_svc_x = $h_cust_svc->h_svc_x( $end, $start ); - #next unless $h_svc_x; #should this happen? - (my $table = $h_svc_x->table) =~ s/^h_//; - require "FS/$table.pm"; - my $class = "FS::$table"; - my $svc_x = $class->new( { - 'pkgnum' => $cust_pkg->pkgnum, - 'svcpart' => $h_cust_svc->svcpart, - map { $_ => $h_svc_x->get($_) } fields($table) - } ); - - # radius_usergroup - if ( $h_svc_x->isa('FS::h_svc_Radius_Mixin') ) { - $svc_x->usergroup( [ $h_svc_x->h_usergroup($end, $start) ] ); - } + foreach my $svc_x ($self->uncancel_svc_x('only_svcnum' => $options{'only_svcnum'})) { + $svc_x->pkgnum($cust_pkg->pkgnum); my $svc_error = $svc_x->insert; + if ( $svc_error ) { if ( $options{svc_fatal} ) { $dbh->rollback if $oldAutoCommit; @@ -1214,23 +1386,7 @@ sub uncancel { } } # svc_fatal } # svc_error - } #foreach $h_cust_svc - - #these are pretty rare, but should handle them - # - dsl_device (mac addresses) - # - phone_device (mac addresses) - # - dsl_note (ikano notes) - # - domain_record (i.e. restore DNS information w/domains) - # - inventory_item(?) (inventory w/un-cancelling service?) - # - nas (svc_broaband nas stuff) - #this stuff is unused in the wild afaik - # - mailinglistmember - # - router.svcnum? - # - svc_domain.parent_svcnum? - # - acct_snarf (ancient mail fetching config) - # - cgp_rule (communigate) - # - cust_svc_option (used by our Tron stuff) - # - acct_rt_transaction (used by our time worked stuff) + } #foreach uncancel_svc_x ## # also move over any services that didn't unprovision at cancellation @@ -1273,14 +1429,15 @@ sub uncancel { =item unexpire -Cancels any pending expiration (sets the expire field to null). +Cancels any pending expiration (sets the expire field to null) +for this package and any supplemental packages. If there is an error, returns the error, otherwise returns false. =cut sub unexpire { - my( $self, %options ) = @_; + my( $self ) = @_; my $error; local $SIG{HUP} = 'IGNORE'; @@ -1317,6 +1474,14 @@ sub unexpire { return $error; } + foreach my $supp_pkg ( $self->supplemental_pkgs ) { + $error = $supp_pkg->unexpire; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "unexpiring supplemental pkg#".$supp_pkg->pkgnum.": $error"; + } + } + $dbh->commit or die $dbh->errstr if $oldAutoCommit; ''; #no errors @@ -1332,7 +1497,7 @@ Available options are: =over 4 -=item reason - can be set to a cancellation reason (see L), +=item reason - can be set to a cancellation reason (see L), 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 @@ -1613,42 +1778,104 @@ sub credit_remaining { my $conf = FS::Conf->new; my $reason_type = $conf->config($mode.'_credit_type'); - my $last_bill = $self->getfield('last_bill') || 0; - my $next_bill = $self->getfield('bill') || 0; - if ( $last_bill > 0 # the package has been billed - and $next_bill > 0 # the package has a next bill date - and $next_bill >= $time # which is in the future - ) { - my $remaining_value = 0; + $time ||= time; - my $remain_pkg = $self; - $remaining_value = $remain_pkg->calc_remain('time' => $time); + my $remain_pkg = $self; + my (@billpkgnums, @amounts, @setuprecurs); + + # we may have to walk back past some package changes to get to the + # one that actually has unused time. loop until that happens, or we + # reach the first package in the chain. + while (1) { + my $last_bill = $remain_pkg->get('last_bill') || 0; + my $next_bill = $remain_pkg->get('bill') || 0; + if ( $last_bill > 0 # the package has been billed + and $next_bill > 0 # the package has a next bill date + and $next_bill >= $time # which is in the future + ) { + + # Find actual charges for the period ending on or after the cancel + # date. + my @charges = qsearch('cust_bill_pkg', { + pkgnum => $remain_pkg->pkgnum, + edate => {op => '>=', value => $time}, + recur => {op => '>' , value => 0}, + }); + + foreach my $cust_bill_pkg (@charges) { + # hack to deal with the weird behavior of edate on package + # cancellation + my $edate = $cust_bill_pkg->edate; + if ( $self->recur_temporality eq 'preceding' ) { + $edate = $self->add_freq($cust_bill_pkg->sdate); + } + + # this will also get any package charges that are _entirely_ after + # the cancellation date (can happen with advance billing). in that + # case, use the entire recurring charge: + my $amount = $cust_bill_pkg->recur - $cust_bill_pkg->usage; + my $max_credit = $amount + - $cust_bill_pkg->credited('', '', setuprecur => 'recur') || 0; + + # but if the cancellation happens during the interval, prorate it: + # (XXX obey prorate_round_day here?) + if ( $cust_bill_pkg->sdate < $time ) { + $amount = $amount * + ($edate - $time) / ($edate - $cust_bill_pkg->sdate); + } + + # if there are existing credits, don't let the sum of credits exceed + # the recurring charge + $amount = $max_credit if $amount > $max_credit; + + $amount = sprintf('%.2f', $amount); + + # if no time has been used and/or there are existing line item + # credits, we may end up not needing to credit anything. + if ( $amount > 0 ) { + + push @billpkgnums, $cust_bill_pkg->billpkgnum; + push @amounts, $amount; + push @setuprecurs, 'recur'; + + warn "Crediting for $amount on package ".$remain_pkg->pkgnum."\n" + if $DEBUG; + } - # we may have to walk back past some package changes to get to the - # one that actually has unused time - while ( $remaining_value == 0 ) { - if ( $remain_pkg->change_pkgnum ) { - $remain_pkg = FS::cust_pkg->by_key($remain_pkg->change_pkgnum); - } else { - # the package has really never been billed - return; } - $remaining_value = $remain_pkg->calc_remain('time' => $time); + + last if @charges; } - if ( $remaining_value > 0 ) { - warn "Crediting for $remaining_value on package ".$self->pkgnum."\n" - if $DEBUG; - my $error = $self->cust_main->credit( - $remaining_value, - 'Credit for unused time on '. $self->part_pkg->pkg, - 'reason_type' => $reason_type, - ); - return "Error crediting customer \$$remaining_value for unused time". - " on ". $self->part_pkg->pkg. ": $error" - if $error; - } #if $remaining_value - } #if $last_bill, etc. + if ( my $changed_from_pkgnum = $remain_pkg->change_pkgnum ) { + $remain_pkg = FS::cust_pkg->by_key($changed_from_pkgnum); + } else { + # the package has really never been billed + return; + } + } + + # keep traditional behavior here. + local $@; + my $reason = FS::reason->new_or_existing( + reason => 'Credit for unused time on '. $self->part_pkg->pkg, + type => $reason_type, + class => 'R', + ); + if ( $@ ) { + return "failed to set credit reason: $@"; + } + + my $error = FS::cust_credit->credit_lineitems( + 'billpkgnums' => \@billpkgnums, + 'setuprecurs' => \@setuprecurs, + 'amounts' => \@amounts, + 'custnum' => $self->custnum, + 'date' => time, + 'reasonnum' => $reason->reasonnum, + 'apply' => 1, + ); + ''; } @@ -1918,14 +2145,15 @@ sub unsuspend { =item unadjourn -Cancels any pending suspension (sets the adjourn field to null). +Cancels any pending suspension (sets the adjourn field to null) +for this package and any supplemental packages. If there is an error, returns the error, otherwise returns false. =cut sub unadjourn { - my( $self, %options ) = @_; + my( $self ) = @_; my $error; local $SIG{HUP} = 'IGNORE'; @@ -1969,6 +2197,14 @@ sub unadjourn { return $error; } + foreach my $supp_pkg ( $self->supplemental_pkgs ) { + $error = $supp_pkg->unadjourn; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "unadjourning supplemental pkg#".$supp_pkg->pkgnum.": $error"; + } + } + $dbh->commit or die $dbh->errstr if $oldAutoCommit; ''; #no errors @@ -2116,32 +2352,77 @@ sub change { $opt->{'locationnum'} = $opt->{'cust_location'}->locationnum; } + # figure out if we're changing pkgpart + if ( $opt->{'cust_pkg'} ) { + $opt->{'pkgpart'} = $opt->{'cust_pkg'}->pkgpart; + } + + # whether to override pkgpart checking on the new package + my $same_pkgpart = 1; + if ( $opt->{'pkgpart'} and ( $opt->{'pkgpart'} != $self->pkgpart ) ) { + $same_pkgpart = 0; + } + + if ($opt->{'waive_setup'}) { $self->set('waive_setup', $opt->{'waive_setup'}) } + else { $self->set('waive_setup', ''); } + # Before going any further here: if the package is still in the pre-setup # state, it's safe to modify it in place. No need to charge/credit for - # partial period, transfer services, transfer usage pools, copy invoice - # details, or change any dates. + # partial period, transfer usage pools, copy invoice details, or change any + # dates. We DO need to "transfer" services (from the package to itself) to + # check their validity on the new pkgpart. if ( ! $self->setup and ! $opt->{cust_pkg} and ! $opt->{cust_main} ) { - foreach ( qw( locationnum pkgpart quantity refnum salesnum ) ) { + foreach ( qw( locationnum pkgpart quantity refnum salesnum waive_setup ) ) { if ( length($opt->{$_}) ) { $self->set($_, $opt->{$_}); } } # almost. if the new pkgpart specifies start/adjourn/expire timers, # apply those. - if ( $opt->{'pkgpart'} and $opt->{'pkgpart'} != $self->pkgpart ) { + if ( !$same_pkgpart ) { $self->set_initial_timers; } # but if contract_end was explicitly specified, that overrides all else $self->set('contract_end', $opt->{'contract_end'}) if $opt->{'contract_end'}; + $error = $self->replace; if ( $error ) { $dbh->rollback if $oldAutoCommit; return "modifying package: $error"; - } else { - $dbh->commit if $oldAutoCommit; - return $self; } + + # check/convert services (only on pkgpart change, to avoid surprises + # when editing locations) + # (maybe do this if changing quantity?) + if ( !$same_pkgpart ) { + + $error = $self->transfer($self); + + if ( $error and $error == 0 ) { + $error = "transferring $error"; + } elsif ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) { + warn "trying transfer again with change_svcpart option\n" if $DEBUG; + $error = $self->transfer($self, 'change_svcpart'=>1 ); + if ($error and $error == 0) { + $error = "converting $error"; + } + } + + if ($error > 0) { + $error = "unable to transfer all services"; + } + + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + + } # done transferring services + + $dbh->commit if $oldAutoCommit; + return $self; + } my %hash = (); @@ -2154,18 +2435,6 @@ sub change { $hash{"change_$_"} = $self->$_() foreach qw( pkgnum pkgpart locationnum ); - if ( $opt->{'cust_pkg'} ) { - # treat changing to a package with a different pkgpart as a - # pkgpart change (because it is) - $opt->{'pkgpart'} = $opt->{'cust_pkg'}->pkgpart; - } - - # whether to override pkgpart checking on the new package - my $same_pkgpart = 1; - if ( $opt->{'pkgpart'} and ( $opt->{'pkgpart'} != $self->pkgpart ) ) { - $same_pkgpart = 0; - } - my $unused_credit = 0; my $keep_dates = $opt->{'keep_dates'}; @@ -2346,6 +2615,21 @@ sub change { return "transferring package notes: $error"; } } + + # transfer scheduled expire/adjourn reasons + foreach my $action ('expire', 'adjourn') { + if ( $cust_pkg->get($action) ) { + my $reason = $self->last_cust_pkg_reason($action); + if ( $reason ) { + $reason->set('pkgnum', $cust_pkg->pkgnum); + $error = $reason->replace; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "transferring $action reason: $error"; + } + } + } + } my @new_supp_pkgs; @@ -2426,6 +2710,19 @@ sub change { return "canceling old package: $error"; } + # transfer rt_field_charge, if we're not changing pkgpart + # after billing of old package, before billing of new package + if ( $same_pkgpart ) { + foreach my $rt_field_charge ($self->rt_field_charge) { + $rt_field_charge->set('pkgnum', $cust_pkg->pkgnum); + $error = $rt_field_charge->replace; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "transferring rt_field_charge: $error"; + } + } + } + if ( $conf->exists('cust_pkg-change_pkgpart-bill_now') ) { #$self->cust_main my $error = $cust_pkg->cust_main->bill( @@ -2468,6 +2765,10 @@ The date for the package change. Required, and must be in the future. =item quantity +=item discount + +Optional hashref that will be passed to $new_pkg->change_discount() + =item contract_end The pkgpart, locationnum, quantity and optional contract_end of the new @@ -2485,6 +2786,9 @@ sub change_later { my $error = $self->_check_change($opt); return $error if $error; + my %discount; + %discount = %{$opt->{discount}} if ref $opt->{discount}; + my $oldAutoCommit = $FS::UID::AutoCommit; local $FS::UID::AutoCommit = 0; my $dbh = dbh; @@ -2498,6 +2802,16 @@ sub change_later { return "start_date $date is in the past"; } + # If the user entered a new location, set it up now. + if ( $opt->{'cust_location'} ) { + $error = $opt->{'cust_location'}->find_or_insert; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "creating location record: $error"; + } + $opt->{'locationnum'} = $opt->{'cust_location'}->locationnum; + } + if ( $self->change_to_pkgnum ) { my $change_to = FS::cust_pkg->by_key($self->change_to_pkgnum); my $new_pkgpart = $opt->{'pkgpart'} @@ -2527,6 +2841,10 @@ sub change_later { (($err_or_pkg->pkgnum == $change_to->pkgnum) ? '' : $change_to->cancel('no_delay_cancel' => 1) || $change_to->delete); + + # Apply user-specified discount to new cust_pkg + $error = $err_or_pkg->change_discount(\%discount) + if !$error && %discount && $discount{discountnum} =~ /^-?\d+$/; } else { $error = $err_or_pkg; } @@ -2534,6 +2852,10 @@ sub change_later { $self->set('expire', $date); $change_to->set('start_date', $date); $error = $self->replace || $change_to->replace; + + # Apply user-specified discount to new cust_pkg + $error = $change_to->change_discount(\%discount) + if !$error && %discount && $discount{discountnum} =~ /^-?\d+$/; } if ( $error ) { $dbh->rollback if $oldAutoCommit; @@ -2573,6 +2895,11 @@ sub change_later { $self->set('expire', $date); $error = $self->replace; } + + # Apply user-specified discount to new cust_pkg + $new->change_discount(\%discount) + if !$error && %discount && $discount{discountnum} =~ /^-?\d+$/; + if ( $error ) { $dbh->rollback if $oldAutoCommit; } else { @@ -2691,7 +3018,7 @@ sub modify_charge { $pkg_opt_modified = 1; } } - $pkg_opt_modified = 1 if (scalar(@old_additional) - 1) != $i; + $pkg_opt_modified = 1 if scalar(@old_additional) != $i; $pkg_opt{'additional_count'} = $i if $i > 0; my $old_classnum; @@ -2844,8 +3171,6 @@ sub modify_charge { ''; } - - use Storable 'thaw'; use MIME::Base64; use Data::Dumper; @@ -2854,11 +3179,10 @@ sub process_bulk_cust_pkg { my $param = thaw(decode_base64(shift)); warn Dumper($param) if $DEBUG; - my $old_part_pkg = qsearchs('part_pkg', - { pkgpart => $param->{'old_pkgpart'} }); my $new_part_pkg = qsearchs('part_pkg', { pkgpart => $param->{'new_pkgpart'} }); - die "Must select a new package type\n" unless $new_part_pkg; + die "Must select a new package definition\n" unless $new_part_pkg; + #my $keep_dates = $param->{'keep_dates'} || 0; my $keep_dates = 1; # there is no good reason to turn this off @@ -2873,7 +3197,14 @@ sub process_bulk_cust_pkg { local $FS::UID::AutoCommit = 0; my $dbh = dbh; - my @cust_pkgs = qsearch('cust_pkg', { 'pkgpart' => $param->{'old_pkgpart'} } ); + my @old_pkgpart = ref($param->{'old_pkgpart'}) ? @{ $param->{'old_pkgpart'} } + : $param->{'old_pkgpart'}; + + my @cust_pkgs = qsearch({ + 'table' => 'cust_pkg', + 'extra_sql' => ' WHERE pkgpart IN ('. + join(',', @old_pkgpart). ')', + }); my $i = 0; foreach my $old_cust_pkg ( @cust_pkgs ) { @@ -3741,23 +4072,27 @@ sub labels { map { [ $_->label ] } $self->cust_svc; } -=item h_labels END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ] +=item h_labels END_TIMESTAMP [, START_TIMESTAMP [, MODE [, LOCALE ] ] ] Like the labels method, but returns historical information on services that were active as of END_TIMESTAMP and (optionally) not cancelled before START_TIMESTAMP. If MODE is 'I' (for 'invoice'), services with the I flag will be omitted. -Returns a list of lists, calling the label method for all (historical) services -(see L) of this billing item. +If LOCALE is passed, service definition names will be localized. + +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; - warn "$me _h_labels called on $self\n" + my ($end, $start, $mode, $locale) = @_; + warn "$me h_labels\n" if $DEBUG; - map { [ $_->label(@_) ] } $self->h_cust_svc(@_); + map { [ $_->label($end, $start, $locale) ] } + $self->h_cust_svc($end, $start, $mode); } =item labels_short @@ -3770,15 +4105,15 @@ individual services rather than individual items. =cut sub labels_short { - shift->_labels_short( 'labels', @_ ); + shift->_labels_short( 'labels' ); # 'labels' takes no further arguments } -=item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ] +=item h_labels_short END_TIMESTAMP [, START_TIMESTAMP [, MODE [, LOCALE ] ] ] Like h_labels, except returns a simple flat list, and shortens long -(currently >5 or the cust_bill-max_same_services configuration value) lists of -identical services to one line that lists the service label and the number of -individual services rather than individual items. +(currently >5 or the cust_bill-max_same_services configuration value) lists +of identical services to one line that lists the service label and the +number of individual services rather than individual items. =cut @@ -3786,6 +4121,9 @@ sub h_labels_short { shift->_labels_short( 'h_labels', @_ ); } +# takes a method name ('labels' or 'h_labels') and all its arguments; +# maybe should be "shorten($self->h_labels( ... ) )" + sub _labels_short { my( $self, $method ) = ( shift, shift ); @@ -4071,8 +4409,10 @@ sub transfer { $target{$pkg_svc->svcpart} = $pkg_svc->quantity * ( $dest->quantity || 1 ); } - foreach my $cust_svc ($dest->cust_svc) { - $target{$cust_svc->svcpart}--; + unless ( $self->pkgnum == $dest->pkgnum ) { + foreach my $cust_svc ($dest->cust_svc) { + $target{$cust_svc->svcpart}--; + } } my %svcpart2svcparts = (); @@ -4106,24 +4446,42 @@ sub transfer { my $error; foreach my $cust_svc ($self->cust_svc) { my $svcnum = $cust_svc->svcnum; - if($target{$cust_svc->svcpart} > 0 - or $FS::cust_svc::ignore_quantity) { # maybe should be a 'force' option + + if ( $target{$cust_svc->svcpart} > 0 + or $FS::cust_svc::ignore_quantity # maybe should be a 'force' option + ) + { $target{$cust_svc->svcpart}--; + + local $FS::cust_svc::ignore_quantity = 1 + if $self->pkgnum == $dest->pkgnum; + + #why run replace at all in the $self->pkgnum == $dest->pkgnum case? + # we do want to trigger location and pkg_change exports, but + # without pkgnum changing from an old to new package, cust_svc->replace + # doesn't know how to trigger those. :/ + # does this mean we scrap the whole idea of "safe to modify it in place", + # or do we special-case and pass the info needed to cust_svc->replace? :/ + my $new = new FS::cust_svc { $cust_svc->hash }; $new->pkgnum($dest_pkgnum); $error = $new->replace($cust_svc); + } 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]; @@ -4135,13 +4493,16 @@ sub transfer { } else { $remaining++; } + } else { $remaining++ } + if ( $error ) { my @label = $cust_svc->label; return "service $label[1]: $error"; } + } return $remaining; } @@ -4269,7 +4630,7 @@ Available options are: =item reason -can be set to a cancellation reason (see L), 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, reason - Text of the new reason. +can be set to a cancellation reason (see L), 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, reason - Text of the new reason. =item reason_otaker @@ -4369,6 +4730,139 @@ sub insert_discount { $cust_pkg_discount->insert; } + +=item change_discount %opt + +Method checks if the given values represent a change in either setup or +discount level. If so, the existing discounts are revoked, the new +discounts are recorded. + +Usage: + +$error = change_discount( + { + # -1: Indicates a "custom discount" + # 0: Indicates to remove any discount + # >0: discountnum to apply + discountnum => [-1, 0, discountnum], + + # When discountnum is "-1" to indicate custom discount, include + # the additional fields: + amount => AMOUNT_DISCOUNT + percent => PERCENTAGE_DISCOUNT + months => 12, + setup => 1, # APPLY TO SETUP + _type => amount/percentage + }, +); + + +=cut + +sub change_discount { + my ($self, $opt) = @_; + return "change_discount() called with bad \%opt hashref" + unless ref $opt; + + my %opt = %{$opt}; + + my @old_discount = + qsearch('cust_pkg_discount',{ + pkgnum => $self->pkgnum, + disabled => '', + }); + + if ($DEBUG) { + warn "change_discount() pkgnum: ".$self->pkgnum." \n"; + warn "change_discount() \%opt: \n"; + warn Dumper(\%opt); + } + + my @to_be_disabled; + my %change = %opt; + + return "change_discount() called with bad discountnum" + unless $change{discountnum} =~ /^-?\d+$/; + + if ($change{discountnum} eq 0) { + # Removing old discount + + %change = (); + + push @to_be_disabled, @old_discount; + + } else { + + if ( grep { $_->discountnum eq $change{discountnum} } @old_discount ){ + # Duplicate, disregard this entry + %change = (); + } else { + # Mark any discounts we're replacing + push @to_be_disabled, @old_discount; + } + } + + # If we still have changes queued, create data structures for + # insert_discount(). + my @discount_insert; + if (%change) { + push @discount_insert, { + discountnum => $change{discountnum}, + discountnum__type => $change{_type}, + discountnum_amount => $change{amount}, + discountnum_percent => $change{percent} ? $change{percent} : '0', + discountnum_months => $change{months}, + discountnum_setup => $change{setup} ? 'Y' : '', + } + } + + if ($DEBUG) { + warn "change_discount() \% opt before insert \n"; + warn Dumper \%opt; + warn "\@to_be_disabled \n"; + warn Dumper \@to_be_disabled; + } + + # Roll these updates into a transaction + my $oldAutoCommit = $FS::UID::AutoCommit; + local $FS::UID::AutoCommit = 0; + my $dbh = dbh; + + my $error; + + # The "waive setup fee" flag has traditionally been handled by setting + # $cust_pkg->waive_setup = Y. This has been appropriately, and separately + # handled, and it operates on a different table than cust_pkg_discount, + # so the "-2 for waive setup fee" option is not being reimplemented + # here. Perhaps this may change later. + + # Create new discounts + for my $insert_discount (@discount_insert) { + + # Set parameters for insert_discount into object, and insert + for my $k (keys %{$insert_discount}) { + $self->set($k, $insert_discount->{$k}); + } + $error ||= $self->insert_discount(); + } + + # Disabling old discounts + for my $tbd (@to_be_disabled) { + unless ($error) { + $tbd->set(disabled => 'Y'); + $error = $tbd->replace(); + } + } + + if ($error) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + + $dbh->commit if $oldAutoCommit; + return undef; +} + =item set_usage USAGE_VALUE_HASHREF USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts @@ -4753,6 +5247,17 @@ sub cancel_sql { "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0"; } +=item ncancelled_recurring_sql + +Returns an SQL expression identifying un-cancelled, recurring packages. + +=cut + +sub ncancelled_recurring_sql { + $_[0]->recurring_sql(). + " AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 ) "; +} + =item status_sql Returns an SQL expression to give the package status as a string. @@ -5045,7 +5550,7 @@ sub search { } ### - # parse refnum (advertising source) + # parse (customer) refnum (advertising source) ### if ( exists($params->{'refnum'}) ) { @@ -5056,7 +5561,7 @@ sub search { @refnum = ( $params->{'refnum'} ); } my $in = join(',', grep /^\d+$/, @refnum); - push @where, "refnum IN($in)" if length $in; + push @where, "cust_main.refnum IN($in)" if length $in; } ### @@ -5235,29 +5740,38 @@ sub search { foreach my $field (qw( setup last_bill bill adjourn susp expire contract_end change_date cancel )) { - next unless exists($params->{$field}); + if ( $params->{$field.'_null'} ) { - my($beginning, $ending) = @{$params->{$field}}; + push @where, "cust_pkg.$field IS NULL"; + # this should surely be obsoleted by now: OR cust_pkg.$field == 0 - next if $beginning == 0 && $ending == 4294967295; + } else { - push @where, - "cust_pkg.$field IS NOT NULL", - "cust_pkg.$field >= $beginning", - "cust_pkg.$field <= $ending"; - - $orderby ||= "ORDER BY cust_pkg.$field"; - - if ( $field eq 'setup' ) { - $exclude_change_from = 1; - } elsif ( $field eq 'cancel' ) { - $exclude_change_to = 1; - } elsif ( $field eq 'change_date' ) { - # if we are given setup and change_date ranges, and the setup date - # falls in _both_ ranges, then include the package whether it was - # a change or not - $exclude_change_from = 0; + 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"; + + if ( $field eq 'setup' ) { + $exclude_change_from = 1; + } elsif ( $field eq 'cancel' ) { + $exclude_change_to = 1; + } elsif ( $field eq 'change_date' ) { + # if we are given setup and change_date ranges, and the setup date + # falls in _both_ ranges, then include the package whether it was + # a change or not + $exclude_change_from = 0; + } } + } if ($exclude_change_from) { @@ -5270,6 +5784,7 @@ sub search { WHERE cust_pkg.pkgnum = changed_to_pkg.change_pkgnum )"; } + } $orderby ||= 'ORDER BY bill'; @@ -5378,6 +5893,8 @@ sub search { push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main'); } + push @where, "cust_pkg_reason.reasonnum = '".$params->{reasonnum}."'" if $params->{reasonnum}; + my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : ''; my $addl_from = 'LEFT JOIN part_pkg USING ( pkgpart ) '. @@ -5385,6 +5902,10 @@ sub search { 'LEFT JOIN cust_location USING ( locationnum ) '. FS::UI::Web::join_cust_main('cust_pkg', 'cust_pkg'); + if ($params->{reasonnum}) { + $addl_from .= 'LEFT JOIN cust_pkg_reason ON (cust_pkg_reason.pkgnum = cust_pkg.pkgnum) '; + } + my $select; my $count_query; if ( $params->{'select_zip5'} ) { @@ -5448,6 +5969,24 @@ sub fcc_477_count { } +=item fcc_477_record + +Returns a fcc_477 record based on option name. + +=cut + +sub fcc_477_record { + my ($self, $option_name) = @_; + + my $fcc_record = qsearchs({ + 'table' => 'part_pkg_fcc_option', + 'hashref' => { 'pkgpart' => $self->{Hash}->{pkgpart}, 'fccoptionname' => $option_name, }, + }); + + return ( $fcc_record ); + +} + =item tax_locationnum_sql Returns an SQL expression for the tax location for a package, based @@ -5909,6 +6448,38 @@ sub _upgrade_data { # class method my $error = $part_pkg_link->remove_linked; die $error if $error; } + + # RT#73607: canceling a package with billing addons sometimes changes its + # pkgpart. + # Find records where the last replace_new record for the package before it + # was canceled has a different pkgpart from the package itself. + my @cust_pkg = qsearch({ + 'table' => 'cust_pkg', + 'select' => 'cust_pkg.*, h_cust_pkg.pkgpart AS h_pkgpart', + 'addl_from' => ' JOIN ( + SELECT pkgnum, MAX(historynum) AS historynum FROM h_cust_pkg + WHERE cancel IS NULL + AND history_action = \'replace_new\' + GROUP BY pkgnum + ) AS last_history USING (pkgnum) + JOIN h_cust_pkg USING (historynum)', + 'extra_sql' => ' WHERE cust_pkg.cancel is not null + AND cust_pkg.pkgpart != h_cust_pkg.pkgpart' + }); + foreach my $cust_pkg ( @cust_pkg ) { + my $pkgnum = $cust_pkg->pkgnum; + warn "fixing pkgpart on canceled pkg#$pkgnum\n"; + $cust_pkg->set('pkgpart', $cust_pkg->h_pkgpart); + my $error = $cust_pkg->replace; + die $error if $error; + } + +} + +# will autoload in v4+ +sub rt_field_charge { + my $self = shift; + qsearch('rt_field_charge',{ 'pkgnum' => $self->pkgnum }); } =back @@ -5940,4 +6511,3 @@ L, schema.html from the base documentation =cut 1; -