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