lib/Eval/WithLexicals.pm

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