File Coverage

blib/lib/Eval/WithLexicals/WithHintPersistence.pm
Criterion Covered Total %
statement 19 19 100.0
branch 3 4 75.0
condition n/a
subroutine 5 5 100.0
pod 0 1 0.0
total 27 29 93.1


line stmt bran cond sub pod time code
1             package Eval::WithLexicals::WithHintPersistence;
2 1     1   592 use Moo::Role;
  1         1  
  1         5  
3 1     1   326 use Sub::Quote;
  1         2  
  1         286  
4              
5             our $VERSION = '1.003004'; # 1.3.4
6             $VERSION = eval $VERSION;
7              
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 1     1   7 use B();
  1         1  
  1         315  
34             sub _capture_unroll_global {
35 5     5   9 my ($from, $captures, $indent) = @_;
36 15 50       37 join(
37             '',
38             map {
39 5         9 /^([\@\%\$])/
40             or die "capture key should start with \@, \% or \$: $_";
41 15         29 (' ' x $indent).qq{${_} = ${1}{${from}->{${\B::perlstring $_}}};\n};
  15         68  
42             } keys %$captures
43             );
44             }
45              
46             sub setup_code {
47 6     6 0 6 my($self) = @_;
48             # Only run the prelude on the first eval, hints will be set after
49             # that.
50 6 100       25 if($self->_first_eval) {
51 1         2 $self->_first_eval(0);
52 1         13 return $self->prelude;
53             } else {
54             # Seems we can't use the technique of passing via @_ for code in a BEGIN
55             # block
56 5         11 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 {
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             );
79             } },
80             $orig->(@_) )
81             };
82              
83             1;
84             __END__