File Coverage

blib/lib/Child.pm

Criterion	Covered	Total	%
statement	64	64	100.0
branch	10	14	71.4
condition			n/a
subroutine	18	18	100.0
pod	6	9	66.6
total	98	105	93.3

package Child;
use 5.006;
use strict;
use warnings;
use Carp;
use Child::Util;
use Child::Link::Proc;
use Child::Link::Parent;

use Exporter 'import';

our $VERSION = "0.012";
our @PROCS;
our @EXPORT_OK = qw/child/;

add_accessors qw/code/;

sub child(&;@) {
    my ( $code, @params ) = @_;
    my $caller = caller;
    return __PACKAGE__->new( $code, @params )->start;
}

sub all_procs { @PROCS }

sub _clean_proc {
    my $class = shift;
    my ($proc) = @_;
    return unless $proc;
    return unless @PROCS;
    @PROCS = grep { $_ && $proc != $_ } @PROCS;
}

sub all_proc_pids {
    my $class = shift;
    map { $_->pid } $class->all_procs;
}

sub wait_all {
    my $class = shift;
    $_->wait() for $class->all_procs;
}

sub new {
    my ( $class, $code, $plugin, @data ) = @_;

    return bless( { _code => $code }, $class )
        unless $plugin;

    my $build = __PACKAGE__;
    $build .= '::IPC::' . ucfirst $plugin;

    eval "require $build; 1"
        || croak( "Could not load plugin '$plugin': $@" );

    return $build->new( $code, @data );
}

sub shared_data {}

sub child_class  { 'Child::Link::Proc'  }
sub parent_class { 'Child::Link::Parent' }

sub start {
    my $self = shift;
    my $ppid = $$;
    my @data = $self->shared_data;

    if ( my $pid = fork() ) {
        my $proc = $self->child_class->new( $pid, @data );
        push @PROCS => $proc;
        return $proc;
    }

    # In the child
    @PROCS = ();
    my $parent = $self->parent_class->new( $ppid, @data );
    my $code = $self->code;

    # Ensure the child code can't die and jump out of our control.
    eval { $code->( $parent ); 1; } || do {
        # Simulate die without dying.
        print STDERR $@;
        exit 255;
    };
    exit;
}

1;

__END__