#
# Forks::Super::LazyEval - bg_eval, bg_qx implementations
#
package Forks::Super::LazyEval;
use Forks::Super::Config qw(:all);
use Exporter;
use Carp;
use strict;
use warnings;
our @ISA = qw(Exporter);
our @EXPORT = qw(bg_eval bg_qx BG_EVAL BG_QX);
our $VERSION = '0.72';
use constant BG_EVAL => 'Forks::Super::bg_eval';
use constant BG_QX => 'Forks::Super::bg_qx';
sub _choose_protocol {
if (CONFIG_module('YAML')) {
return 'YAML';
}
if (CONFIG_module('JSON')) {
return $JSON::VERSION >= 2.0 ? 'JSON2' : 'JSON1';
}
if (CONFIG_module('YAML::Tiny')) {
return 'YAML::Tiny';
}
if (CONFIG_module('Data::Dumper')) {
return 'Data::Dumper';
}
return;
}
sub _options {
my (@options) = @_;
my %options = ();
if (@options > 0) {
if (ref($options[0]) eq 'HASH') {
%options = %{$options[0]};
} else {
%options = @options;
}
}
return %options;
}
sub bg_eval (&;@) {
my ($code, @other_options) = @_;
my $proto = _choose_protocol();
if (!defined $proto) {
croak "Forks::Super: bg_eval call requires either YAML or JSON\n";
}
my %other_options = _options(@other_options);
if (defined($other_options{daemon}) && $other_options{daemon}) {
croak 'Forks::Super::bg_eval: ',
'daemon option not allowed on bg_eval call';
}
my $p = $$;
my $result;
if ($other_options{wantarray}) {
require Forks::Super::LazyEval::BackgroundArray;
$result = Forks::Super::LazyEval::BackgroundArray->new(
'eval', $code,
protocol => $proto,
%other_options);
} else {
require Forks::Super::LazyEval::BackgroundScalar;
$result = Forks::Super::LazyEval::BackgroundScalar->new(
'eval', $code,
protocol => $proto,
%other_options);
if ($$ != $p) {
# a WTF observed on Windows
croak 'Forks::Super::bg_eval: ',
"Inconsistency in process IDs: $p changed to $$!\n";
}
}
return $result;
}
sub bg_qx {
my ($command, @other_options) = @_;
my %other_options = _options(@other_options);
if (defined($other_options{daemon}) && $other_options{daemon}) {
croak 'Forks::Super::bg_qx: daemon option not allowed on bg_qx call';
}
my $p = $$;
my (@result, $result);
require Forks::Super::LazyEval::BackgroundScalar;
$result = Forks::Super::LazyEval::BackgroundScalar->new(
'qx', $command, %other_options);
if ($$ != $p) {
# a WTF observed on Windows
croak 'Forks::Super::bg_qx: ',
"Inconsistency in process IDs: $p changed to $$!\n";
}
return $result;
}
# tied class definitions for
# tie $@%result, 'Forks::Super::bg_XXX', ... statements
{
package Forks::Super::bg_eval;
sub TIESCALAR ($&;@) {
my ($pkg,$code,@other_options) = @_;
my $result = &Forks::Super::LazyEval::bg_eval($code,
@other_options);
my $self = { result => $result };
bless $self, $pkg;
}
sub TIEARRAY ($&;@) {
my ($pkg,$code,@other_options) = @_;
my %options = Forks::Super::LazyEval::_options(@other_options);
$options{wantarray} = 1;
my $result = &Forks::Super::LazyEval::bg_eval($code, %options);
my $self = { result => $result, is_array => 1 };
bless $self, $pkg;
}
sub TIEHASH ($&;@) {
my ($pkg,$code,@other_options) = @_;
my %options = Forks::Super::LazyEval::_options(@other_options);
$options{wantarray} = 2;
my $result = &Forks::Super::LazyEval::bg_eval($code, %options);
my $self = { result => $result, is_hash => 1 };
bless $self, $pkg;
}
sub FETCH {
my $this = shift;
if ($this->{is_array}) {
my $index = shift;
return $this->array->[$index];
} elsif ($this->{hash}) {
my $key = shift;
return $this->hash->{$key};
} elsif (exists $this->{value}) {
return $this->{value};
} else {
return $this->{value} = $this->{result}->_fetch;
}
}
sub STORE {
my $this = shift;
if ($this->{is_array}) {
my ($index,$value) = @_;
my $old = $this->array->[$index];
$this->{array}[$index] = $value;
return $old;
} elsif ($this->{is_hash}) {
my ($key,$value) = @_;
my $old = $this->hash->{$key};
$this->{hash}{$key} = $value;
return $old;
} else {
my $value = shift;
my $old = $this->FETCH;
$this->{value} = $value;
return $old;
}
}
sub FETCHSIZE {
my $this = shift;
return scalar @{$this->array};
}
sub STORESIZE {
my ($this,$count) = @_;
my $array = $this->array;
if (@$array < $count) {
push @$array, (undef) x (@$array-$count);
} else {
pop @$array while @$array > $count;
}
}
sub EXTEND {
my ($this,$count) = @_;
$this->STORESIZE($count);
}
sub EXISTS {
my ($this,$index) = @_;
if ($this->{is_array}) {
return defined $this->array->[$index];
} elsif ($this->{is_hash}) {
return exists $this->hash->{$index};
}
}
sub FIRSTKEY {
my $this = shift;
my $hash = $this->hash;
() = keys %$hash;
each %$hash;
}
sub SCALAR {
my $this = shift;
if ($this->{is_array}) {
return $this->FETCHSIZE;
} elsif ($this->{is_hash}) {
my $hash = $this->hash;
return scalar %$hash;
}
}
sub NEXTKEY {
my ($this, $last) = @_;
my $hash = $this->hash;
each %$hash;
}
sub DELETE {
my $this = shift;
if ($this->{is_array}) {
my $index = shift;
undef $this->array->[$index];
} elsif ($this->{is_hash}) {
my $key = shift;
delete $this->hash->{$key};
}
}
sub CLEAR {
my $this = shift;
if ($this->{is_array}) {
$this->{array} = [];
} elsif ($this->{is_hash}) {
$this->{hash} = {};
}
}
sub PUSH {
my ($this,@list) = @_;
my $array = $this->array;
return push @$array, @list;
}
sub POP {
my $this = shift;
my $array = $this->array;
return pop @$array;
}
sub SHIFT {
my $this = shift;
my $array = $this->array;
return shift @$array;
}
sub UNSHIFT {
my ($this, @list) = @_;
my $array = $this->array;
unshift @$array, @list;
}
sub SPLICE {
my ($this, $offset, $length, @list) = @_;
$offset ||= 0;
$length ||= $this->FETCHSIZE - $offset;
my $array = $this->array;
return splice @$array, $offset, $length, @list;
}
sub array {
my $this = shift;
if (!$this->{array}) {
$this->{array} = [ $this->{result}->_fetch ];
}
$this->{array};
}
sub hash {
my $this = shift;
if (!$this->{hash}) {
$this->{hash} = { $this->{result}->_fetch };
}
$this->{hash};
}
sub _fetch {
my $this = shift;
return $this->{result}->_fetch;
}
}
{
package Forks::Super::bg_qx;
our @ISA = qw(Forks::Super::bg_eval);
sub TIESCALAR {
my ($pkg,$command,@other_options) = @_;
my $result = Forks::Super::LazyEval::bg_qx $command, @other_options;
my $self = { result => $result };
bless $self, $pkg;
}
sub TIEARRAY {
my ($pkg,$command,@other_options) = @_;
my $result = Forks::Super::LazyEval::bg_qx $command, @other_options;
my $self = { result => $result, is_array => 1 };
bless $self, $pkg;
}
sub TIEHASH {
my ($pkg,$command,@other_options) = @_;
my $result = Forks::Super::LazyEval::bg_qx $command, @other_options;
my $self = { result => $result, is_hash => 1 };
bless $self, $pkg;
}
sub array {
my $this = shift;
if (!$this->{array}) {
my $eol = quotemeta($/);
$this->{array} = [ split m{(?<=$eol)}, $this->{result}->_fetch ];
}
$this->{array};
}
sub hash {
my $this = shift;
if (!$this->{hash}) {
my $eol = quotemeta($/);
$this->{hash} = { split m{(?<=$eol)}, $this->{result}->_fetch };
}
$this->{hash};
}
}
1;
=head1 NAME
Forks::Super::LazyEval
=head1 VERSION
0.72
=head1 DESCRIPTION
Implementation of L<Forks::Super::bg_qx|Forks::Super/bg_qx>
and L<Forks::Super::bg_eval|Forks::Super/bg_eval> functions,
and C<Forks::Super::bg_qx> and C<Forks::Super::bg_eval> tied
classes for retrieving results of external commands and
Perl subroutines executed in background processes.
See L<Forks::Super|Forks::Super> for details.
=head1 AUTHOR
Marty O'Brien, E<lt>mob@cpan.orgE<gt>
=head1 LICENSE AND COPYRIGHT
Copyright (c) 2010-2013, Marty O'Brien.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.8 or,
at your option, any later version of Perl 5 you may have available.
See http://dev.perl.org/licenses/ for more information.
=cut