diff options
Diffstat (limited to 'FS/FS/cust_pkg.pm')
-rw-r--r-- | FS/FS/cust_pkg.pm | 997 |
1 files changed, 997 insertions, 0 deletions
diff --git a/FS/FS/cust_pkg.pm b/FS/FS/cust_pkg.pm new file mode 100644 index 000000000..3bce653b5 --- /dev/null +++ b/FS/FS/cust_pkg.pm @@ -0,0 +1,997 @@ +package FS::cust_pkg; + +use strict; +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; + +# 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_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 + +=head1 SYNOPSIS + + use FS::cust_pkg; + + $record = new FS::cust_pkg \%hash; + $record = new FS::cust_pkg { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + + $error = $record->cancel; + + $error = $record->suspend; + + $error = $record->unsuspend; + + $part_pkg = $record->part_pkg; + + @labels = $record->labels; + + $seconds = $record->seconds_since($timestamp); + + $error = FS::cust_pkg::order( $custnum, \@pkgparts ); + $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] ); + +=head1 DESCRIPTION + +An FS::cust_pkg object represents a customer billing item. FS::cust_pkg +inherits from FS::Record. The following fields are currently supported: + +=over 4 + +=item pkgnum - primary key (assigned automatically for new billing items) + +=item custnum - Customer (see L<FS::cust_main>) + +=item pkgpart - Billing item definition (see L<FS::part_pkg>) + +=item setup - date + +=item bill - date (next bill date) + +=item last_bill - last bill date + +=item susp - date + +=item expire - date + +=item cancel - date + +=item otaker - order taker (assigned automatically if null, see L<FS::UID>) + +=item manual_flag - If this field is set to 1, disables the automatic +unsuspension of this package when using the B<unsuspendauto> config file. + +=back + +Note: setup, bill, susp, expire and cancel are specified as UNIX timestamps; +see L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for +conversion functions. + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Create a new billing item. To add the item to the database, see L<"insert">. + +=cut + +sub table { 'cust_pkg'; } + +=item insert + +Adds this billing item to the database ("Orders" the item). If there is an +error, returns the error, otherwise returns false. + +=cut + +sub insert { + my $self = shift; + + # 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 $error = $self->ut_number('custnum'); + return $error if $error; + + my $cust_main = $self->cust_main; + return "Unknown custnum: ". $self->custnum unless $cust_main; + + unless ( $disable_agentcheck ) { + 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; + +} + +=item delete + +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!"; +#} + +=item replace OLD_RECORD + +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. + +Changing pkgpart may have disasterous effects. See the order subroutine. + +setup and bill are normally updated by calling the bill method of a customer +object (see L<FS::cust_main>). + +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). + +=cut + +sub replace { + my( $new, $old ) = ( shift, shift ); + + #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart; + return "Can't change otaker!" if $old->otaker ne $new->otaker; + + #allow this *sigh* + #return "Can't change setup once it exists!" + # if $old->getfield('setup') && + # $old->getfield('setup') != $new->getfield('setup'); + + #some logic for bill, susp, cancel? + + $new->SUPER::replace($old); +} + +=item check + +Checks all fields to make sure this is a valid billing item. If there is an +error, returns the error, otherwise returns false. Called by the insert and +replace methods. + +=cut + +sub check { + my $self = shift; + + my $error = + $self->ut_numbern('pkgnum') + || $self->ut_numbern('custnum') + || $self->ut_number('pkgpart') + || $self->ut_numbern('setup') + || $self->ut_numbern('bill') + || $self->ut_numbern('susp') + || $self->ut_numbern('cancel') + ; + return $error if $error; + + if ( $self->custnum ) { + return "Unknown customer ". $self->custnum unless $self->cust_main; + } + + return "Unknown pkgpart: ". $self->pkgpart + unless qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } ); + + $self->otaker(getotaker) unless $self->otaker; + $self->otaker =~ /^([\w\.\-]{0,16})$/ or return "Illegal otaker"; + $self->otaker($1); + + if ( $self->dbdef_table->column('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); + } + + $self->SUPER::check; +} + +=item cancel [ OPTION => VALUE ... ] + +Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>) +in this package, then cancels the package itself (sets the cancel field to +now). + +Available options are: I<quiet> + +I<quiet> 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, %options ) = @_; + my $error; + + 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 %svc; + foreach my $cust_svc ( + qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) + ) { + push @{ $svc{$cust_svc->part_svc->svcdb} }, $cust_svc; + } + + foreach my $svcdb (@SVCDB_CANCEL_SEQ) { + foreach my $cust_svc (@{ $svc{$svcdb} }) { + my $error = $cust_svc->cancel; + + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "Error cancelling cust_svc: $error"; + } + } + } + + unless ( $self->getfield('cancel') ) { + my %hash = $self->hash; + $hash{'cancel'} = time; + my $new = new FS::cust_pkg ( \%hash ); + $error = $new->replace($self); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + } + + $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 + +Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this +package, then suspends the package itself (sets the susp field to now). + +If there is an error, returns the error, otherwise returns false. + +=cut + +sub suspend { + my $self = shift; + my $error ; + + 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 ( + qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) + ) { + my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } ); + + $part_svc->svcdb =~ /^([\w\-]+)$/ or do { + $dbh->rollback if $oldAutoCommit; + return "Illegal svcdb value in part_svc!"; + }; + my $svcdb = $1; + require "FS/$svcdb.pm"; + + my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } ); + if ($svc) { + $error = $svc->suspend; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + } + + } + + unless ( $self->getfield('susp') ) { + my %hash = $self->hash; + $hash{'susp'} = time; + my $new = new FS::cust_pkg ( \%hash ); + $error = $new->replace($self); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + + ''; #no errors +} + +=item unsuspend + +Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this +package, then unsuspends the package itself (clears the susp field). + +If there is an error, returns the error, otherwise returns false. + +=cut + +sub unsuspend { + my $self = shift; + my($error); + + 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 ( + qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } ) + ) { + my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } ); + + $part_svc->svcdb =~ /^([\w\-]+)$/ or do { + $dbh->rollback if $oldAutoCommit; + return "Illegal svcdb value in part_svc!"; + }; + my $svcdb = $1; + require "FS/$svcdb.pm"; + + my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } ); + if ($svc) { + $error = $svc->unsuspend; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + } + + } + + 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 ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + + ''; #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 +L<FS::part_pkg>). + +=cut + +sub part_pkg { + my $self = shift; + #exists( $self->{'_pkgpart'} ) + $self->{'_pkgpart'} + ? $self->{'_pkgpart'} + : qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } ); +} + +=item calc_setup + +Calls the I<calc_setup> 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<calc_recur> 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 cust_svc [ SVCPART ] + +Returns the services for this package, as FS::cust_svc objects (see +L<FS::cust_svc>). 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 { + 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, + ]; + } + qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ); + #} + +} + +=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<num_avail>, 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 + +Returns a list of lists, calling the label method for all services +(see L<FS::cust_svc>) of this billing item. + +=cut + +sub labels { + my $self = shift; + map { [ $_->label ] } $self->cust_svc; +} + +=item cust_main + +Returns the parent customer object (see L<FS::cust_main>). + +=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<FS::svc_acct>) in this +package have been online since TIMESTAMP, according to the session monitor. + +TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see +L<Time::Local> and L<Date::Parse> 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<FS::svc_acct>) 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<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> 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<FS::svc_acct>) +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<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> 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<svcpart> (not svcdb), unless the B<change_svcpart> 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<depend_jobnum> 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 + +=over 4 + +=item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ] ] + +CUSTNUM is a customer (see L<FS::cust_main>) + +PKGPARTS is a list of pkgparts specifying the the billing item definitions (see +L<FS::part_pkg>) 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<FS::cust_svc>) are moved to the +new billing items. An error is returned if this is not possible (see +L<FS::pkg_svc>). 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; + + # Create the new packages. + my $cust_pkg; + foreach (@$pkgparts) { + $cust_pkg = new FS::cust_pkg { custnum => $custnum, + pkgpart => $_ }; + $error = $cust_pkg->insert; + 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_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; + } + } + + 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; + ''; +} + +=back + +=head1 BUGS + +sub order is not OO. Perhaps it should be moved to FS::cust_main and made so? + +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, 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 ? + +=head1 SEE ALSO + +L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>, +L<FS::pkg_svc>, schema.html from the base documentation + +=cut + +1; + |