Commit | Line | Data |
148445b9 |
1 | package Eval::WithLexicals::Role::Eval; |
2 | use Moo::Role; |
3 | use Sub::Quote; |
4 | |
5 | has lexicals => (is => 'rw', default => quote_sub q{ {} }); |
6 | |
7 | { |
8 | my %valid_contexts = map +($_ => 1), qw(list scalar void); |
9 | |
10 | has context => ( |
11 | is => 'rw', default => quote_sub(q{ 'list' }), |
12 | isa => sub { |
13 | my ($val) = @_; |
14 | die "Invalid context type $val - should be list, scalar or void" |
15 | unless $valid_contexts{$val}; |
16 | }, |
17 | ); |
18 | } |
19 | |
20 | has in_package => ( |
21 | is => 'rw', default => quote_sub q{ 'Eval::WithLexicals::Scratchpad' } |
22 | ); |
23 | |
24 | has prelude => ( |
25 | is => 'rw', default => quote_sub q{ 'use strictures 1;' } |
26 | ); |
27 | |
28 | sub setup_code { |
29 | my ($self) = @_; |
30 | |
31 | return Sub::Quote::capture_unroll('$_[2]', $self->lexicals, 2); |
32 | } |
33 | |
34 | sub capture_code { |
35 | ( qq{ BEGIN { Eval::WithLexicals::Util::capture_list() } } ) |
36 | } |
37 | |
38 | sub eval { |
39 | my ($self, $to_eval) = @_; |
40 | local *Eval::WithLexicals::Cage::current_line; |
41 | local *Eval::WithLexicals::Cage::pad_capture; |
42 | local *Eval::WithLexicals::Cage::grab_captures; |
43 | |
44 | my $package = $self->in_package; |
45 | my $setup_code = join '', $self->setup_code; |
46 | my $capture_code = join '', $self->capture_code; |
47 | |
48 | local our $current_code = qq! |
49 | ${setup_code} |
50 | sub Eval::WithLexicals::Cage::current_line { |
51 | package ${package}; |
52 | #line 1 "(eval)" |
53 | ${to_eval} |
54 | ;sub Eval::WithLexicals::Cage::pad_capture { } |
55 | ${capture_code} |
56 | sub Eval::WithLexicals::Cage::grab_captures { |
57 | no warnings 'closure'; no strict 'vars'; |
58 | package Eval::WithLexicals::VarScope;!; |
59 | # rest is appended by Eval::WithLexicals::Util::capture_list, called |
60 | # during parsing by the BEGIN block from capture_code. |
61 | |
62 | $self->_eval_do(\$current_code, $self->lexicals, $to_eval); |
63 | $self->_run(\&Eval::WithLexicals::Cage::current_line); |
64 | } |
65 | |
66 | sub _run { |
67 | my($self, $code) = @_; |
68 | |
69 | my @ret; |
70 | my $ctx = $self->context; |
71 | if ($ctx eq 'list') { |
72 | @ret = $code->(); |
73 | } elsif ($ctx eq 'scalar') { |
74 | $ret[0] = $code->(); |
75 | } else { |
76 | $code->(); |
77 | } |
78 | $self->lexicals({ |
79 | %{$self->lexicals}, |
80 | %{$self->_grab_captures}, |
81 | }); |
82 | @ret; |
83 | } |
84 | |
85 | sub _grab_captures { |
86 | my ($self) = @_; |
87 | my $cap = Eval::WithLexicals::Cage::grab_captures(); |
88 | foreach my $key (keys %$cap) { |
89 | my ($sigil, $name) = $key =~ /^(.)(.+)$/; |
90 | my $var_scope_name = $sigil.'Eval::WithLexicals::VarScope::'.$name; |
91 | if ($cap->{$key} eq eval "\\${var_scope_name}") { |
92 | delete $cap->{$key}; |
93 | } |
94 | } |
95 | $cap; |
96 | } |
97 | |
98 | sub _eval_do { |
99 | my ($self, $text_ref, $lexical, $original) = @_; |
100 | local @INC = (sub { |
101 | if ($_[1] eq '/eval_do') { |
102 | open my $fh, '<', $text_ref; |
103 | $fh; |
104 | } else { |
105 | (); |
106 | } |
107 | }, @INC); |
108 | do '/eval_do' or die $@; |
109 | } |
110 | |
111 | { |
112 | package Eval::WithLexicals::Util; |
113 | |
114 | use B qw(svref_2object); |
115 | |
116 | sub capture_list { |
117 | my $pad_capture = \&Eval::WithLexicals::Cage::pad_capture; |
118 | my @names = grep $_ ne '&', map $_->PV, grep $_->isa('B::PV'), |
119 | svref_2object($pad_capture)->OUTSIDE->PADLIST->ARRAYelt(0)->ARRAY; |
120 | $Eval::WithLexicals::Role::Eval::current_code .= |
121 | '+{ '.join(', ', map "'$_' => \\$_", @names).' };' |
122 | ."\n}\n}\n1;\n"; |
123 | } |
124 | } |
125 | |
126 | 1; |