File Coverage

blib/lib/IO/Die.pm

Criterion	Covered	Total	%
statement	25	38	65.7
branch	3	8	37.5
condition	1	3	33.3
subroutine	8	9	88.8
pod			n/a
total	37	58	63.7

package IO::Die;

use 5.006;
use strict;

#not in production
#use warnings;

=head1 NAME

IO::Die - Namespaced, error-checked I/O

=head1 VERSION

Version 0.057

=cut

our $VERSION = '0.057';

#----------------------------------------------------------------------
#PROTECTED

#Override in subclasses as needed
sub _CREATE_ERROR {
    shift;
    return shift() . ": " . join( ' ', map { defined() ? $_ : q<> } @_ );
}

sub _DO_WITH_ERROR { die $_[1] }

#----------------------------------------------------------------------
#PRIVATES

sub __THROW {
    my ( $NS, $type, @args ) = @_;

    $NS->_DO_WITH_ERROR(
        $NS->_CREATE_ERROR(
            $type,
            @args,
            OS_ERROR          => $!,
            EXTENDED_OS_ERROR => $^E,
        )
    );
}

sub __is_a_fh {
    my ($thing) = @_;

    my $is_fh;

    #Every file handle is a GLOB reference. This would be sufficient, except
    #GLOBs can also be symbol table references.
    if ( UNIVERSAL::isa( $thing, 'GLOB' ) ) {

        # You can’t tie() a symbol table reference, so if we’re tied(),
        # then this is a filehandle.
        #
        # If we’re not tied(), then we have to check fileno().
        $is_fh = ( tied *{$thing} ) || defined( CORE::fileno($thing) );
    }

    return $is_fh;
}

#----------------------------------------------------------------------

our $AUTOLOAD;
sub AUTOLOAD {
    $AUTOLOAD =~ s<.*::><>;

    local ($!, $^E);

    my $reldir = __PACKAGE__;
    $reldir =~ s<::>g;

    require "$reldir/$AUTOLOAD.pm";

    return __PACKAGE__->can($AUTOLOAD)->(@_);
}

sub import {
    my ($class, @tags) = @_;

    for my $t (@tags) {
        if ($t eq ':preload') {
            $class->_preload();
        }
    }

    return;
}

sub _preload {
    my ($class) = @_;

    my $path = __FILE__;
    $path =~ s<\.pm\z><>;

    my $reldir = __PACKAGE__;
    $reldir =~ s<::>g;

    $class->opendir( my $dh, $path );
    local ($!, $^E);
    while ( my $node = readdir $dh ) {
        next if substr( $node, -3 ) ne '.pm';
        require "$reldir/$node";
    }

    return;
}

1;

__END__