lib/Eval/WithLexicals/WithHintPersistence.pm

   1 package Eval::WithLexicals::WithHintPersistence;
   2 use Moo::Role;
   3 use Sub::Quote;
   4
   5 our $VERSION = '1.003006'; # v1.3.6
   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 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 {
  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__
  85
  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
 112 =head1 SUPPORT
 113
 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