3 BEGIN { ## no critic strict
4 if ( $ENV{PERL_CORE} ) {
6 @INC = qw(../lib . lib);
12 if ( ( $Config::Config{'extensions'} !~ /\bB\b/ ) ) {
13 print "1..0 # Skip -- Perl configured without B module\n";
17 print "1..0 # Skip -- No user pragmata in 5.8.x\n";
24 use Test::More tests => 4 * 3;
25 use B 'svref_2object';
27 # use Data::Dumper 'Dumper';
35 # hh => { mypragma => 42 }
39 # hh => { mypragma => 0 }
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' );
50 my $rhe = $cop->hints_hash;
51 isa_ok( $rhe, 'B::RHE', 'got hints_hash' );
53 my $hints_hash = $rhe->HASH;
54 is( ref($hints_hash), 'HASH', 'Got hash reference' );
56 ok( not( exists $hints_hash->{mypragma} ), q[! exists mypragma] );
61 # Pragmas can be fetched.
62 my $cop = find_op_cop( \&foo, qr/add/ );
63 isa_ok( $cop, 'B::COP', 'found pp_add opnode' );
65 my $rhe = $cop->hints_hash;
66 isa_ok( $rhe, 'B::RHE', 'got hints_hash' );
68 my $hints_hash = $rhe->HASH;
69 is( ref($hints_hash), 'HASH', 'Got hash reference' );
71 is( $hints_hash->{mypragma}, 42, q[mypragma => 42] );
76 # Pragmas can be changed.
77 my $cop = find_op_cop( \&foo, qr/subtract/ );
78 isa_ok( $cop, 'B::COP', 'found pp_subtract opnode' );
80 my $rhe = $cop->hints_hash;
81 isa_ok( $rhe, 'B::RHE', 'got hints_hash' );
83 my $hints_hash = $rhe->HASH;
84 is( ref($hints_hash), 'HASH', 'Got hash reference' );
86 is( $hints_hash->{mypragma}, 0, q[mypragma => 0] );
93 my ( $sub, $op ) = @_;
94 my $cv = svref_2object($sub);
97 if ( not _find_op_cop( $cv->ROOT, $op ) ) {
106 # Make B::NULL objects evaluate as false.
108 use overload 'bool' => sub () { !!0 };
112 my ( $op, $name ) = @_;
114 # Fail on B::NULL or whatever.
117 # Succeed when we find our match.
118 return 1 if $op->name =~ $name;
120 # Stash the latest seen COP opnode. This has our hints hash.
121 if ( $op->isa('B::COP') ) {
125 # hints => $op->hints_hash->HASH
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 );
135 return 1 if _find_op_cop( $op->sibling, $name );
137 # Oh well. Hopefully our caller knows where to try next.