Commit | Line | Data |
6f914695 |
1 | package Eval::WithLexicals; |
2 | |
3 | use Moo; |
4 | use Sub::Quote; |
5 | |
6 | has lexicals => (is => 'rw', default => quote_sub q{ {} }); |
7 | |
8 | { |
9 | my %valid_contexts = map +($_ => 1), qw(list scalar void); |
10 | |
11 | has context => ( |
12 | is => 'rw', default => quote_sub(q{ 'list' }), |
13 | isa => sub { |
14 | my ($val) = @_; |
15 | die "Invalid context type $val - should be list, scalar or void" |
16 | unless $valid_contexts{$val}; |
17 | }, |
18 | ); |
19 | } |
20 | |
21 | has in_package => ( |
22 | is => 'rw', default => quote_sub q{ 'Eval::WithLexicals::Scratchpad' } |
23 | ); |
24 | |
25 | sub eval { |
26 | my ($self, $to_eval) = @_; |
27 | local *Eval::WithLexicals::Cage::current_line; |
28 | local *Eval::WithLexicals::Cage::pad_capture; |
29 | local *Eval::WithLexicals::Cage::grab_captures; |
30 | my $setup = Sub::Quote::capture_unroll('$_[2]', $self->lexicals, 2); |
31 | my $package = $self->in_package; |
32 | local our $current_code = qq!use strictures 1; |
33 | ${setup} |
34 | sub Eval::WithLexicals::Cage::current_line { |
35 | package ${package}; |
36 | ${to_eval} |
37 | ;sub Eval::WithLexicals::Cage::pad_capture { } |
38 | BEGIN { Eval::WithLexicals::Util::capture_list() } |
39 | sub Eval::WithLexicals::Cage::grab_captures { |
40 | no warnings 'closure'; no strict 'refs'; |
41 | package Eval::WithLexicals::Cage;!; |
42 | $self->_eval_do(\$current_code, $self->lexicals); |
43 | my @ret; |
44 | my $ctx = $self->context; |
45 | if ($ctx eq 'list') { |
46 | @ret = Eval::WithLexicals::Cage::current_line(); |
47 | } elsif ($ctx eq 'scalar') { |
48 | $ret[0] = Eval::WithLexicals::Cage::current_line(); |
49 | } else { |
50 | Eval::WithLexicals::Cage::current_line(); |
51 | } |
52 | $self->lexicals({ |
53 | %{$self->lexicals}, |
54 | %{Eval::WithLexicals::Cage::grab_captures()} |
55 | }); |
56 | @ret; |
57 | } |
58 | |
59 | sub _eval_do { |
60 | my ($self, $text_ref) = @_; |
61 | local @INC = (sub { |
62 | if ($_[1] eq '/eval_do') { |
63 | open my $fh, '<', $text_ref; |
64 | $fh; |
65 | } else { |
66 | (); |
67 | } |
68 | }, @INC); |
69 | do '/eval_do' or die "Error: $@\nCompiling: $$text_ref"; |
70 | } |
71 | |
72 | { |
73 | package Eval::WithLexicals::Util; |
74 | |
75 | use B qw(svref_2object); |
76 | |
77 | sub capture_list { |
78 | my $pad_capture = \&Eval::WithLexicals::Cage::pad_capture; |
79 | my @names = map $_->PV, grep $_->isa('B::PV'), |
80 | svref_2object($pad_capture)->OUTSIDE->PADLIST->ARRAYelt(0)->ARRAY; |
81 | $Eval::WithLexicals::current_code .= |
82 | '+{ '.join(', ', map "'$_' => \\$_", @names).' };' |
83 | ."\n}\n}\n1;\n"; |
84 | } |
85 | } |
86 | |
87 | 1; |