lib/Eval/WithLexicals.pm

   1 package Eval::WithLexicals;
   2
   3 use Moo;
   4 use Sub::Quote;
   5
   6 has lexicals => (is => 'rw', default => quote_sub q{ {} });
   7
   8 {
   9   my %valid_contexts = map +($_ => 1), qw(list scalar void);
  10
  11   has context => (
  12     is => 'rw', default => quote_sub(q{ 'list' }),
  13     isa => sub {
  14       my ($val) = @_;
  15       die "Invalid context type $val - should be list, scalar or void"
  16         unless $valid_contexts{$val};
  17     },
  18   );
  19 }
  20
  21 has in_package => (
  22   is => 'rw', default => quote_sub q{ 'Eval::WithLexicals::Scratchpad' }
  23 );
  24
  25 sub eval {
  26   my ($self, $to_eval) = @_;
  27   local *Eval::WithLexicals::Cage::current_line;
  28   local *Eval::WithLexicals::Cage::pad_capture;
  29   local *Eval::WithLexicals::Cage::grab_captures;
  30   my $setup = Sub::Quote::capture_unroll('$_[2]', $self->lexicals, 2);
  31   my $package = $self->in_package;
  32   local our $current_code = qq!use strictures 1;
  33 ${setup}
  34 sub Eval::WithLexicals::Cage::current_line {
  35 package ${package};
  36 ${to_eval}
  37 ;sub Eval::WithLexicals::Cage::pad_capture { }
  38 BEGIN { Eval::WithLexicals::Util::capture_list() }
  39 sub Eval::WithLexicals::Cage::grab_captures {
  40   no warnings 'closure'; no strict 'vars';
  41   package Eval::WithLexicals::VarScope;!;
  42   $self->_eval_do(\$current_code, $self->lexicals);
  43   my @ret;
  44   my $ctx = $self->context;
  45   if ($ctx eq 'list') {
  46     @ret = Eval::WithLexicals::Cage::current_line();
  47   } elsif ($ctx eq 'scalar') {
  48     $ret[0] = Eval::WithLexicals::Cage::current_line();
  49   } else {
  50     Eval::WithLexicals::Cage::current_line();
  51   }
  52   $self->lexicals({
  53     %{$self->lexicals},
  54     %{$self->_grab_captures},
  55   });
  56   @ret;
  57 }
  58
  59 sub _grab_captures {
  60   my ($self) = @_;
  61   my $cap = Eval::WithLexicals::Cage::grab_captures();
  62   foreach my $key (keys %$cap) {
  63     my ($sigil, $name) = $key =~ /^(.)(.+)$/;
  64     my $var_scope_name = $sigil.'Eval::WithLexicals::VarScope::'.$name;
  65     if ($cap->{$key} eq eval "\\${var_scope_name}") {
  66       delete $cap->{$key};
  67     }
  68   }
  69   $cap;
  70 }
  71
  72 sub _eval_do {
  73   my ($self, $text_ref) = @_;
  74   local @INC = (sub {
  75     if ($_[1] eq '/eval_do') {
  76       open my $fh, '<', $text_ref;
  77       $fh;
  78     } else {
  79       ();
  80     }
  81   }, @INC);
  82   do '/eval_do' or die "Error: $@\nCompiling: $$text_ref";
  83 }
  84
  85 {
  86   package Eval::WithLexicals::Util;
  87
  88   use B qw(svref_2object);
  89
  90   sub capture_list {
  91     my $pad_capture = \&Eval::WithLexicals::Cage::pad_capture;
  92     my @names = map $_->PV, grep $_->isa('B::PV'),
  93       svref_2object($pad_capture)->OUTSIDE->PADLIST->ARRAYelt(0)->ARRAY;
  94     $Eval::WithLexicals::current_code .=
  95       '+{ '.join(', ', map "'$_' => \\$_", @names).' };'
  96       ."\n}\n}\n1;\n";
  97   }
  98 }
  99
 100 1;