File Coverage

blib/lib/Parallel/Simple.pm

Criterion	Covered	Total	%
statement	12	60	20.0
branch	0	40	0.0
condition	0	6	0.0
subroutine	4	8	50.0
pod	4	4	100.0
total	20	118	16.9

package Parallel::Simple;

use strict;
use warnings;

use Exporter ();
use vars qw( $VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS );
$VERSION = '0.01';

@ISA       = qw( Exporter );
@EXPORT    = qw();
@EXPORT_OK = qw( prun );

my $error;
my $return_values;

sub err { $error         }
sub rv  { $return_values }

sub errplus {
    return unless ( defined $error );
    "$error\n" . ( ref($return_values) =~ /HASH/ ?
        join( '', map { "\t$_ => $return_values->{$_}\n" } sort keys %$return_values ) :
        join( '', map { "\t$_ => $return_values->[$_]\n" } 0..$#$return_values )
    );
}

sub prun {
    ( $error, $return_values ) = ( undef, undef );         # reset globals
    return 1 unless ( @_ );                                # return true if 0 args passed
    my %options = %{pop @_} if ( ref($_[-1]) =~ /HASH/ );  # grab options, if specified
    return 1 unless ( @_ );                                # return true if 0 code blocks passed

    # normalize named and unnamed blocks into similar structure to simplify main loop
    my $named  = ref($_[0]) ? 0 : 1;  # if first element is a subref, they're not named
    my $i      = 0;                   # used to turn array into hash with array-like keys
    my %blocks = $named ? @_ : map { $i++ => $_ } @_;

    # fork children
    my %child_registry;  # pid => { name => $name, return_value => $return_value }
    while ( my ( $name, $block ) = each %blocks ) {
        my $child = fork();
        unless ( defined $child ) {
            $error = "$!";
            last;  # something's wrong; stop trying to fork
        }
        if ( $child == 0 ) {  # child
            my ( $subref, @args ) = ref($block) =~ /ARRAY/ ? @$block : ( $block );
            my $return_value = eval { $subref->( @args ) };
            warn( $@ ) if ( $@ );  # print death message, because eval doesn't
            exit( $@ ? 255 : $options{use_return} ? $return_value : 0 );
        }
        $child_registry{$child} = { name => $name, return_value => undef };
    }

    # wait for children to finish
    my $successes = 0;
    my $child;
    do {
        $child = waitpid( -1, 0 );
        if ( $child > 0 and exists $child_registry{$child} ) {
            $child_registry{$child}{return_value} = $? unless ( defined $child_registry{$child}{return_value} );
            $successes++ if ( $? == 0 );
            if ( $? > 0 and $options{abort_on_error} ) {
                while ( my ( $pid, $child ) = each %child_registry ) {
                    unless ( defined $child->{return_value} ) {
                        kill( 9, $pid );
                        $child->{return_value} = -1;
                    }
                }
            }
        }
    } while ( $child > 0 );

    # store return values using appropriate data type
    $return_values = $named
        ? { map { $_->{name} => $_->{return_value} } values %child_registry }
        : [ map { $_->{return_value} } sort { $a->{name} <=> $b->{name} } values %child_registry ];

    my $num_blocks = keys %blocks;
    return 1 if ( $successes == $num_blocks );  # all good!

    $error = "only $successes of $num_blocks blocks completed successfully";
    return 0;  # sorry... better luck next time
}

1;

__END__