X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit%2FEval-WithLexicals.git;a=blobdiff_plain;f=t%2Fhints.t;h=7040b4258cd67539b99c10d4fd258db5c57f169f;hp=f5681b3d4178eee719dc52e6a2d2d16aa43221e1;hb=6c8bf56cd4942ec40e37a6db79d4bab121e1cff8;hpb=2b376bd0dc102f9019e007d889a844f94b3a87b9

diff --git a/t/hints.t b/t/hints.t
index f5681b3..7040b42 100644
--- a/t/hints.t
+++ b/t/hints.t
@@ -1,15 +1,10 @@
 use strictures ();
-my $strictures_hints;
-BEGIN {
-  local $ENV{PERL_STRICTURES_EXTRA} = 0;
-  strictures->VERSION(1); strictures->import();
-  # Find the hint value that 'use strictures 1' sets on this perl.
-  $strictures_hints = $^H;
-}
-use strictures 1;
-
 use Test::More;
 use Eval::WithLexicals;
+use lib 't/lib';
+
+use strictures 1;
+use get_strictures_hints;
 
 my $eval = Eval::WithLexicals->with_plugins("HintPersistence")->new(prelude => '');
 
@@ -24,33 +19,81 @@ is_deeply(
   'Lexical not stored'
 );
 
+my ($strictures_hints, $strictures_warn) = get_strictures_hints::hints();
 $eval->eval('use strictures 1');
 
 {
   local $SIG{__WARN__} = sub { };
 
-  ok !eval { $eval->eval('$x') }, 'Unable to use undeclared variable';
-  like $@, qr/requires explicit package/, 'Correct message in $@';
+  ok !eval { $eval->eval('${"x"}') }, 'Unable to use undeclared variable';
+  like $@, qr/Can't use string .* as a SCALAR ref/,
+  'Correct message in $@';
 }
 
-is_deeply(
-  $eval->hints->{q{$^H}}, \$strictures_hints,
+is(
+  ${$eval->hints->{q{$^H}}}, $strictures_hints,
  'Hints are set per strictures'
 );
 
+is(
+  (unpack "H*", ${ $eval->hints->{'${^WARNING_BITS}'} }),
+  (unpack "H*", $strictures_warn),
+  'Warning bits are set per strictures'
+) or do {
+  my @cats =
+    map {
+      [ $_         => $warnings::Bits{$_} ],
+      [ "fatal $_" => $warnings::DeadBits{$_} ],
+    }
+    grep $_ ne 'all',
+    keys %warnings::Bits;
+
+  my %info;
+  for my $check (
+    [ missing => $strictures_warn ],
+    [ extra   => ${ $eval->hints->{'${^WARNING_BITS}'} } ],
+  ) {
+    my $bits = $check->[1];
+    $info{$check->[0]} = {
+      map { ($bits & $_->[1]) =~ /[^\0]/ ? ( $_->[0] => 1 ) : () }
+      @cats
+    };
+  }
+
+  {
+    my @extra = keys %{$info{extra}};
+    my @missing = keys %{$info{missing}};
+    delete @{$info{missing}}{ @extra };
+    delete @{$info{extra}}{ @missing };
+  }
+
+  for my $type (qw(missing extra)) {
+    my @found = grep $info{$type}{$_}, map $_->[0], @cats;
+    diag "$type:"
+      if @found;
+    diag "    $_"
+      for @found;
+  }
+};
+
 is_deeply(
   $eval->lexicals, { },
   'Lexical not stored'
 );
 
 # Assumption about perl internals: sort pragma will set a key in %^H.
-
-$eval->eval(q{ { use sort 'stable' } }),
-ok !exists $eval->hints->{q{%^H}}->{sort},
+$eval->eval(q{ { use hint_hash_pragma 'param' } }),
+ok !exists $eval->hints->{q{%^H}}->{hint_hash_pragma},
   "Lexical pragma used below main scope not captured";
 
-$eval->eval(q{ use sort 'stable' }),
-ok exists $eval->hints->{q{%^H}}->{sort},
+$eval->eval(q{ use hint_hash_pragma 'param' }),
+is $eval->hints->{q{%^H}}->{hint_hash_pragma}, 'param',
   "Lexical pragma captured";
 
+$eval->eval('my $x = 1');
+is_deeply(
+  $eval->lexicals->{'$x'}, \1,
+  'Lexical captured when preserving hints',
+);
+
 done_testing;