lib/Eval/WithLexicals/WithHintPersistence.pm

   1 package Eval::WithLexicals::WithHintPersistence;
   2 use Moo::Role;
   3 use Sub::Quote;
   4
   5 our $VERSION = '1.002000'; # 1.2.0
   6 $VERSION = eval $VERSION;
   7
   8 has hints => (
   9   is => 'rw',
  10   default => quote_sub q{ {} },
  11 );
  12
  13 around eval => sub {
  14   my $orig = shift;
  15   my($self) = @_;
  16
  17   local *Eval::WithLexicals::Cage::capture_hints;
  18   local $Eval::WithLexicals::Cage::hints = { %{$self->hints} };
  19
  20   my @ret = $orig->(@_);
  21
  22   $self->hints({ Eval::WithLexicals::Cage::capture_hints() });
  23   $self->prelude(
  24     join '', q[ BEGIN { ],
  25       _capture_unroll_global('$Eval::WithLexicals::Cage::hints', $self->hints, 2),
  26     q[ } ],
  27   );
  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 around capture_code => sub {
  47   my $orig = shift;
  48   my($self) = @_;
  49
  50   ( q{ sub Eval::WithLexicals::Cage::capture_hints {
  51           my ($hints, %hints, $warn_bits);
  52           BEGIN {
  53             no warnings 'closure';
  54             $hints = $^H;
  55             %hints = %^H;
  56             $warn_bits = ${^WARNING_BITS};
  57           }
  58           return (
  59             q{$^H}              => \$hints,
  60             q{%^H}              => \%hints,
  61             q{${^WARNING_BITS}} => \$warn_bits,
  62           );
  63         } },
  64     $orig->(@_) )
  65 };
  66
  67 1;
  68 __END__
  69
  70 =head1 NAME
  71
  72 Eval::WithLexicals::WithHintPersistence - Persist compile hints between evals
  73
  74 =head1 SYNOPSIS
  75
  76  use Eval::WithLexicals;
  77
  78  my $eval = Eval::WithLexicals->with_plugins("HintPersistence")->new;
  79
  80 =head1 DESCRIPTION
  81
  82 Persist pragams and other compile hints between evals (for example the
  83 L<strict> and L<warnings> flags in effect).
  84
  85 Saves and restores the C<$^H> and C<%^H> variables.
  86
  87 =head1 METHODS
  88
  89 =head2 hints
  90
  91  $eval->hints('$^H')
  92
  93 Returns the internal hints hash, keys are C<$^H> and C<%^H> for the hint bits
  94 and hint hash respectively.
  95
  96 =head1 SUPPORT
  97
  98 See L<Eval::WithLexicals> for support and contact information.
  99
 100 =head1 AUTHORS
 101
 102 See L<Eval::WithLexicals> for authors.
 103
 104 =head1 COPYRIGHT AND LICENSE
 105
 106 See L<Eval::WithLexicals> for the copyright and license.
 107
 108 =cut