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