t/hints.t

   1 use strictures ();
   2 use Test::More;
   3 use Eval::WithLexicals;
   4 use lib 't/lib';
   5
   6 my $strictures_hints;
   7 my $strictures_warn;
   8 {
   9   local $ENV{PERL_STRICTURES_EXTRA} = 0;
  10   eval q{
  11     use strictures 1;
  12     BEGIN {
  13       # Find the hint value that 'use strictures 1' sets on this perl.
  14       $strictures_hints = $^H;
  15       $strictures_warn = ${^WARNING_BITS};
  16     };
  17     1;
  18   } or die $@;
  19 };
  20
  21 use strictures 1;
  22
  23 my $eval = Eval::WithLexicals->with_plugins("HintPersistence")->new(prelude => '');
  24
  25 is_deeply(
  26   [ $eval->eval('$x = 1') ],
  27   [ 1 ],
  28   'Basic non-strict eval ok'
  29 );
  30
  31 is_deeply(
  32   $eval->lexicals, { },
  33   'Lexical not stored'
  34 );
  35
  36 $eval->eval('use strictures 1');
  37
  38 {
  39   local $SIG{__WARN__} = sub { };
  40
  41   ok !eval { $eval->eval('$x') }, 'Unable to use undeclared variable';
  42   like $@, qr/requires explicit package/, 'Correct message in $@';
  43 }
  44
  45 is(
  46   ${$eval->hints->{q{$^H}}}, $strictures_hints,
  47  'Hints are set per strictures'
  48 );
  49
  50 is(
  51   (unpack "H*", ${$eval->hints->{q{${^WARNING_BITS}}}}),
  52   (unpack "H*", $strictures_warn),
  53   'Warning bits are set per strictures'
  54 );
  55
  56 is_deeply(
  57   $eval->lexicals, { },
  58   'Lexical not stored'
  59 );
  60
  61 # Assumption about perl internals: sort pragma will set a key in %^H.
  62 $eval->eval(q{ { use hint_hash_pragma 'param' } }),
  63 ok !exists $eval->hints->{q{%^H}}->{hint_hash_pragma},
  64   "Lexical pragma used below main scope not captured";
  65
  66 $eval->eval(q{ use hint_hash_pragma 'param' }),
  67 is $eval->hints->{q{%^H}}->{hint_hash_pragma}, 'param',
  68   "Lexical pragma captured";
  69
  70 done_testing;