File Coverage

blib/lib/Eval/Safe.pm

Criterion	Covered	Total	%
statement	49	98	50.0
branch	8	44	18.1
condition	3	5	60.0
subroutine	13	22	59.0
pod	7	7	100.0
total	80	176	45.4

package Eval::Safe;

use 5.022;
use strict;
use warnings;

use Carp;
use Eval::Safe::Eval;
use Eval::Safe::Safe;
use List::Util qw(none);
use Scalar::Util qw(reftype refaddr);

our $VERSION = '0.02';

sub new {
  my ($class, %options) = @_;
  croak "Eval::Safe->new called with invalid class name: $class" unless $class eq 'Eval::Safe';
  my @known_options = qw(safe strict warnings debug package force_package);
  my @unknown_options = grep {my $k = $_; none { $k eq $_ } @known_options } keys %options;
  if (@unknown_options) {
    croak "Unknown options: ".join(' ', @unknown_options);
  }
  $options{strict} = _make_pragma('strict', $options{strict});
  $options{warnings} = _make_pragma('warnings', $options{warnings});
  if ($options{package} and not $options{force_package}) {
    $options{package} = Eval::Safe::_validate_package_name($options{package});
    croak "Package $options{package} already exists" if eval "%$options{package}::";
  }
  if ($options{safe} // 0 > 0) {
    return Eval::Safe::Safe->new(%options);
  } else {
    return Eval::Safe::Eval->new(%options);
  }
}

sub package {
  my ($this) = @_;
  return $this->{package};
}

sub wrap {
  my ($this, $code) = @_;
  return $this->eval("sub { ${code} }");
}

sub share {
  my ($this, @vars) = @_;
  my $calling_package = caller;
  $this->share_from($calling_package, @vars);
}

sub share_from {
  my ($this, $package, @vars) = @_;
  $package = _validate_package_name($package);
  croak "Package $package does not exist" unless eval "%${package}::";
  for my $v (@vars) {
    croak "Variable has no leading sigil: $v" unless $v =~ m'^([&*$%@])(\w+)$';
    my ($sigil, $symbol) = ($1, $2);
    # There are only 5 different sigils, so we could skip the eval here and
    # instead branch on the $sigil and use a syntax like the one on the left of
    # the equal (e.g. \&{$package."::$symbol"}). See:
    # https://metacpan.org/source/MICB/Safe-b2/Safe.pm
    no strict 'refs';
    *{($this->package())."::${symbol}"} = eval "\\${sigil}${package}::${symbol}";
  }
}

sub var_ref {
  my ($this, $var) = @_;
  croak "Variable has no leading sigil: $var" unless $var =~ m'^([&*$%@])(\w+)$';
  # There are only 5 different sigils, so we could skip the eval here and
  # instead branch on the $sigil. See:
  # https://metacpan.org/source/MICB/Safe-b2/Safe.pm
  no strict 'refs';
  return eval sprintf '\%s%s::%s', $1, $this->package(), $2;
}

sub interpolate {
  my ($this, $str) = @_;
  # It's not clear if Text::Balanced could help here.
  my $r = $this->eval("<<\"EVAL_SAFE_EOF_WORD\"\n${str}\nEVAL_SAFE_EOF_WORD\n");
  $r =~ s/\n$//;
  return $r;
}

# _make_pragma('pragma', $arg)
# Returns a string saying "no pragma" if $arg is false, "use pragma" if arg is
# a `true` scalar, "use pragma $$arg" if arg is a scalar reference, and
# "use pragma @$arg" if arg is an array reference.
sub _make_pragma() {
  my ($pragma, $arg) = @_;
  my $reftype = reftype $arg;
  if (not defined $reftype) {
    if ($arg) {
      return "use ${pragma};";
    } else {
      return "no ${pragma};";
    }
  } elsif ($reftype eq 'SCALAR') {
    return "use ${pragma} '$arg';";
  } elsif ($reftype eq 'ARRAY') {
    # We should probably use Data::Dumper to format the arg list properly in
    # case some of the args contain a space.
    return ("use ${pragma} qw(".join(' ', @$arg).');');
  } elsif ($reftype eq 'HASH') {
    return ("use ${pragma} qw(".join(' ', %$arg).');');
  } else {
    croak "Invalid argument for '${pragma}' option, expected a scalar or array reference";
  }
}

# $safe->_wrap_code_refs('sub', @objects)
# will call $safe->sub($ref) for all code references found within @objects and
# store the result in place in @objects. The passed objects are crawled
# recursively.
# Finally, the modified array is returned.
#
# This is similar to the wrap_code_refs_within method in Safe.
sub _wrap_code_refs {
  my ($this, $wrapper) = splice @_, 0, 2;
  # We need to use @_ below (without giving it a new name) to retain its
  # aliasing property to modify the arguments in-place.
  my %seen_refs = ();
  my $crawler = sub {
    for my $item (@_) {
      my $reftype = reftype $item;
      next unless $reftype;
      next if ++$seen_refs{refaddr $item} > 1;
      if ($reftype eq 'ARRAY') {
          __SUB__->(@$item);  # __SUB__ is the current sub.
      } elsif ($reftype eq 'HASH') {
          __SUB__->(values %$item);
      } elsif ($reftype eq 'CODE') {
          $item = $this->$wrapper($item);
      }
      # We're ignoring the GLOBs for the time being.
    }
  };
  $crawler->(@_);
  if (defined wantarray) {
    return (wantarray) ? @_ : $_[0];
  }
  return;
}

# _validate_package_name('package::name')
# Croaks (dies) if the given package name does not look like a package name.
# Otherwise returns a cleaned form of the package name (trailing '::' are
# removed, and '' or '::' is made into 'main').
sub _validate_package_name {
  my ($p) = @_;
  $p =~ s/::$//;
  $p = 'main' if $p eq '';
  croak "${p} does not look like a package name" unless $p =~ m/^\w+(::\w+)*$/;
  return $p;
}

1;

__DATA__