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