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