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