ext/B/t/pragma.t

   1 #!./perl -w
   2
   3 BEGIN {    ## 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
  22 use strict;
  23 use warnings;
  24 use Test::More tests => 4 * 3;
  25 use B 'svref_2object';
  26
  27 # use Data::Dumper 'Dumper';
  28
  29 sub 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 }
  88 exit;
  89
  90 our $COP;
  91
  92 sub 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
 111 sub _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