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