lib/Eval/WithLexicals.pm

   1 package Eval::WithLexicals;
   2
   3 use Moo;
   4 use Sub::Quote;
   5
   6 our $VERSION = '1.000000'; # 1.0.0
   7 $VERSION = eval $VERSION;
   8
   9 has lexicals => (is => 'rw', default => quote_sub q{ {} });
  10
  11 {
  12   my %valid_contexts = map +($_ => 1), qw(list scalar void);
  13
  14   has context => (
  15     is => 'rw', default => quote_sub(q{ 'list' }),
  16     isa => sub {
  17       my ($val) = @_;
  18       die "Invalid context type $val - should be list, scalar or void"
  19         unless $valid_contexts{$val};
  20     },
  21   );
  22 }
  23
  24 has in_package => (
  25   is => 'rw', default => quote_sub q{ 'Eval::WithLexicals::Scratchpad' }
  26 );
  27
  28 sub eval {
  29   my ($self, $to_eval) = @_;
  30   local *Eval::WithLexicals::Cage::current_line;
  31   local *Eval::WithLexicals::Cage::pad_capture;
  32   local *Eval::WithLexicals::Cage::grab_captures;
  33   my $setup = Sub::Quote::capture_unroll('$_[2]', $self->lexicals, 2);
  34   my $package = $self->in_package;
  35   local our $current_code = qq!use strictures 1;
  36 ${setup}
  37 sub Eval::WithLexicals::Cage::current_line {
  38 package ${package};
  39 #line 1 "(eval)"
  40 ${to_eval}
  41 ;sub Eval::WithLexicals::Cage::pad_capture { }
  42 BEGIN { Eval::WithLexicals::Util::capture_list() }
  43 sub Eval::WithLexicals::Cage::grab_captures {
  44   no warnings 'closure'; no strict 'vars';
  45   package Eval::WithLexicals::VarScope;!;
  46   $self->_eval_do(\$current_code, $self->lexicals, $to_eval);
  47   my @ret;
  48   my $ctx = $self->context;
  49   if ($ctx eq 'list') {
  50     @ret = Eval::WithLexicals::Cage::current_line();
  51   } elsif ($ctx eq 'scalar') {
  52     $ret[0] = Eval::WithLexicals::Cage::current_line();
  53   } else {
  54     Eval::WithLexicals::Cage::current_line();
  55   }
  56   $self->lexicals({
  57     %{$self->lexicals},
  58     %{$self->_grab_captures},
  59   });
  60   @ret;
  61 }
  62
  63 sub _grab_captures {
  64   my ($self) = @_;
  65   my $cap = Eval::WithLexicals::Cage::grab_captures();
  66   foreach my $key (keys %$cap) {
  67     my ($sigil, $name) = $key =~ /^(.)(.+)$/;
  68     my $var_scope_name = $sigil.'Eval::WithLexicals::VarScope::'.$name;
  69     if ($cap->{$key} eq eval "\\${var_scope_name}") {
  70       delete $cap->{$key};
  71     }
  72   }
  73   $cap;
  74 }
  75
  76 sub _eval_do {
  77   my ($self, $text_ref, $lexicals, $original) = @_;
  78   local @INC = (sub {
  79     if ($_[1] eq '/eval_do') {
  80       open my $fh, '<', $text_ref;
  81       $fh;
  82     } else {
  83       ();
  84     }
  85   }, @INC);
  86   do '/eval_do' or die $@;
  87 }
  88
  89 {
  90   package Eval::WithLexicals::Util;
  91
  92   use B qw(svref_2object);
  93
  94   sub capture_list {
  95     my $pad_capture = \&Eval::WithLexicals::Cage::pad_capture;
  96     my @names = grep $_ ne '&', map $_->PV, grep $_->isa('B::PV'),
  97       svref_2object($pad_capture)->OUTSIDE->PADLIST->ARRAYelt(0)->ARRAY;
  98     $Eval::WithLexicals::current_code .=
  99       '+{ '.join(', ', map "'$_' => \\$_", @names).' };'
 100       ."\n}\n}\n1;\n";
 101   }
 102 }
 103
 104 =head1 NAME
 105
 106 Eval::WithLexicals - pure perl eval with persistent lexical variables
 107
 108 =head1 SYNOPSIS
 109
 110   # file: bin/tinyrepl
 111
 112   #!/usr/bin/env perl
 113
 114   use strictures 1;
 115   use Eval::WithLexicals;
 116   use Term::ReadLine;
 117   use Data::Dumper;
 118
 119   $SIG{INT} = sub { warn "SIGINT\n" };
 120
 121   { package Data::Dumper; no strict 'vars';
 122     $Terse = $Indent = $Useqq = $Deparse = $Sortkeys = 1;
 123     $Quotekeys = 0;
 124   }
 125
 126   my $eval = Eval::WithLexicals->new;
 127   my $read = Term::ReadLine->new('Perl REPL');
 128   while (1) {
 129     my $line = $read->readline('re.pl$ ');
 130     exit unless defined $line;
 131     my @ret; eval {
 132       local $SIG{INT} = sub { die "Caught SIGINT" };
 133       @ret = $eval->eval($line); 1;
 134     } or @ret = ("Error!", $@);
 135     print Dumper @ret;
 136   }
 137
 138   # shell session:
 139
 140   $ perl -Ilib bin/tinyrepl
 141   re.pl$ my $x = 0;
 142   0
 143   re.pl$ ++$x;
 144   1
 145   re.pl$ $x + 3;
 146   4
 147   re.pl$ ^D
 148   $
 149
 150 =head1 METHODS
 151
 152 =head2 new
 153
 154   my $eval = Eval::WithLexicals->new(
 155     lexicals => { '$x' => \1 },      # default {}
 156     in_package => 'PackageToEvalIn', # default Eval::WithLexicals::Scratchpad
 157     context => 'scalar',             # default 'list'
 158   );
 159
 160 =head2 eval
 161
 162   my @return_value = $eval->eval($code_to_eval);
 163
 164 =head2 lexicals
 165
 166   my $current_lexicals = $eval->lexicals;
 167
 168   $eval->lexicals(\%new_lexicals);
 169
 170 =head2 in_package
 171
 172   my $current_package = $eval->in_package;
 173
 174   $eval->in_package($new_package);
 175
 176 =head2 context
 177
 178   my $current_context = $eval->context;
 179
 180   $eval->context($new_context); # 'list', 'scalar' or 'void'
 181
 182 =head1 AUTHOR
 183
 184 Matt S. Trout <mst@shadowcat.co.uk>
 185
 186 =head1 CONTRIBUTORS
 187
 188 David Leadbeater <dgl@dgl.cx>
 189
 190 =head1 COPYRIGHT
 191
 192 Copyright (c) 2010 the Eval::WithLexicals L</AUTHOR> and L</CONTRIBUTORS>
 193 as listed above.
 194
 195 =head1 LICENSE
 196
 197 This library is free software and may be distributed under the same terms
 198 as perl itself.
 199
 200 =cut
 201
 202 1;