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