File Coverage

blib/lib/IO/Lambda/Fork.pm

Criterion	Covered	Total	%
statement	82	104	78.8
branch	18	50	36.0
condition	1	3	33.3
subroutine	16	19	84.2
pod	4	4	100.0
total	121	180	67.2

# $Id: Fork.pm,v 1.12 2010/02/09 08:40:41 dk Exp $

package IO::Lambda::Fork;

use base qw(IO::Lambda);

our $DEBUG = $IO::Lambda::DEBUG{fork} || 0;

use strict;
use warnings;
use Exporter;
use Socket;
use POSIX;
use Storable qw(thaw freeze);
use IO::Handle;
use IO::Lambda qw(:all :dev);
use IO::Lambda::Signal qw(pid);

our @ISA = qw(Exporter);
our @EXPORT_OK = qw(new_process process new_forked forked);
our %EXPORT_TAGS = (all => \@EXPORT_OK);

sub _d { "forked(" . _o($_[0]) . ")" }

# return pid and socket
sub new_process(&)
{
	my $cb = shift;

	my $r = IO::Handle-> new;
	my $w = IO::Handle-> new;
	socketpair( $r, $w, AF_UNIX, SOCK_STREAM, PF_UNSPEC);
	$w-> blocking(0);

	my $pid = fork;
	unless ( defined $pid) {
		warn "fork() failed:$!\n" if $DEBUG;
		close($w);
		close($r);
		return ( undef, $! );
	}

	if ( $pid == 0) {
		close($w);
		warn "process($$) started\n" if $DEBUG;
		eval { $cb-> ($r) if $cb; };
		warn "process($$) ended\n" if $DEBUG;
		warn $@ if $@;
		close($r);
		POSIX::exit($@ ? 1 : 0);
	}

	warn "forked pid=$pid\n" if $DEBUG;

	close($r);

	return ($pid, $w);
}

# simple fork, return only $? and $!
sub process(&)
{
	my $cb = shift;

	lambda {
		my $pid = fork;
		return undef, $! unless defined $pid;
		unless ( $pid) {
			warn "process($$) started\n" if $DEBUG;
			eval { $cb->(); };
			warn "process($$) ended\n" if $DEBUG;
			warn $@ if $@;
			POSIX::exit($@ ? 1 : 0);
		}

		warn "forked pid=$pid\n" if $DEBUG;
		context $pid;
		&pid();
	}

}

# return output from a subprocess
sub new_forked(&)
{
	my $cb = shift;

	my ( $pid, $r) = new_process {
		my @ret;
		my $socket = shift;
		eval { @ret = $cb-> () if $cb };
		my $msg = $@ ? [ 0, $@ ] : [ 1, @ret ];
		warn "process($$) ended: [@$msg]\n" if $DEBUG > 1;
		print $socket freeze($msg);
	};

	lambda {
		return undef, undef, $r unless defined $pid;

		my $buf = '';
		context readbuf, $r, \ $buf, undef;
	tail {
		my ( $ok, $error) = @_;
		my @ret;

		($ok,$error) = (0,$!) unless close($r);

		unless ( $ok) {
			@ret = ( undef, $error);
		} else {
			my $msg;
			eval { $msg = thaw $buf };
			unless ( $msg and ref($msg) and ref($msg) eq 'ARRAY') {
				@ret = ( undef, $@);
			} elsif ( 0 == shift @$msg) {
				@ret = ( undef, @$msg);
			} else {
				@ret = ( 1, @$msg);
			}
		}

		context $pid;
	pid {
		warn "pid($pid): exitcode=$?, [@ret]\n" if $DEBUG > 1;
		return shift, @ret;
	}}}
}

# simpler version of new_forked
sub forked(&)
{
	my $cb = shift;
	lambda {
		context &new_forked($cb);
	tail {
		my ( $pid, $ok, @ret) = @_;
		return @ret;
	}}
}

1;

__DATA__