Add persistent hints
[p5sagit/Eval-WithLexicals.git] / lib / Eval / WithLexicals / Role / LexicalHints.pm
CommitLineData
148445b9 1package Eval::WithLexicals::Role::LexicalHints;
2use Moo::Role;
3
4our($hints, %hints);
5
6has first_eval => (
7 is => 'rw',
8 default => sub { 1 },
9);
10
11has hints => (
12 is => 'rw',
13 default => sub { {} },
14);
15
16around 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'
31use B();
32sub _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
44around setup_code => sub {
45 my $orig = shift;
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);
51 return $self->prelude, $orig->(@_);
52 } else {
53 # Seems we can't use the technique of passing via @_ for code in a BEGIN block
54 return q[ BEGIN { ], _capture_unroll_global('$Eval::WithLexicals::Cage::hints', $self->hints, 2), q[ } ],
55 $orig->(@_);
56 }
57};
58
59around capture_code => sub {
60 my $orig = shift;
61 my($self) = @_;
62
63 ( q{ sub Eval::WithLexicals::Cage::capture_hints {
64 no warnings 'closure';
65 my($hints, %hints);
66 BEGIN { $hints = $^H; %hints = %^H; }
67 return q{$^H} => \$hints, q{%^H} => \%hints;
68 } },
69 $orig->(@_) )
70};
71
721;