lib/Eval/WithLexicals/WithHintPersistence.pm

   1 package Eval::WithLexicals::WithHintPersistence;
   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
  44 around setup_code => sub {
  45   shift; # we bypass orig, i.e. using role as normal inheritance.
  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;
  52   } else {
  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[ } ],
  58   }
  59 };
  60
  61 around capture_code => sub {
  62   my $orig = shift;
  63   my($self) = @_;
  64
  65   ( q{ sub Eval::WithLexicals::Cage::capture_hints {
  66           no warnings 'closure'; # XXX: can we limit the scope of this?
  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;