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