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 # Used localised
   9 our($hints, %hints);
  10
  11 has hints => (
  12   is => 'rw',
  13   default => quote_sub q{ {} },
  14 );
  15
  16 has _first_eval => (
  17   is => 'rw',
  18   default => quote_sub q{ 1 },
  19 );
  20
  21 around eval => sub {
  22   my $orig = shift;
  23   my($self) = @_;
  24
  25   local *Eval::WithLexicals::Cage::capture_hints;
  26   local $Eval::WithLexicals::Cage::hints = { %{$self->hints} };
  27
  28   my @ret = $orig->(@_);
  29
  30   $self->hints({ Eval::WithLexicals::Cage::capture_hints() });
  31
  32   @ret;
  33 };
  34
  35 # XXX: Sub::Quote::capture_unroll without 'my'
  36 use B();
  37 sub _capture_unroll_global {
  38   my ($from, $captures, $indent) = @_;
  39   join(
  40     '',
  41     map {
  42       /^([\@\%\$])/
  43         or die "capture key should start with \@, \% or \$: $_";
  44       (' ' x $indent).qq{${_} = ${1}{${from}->{${\B::perlstring $_}}};\n};
  45     } keys %$captures
  46   );
  47 }
  48
  49 sub setup_code {
  50   my($self) = @_;
  51   # Only run the prelude on the first eval, hints will be set after
  52   # that.
  53   if($self->_first_eval) {
  54     $self->_first_eval(0);
  55     return $self->prelude;
  56   } else {
  57     # Seems we can't use the technique of passing via @_ for code in a BEGIN
  58     # block
  59     return q[ BEGIN { ],
  60       _capture_unroll_global('$Eval::WithLexicals::Cage::hints', $self->hints, 2),
  61       q[ } ],
  62   }
  63 };
  64
  65 around capture_code => sub {
  66   my $orig = shift;
  67   my($self) = @_;
  68
  69   ( q{ sub Eval::WithLexicals::Cage::capture_hints {
  70           my ($hints, %hints, $warn_bits);
  71           BEGIN {
  72             no warnings 'closure';
  73             $hints = $^H;
  74             %hints = %^H;
  75             $warn_bits = ${^WARNING_BITS};
  76           }
  77           return (
  78             q{$^H}              => \$hints,
  79             q{%^H}              => \%hints,
  80             q{${^WARNING_BITS}} => \$warn_bits,
  81           );
  82         } },
  83     $orig->(@_) )
  84 };
  85
  86 1;
  87 __END__
  88
  89 =head1 NAME
  90
  91 Eval::WithLexicals::WithHintPersistence - Persist compile hints between evals
  92
  93 =head1 SYNOPSIS
  94
  95  use Eval::WithLexicals;
  96
  97  my $eval = Eval::WithLexicals->with_plugins("HintPersistence")->new;
  98
  99 =head1 DESCRIPTION
 100
 101 Persist pragams and other compile hints between evals (for example the
 102 L<strict> and L<warnings> flags in effect).
 103
 104 Saves and restores the C<$^H> and C<%^H> variables.
 105
 106 =head1 METHODS
 107
 108 =head2 hints
 109
 110  $eval->hints('$^H')
 111
 112 Returns the internal hints hash, keys are C<$^H> and C<%^H> for the hint bits
 113 and hint hash respectively.
 114
 115 =head1 SUPPORT
 116
 117 See L<Eval::WithLexicals> for support and contact information.
 118
 119 =head1 AUTHORS
 120
 121 See L<Eval::WithLexicals> for authors.
 122
 123 =head1 COPYRIGHT AND LICENSE
 124
 125 See L<Eval::WithLexicals> for the copyright and license.
 126
 127 =cut