File Coverage

blib/lib/Test/MultiProcess.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package Test::MultiProcess;

use strict;
use warnings;

use POSIX;
use Cache::FastMmap;

our @ISA = qw(Exporter);

our %EXPORT_TAGS = ( 'all' => [ qw(

) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(
	run_forked
);

our $VERSION = '0.01';

our $RESULT_CACHE_FILE = '/tmp/mu1tiproc.tmp';

our $children;
our %children;

$SIG{CHLD} = \&WAITER;
$SIG{INT}  = \&HUNTSMAN;
$SIG{ALRM} = sub { die "server timeout" };

sub run_forked {
    my %params = @_;
    my $code = $params{code};
    my $forks = $params{forks} || 1;

    my $cache = Cache::FastMmap->new( share_file => $RESULT_CACHE_FILE, expire_time => 0, unlink_on_exit => 0, init_file => 1 );

    for (1 .. $forks) {
        make_new_child($code);
    }

    for my $pid (keys %children) {
        while (waitpid($pid,0) != -1) {}
    }

    my $results = $cache->get('results');

    return $results;
}

sub WAITER {
    $SIG{CHLD} = \&WAITER;
    my $pid = wait;
    $children--;
    delete $children{$pid};
    #1 until (-1 == waitpid(-1, WNOHANG));
}

# SIGINT handler
sub HUNTSMAN {
    local($SIG{CHLD}) = 'IGNORE';
    kill 'INT' => keys %children;
    exit;
}

sub make_new_child {
    my $code = shift;

    my $pid;
    my $sigset;

    # block sig for fork
    $sigset = POSIX::SigSet->new(SIGINT);
    sigprocmask(SIG_BLOCK, $sigset) or die "Can't block SIGINT for fork: $!\n";
    die "fork: $!" unless defined ($pid = fork);

    if ($pid)
    {
        sigprocmask(SIG_UNBLOCK, $sigset) or die "Can't unblock SIGINT for fork: $!\n";
        $children{$pid} = 1;
        $children++;
        return;
    } else {
        $SIG{INT} = 'DEFAULT';
        sigprocmask(SIG_UNBLOCK, $sigset) or die "Can't unblock SIGINT for fork: $!\n";

        my $cachel = Cache::FastMmap->new( share_file => $RESULT_CACHE_FILE, expire_time => 0, unlink_on_exit => 0 );
        my $returned = &$code;
        $cachel->get_and_set('results', sub { ++${$_[1]}{$returned}; return $_[1]; });

        exit;
    }
}


1;
__END__