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 'refs';
  41   package Eval::WithLexicals::Cage;!;
  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     %{Eval::WithLexicals::Cage::grab_captures()}
  55   });
  56   @ret;
  57 }
  58
  59 sub _eval_do {
  60   my ($self, $text_ref) = @_;
  61   local @INC = (sub {
  62     if ($_[1] eq '/eval_do') {
  63       open my $fh, '<', $text_ref;
  64       $fh;
  65     } else {
  66       ();
  67     }
  68   }, @INC);
  69   do '/eval_do' or die "Error: $@\nCompiling: $$text_ref";
  70 }
  71
  72 {
  73   package Eval::WithLexicals::Util;
  74
  75   use B qw(svref_2object);
  76
  77   sub capture_list {
  78     my $pad_capture = \&Eval::WithLexicals::Cage::pad_capture;
  79     my @names = map $_->PV, grep $_->isa('B::PV'),
  80       svref_2object($pad_capture)->OUTSIDE->PADLIST->ARRAYelt(0)->ARRAY;
  81     $Eval::WithLexicals::current_code .=
  82       '+{ '.join(', ', map "'$_' => \\$_", @names).' };'
  83       ."\n}\n}\n1;\n";
  84   }
  85 }
  86
  87 1;