Commit | Line | Data |
d9087132 |
1 | package Eval::WithLexicals::WithHintPersistence; |
148445b9 |
2 | use Moo::Role; |
3 | |
4 | our($hints, %hints); |
5 | |
6 | has first_eval => ( |
7 | is => 'rw', |
8 | default => sub { 1 }, |
9 | ); |
10 | |
11 | has hints => ( |
12 | is => 'rw', |
13 | default => sub { {} }, |
14 | ); |
15 | |
16 | around eval => sub { |
17 | my $orig = shift; |
18 | my($self) = @_; |
19 | |
20 | local *Eval::WithLexicals::Cage::capture_hints; |
21 | local $Eval::WithLexicals::Cage::hints = { %{$self->hints} }; |
22 | |
23 | my @ret = $orig->(@_); |
24 | |
25 | $self->hints({ Eval::WithLexicals::Cage::capture_hints() }); |
26 | |
27 | @ret; |
28 | }; |
29 | |
30 | # XXX: Sub::Quote::capture_unroll without 'my' |
31 | use B(); |
32 | sub _capture_unroll_global { |
33 | my ($from, $captures, $indent) = @_; |
34 | join( |
35 | '', |
36 | map { |
37 | /^([\@\%\$])/ |
38 | or die "capture key should start with \@, \% or \$: $_"; |
39 | (' ' x $indent).qq{${_} = ${1}{${from}->{${\B::perlstring $_}}};\n}; |
40 | } keys %$captures |
41 | ); |
42 | } |
43 | |
235f6399 |
44 | around setup_code => sub { |
45 | shift; # we bypass orig, i.e. using role as normal inheritance. |
148445b9 |
46 | my($self) = @_; |
47 | # Only run the prelude on the first eval, hints will be set after |
48 | # that. |
49 | if($self->first_eval) { |
50 | $self->first_eval(0); |
d9087132 |
51 | return $self->prelude; |
148445b9 |
52 | } else { |
d9087132 |
53 | # Seems we can't use the technique of passing via @_ for code in a BEGIN |
54 | # block |
55 | return q[ BEGIN { ], |
56 | _capture_unroll_global('$Eval::WithLexicals::Cage::hints', $self->hints, 2), |
57 | q[ } ], |
148445b9 |
58 | } |
59 | }; |
60 | |
61 | around capture_code => sub { |
62 | my $orig = shift; |
63 | my($self) = @_; |
64 | |
65 | ( q{ sub Eval::WithLexicals::Cage::capture_hints { |
d9087132 |
66 | no warnings 'closure'; # XXX: can we limit the scope of this? |
148445b9 |
67 | my($hints, %hints); |
68 | BEGIN { $hints = $^H; %hints = %^H; } |
69 | return q{$^H} => \$hints, q{%^H} => \%hints; |
70 | } }, |
71 | $orig->(@_) ) |
72 | }; |
73 | |
74 | 1; |