File Coverage

blib/lib/Test2/Plugin/OpenFixPerlIO.pm

Criterion	Covered	Total	%
statement	71	73	97.2
branch	15	22	68.1
condition	7	12	58.3
subroutine	12	13	92.3
pod			n/a
total	105	120	87.5

package Test2::Plugin::OpenFixPerlIO;
use strict;
use warnings;

our $VERSION = '0.000009';

use Carp qw/cluck/;
use PerlIO;

BEGIN {
    return if $] >= 5.027001;

    my $maker = sub {
        my ($pkg) = @_;
        my ($open, $layers, $binmode);

        my $ok = eval "#line ${ \__LINE__ } \"${ \__FILE__ }\"\n
        package $pkg;" . '

        $open = sub {
            no strict q(refs);
            return CORE::open($_[0]) if @_ == 1;
            return CORE::open($_[0], $_[1]) if @_ == 2;
            return CORE::open($_[0], $_[1], @_[2 .. $#_]);
        };

        $layers = sub { PerlIO::get_layers($_[0]) };

        $binmode = sub { binmode($_[0], $_[1]) };

        1;
        ';
        die "Eval failed for ${pkg}: $@" unless $ok;
        return [$open, $layers, $binmode];
    };

    my %opens;
    my $new_open = sub (*;$@) {
        my ($in, @args) = @_;

        my $caller = caller;

        $opens{$caller} ||= $maker->($caller);

        my @keep_layers;

        if ($args[0] =~ m/^(\+?>{1,2})\&(.*)$/) {
            my $handle = $2 || $args[1];

            my $is_fileno = $handle =~ m/^\d+$/;

            my @layers = $opens{$caller}->[1]->($handle);
            @keep_layers = grep { $_ ne 'via' } @layers;

            if (!$is_fileno && @layers != @keep_layers) {
                my $fileno;
                if (ref($handle) eq 'GLOB') {
                    $fileno = fileno($handle);
                }
                elsif ($handle =~ m/^\d+$/) {
                    $fileno = $handle;
                }
                else {
                    no strict 'refs';
                    no warnings 'once';
                    $fileno = $handle =~ m/^\*(.*)$/ ? fileno(\*{$1}) : fileno(\*{"$caller\::$handle"});
                }

                $args[0] =~ s/\Q$handle\E$//;
                $args[1] = $fileno;
            }
            else {
                @keep_layers = ();
            }
        }

        # Need to pass $_[0] in for magic.
        my $out = $opens{$caller}->[0]->($_[0], @args);
        return $out unless defined $out;

        if (@keep_layers) {
            my %have = map {$_ => 1} $opens{$caller}->[1]->($_[0]);
            my $binmode = join '' => map ":$_", grep { !$have{$_} } @keep_layers;
            $opens{$caller}->[2]->($_[0], $binmode) if $binmode;
        }
        return $out;
    };

    bless $new_open, __PACKAGE__;

    no warnings 'once';
    *CORE::GLOBAL::open = $new_open;

    # Make sure the global reference is the only reference
    $new_open = undef;
}

my $WE_CARE = 1;
END { $WE_CARE = 0 };
sub DESTROY {
    cluck "DESTROYED 'CORE::GLOBAL::open' override before it was time!" if $WE_CARE && !$^C;
};

1;

__END__