Commit | Line | Data |
6f914695 |
1 | package Eval::WithLexicals; |
2 | |
3 | use Moo; |
8d732f30 |
4 | use Moo::Role (); |
6f914695 |
5 | use Sub::Quote; |
6 | |
9aa1478d |
7 | our $VERSION = '1.002000'; # 1.2.0 |
8d080039 |
8 | $VERSION = eval $VERSION; |
9 | |
6f914695 |
10 | has lexicals => (is => 'rw', default => quote_sub q{ {} }); |
11 | |
12 | { |
13 | my %valid_contexts = map +($_ => 1), qw(list scalar void); |
14 | |
15 | has context => ( |
16 | is => 'rw', default => quote_sub(q{ 'list' }), |
17 | isa => sub { |
18 | my ($val) = @_; |
19 | die "Invalid context type $val - should be list, scalar or void" |
3092edd9 |
20 | unless $valid_contexts{$val}; |
6f914695 |
21 | }, |
22 | ); |
23 | } |
24 | |
25 | has in_package => ( |
26 | is => 'rw', default => quote_sub q{ 'Eval::WithLexicals::Scratchpad' } |
27 | ); |
28 | |
73a98f1c |
29 | has prelude => ( |
30 | is => 'rw', default => quote_sub q{ 'use strictures 1;' } |
31 | ); |
32 | |
a721c957 |
33 | has line => ( is => 'rw', default => 1 ); |
34 | |
8d732f30 |
35 | sub with_plugins { |
36 | my($class, @names) = @_; |
37 | |
38 | Moo::Role->create_class_with_roles($class, |
39 | map "Eval::WithLexicals::With$_", @names); |
40 | } |
41 | |
42 | sub setup_code { |
43 | my($self) = @_; |
44 | $self->prelude; |
45 | } |
46 | |
47 | sub capture_code { |
48 | ( qq{ BEGIN { Eval::WithLexicals::Util::capture_list() } } ) |
49 | } |
50 | |
6f914695 |
51 | sub eval { |
52 | my ($self, $to_eval) = @_; |
53 | local *Eval::WithLexicals::Cage::current_line; |
54 | local *Eval::WithLexicals::Cage::pad_capture; |
55 | local *Eval::WithLexicals::Cage::grab_captures; |
8d732f30 |
56 | |
6f914695 |
57 | my $package = $self->in_package; |
a721c957 |
58 | my $line = $self->line; |
59 | $self->line($line+1); |
8d732f30 |
60 | my $setup_code = join '', $self->setup_code, |
61 | # $_[2] being what is passed to _eval_do below |
62 | Sub::Quote::capture_unroll('$_[2]', $self->lexicals, 2); |
63 | |
64 | my $capture_code = join '', $self->capture_code; |
65 | |
66 | local our $current_code = qq! |
67 | ${setup_code} |
6f914695 |
68 | sub Eval::WithLexicals::Cage::current_line { |
69 | package ${package}; |
a721c957 |
70 | #line $line "(eval)" |
6f914695 |
71 | ${to_eval} |
72 | ;sub Eval::WithLexicals::Cage::pad_capture { } |
8d732f30 |
73 | ${capture_code} |
6f914695 |
74 | sub Eval::WithLexicals::Cage::grab_captures { |
40d8277f |
75 | no warnings 'closure'; no strict 'vars'; |
76 | package Eval::WithLexicals::VarScope;!; |
8d732f30 |
77 | # rest is appended by Eval::WithLexicals::Util::capture_list, called |
78 | # during parsing by the BEGIN block from capture_code. |
79 | |
8d080039 |
80 | $self->_eval_do(\$current_code, $self->lexicals, $to_eval); |
8d732f30 |
81 | $self->_run(\&Eval::WithLexicals::Cage::current_line); |
82 | } |
83 | |
84 | sub _run { |
85 | my($self, $code) = @_; |
86 | |
6f914695 |
87 | my @ret; |
88 | my $ctx = $self->context; |
89 | if ($ctx eq 'list') { |
8d732f30 |
90 | @ret = $code->(); |
6f914695 |
91 | } elsif ($ctx eq 'scalar') { |
8d732f30 |
92 | $ret[0] = $code->(); |
6f914695 |
93 | } else { |
8d732f30 |
94 | $code->(); |
6f914695 |
95 | } |
96 | $self->lexicals({ |
97 | %{$self->lexicals}, |
40d8277f |
98 | %{$self->_grab_captures}, |
6f914695 |
99 | }); |
100 | @ret; |
101 | } |
102 | |
40d8277f |
103 | sub _grab_captures { |
104 | my ($self) = @_; |
105 | my $cap = Eval::WithLexicals::Cage::grab_captures(); |
106 | foreach my $key (keys %$cap) { |
107 | my ($sigil, $name) = $key =~ /^(.)(.+)$/; |
108 | my $var_scope_name = $sigil.'Eval::WithLexicals::VarScope::'.$name; |
109 | if ($cap->{$key} eq eval "\\${var_scope_name}") { |
110 | delete $cap->{$key}; |
111 | } |
112 | } |
113 | $cap; |
114 | } |
115 | |
6f914695 |
116 | sub _eval_do { |
8d732f30 |
117 | my ($self, $text_ref, $lexical, $original) = @_; |
6f914695 |
118 | local @INC = (sub { |
119 | if ($_[1] eq '/eval_do') { |
120 | open my $fh, '<', $text_ref; |
121 | $fh; |
122 | } else { |
123 | (); |
124 | } |
125 | }, @INC); |
8d080039 |
126 | do '/eval_do' or die $@; |
6f914695 |
127 | } |
128 | |
129 | { |
130 | package Eval::WithLexicals::Util; |
131 | |
132 | use B qw(svref_2object); |
133 | |
134 | sub capture_list { |
135 | my $pad_capture = \&Eval::WithLexicals::Cage::pad_capture; |
4a3d69ab |
136 | my @names = grep $_ ne '&', map $_->PV, grep $_->isa('B::PV'), |
6f914695 |
137 | svref_2object($pad_capture)->OUTSIDE->PADLIST->ARRAYelt(0)->ARRAY; |
138 | $Eval::WithLexicals::current_code .= |
139 | '+{ '.join(', ', map "'$_' => \\$_", @names).' };' |
140 | ."\n}\n}\n1;\n"; |
141 | } |
142 | } |
143 | |
54153012 |
144 | 1; |
145 | __END__ |
146 | |
8d080039 |
147 | =head1 NAME |
148 | |
149 | Eval::WithLexicals - pure perl eval with persistent lexical variables |
150 | |
151 | =head1 SYNOPSIS |
152 | |
153 | # file: bin/tinyrepl |
154 | |
155 | #!/usr/bin/env perl |
156 | |
157 | use strictures 1; |
158 | use Eval::WithLexicals; |
159 | use Term::ReadLine; |
160 | use Data::Dumper; |
8d732f30 |
161 | use Getopt::Long; |
162 | |
163 | GetOptions( |
164 | "plugin=s" => \my @plugins |
165 | ); |
8d080039 |
166 | |
167 | $SIG{INT} = sub { warn "SIGINT\n" }; |
168 | |
169 | { package Data::Dumper; no strict 'vars'; |
170 | $Terse = $Indent = $Useqq = $Deparse = $Sortkeys = 1; |
171 | $Quotekeys = 0; |
172 | } |
173 | |
8d732f30 |
174 | my $eval = @plugins |
175 | ? Eval::WithLexicals->with_plugins(@plugins)->new |
176 | : Eval::WithLexicals->new; |
177 | |
8d080039 |
178 | my $read = Term::ReadLine->new('Perl REPL'); |
179 | while (1) { |
180 | my $line = $read->readline('re.pl$ '); |
181 | exit unless defined $line; |
182 | my @ret; eval { |
183 | local $SIG{INT} = sub { die "Caught SIGINT" }; |
184 | @ret = $eval->eval($line); 1; |
185 | } or @ret = ("Error!", $@); |
186 | print Dumper @ret; |
187 | } |
188 | |
189 | # shell session: |
190 | |
191 | $ perl -Ilib bin/tinyrepl |
192 | re.pl$ my $x = 0; |
193 | 0 |
194 | re.pl$ ++$x; |
195 | 1 |
196 | re.pl$ $x + 3; |
197 | 4 |
198 | re.pl$ ^D |
199 | $ |
200 | |
201 | =head1 METHODS |
202 | |
203 | =head2 new |
204 | |
205 | my $eval = Eval::WithLexicals->new( |
206 | lexicals => { '$x' => \1 }, # default {} |
207 | in_package => 'PackageToEvalIn', # default Eval::WithLexicals::Scratchpad |
208 | context => 'scalar', # default 'list' |
73a98f1c |
209 | prelude => 'use warnings', # default 'use strictures 1' |
8d080039 |
210 | ); |
211 | |
212 | =head2 eval |
213 | |
214 | my @return_value = $eval->eval($code_to_eval); |
215 | |
216 | =head2 lexicals |
217 | |
218 | my $current_lexicals = $eval->lexicals; |
219 | |
220 | $eval->lexicals(\%new_lexicals); |
221 | |
222 | =head2 in_package |
223 | |
224 | my $current_package = $eval->in_package; |
225 | |
226 | $eval->in_package($new_package); |
227 | |
228 | =head2 context |
229 | |
230 | my $current_context = $eval->context; |
231 | |
232 | $eval->context($new_context); # 'list', 'scalar' or 'void' |
233 | |
73a98f1c |
234 | =head2 prelude |
235 | |
236 | Code to run before evaling code. Loads L<strictures> by default. |
237 | |
238 | my $current_prelude = $eval->prelude; |
239 | |
240 | $eval->prelude(q{use warnings}); # only warnings, not strict. |
241 | |
8d732f30 |
242 | =head2 with_plugins |
243 | |
244 | my $eval = Eval::WithLexicals->with_plugins("HintPersistence")->new; |
245 | |
246 | Construct a class with the given plugins. Plugins are roles located under |
247 | a package name like C<Eval::WithLexicals::With*>. |
248 | |
249 | Current plugins are: |
250 | |
251 | =over 4 |
252 | |
253 | =item * HintPersistence |
254 | |
255 | When enabled this will persist pragams and other compile hints between evals |
256 | (for example the L<strict> and L<warnings> flags in effect). See |
257 | L<Eval::WithLexicals::WithHintPersistence> for further details. |
258 | |
259 | =back |
260 | |
8d080039 |
261 | =head1 AUTHOR |
262 | |
263 | Matt S. Trout <mst@shadowcat.co.uk> |
264 | |
265 | =head1 CONTRIBUTORS |
266 | |
9a82ac00 |
267 | David Leadbeater <dgl@dgl.cx> |
8d080039 |
268 | |
f0d3f86b |
269 | haarg - Graham Knop (cpan:HAARG) <haarg@cpan.org> |
270 | |
8d080039 |
271 | =head1 COPYRIGHT |
272 | |
273 | Copyright (c) 2010 the Eval::WithLexicals L</AUTHOR> and L</CONTRIBUTORS> |
274 | as listed above. |
275 | |
276 | =head1 LICENSE |
277 | |
278 | This library is free software and may be distributed under the same terms |
279 | as perl itself. |
280 | |
281 | =cut |