Commit | Line | Data |
d9087132 |
1 | package Eval::WithLexicals::WithHintPersistence; |
148445b9 |
2 | use Moo::Role; |
3fb66cc7 |
3 | use Sub::Quote; |
148445b9 |
4 | |
3fb66cc7 |
5 | our $VERSION = '1.001000'; # 1.1.0 |
6 | $VERSION = eval $VERSION; |
7 | |
8 | # Used localised |
148445b9 |
9 | our($hints, %hints); |
10 | |
3fb66cc7 |
11 | has hints => ( |
148445b9 |
12 | is => 'rw', |
3fb66cc7 |
13 | default => quote_sub q{ {} }, |
148445b9 |
14 | ); |
15 | |
3fb66cc7 |
16 | has _first_eval => ( |
148445b9 |
17 | is => 'rw', |
3fb66cc7 |
18 | default => quote_sub q{ 1 }, |
148445b9 |
19 | ); |
20 | |
21 | around eval => sub { |
22 | my $orig = shift; |
23 | my($self) = @_; |
24 | |
25 | local *Eval::WithLexicals::Cage::capture_hints; |
26 | local $Eval::WithLexicals::Cage::hints = { %{$self->hints} }; |
27 | |
28 | my @ret = $orig->(@_); |
29 | |
30 | $self->hints({ Eval::WithLexicals::Cage::capture_hints() }); |
31 | |
32 | @ret; |
33 | }; |
34 | |
35 | # XXX: Sub::Quote::capture_unroll without 'my' |
36 | use B(); |
37 | sub _capture_unroll_global { |
38 | my ($from, $captures, $indent) = @_; |
39 | join( |
40 | '', |
41 | map { |
42 | /^([\@\%\$])/ |
43 | or die "capture key should start with \@, \% or \$: $_"; |
44 | (' ' x $indent).qq{${_} = ${1}{${from}->{${\B::perlstring $_}}};\n}; |
45 | } keys %$captures |
46 | ); |
47 | } |
48 | |
235f6399 |
49 | around setup_code => sub { |
50 | shift; # we bypass orig, i.e. using role as normal inheritance. |
148445b9 |
51 | my($self) = @_; |
52 | # Only run the prelude on the first eval, hints will be set after |
53 | # that. |
3fb66cc7 |
54 | if($self->_first_eval) { |
55 | $self->_first_eval(0); |
d9087132 |
56 | return $self->prelude; |
148445b9 |
57 | } else { |
d9087132 |
58 | # Seems we can't use the technique of passing via @_ for code in a BEGIN |
59 | # block |
60 | return q[ BEGIN { ], |
61 | _capture_unroll_global('$Eval::WithLexicals::Cage::hints', $self->hints, 2), |
62 | q[ } ], |
148445b9 |
63 | } |
64 | }; |
65 | |
66 | around capture_code => sub { |
67 | my $orig = shift; |
68 | my($self) = @_; |
69 | |
70 | ( q{ sub Eval::WithLexicals::Cage::capture_hints { |
3fb66cc7 |
71 | no warnings 'closure'; |
148445b9 |
72 | my($hints, %hints); |
73 | BEGIN { $hints = $^H; %hints = %^H; } |
74 | return q{$^H} => \$hints, q{%^H} => \%hints; |
75 | } }, |
76 | $orig->(@_) ) |
77 | }; |
78 | |
3fb66cc7 |
79 | =head1 NAME |
80 | |
81 | Eval::WithLexicals::WithHintPersistence - Persist compile hints between evals |
82 | |
83 | =head1 SYNOPSIS |
84 | |
85 | use Eval::WithLexicals; |
86 | |
87 | my $eval = Eval::WithLexicals->with_plugins("HintPersistence")->new; |
88 | |
89 | =head1 DESCRIPTION |
90 | |
91 | Persist pragams and other compile hints between evals (for example the |
92 | L<strict> and L<warnings> flags in effect). |
93 | |
94 | Saves and restores the C<$^H> and C<%^H> variables. |
95 | |
96 | =head1 METHODS |
97 | |
98 | =head2 hints |
99 | |
100 | $eval->hints('$^H') |
101 | |
102 | Returns the internal hints hash, keys are C<$^H> and C<%^H> for the hint bits |
103 | and hint hash respectively. |
104 | |
105 | =cut |
106 | |
148445b9 |
107 | 1; |