X-Git-Url: http://git.freeside.biz/gitweb/?p=freeside.git;a=blobdiff_plain;f=FS%2FFS%2Fcust_pkg.pm;h=56da5c77de86ecc8e148a4d3710be594e0180ff1;hp=069ac8cf734d3f0a31113b1f43b3eb2c96a71aa2;hb=e4ae5122522f2d45c68a38eaef337a82029f2fc1;hpb=9410e9f656b950a9d4b383a3992fa50bb7a270db diff --git a/FS/FS/cust_pkg.pm b/FS/FS/cust_pkg.pm index 069ac8cf7..56da5c77d 100644 --- a/FS/FS/cust_pkg.pm +++ b/FS/FS/cust_pkg.pm @@ -1,25 +1,64 @@ package FS::cust_pkg; use strict; -use vars qw(@ISA); +use vars qw(@ISA $disable_agentcheck @SVCDB_CANCEL_SEQ $DEBUG); use FS::UID qw( getotaker dbh ); use FS::Record qw( qsearch qsearchs ); +use FS::Misc qw( send_email ); 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; # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend, # setup } # because they load configuraion by setting FS::UID::callback (see TODO) use FS::svc_acct; -use FS::svc_acct_sm; use FS::svc_domain; use FS::svc_www; +use FS::svc_forward; + +# for sending cancel emails in sub cancel +use FS::Conf; @ISA = qw( FS::Record ); +$DEBUG = 0; + +$disable_agentcheck = 0; + +# The order in which to unprovision services. +@SVCDB_CANCEL_SEQ = qw( svc_external + svc_www + svc_forward + svc_acct + svc_domain + svc_broadband ); + +sub _cache { + my $self = shift; + my ( $hashref, $cache ) = @_; + #if ( $hashref->{'pkgpart'} ) { + if ( $hashref->{'pkg'} ) { + # #@{ $self->{'_pkgnum'} } = (); + # my $subcache = $cache->subcache('pkgpart', 'part_pkg'); + # $self->{'_pkgpart'} = $subcache; + # #push @{ $self->{'_pkgnum'} }, + # FS::part_pkg->new_or_cached($hashref, $subcache); + $self->{'_pkgpart'} = FS::part_pkg->new($hashref); + } + if ( exists $hashref->{'svcnum'} ) { + #@{ $self->{'_pkgnum'} } = (); + my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum}); + $self->{'_svcnum'} = $subcache; + #push @{ $self->{'_pkgnum'} }, + FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum}; + } +} + =head1 NAME FS::cust_pkg - Object methods for cust_pkg objects @@ -49,6 +88,8 @@ FS::cust_pkg - Object methods for cust_pkg objects @labels = $record->labels; + $seconds = $record->seconds_since($timestamp); + $error = FS::cust_pkg::order( $custnum, \@pkgparts ); $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] ); @@ -67,7 +108,9 @@ inherits from FS::Record. The following fields are currently supported: =item setup - date -=item bill - date +=item bill - date (next bill date) + +=item last_bill - last bill date =item susp - date @@ -78,7 +121,7 @@ inherits from FS::Record. The following fields are currently supported: =item otaker - order taker (assigned automatically if null, see L) =item manual_flag - If this field is set to 1, disables the automatic -unsuspensiond of this package when using the B config file. +unsuspension of this package when using the B config file. =back @@ -98,40 +141,94 @@ Create a new billing item. To add the item to the database, see L<"insert">. sub table { 'cust_pkg'; } -=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 ) = @_; - # 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?) + 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 $error = $self->ut_number('custnum'); - return $error if $error; + my $oldAutoCommit = $FS::UID::AutoCommit; + local $FS::UID::AutoCommit = 0; + my $dbh = dbh; + + my $error = $self->SUPER::insert; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } - return "Unknown customer ". $self->custnum unless $self->cust_main; + my $conf = new FS::Conf; + my $cust_main = $self->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 + ); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "Error crediting customer ". $cust_main->referral_custnum. + " for referral: $error"; + } - $self->SUPER::insert; + } + + } + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + ''; } =item delete -Currently unimplemented. You don't want to delete billing items, because there -would then be no record the customer ever purchased the item. Instead, see -the cancel method. +This method now works but you probably shouldn't use it. + +You don't want to delete billing items, because there would then be no record +the customer ever purchased the item. Instead, see the cancel method. =cut -sub delete { - return "Can't delete cust_pkg records!"; -} +#sub delete { +# return "Can't delete cust_pkg records!"; +#} =item replace OLD_RECORD @@ -165,6 +262,8 @@ sub replace { #some logic for bill, susp, cancel? + local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart; + $new->SUPER::replace($old); } @@ -181,8 +280,8 @@ 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') @@ -190,37 +289,62 @@ sub check { ; return $error if $error; - if ( $self->custnum ) { - return "Unknown customer ". $self->custnum unless $self->cust_main; - } + if ( $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; + $self->pkgpart($promo_part_pkg->pkgpart); + + } else { + + 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 }; + } - return "Unknown pkgpart" - unless qsearchs( 'part_pkg', { 'pkgpart' => $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\.\-]{0,16})$/ 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'; @@ -234,39 +358,33 @@ sub cancel { local $FS::UID::AutoCommit = 0; my $dbh = dbh; + my %svc; foreach my $cust_svc ( - qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) + qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ) { - my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } ); + push @{ $svc{$cust_svc->part_svc->svcdb} }, $cust_svc; + } - $part_svc->svcdb =~ /^([\w\-]+)$/ or do { - $dbh->rollback if $oldAutoCommit; - return "Illegal svcdb value in part_svc!"; - }; - my $svcdb = $1; - require "FS/$svcdb.pm"; + foreach my $svcdb (@SVCDB_CANCEL_SEQ) { + foreach my $cust_svc (@{ $svc{$svcdb} }) { + my $error = $cust_svc->cancel; - my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } ); - if ($svc) { - $error = $svc->cancel; if ( $error ) { - $dbh->rollback if $oldAutoCommit; - return "Error cancelling service: $error" - } - $error = $svc->delete; - if ( $error ) { - $dbh->rollback if $oldAutoCommit; - return "Error deleting service: $error"; + $dbh->rollback if $oldAutoCommit; + return "Error cancelling cust_svc: $error"; } } + } - $error = $cust_svc->delete; - if ( $error ) { + # Add a credit for remaining service + my $remaining_value= $self->calc_remain(); + if ($remaining_value > 0) { + my $error = $self->credit($remaining_value, 'Credit for service remaining'); + if ($error) { $dbh->rollback if $oldAutoCommit; - return "Error deleting cust_svc: $error"; - } - - } + return "Error crediting customer for service remaining: $error"; + } + } unless ( $self->getfield('cancel') ) { my %hash = $self->hash; @@ -281,7 +399,21 @@ sub cancel { $dbh->commit or die $dbh->errstr if $oldAutoCommit; + my $conf = new FS::Conf; + my @invoicing_list = grep { $_ ne 'POST' } $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'), + 'body' => [ map "$_\n", $conf->config('cancelmessage') ], + ); + #should this do something on errors? + } + ''; #no errors + } =item suspend @@ -396,7 +528,10 @@ sub unsuspend { unless ( ! $self->getfield('susp') ) { my %hash = $self->hash; + my $inactive = time - $hash{'susp'}; $hash{'susp'} = ''; + $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive + if $inactive > 0 && ( $hash{'bill'} || $hash{'setup'} ); my $new = new FS::cust_pkg ( \%hash ); $error = $new->replace($self); if ( $error ) { @@ -410,6 +545,24 @@ sub unsuspend { ''; #no errors } +=item last_bill + +Returns the last bill date, or if there is no last bill date, the setup date. +Useful for billing metered services. + +=cut + +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 part_pkg Returns the definition for this billing item, as an FS::part_pkg object (see @@ -419,7 +572,157 @@ L). sub part_pkg { my $self = shift; - qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } ); + #exists( $self->{'_pkgpart'} ) + $self->{'_pkgpart'} + ? $self->{'_pkgpart'} + : qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } ); +} + +=item calc_setup + +Calls the I of the FS::part_pkg object associated with this billing +item. + +=cut + +sub calc_setup { + my $self = shift; + $self->part_pkg->calc_setup($self, @_); +} + +=item calc_recur + +Calls the I of the FS::part_pkg object associated with this billing +item. + +=cut + +sub calc_recur { + my $self = shift; + $self->part_pkg->calc_recur($self, @_); +} + +=item calc_remain + +Calls the I of the FS::part_pkg object associated with this +billing item. + +=cut + +sub calc_recur { + my $self = shift; + $self->part_pkg->calc_remain($self, @_); +} + +=item calc_cancel + +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 cust_svc [ SVCPART ] + +Returns the services for this package, as FS::cust_svc objects (see +L). If a svcpart is specified, return only the matching +services. + +=cut + +sub cust_svc { + my $self = shift; + + if ( @_ ) { + return qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum, + 'svcpart' => shift, } ); + } + + #if ( $self->{'_svcnum'} ) { + # values %{ $self->{'_svcnum'}->cache }; + #} else { + $self->_sort_cust_svc( + [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ] + ); + #} + +} + +=item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ] + +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 h_cust_svc { + my $self = shift; + + $self->_sort_cust_svc( + [ qsearch( 'h_cust_svc', + { 'pkgnum' => $self->pkgnum, }, + FS::h_cust_svc->sql_h_search(@_), + ) + ] + ); +} + +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, + ]; + } + @$arrayref; + +} + +=item num_cust_svc [ SVCPART ] + +Returns the number of provisioned services for this package. If a svcpart is +specified, counts only the matching services. + +=cut + +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]; +} + +=item available_part_svc + +Returns a list 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 labels @@ -431,7 +734,53 @@ Returns a list of lists, calling the label method for all services sub labels { my $self = shift; - map { [ $_->label ] } qsearch ( 'cust_svc', { 'pkgnum' => $self->pkgnum } ); + 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 @@ -445,6 +794,249 @@ sub cust_main { 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 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 { + svcnum => $cust_svc->svcnum, + svcpart => $cust_svc->svcpart, + 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 { + svcnum => $cust_svc->svcnum, + svcpart => $change_svcpart, + 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 SUBROUTINES @@ -471,61 +1063,11 @@ newly-created cust_pkg objects. =cut sub order { - my($custnum, $pkgparts, $remove_pkgnums, $return_cust_pkg) = @_; - $remove_pkgnums = [] unless defined($remove_pkgnums); + my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg) = @_; - my $oldAutoCommit = $FS::UID::AutoCommit; - local $FS::UID::AutoCommit = 0; - my $dbh = dbh; + my $conf = new FS::Conf; - # 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::Record - # objects (table eq 'cust_svc') - my($pkgnum); - foreach $pkgnum ( @{$remove_pkgnums} ) { - my($cust_svc); - foreach $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 - my($pkgpart); - foreach $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 }) - ]; - } - - #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. - + # Transactionize this whole mess local $SIG{HUP} = 'IGNORE'; local $SIG{INT} = 'IGNORE'; local $SIG{QUIT} = 'IGNORE'; @@ -533,63 +1075,74 @@ sub order { local $SIG{TSTP} = 'IGNORE'; local $SIG{PIPE} = 'IGNORE'; - #first cancel old packages -# my($pkgnum); - foreach $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 ) { + 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 $change = scalar(@$remove_pkgnum) != 0; + + # Create the new packages. + foreach my $pkgpart (@$pkgparts) { + my $cust_pkg = new FS::cust_pkg { custnum => $custnum, + pkgpart => $pkgpart }; + $error = $cust_pkg->insert( 'change' => $change ); + if ($error) { $dbh->rollback if $oldAutoCommit; - return "Couldn't update package $pkgnum: $error"; + return $error; } + push @$return_cust_pkg, $cust_pkg; } - - #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"; + # $return_cust_pkg now contains refs to all of the newly + # created packages. + + # Transfer services and cancel old packages. + foreach my $old_pkgnum (@$remove_pkgnum) { + my $old_pkg = qsearchs ('cust_pkg', { pkgnum => $old_pkgnum }); + + 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; + } } - 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 ); - my($error)=$new->replace($cust_svc); - if ( $error ) { - $dbh->rollback if $oldAutoCommit; - return "Couldn't link old service to new package: $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; + if ($error) { + $dbh->rollback; + return $error; + } + } $dbh->commit or die $dbh->errstr if $oldAutoCommit; - - ''; #no errors + ''; } =back -=head1 VERSION - -$Id: cust_pkg.pm,v 1.11 2001-10-15 14:58:03 ivan Exp $ - =head1 BUGS sub order is not OO. Perhaps it should be moved to FS::cust_main and made so? @@ -599,11 +1152,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_acct_sm, and FS::svc_domain 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 ?