t/hints.t

   1 use strictures ();
   2 use Test::More;
   3 use Eval::WithLexicals;
   4 use lib 't/lib';
   5
   6 use strictures 1;
   7 use get_strictures_hints;
   8
   9 my $eval = Eval::WithLexicals->with_plugins("HintPersistence")->new(prelude => '');
  10
  11 is_deeply(
  12   [ $eval->eval('$x = 1') ],
  13   [ 1 ],
  14   'Basic non-strict eval ok'
  15 );
  16
  17 is_deeply(
  18   $eval->lexicals, { },
  19   'Lexical not stored'
  20 );
  21
  22 my ($strictures_hints, $strictures_warn) = get_strictures_hints::hints();
  23 $eval->eval('use strictures 1');
  24
  25 {
  26   local $SIG{__WARN__} = sub { };
  27
  28   ok !eval { $eval->eval('${"x"}') }, 'Unable to use undeclared variable';
  29   like $@, qr/Can't use string .* as a SCALAR ref/,
  30   'Correct message in $@';
  31 }
  32
  33 is(
  34   ${$eval->hints->{q{$^H}}}, $strictures_hints,
  35  'Hints are set per strictures'
  36 );
  37
  38 is(
  39   (unpack "H*", ${ $eval->hints->{'${^WARNING_BITS}'} }),
  40   (unpack "H*", $strictures_warn),
  41   'Warning bits are set per strictures'
  42 ) or do {
  43   my @cats =
  44     map {
  45       [ $_         => $warnings::Bits{$_} ],
  46       [ "fatal $_" => $warnings::DeadBits{$_} ],
  47     }
  48     grep $_ ne 'all',
  49     keys %warnings::Bits;
  50
  51   my %info;
  52   for my $check (
  53     [ missing => $strictures_warn ],
  54     [ extra   => ${ $eval->hints->{'${^WARNING_BITS}'} } ],
  55   ) {
  56     my $bits = $check->[1];
  57     $info{$check->[0]} = {
  58       map { ($bits & $_->[1]) =~ /[^\0]/ ? ( $_->[0] => 1 ) : () }
  59       @cats
  60     };
  61   }
  62
  63   {
  64     my @extra = keys %{$info{extra}};
  65     my @missing = keys %{$info{missing}};
  66     delete @{$info{missing}}{ @extra };
  67     delete @{$info{extra}}{ @missing };
  68   }
  69
  70   for my $type (qw(missing extra)) {
  71     my @found = grep $info{$type}{$_}, map $_->[0], @cats;
  72     diag "$type:"
  73       if @found;
  74     diag "    $_"
  75       for @found;
  76   }
  77 };
  78
  79 is_deeply(
  80   $eval->lexicals, { },
  81   'Lexical not stored'
  82 );
  83
  84 # Assumption about perl internals: sort pragma will set a key in %^H.
  85 $eval->eval(q{ { use hint_hash_pragma 'param' } }),
  86 ok !exists $eval->hints->{q{%^H}}->{hint_hash_pragma},
  87   "Lexical pragma used below main scope not captured";
  88
  89 $eval->eval(q{ use hint_hash_pragma 'param' }),
  90 is $eval->hints->{q{%^H}}->{hint_hash_pragma}, 'param',
  91   "Lexical pragma captured";
  92
  93 $eval->eval('my $x = 1');
  94 is_deeply(
  95   $eval->lexicals->{'$x'}, \1,
  96   'Lexical captured when preserving hints',
  97 );
  98
  99 done_testing;