File Coverage

blib/lib/Devel/EvalContext.pm

Criterion	Covered	Total	%
statement	84	94	89.3
branch	11	18	61.1
condition	3	5	60.0
subroutine	13	15	86.6
pod	2	3	66.6
total	113	135	83.7

package Devel::EvalContext;

{ package main; sub Devel::EvalContext::_hygenic_eval { eval $_[0] } }

use strict;
use warnings;

use PadWalker qw(peek_sub);
use Carp;
use Data::Alias qw(alias);
use B ();

our $VERSION = "0.09";

our $TRACING = 0;

# public interface needs:
#
#   create an empty context
#   create an empty context from here (is this possible?)
#   clone a context
#   evaluate in a context and get new context
#   inspect hints and variables

# global vars allowing bits to talk without using closures or lexicals
our $_new_context;

sub _warn {
  warn @_ if $TRACING;
}
sub _warnblock {
  _warn "  | $_\n" for split /\n/, $_[0];
}
sub _warndump {
  require YAML;
  _warnblock(YAML::Dump($_[0]));
}

sub _magic_code {
  qq{
#line 1 "_magic_code"
    sub {
      $_[0]
#line 3 "_magic_code"
      eval \$_[0];
    }
  };
}

sub _save_context {
  my $evalcv = delete $_new_context->{evalcv};
  _warn "saving context for ", $evalcv->object_2svref, "\n";

  $_new_context->{saved}++; # this confirms that the code has been compiled

  # should I do my own pp version?
  my $v = peek_sub $evalcv->object_2svref;
  $_new_context->{vars} = {};
  while (my ($key, $val) = each %$v) {
    next if $key =~ /^.__repl_/;
    _warn "  processing: $key => $val\n";
    $_new_context->{vars}{$key} = $val;
  }

  # save hints
  # hrm I'm getting the wrong values
  $_new_context->{hints}->{'$^H'} = $^H & ~(256);
  $_new_context->{hints}->{'%^H'} = \%^H;
  $_new_context->{hints}->{'$^W'} = $^W;
  $_new_context->{hints}->{'${^WARNING_BITS}'} = ${^WARNING_BITS};
}

# New context
sub new { return bless \{}, $_[0] }

sub trace {
  my ($s, $t) = @_;
  if ($t) {
    $$s->{trace} = $t;
  }
  return $$s->{trace};
}

# Run a context
sub run {
  my ($cxt, $code) = @_;
  local $TRACING = $$cxt->{trace};
  _warn "+", ("-" x 71), "\n";
  _warn "context_eval: {", $code, "} using ", $cxt, "/", $$cxt, "\n";

  local $_new_context = undef;

  # I bet I could write a PP version of this using B
  my $recreate_context = qq[\n#line 1 ""\n];
  for my $var_name (qw($^H $^W ${^WARNING_BITS})) {
    my $val = $$cxt->{hints}{$var_name} || 0;
    $recreate_context .=
      qq[BEGIN { $var_name = $val; }\n];
  }
  $recreate_context .=
    q[BEGIN { %^H = %{$$cxt->{hints}{'%^H'} || {}}; }] . "\n";
  for my $var_name (keys %{$$cxt->{vars}}) {
    my $sigil = substr $var_name, 0, 1;
    $recreate_context .=
      qq[my $var_name; Data::Alias::alias $var_name = ] .
      qq[$sigil\{\$\$cxt->{vars}->{'$var_name'}};\n];
  }
  $recreate_context .= qq[package main;\n];
  $recreate_context .= q[
    BEGIN {
      local *^H = \do{my$x=$^H};
#      local *^H = {%^H};
      local *^W = \do{my$x=$^W};
      local *{^WARNING_BITS} = \do{my$x=${^WARNING_BITS}};
    }
  ] if 0;

  my $prologue = q[
#line 1 ""
    Devel::EvalContext::_save_context();
    BEGIN {
      $Devel::EvalContext::_new_context->{evalcv} =
        B::svref_2object(sub{})->OUTSIDE->OUTSIDE;
    }
  ];
  $prologue .= "{ no warnings; " .
    join(" ", map "$_;", keys %{$$cxt->{vars}}) . " }\n";

  # TODO: make this eval hygenic
  my $evaluator = eval do {
    my $m = _magic_code($recreate_context);
    _warn "magic_code:\n"; _warnblock $m;
    $m
  };
  if ($@) {
    croak "Devel::EvalContext::run: internal error: $@";
  }

  if ($TRACING) {
    require B::Deparse;
    _warn "evaluator:\n"; _warnblock(B::Deparse->new->coderef2text($evaluator));
  }

  $code = qq[$prologue\n#line 1 ""\n$code\n];
  _warn "code:\n"; _warnblock($code);

  my $user_retval = $evaluator->($code);
  my $user_error = $@;

  # A = $user_error
  # B = $_new_context->{saved}
  # 0  : we're screwed, compiled but not run, but no errors reported
  # A  : compile error, retval invalid, not run
  # B  : retval okay, compile & run ok
  # AB : runtime error, retval invalid, compile ok

  if ($_new_context->{saved}) {
    # frob it to make sure we keep the variables
    # This does the same thing as the variable mentioning in the prologue
    $_new_context->{vars} = {%{$$cxt->{vars}}, %{$_new_context->{vars}}};

    _warn "new context:\n";
    _warndump($_new_context);
  }

  $_new_context->{trace} = $TRACING;

  if (ref($user_error) or $user_error ne '') {
    if ($_new_context->{saved}) { # runtime error
      $$cxt = $_new_context;
      return ($user_error, undef);
    } else { # compile error
      die $user_error;
    }
    return;
  }
  # success below here

  # no error so we expect the save to have worked
  croak "Devel::EvalContext::run: internal error: not saved but no error"
    unless $_new_context->{saved};

  _warn "retval: ", $user_retval, "\n";

  $$cxt = $_new_context;
  return (undef, $user_retval);
}

1;

__END__