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