File Coverage

lib/Test/Stream/Plugin/Hide.pm

Criterion	Covered	Total	%
statement	90	90	100.0
branch	22	24	91.6
condition	4	4	100.0
subroutine	20	20	100.0
pod	3	4	75.0
total	139	142	97.8

package Test::Stream::Plugin::Hide;
use strict;
use warnings;

use Test::Stream::Util qw/try/;

our $VERSION = '0.000001';

my %HIDE;

# For testing
{
    no warnings 'once';
    *HIDE = sub { \%HIDE } if $Test::Stream::Plugin::Hide::TESTING;
}

# regexp for valid module name. Lifted from Module::Runtime and
# UNIVERSAL::require (modified to have anchors)
my $module_name_rx = qr/^[A-Z_a-z][0-9A-Z_a-z]*(?:::[0-9A-Z_a-z]+)*$/;

# Subs we cannot prefix with underscore, but do not want to export.
my %BAD = (
    import         => 1,
    unimport       => 1,
    load_ts_plugin => 1,
    HIDE           => 1,
);

sub load_ts_plugin {
    my $class = shift;
    my ($caller, @hide) = @_;

    my @real_hide;
    for my $hide (@hide) {
        if ($hide =~ m/^-([^_].*)$/) {
            my $name = $1;

            if ($name eq 'all') {
                my $stash = \%Test::Stream::Plugin::Hide::;
                for my $name (keys %$stash) {
                    next if $BAD{$name};
                    next if $name =~ m/^_/;
                    my $sub = $class->can($name) || next;

                    no strict 'refs';
                    *{$caller->[0] . "::$name"} = $sub;
                }
            }
            else {
                my $error = "$class does not export $name() at $caller->[1] line $caller->[2]\n";
                die $error if $BAD{$name};
                my $sub = $class->can($name) || die $error;

                no strict 'refs';
                *{$caller->[0] . "::$name"} = $sub;
            }
        }
        else {
            push @real_hide => $hide;
        }
    }
    _hide($caller, @real_hide);
}

sub import {
    my $class = shift;
    my @caller = caller;
    $class->load_ts_plugin(\@caller, @_);
}

sub unimport {
    my $class = shift;
    unhide(@_);
}

sub unhide {
    my @caller = caller;
    _unhide(\@caller, map {_mod_to_file($_, \@caller) => 1} @_);
}

sub hide {
    my @caller = caller;
    _hide(\@caller, @_);
}

sub do_hidden(&;@) {
    my ($code, @mods) = @_;

    # Copy %HIDE
    my %orig = %HIDE;
    my @caller = caller;

    my ($ok, $error) = try {
        _hide(\@caller, @mods);
        $code->();
    };

    # Unhide the new keys
    _unhide(\@caller, grep {!$orig{$_}} keys %HIDE);

    # Die if we failed, otherwise just return.
    die $error unless $ok;
    return;
}

sub _mod_to_file {
    my ($mod, $caller) = @_;

    die "'$mod' does not appear to be a valid module at $caller->[1] line $caller->[2]\n"
        unless $mod =~ $module_name_rx;

    my $file = $mod;
    $file =~ s{::}{/}g;
    $file .= '.pm';
    return $file;
}

sub _hide {
    my $caller = shift;
    for my $mod (@_) {
        my $file = _mod_to_file($mod, $caller);
        $HIDE{$file} = 1;
        next unless $INC{$file};
        die "Module '$mod' was already loaded from '$INC{$file}' before hide was requested at $caller->[1] line $caller->[2]\n";
    }
    _munge_inc();
}

sub _unhide {
    my $caller = shift;
    for my $file (@_) {
        delete $HIDE{$file};
        delete $INC{$file} unless defined $INC{$file};
    }
    _munge_inc();
}

sub _munge_inc { @INC = (\&_hook, grep { !ref($_) || $_ != \&_hook } @INC); 1 }

sub _hook {
    my ($this, $file) = @_;
    _munge_inc(); # Try to keep the hook in front.
    return unless $HIDE{$file};

    my $error = "die q|Can't locate $file in \@INC (Hidden by request)\n|;\n";
    open(my $handle, '<', \$error) || die $!;
    return $handle;
}

1;

__END__