| 1 | #!./perl -w |
| 2 | |
| 3 | BEGIN { ## no critic strict |
| 4 | if ( $ENV{PERL_CORE} ) { |
| 5 | unshift @INC, '../../t/lib'; |
| 6 | } else { |
| 7 | unshift @INC, 't'; |
| 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 | |