ext/B/t/pragma.t

   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