File Coverage

blib/lib/Process/Delegatable.pm

Criterion	Covered	Total	%
statement	58	61	95.0
branch	8	14	57.1
condition	1	3	33.3
subroutine	10	10	100.0
pod	1	1	100.0
total	78	89	87.6

package Process::Delegatable;

use 5.00503;
use strict;
use File::Temp        ();
use IPC::Run3         ();
use Probe::Perl       ();
use Storable          ();
use Process::Storable ();

use vars qw{$VERSION @ISA @PERLCMD};
BEGIN {
	$VERSION = '0.30';
	@ISA     = 'Process::Storable';

	# Contains the command to use to launch perl
	# Should be the path to the perl current running.
	# People with special needs should localise this
	# to add any flags.
	@PERLCMD = ( Probe::Perl->find_perl_interpreter );
}

sub delegate {
	my $self  = shift;
	my $class = ref($self);
	my @perl  = @_ ? @_ : @PERLCMD;

	# We always pass the object by file
	my ($stdin, $filein ) = File::Temp::tempfile();
	$self->serialize($stdin);
	close($stdin);

	# Dump the object to the input filehandle,
	# and recover it afterwards
	my ($stdout, $fileout) = File::Temp::tempfile();
	# my ($stderr, $fileerr) = File::Temp::tempfile();
	close($stdout);
	# close($stderr);

	# Generate the command
	#print STDERR "Process::Delegatable STDIN  $filein\n";
	#print STDERR "Process::Delegatable STDOUT $fileout\n";
	#print STDERR "Process::Delegatable STDERR $fileerr\n";
	my $cmd = [ @perl, '-MProcess::Launcher', '-e serialized', $class, $filein ];

	# Fire the command
	# print STDERR "# " . join(' ', @$cmd) . " < $filein > $fileout\n";
	my $ok = IPC::Run3::run3( $cmd, \undef, $fileout, \undef );
	if ( ! $ok or $? != 0 ) {
		# Failed
		$self->{errstr} = "Failed to execute delegated Process";
		# $self->{stderr} = $extras;
		return 1;
	}

	# Get the first line with content of the response, which will be an OK/FAIL
	local *STDOUT2;
	open( STDOUT2, $fileout ) or die "open($fileout): $!";
	# open( STDERR2, $fileerr ) or die "open($fileerr): $!";
	my $result;
#	my $extras;
	while ( 1 ) {
		$result = ;
		$result = "FAIL No output returned\n" unless defined $result;
		next unless $result =~ /\S/;
		$result =~ s/[\012\015]+\z//;
		last;
	}
	# while ( 1 ) {
		# $extras = ;
		# $extras = "FAIL No output returned\n" unless defined $extras;
		# next unless $extras =~ /\S/;
		# $extras =~ s/[\012\015]+\z//;
		# last;
	# }
	if ( $result eq 'OK' ) {
		# Looks good, deserialize the data
		my $complete = $class->deserialize( \*STDOUT2 );
		%$self = %$complete;

		# Clean up and return
		close( STDOUT2 );
		close( STDERR2 );
		return 1;
	} else {
		# Just clean up
		close( STDOUT2 );
		close( STDERR2 );
	}

	# Is it an error?
	if ( $result =~ s/^FAIL// ) {
		# Failed
		$self->{errstr} = $result;
		# $self->{stderr} = $extras;
		return 1;
	}

	# err...
	die "Unknown delegate response $result";
}

1;

__END__