Commit | Line | Data |
6f914695 |
1 | package Eval::WithLexicals; |
2 | |
3 | use Moo; |
4 | use Sub::Quote; |
5 | |
1de34059 |
6 | our $VERSION = '1.001000'; # 1.1.0 |
8d080039 |
7 | $VERSION = eval $VERSION; |
8 | |
6f914695 |
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}; |
e764ce9b |
39 | #line 1 "(eval)" |
6f914695 |
40 | ${to_eval} |
41 | ;sub Eval::WithLexicals::Cage::pad_capture { } |
42 | BEGIN { Eval::WithLexicals::Util::capture_list() } |
43 | sub Eval::WithLexicals::Cage::grab_captures { |
40d8277f |
44 | no warnings 'closure'; no strict 'vars'; |
45 | package Eval::WithLexicals::VarScope;!; |
8d080039 |
46 | $self->_eval_do(\$current_code, $self->lexicals, $to_eval); |
6f914695 |
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}, |
40d8277f |
58 | %{$self->_grab_captures}, |
6f914695 |
59 | }); |
60 | @ret; |
61 | } |
62 | |
40d8277f |
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 | |
6f914695 |
76 | sub _eval_do { |
8d080039 |
77 | my ($self, $text_ref, $lexicals, $original) = @_; |
6f914695 |
78 | local @INC = (sub { |
79 | if ($_[1] eq '/eval_do') { |
80 | open my $fh, '<', $text_ref; |
81 | $fh; |
82 | } else { |
83 | (); |
84 | } |
85 | }, @INC); |
8d080039 |
86 | do '/eval_do' or die $@; |
6f914695 |
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; |
4a3d69ab |
96 | my @names = grep $_ ne '&', map $_->PV, grep $_->isa('B::PV'), |
6f914695 |
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 | |
8d080039 |
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 | |
9a82ac00 |
188 | David Leadbeater <dgl@dgl.cx> |
8d080039 |
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 | |
6f914695 |
202 | 1; |