view release on metacpan or  search on metacpan

lib/Forks/Super/LazyEval/BackgroundArray.pm  view on Meta::CPAN

#
# Forks::Super::LazyEval::BackgroundArray - lazy evaluation of a perl
#    expression in list context
#

package Forks::Super::LazyEval::BackgroundArray;
use Forks::Super;
use Forks::Super::Wait 'WREAP_BG_OK';
use Carp;
use strict;
use warnings;

our $VERSION = '0.97';

# "protocols" for serializing data and the methods used
# to carry out the serialization

my %serialization_dispatch = (

    YAML => {
	require => sub { require YAML },
	encode => sub { return YAML::Dump( \@_ ) },
	decode => sub { return YAML::Load($_[0]) }
    },

    'Data::Dumper' => {
	require => sub { require Data::Dumper },
	encode => sub { return Data::Dumper::Dumper( \@_ ) },
	decode => sub {
	    my ($data,$job,$VAR1) = @_;
            if ($job->{untaint}) {
                ($data) = $data =~ /(.*)/s;
            } elsif (${^TAINT}) {
                carp 'Forks::Super::bg_eval/bg_qx(): ',
		        'Using Data::Dumper for serialization, which cannot ',
		        "operate on 'tainted' data. Use bg_eval {...} ",
		        '{untaint => 1} or bg_qx COMMAND, ',
		        "{untaint => 1} to retrieve the result.\n";
                return;
	    }
	    my $decoded = eval "$data";    ## no critic (StringyEval)
	    return $decoded;
	}
    },

    );

# an array that is evaluated in a child process.
# the first time an element of the array is dereferenced,
# retrieve the output from the child,
# waiting for the child to finish if necessary

sub new {
    my ($class, $style, $command_or_code, %other_options) = @_;
    my $self = { value_set => 0, value => undef, style => $style };
    if ($style eq 'eval') {
	my $protocol = $other_options{'protocol'};
	$self->{code} = $command_or_code;
	$self->{job_id} = Forks::Super::fork {
	    (%other_options,
	     child_fh => 'out',
	     sub => sub {
		 my @result = $command_or_code->();
		 print STDOUT _encode($protocol, @result);
	     }, 
	     _is_bg => 2, 
	     _lazy_proto => $protocol )
	};

    } elsif ($style eq 'qx') {
	croak "Always use F::S::LazyEval::BackgroundScalar with bg_qx\n";
    }
    $self->{job} = Forks::Super::Job::get($self->{job_id});
    ($Forks::Super::LAST_JOB, $Forks::Super::LAST_JOB_ID)
	= ($self->{job}, $self->{job_id});
    $self->{value} = [];
    return bless $self, $class;
}

sub _encode {
    my ($protocol, @data) = @_;
    if (defined $serialization_dispatch{$protocol}) {
	$serialization_dispatch{$protocol}{'require'}->();
	return $serialization_dispatch{$protocol}{encode}->(@data);
    } else {
	croak 'Forks::Super::LazyEval::BackgroundScalar: ',
	    'YAML or Data::Dumper required to use bg_eval';
    }
}

sub _decode {
    my ($protocol, $data, $job) = @_;
    if (defined $serialization_dispatch{$protocol}) {
	$serialization_dispatch{$protocol}{require}->();
	return $serialization_dispatch{$protocol}{decode}->($data,$job);
    } else {
	croak 'Forks::Super::LazyEval::BackgroundScalar: ',
	    'YAML or Data::Dumper required to use bg_eval';
    }
}

sub _fetch {