xref: /openbsd/gnu/usr.bin/perl/ext/B/t/pragma.t (revision 73471bf0) 
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}
15
16use strict;
17use warnings;
18use Test::More tests => 4 * 3;
19use B 'svref_2object';
20
21# use Data::Dumper 'Dumper';
22
23sub 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}
82exit;
83
84our $COP;
85
86sub 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
105sub _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
135