Gecko [ www.blackthorn-inc.com ]

Name	Size	Permission	Date
OptreeCheck.pm	31.93 KB	-r--r--r--	2014-12-27 11:49
b.t	13.51 KB	-r--r--r--	2014-12-27 11:49
concise-xs.t	11.9 KB	-r--r--r--	2014-12-27 11:49
concise.t	13.9 KB	-r--r--r--	2014-12-27 11:49
f_map	707 B	-r--r--r--	2014-12-27 11:48
f_map.t	14.32 KB	-r--r--r--	2014-12-27 11:49
f_sort	2.43 KB	-r--r--r--	2014-12-27 11:48
f_sort.t	25.32 KB	-r--r--r--	2014-12-27 11:49
o.t	2 KB	-r--r--r--	2014-12-27 11:48
optree_check.t	6.67 KB	-r--r--r--	2014-12-27 11:49
optree_concise.t	14.5 KB	-r--r--r--	2014-12-27 11:49
optree_constants.t	15.5 KB	-r--r--r--	2014-12-27 11:48
optree_misc.t	17.38 KB	-r--r--r--	2014-12-27 11:49
optree_samples.t	22.36 KB	-r--r--r--	2014-12-27 11:49
optree_sort.t	8.05 KB	-r--r--r--	2014-12-27 11:49
optree_specials.t	14.43 KB	-r--r--r--	2014-12-27 11:49
optree_varinit.t	12.02 KB	-r--r--r--	2014-12-27 11:49
pragma.t	2.77 KB	-r--r--r--	2014-12-27 11:48
showlex.t	2.79 KB	-r--r--r--	2014-12-27 11:49
terse.t	2.63 KB	-r--r--r--	2014-12-27 11:48
walkoptree.t	1.98 KB	-r--r--r--	2014-12-27 11:48
xref.t	2.75 KB	-r--r--r--	2014-12-27 11:48

Rename

#!./perl -w

BEGIN {    ## no critic strict
    if ( $ENV{PERL_CORE} ) {
	unshift @INC, '../../t/lib';
    } else {
        unshift @INC, 't';
    }
    require Config;
    if ( ( $Config::Config{'extensions'} !~ /\bB\b/ ) ) {
        print "1..0 # Skip -- Perl configured without B module\n";
        exit 0;
    }
}

use strict;
use warnings;
use Test::More tests => 4 * 3;
use B 'svref_2object';

# use Data::Dumper 'Dumper';

sub foo {
    my ( $x, $y, $z );

# hh => {},
    $z = $x * $y;

# hh => { mypragma => 42 }
    use mypragma;
    $z = $x + $y;

# hh => { mypragma => 0 }
    no mypragma;
    $z = $x - $y;
}

{

# Pragmas don't appear til they're used.
    my $cop = find_op_cop( \&foo, qr/multiply/ );
    isa_ok( $cop, 'B::COP', 'found pp_multiply opnode' );

my $rhe = $cop->hints_hash;
    isa_ok( $rhe, 'B::RHE', 'got hints_hash' );

my $hints_hash = $rhe->HASH;
    is( ref($hints_hash), 'HASH', 'Got hash reference' );

ok( not( exists $hints_hash->{mypragma} ), q[! exists mypragma] );
}

{

# Pragmas can be fetched.
    my $cop = find_op_cop( \&foo, qr/add/ );
    isa_ok( $cop, 'B::COP', 'found pp_add opnode' );

my $rhe = $cop->hints_hash;
    isa_ok( $rhe, 'B::RHE', 'got hints_hash' );

my $hints_hash = $rhe->HASH;
    is( ref($hints_hash), 'HASH', 'Got hash reference' );

is( $hints_hash->{mypragma}, 42, q[mypragma => 42] );
}

{

# Pragmas can be changed.
    my $cop = find_op_cop( \&foo, qr/subtract/ );
    isa_ok( $cop, 'B::COP', 'found pp_subtract opnode' );

my $rhe = $cop->hints_hash;
    isa_ok( $rhe, 'B::RHE', 'got hints_hash' );

my $hints_hash = $rhe->HASH;
    is( ref($hints_hash), 'HASH', 'Got hash reference' );

is( $hints_hash->{mypragma}, 0, q[mypragma => 0] );
}
exit;

our $COP;

sub find_op_cop {
    my ( $sub, $op ) = @_;
    my $cv = svref_2object($sub);
    local $COP;

if ( not _find_op_cop( $cv->ROOT, $op ) ) {
        $COP = undef;
    }

return $COP;
}

{

# Make B::NULL objects evaluate as false.
    package B::NULL;
    use overload 'bool' => sub () { !!0 };
}

sub _find_op_cop {
    my ( $op, $name ) = @_;

# Fail on B::NULL or whatever.
    return 0 if not $op;

# Succeed when we find our match.
    return 1 if $op->name =~ $name;

# Stash the latest seen COP opnode. This has our hints hash.
    if ( $op->isa('B::COP') ) {

# print Dumper(
        #     {   cop   => $op,
        #         hints => $op->hints_hash->HASH
        #     }
        # );
        $COP = $op;
    }

# Recurse depth first passing success up if it happens.
    if ( $op->can('first') ) {
        return 1 if _find_op_cop( $op->first, $name );
    }
    return 1 if _find_op_cop( $op->sibling, $name );

# Oh well. Hopefully our caller knows where to try next.
    return 0;
}