Commit | Line | Data |
fd9f6265 |
1 | #!./perl -w |
2 | |
3 | BEGIN { ## no critic strict |
4 | if ( $ENV{PERL_CORE} ) { |
5 | chdir('t') if -d 't'; |
6 | @INC = qw(../lib . lib); |
7 | } |
8 | else { |
9 | unshift @INC, 't'; |
10 | } |
11 | require Config; |
12 | if ( ( $Config::Config{'extensions'} !~ /\bB\b/ ) ) { |
13 | print "1..0 # Skip -- Perl configured without B module\n"; |
14 | exit 0; |
15 | } |
16 | } |
17 | |
18 | use strict; |
19 | use warnings; |
20 | use Test::More tests => 4 * 3; |
21 | use B 'svref_2object'; |
22 | |
23 | # use Data::Dumper 'Dumper'; |
24 | |
25 | sub foo { |
26 | my ( $x, $y, $z ); |
27 | |
28 | # hh => {}, |
29 | $z = $x * $y; |
30 | |
31 | # hh => { mypragma => 42 } |
32 | use mypragma; |
33 | $z = $x + $y; |
34 | |
35 | # hh => { mypragma => 0 } |
36 | no mypragma; |
37 | $z = $x - $y; |
38 | } |
39 | |
40 | { |
41 | |
42 | # Pragmas don't appear til they're used. |
43 | my $cop = find_op_cop( \&foo, qr/multiply/ ); |
44 | isa_ok( $cop, 'B::COP', 'found pp_multiply opnode' ); |
45 | |
46 | my $rhe = $cop->hints_hash; |
47 | isa_ok( $rhe, 'B::RHE', 'got hints_hash' ); |
48 | |
49 | my $hints_hash = $rhe->HASH; |
50 | is( ref($hints_hash), 'HASH', 'Got hash reference' ); |
51 | |
52 | ok( not( exists $hints_hash->{mypragma} ), q[! exists mypragma] ); |
53 | } |
54 | |
55 | { |
56 | |
57 | # Pragmas can be fetched. |
58 | my $cop = find_op_cop( \&foo, qr/add/ ); |
59 | isa_ok( $cop, 'B::COP', 'found pp_add opnode' ); |
60 | |
61 | my $rhe = $cop->hints_hash; |
62 | isa_ok( $rhe, 'B::RHE', 'got hints_hash' ); |
63 | |
64 | my $hints_hash = $rhe->HASH; |
65 | is( ref($hints_hash), 'HASH', 'Got hash reference' ); |
66 | |
67 | is( $hints_hash->{mypragma}, 42, q[mypragma => 42] ); |
68 | } |
69 | |
70 | { |
71 | |
72 | # Pragmas can be changed. |
73 | my $cop = find_op_cop( \&foo, qr/subtract/ ); |
74 | isa_ok( $cop, 'B::COP', 'found pp_subtract opnode' ); |
75 | |
76 | my $rhe = $cop->hints_hash; |
77 | isa_ok( $rhe, 'B::RHE', 'got hints_hash' ); |
78 | |
79 | my $hints_hash = $rhe->HASH; |
80 | is( ref($hints_hash), 'HASH', 'Got hash reference' ); |
81 | |
82 | is( $hints_hash->{mypragma}, 0, q[mypragma => 0] ); |
83 | } |
84 | exit; |
85 | |
86 | our $COP; |
87 | |
88 | sub find_op_cop { |
89 | my ( $sub, $op ) = @_; |
90 | my $cv = svref_2object($sub); |
91 | local $COP; |
92 | |
93 | if ( not _find_op_cop( $cv->ROOT, $op ) ) { |
94 | $COP = undef; |
95 | } |
96 | |
97 | return $COP; |
98 | } |
99 | |
100 | { |
101 | |
102 | # Make B::NULL objects evaluate as false. |
103 | package B::NULL; |
104 | use overload 'bool' => sub () { !!0 }; |
105 | } |
106 | |
107 | sub _find_op_cop { |
108 | my ( $op, $name ) = @_; |
109 | |
110 | # Fail on B::NULL or whatever. |
111 | return 0 if not $op; |
112 | |
113 | # Succeed when we find our match. |
114 | return 1 if $op->name =~ $name; |
115 | |
116 | # Stash the latest seen COP opnode. This has our hints hash. |
117 | if ( $op->isa('B::COP') ) { |
118 | |
119 | # print Dumper( |
120 | # { cop => $op, |
121 | # hints => $op->hints_hash->HASH |
122 | # } |
123 | # ); |
124 | $COP = $op; |
125 | } |
126 | |
127 | # Recurse depth first passing success up if it happens. |
128 | if ( $op->can('first') ) { |
129 | return 1 if _find_op_cop( $op->first, $name ); |
130 | } |
131 | return 1 if _find_op_cop( $op->sibling, $name ); |
132 | |
133 | # Oh well. Hopefully our caller knows where to try next. |
134 | return 0; |
135 | } |
136 | |