pragma.t

source of perl for linux application,

#!./perl -w

BEGIN {    ## no critic strict
    if ( $ENV{PERL_CORE} ) {
        chdir('t') if -d 't';
	@INC = qw(../lib . 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;
    }
    if ( $] < 5.009 ) {
        print "1..0 # Skip -- No user pragmata in 5.8.x\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;
}