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