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