File Coverage

blib/lib/IO/Die.pm

Criterion	Covered	Total	%
statement	9	213	4.2
branch	0	96	0.0
condition	0	72	0.0
subroutine	3	39	7.6
pod			n/a
total	12	420	2.8

package IO::Die;

use 5.006;
use strict;
use warnings;

=head1 NAME

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

=head1 VERSION

Version 0.01

=cut

our $VERSION = '0.01';

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

#Override in subclasses as needed
sub _CREATE_ERROR {
    shift;
    return shift . ": @_";
}

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;
}

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

#NOTE: This function does not attempt to support every possible way of calling
#Perl’s open() built-in, but to support the minimal syntax required to do
#everything that is useful to do with open(), with preference given to those
#forms that may (somewhat arbitrarily) be considered "better".
#
#For example, this function does NOT allow one-arg or two-arg open() except for
#the more "useful" cases like when MODE is '-|' or '|-'.
#
#On the other hand, open($fh, '-') seems harder to understand than its 3-arg
#equivalent, open($fh, '<&=', STDIN), so that two-arg form is unsupported.
#
#Current forms of open() that this supports are:
#   - any form of 3 or more arguments
#   - 2-arg when the MODE is '-|' or '|-'
#
#NOTE: Bareword file handles DO NOT WORK. (Auto-vivification does, though.)
#
sub open {
    my ( $NS, $handle_r, $mode, $expr, @list ) = ( shift, \shift, @_ );

    die "Avoid bareword file handles." if !ref $$handle_r && length $$handle_r;
    die "Avoid one-argument open()." if !$mode;

    local ( $!, $^E );
    if ( !defined $expr ) {
        if ( $mode eq '|-' or $mode eq '-|' ) {

            #NOTE: Avoid // for compatibility with old Perl versions.
            my $open = CORE::open( $$handle_r, $mode );
            if ( !defined $open ) {
                $NS->__THROW('Fork');
            }

            return $open;
        }

        my $file = __FILE__;
        die "Avoid most forms of two-argument open(). (See $file and its tests for allowable forms.)";
    }

    return CORE::open( $$handle_r, $mode, $expr, @list ) || do {
        if ( $mode eq '|-' || $mode eq '-|' ) {
            my $cmd = $expr;

            #If the EXPR (cf. perldoc -f open) has spaces and no LIST
            #is given, then Perl interprets EXPR as a space-delimited
            #shell command, the first component of which is the actual
            #command.
            if ( !@list ) {
                ($cmd) = ( $cmd =~ m<\A(\S+)> );
            }

            $NS->__THROW( 'Exec', path => $cmd, arguments => \@list );
        }

        if ( 'SCALAR' eq ref $expr ) {
            $NS->__THROW('ScalarOpen');
        }

        $NS->__THROW( 'FileOpen', mode => $mode, path => $expr );
    };
}

sub sysopen {
    my ( $NS, $handle_r, @post_handle_args ) = ( shift, \shift, @_ );

    my ( $path, $mode, $perms ) = @post_handle_args;

    local ( $!, $^E );

    my $ret;
    if ( @post_handle_args < 3 ) {
        $ret = CORE::sysopen( $$handle_r, $path, $mode );
    }
    else {
        $ret = CORE::sysopen( $$handle_r, $path, $mode, $perms );
    }

    #XXX: Perl bug? $! is often set here even when $ret is truthy.

    if ( !$ret ) {
        $NS->__THROW( 'FileOpen', path => $path, mode => $mode, mask => $perms );
    }

    return $ret;
}

sub chroot {
    my ( $NS, $filename ) = @_;

    local ( $!, $^E );

    if (!defined $filename) {
        $filename = $_;
    }

    return CORE::chroot($filename) || do {
        $NS->__THROW( 'Chroot', filename => $filename );
    };
}

#A bit more restrictive than Perl’s built-in print():
#   - A file handle is still optional, but it MUST be a reference.
#
#This does still fall back to $_ and does still use the default file handle
#if either the LIST or FILEHANDLE is omitted (cf. perldoc -f print).
#
sub print {
    my ( $NS, $args_ar ) = ( shift, \@_ );

    local ( $!, $^E );

    my $ret;
    if ( __is_a_fh( $args_ar->[0] ) ) {
        $ret = CORE::print { shift @$args_ar } ( @$args_ar ? @$args_ar : $_ );
    }
    else {
        $ret = CORE::print( @$args_ar ? @$args_ar : $_ );
    }

    if ($^E) {

        #Figure out the "length" to report to the exception object.
        my $length;
        if (@$args_ar) {
            $length = 0;
            $length += length for @$args_ar;
        }
        else {
            $length = length;
        }

        $NS->__THROW( 'Write', length => $length );
    }

    return $ret;
}

sub syswrite {
    my ( $NS, $fh, $buffer_sr, @length_offset ) = ( shift, shift, \shift, @_ );

    my ( $length, $offset ) = @length_offset;

    local ( $!, $^E );

    my $ret;
    if ( @length_offset > 1 ) {
        $ret = CORE::syswrite( $fh, $$buffer_sr, $length, $offset );
    }
    elsif (@length_offset) {
        $ret = CORE::syswrite( $fh, $$buffer_sr, $length );
    }
    else {
        $ret = CORE::syswrite( $fh, $$buffer_sr );
    }

    if ( !defined $ret ) {
        my $real_length = length $$buffer_sr;

        if ($offset) {
            if ( $offset > 0 ) {
                $real_length -= $offset;
            }
            else {
                $real_length = 0 - $offset;
            }
        }

        if ( defined $length && $length < $real_length ) {
            $real_length = $length;
        }

        $NS->__THROW( 'Write', length => $real_length );
    }

    return $ret;
}

#----------------------------------------------------------------------
#NOTE: read() and sysread() implementations are exactly the same except
#for the CORE:: function call.  Alas, Perl’s prototyping stuff seems to
#make it impossible not to duplicate code here.

sub read {
    my ( $NS, $fh, $buffer_sr, @length_offset ) = ( shift, shift, \shift, @_ );

    my ( $length, $offset ) = @length_offset;

    local ( $!, $^E );

    #NOTE: Perl’s prototypes can throw errors on things like:
    #(@length_offset > 1) ? $offset : ()
    #...so the following writes out the two forms of read():

    my $ret;
    if ( @length_offset > 1 ) {
        $ret = CORE::read( $fh, $$buffer_sr, $length, $offset );
    }
    else {
        $ret = CORE::read( $fh, $$buffer_sr, $length );
    }

    if ( !defined $ret ) {
        $NS->__THROW( 'Read', length => $length );
    }

    return $ret;
}

sub sysread {
    my ( $NS, $fh, $buffer_sr, @length_offset ) = ( shift, shift, \shift, @_ );

    my ( $length, $offset ) = @length_offset;

    local ( $!, $^E );

    #NOTE: Perl’s prototypes can throw errors on things like:
    #(@length_offset > 1) ? $offset : ()
    #...so the following writes out the two forms of sysread():

    my $ret;
    if ( @length_offset > 1 ) {
        $ret = CORE::sysread( $fh, $$buffer_sr, $length, $offset );
    }
    else {
        $ret = CORE::sysread( $fh, $$buffer_sr, $length );
    }

    if ( !defined $ret ) {
        $NS->__THROW( 'Read', length => $length );
    }

    return $ret;
}

sub close {
    my ($NS, $fh ) = @_;

    local ( $!, $^E );
    return ( $fh ? CORE::close($fh) : CORE::close() ) || do {
        $NS->__THROW('Close');
    };
}

#NOTE: See above about read/sysread; the same duplicated code problem
#applies to seek/sysseek.

sub seek {
    my ( $NS, $fh, $pos, $whence ) = @_;

    local ( $!, $^E );
    return CORE::seek( $fh, $pos, $whence ) || do {
        $NS->__THROW( 'FileSeek', whence => $whence, position => $pos );
    };
}

sub sysseek {
    my ( $NS, $fh, $pos, $whence ) = @_;

    local ( $!, $^E );
    return CORE::sysseek( $fh, $pos, $whence ) || do {
        $NS->__THROW( 'FileSeek', whence => $whence, position => $pos );
    };
}

sub truncate {
    my ( $NS, $fh_or_expr, $length ) = @_;

    local ( $!, $^E );
    return CORE::truncate( $fh_or_expr, $length ) || do {
        $NS->__THROW( 'FileTruncate', length => $length );
    };
}

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

sub opendir {
    my ( $NS, $dh_r, $dir ) = ( shift, \shift, shift );

    local ( $!, $^E );
    return CORE::opendir( $$dh_r, $dir ) || do {
        $NS->__THROW( 'DirectoryOpen', path => $dir );
    };
}

sub rewinddir {
    my ($NS, $dh) = @_;

    local ( $!, $^E );
    return CORE::rewinddir($dh) || do {
        $NS->__THROW('DirectoryRewind');
    };
}

sub closedir {
    my ($NS, $dh) = @_;

    local ( $!, $^E );
    return CORE::closedir($dh) || do {
        $NS->__THROW('DirectoryClose');
    };
}

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

#NOTE: To get stat(_), do stat(\*_).
sub stat {
    my ($NS, $path_or_fh) = @_;

    local ( $!, $^E );

    my $ret = wantarray ? [ CORE::stat($path_or_fh) ] : CORE::stat($path_or_fh);

    if ($^E) {
        if ( __is_a_fh($path_or_fh) ) {
            $NS->__THROW('Stat');
        }

        $NS->__THROW( 'Stat', path => $path_or_fh );
    }

    return wantarray ? @$ret : $ret;
}

#NOTE: To get lstat(_), do lstat(\*_).
sub lstat {
    my ($NS, $path_or_fh) = @_;

    local ( $!, $^E );

    my $ret = wantarray ? [ CORE::lstat($path_or_fh) ] : CORE::lstat($path_or_fh);

    if ($^E) {
        if ( __is_a_fh($path_or_fh) ) {
            $NS->__THROW('Stat');
        }

        $NS->__THROW( 'Stat', path => $path_or_fh );
    }

    return wantarray ? @$ret : $ret;
}

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

sub fileno {
    my ( $NS, $fh ) = @_;

    local ( $!, $^E );
    my $fileno = CORE::fileno($fh);

    if (!defined $fileno) {
        $NS->__THROW( 'Fileno' );
    }

    return $fileno;
}

sub flock {
    my ( $NS, $fh, $operation ) = @_;

    local ( $!, $^E );
    return CORE::flock( $fh, $operation ) || do {
        $NS->__THROW( 'Flock', operation => $operation );
    };
}

#NOTE: This will only chmod() one thing at a time. It refuses to support
#multiple chmod() operations within the same call. This is in order to provide
#reliable error reporting.
#
#You, of course, can still do: IO::Die::chmod() for @items;
#
sub chmod {
    my ( $NS, $mode, $target, @too_many_args ) = @_;

    #This is here because it’s impossible to do reliable error-checking when
    #you operate on >1 filesystem node at once.
    die "Only one path at a time!" if @too_many_args;

    #NOTE: This breaks chmod’s error reporting when a file handle is passed in.
    #cf. https://rt.perl.org/Ticket/Display.html?id=122703
    local ( $!, $^E );

    return CORE::chmod( $mode, $target ) || do {
        if ( __is_a_fh($target) ) {
            $NS->__THROW( 'Chmod', permissions => $mode );
        }

        $NS->__THROW( 'Chmod', permissions => $mode, path => $target );
    };
}

#NOTE: This will only chown() one thing at a time. It refuses to support
#multiple chown() operations within the same call. This is in order to provide
#reliable error reporting.
#
#You, of course, can still do: IO::Die::chown() for @items;
#
sub chown {
    my ( $NS, $uid, $gid, $target, @too_many_args ) = @_;

    #This is here because it’s impossible to do reliable error-checking when
    #you operate on >1 filesystem node at once.
    die "Only one path at a time!" if @too_many_args;

    local ( $!, $^E );

    return CORE::chown( $uid, $gid, $target ) || do {
        if ( __is_a_fh($target) ) {
            $NS->__THROW( 'Chown', uid => $uid, gid => $gid );
        }

        $NS->__THROW( 'Chown', uid => $uid, gid => $gid, path => $target );
    };
}

sub link {
    my ( $NS, $old, $new ) = @_;

    local ( $!, $^E );
    return CORE::link( $old, $new ) || do {
        $NS->__THROW( 'Link', oldpath => $old, newpath => $new );
    };
}

sub symlink {
    my ( $NS, $old, $new ) = @_;

    local ( $!, $^E );
    return CORE::symlink( $old, $new ) || do {
        $NS->__THROW( 'SymlinkCreate', oldpath => $old, newpath => $new );
    };
}

sub readlink {
    my $NS = shift;
    my $path = @_ ? shift : $_;

    local ( $!, $^E );
    return CORE::readlink($path) || do {
        $NS->__THROW( 'SymlinkRead', path => $path );
    };
}

sub rename {
    my ( $NS, $old, $new ) = @_;

    local ( $!, $^E );
    return CORE::rename( $old, $new ) || do {
        $NS->__THROW( 'Rename', oldpath => $old, newpath => $new );
    };
}

#NOTE: This will only unlink() one file at a time. It refuses to support
#multiple unlink() operations within the same call. This is in order to provide
#reliable error reporting.
#
#You, of course, can still do: IO::Die::unlink() for @files;
#
sub unlink {
    my ($NS, @paths) = @_;

    #This is here because it’s impossible to do reliable error-checking when
    #you operate on >1 filesystem node at once.
    die "Only one path at a time!" if @paths > 1;

    if ( !@paths ) {
        @paths = ($_);
    }

    local ( $!, $^E );
    return CORE::unlink(@paths) || do {
        $NS->__THROW( 'Unlink', path => $paths[0] );
    };
}

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

    local ( $!, $^E );

    my $ret;
    if ( @args > 1 ) {
        $ret = CORE::mkdir $args[0], $args[1];
    }
    else {
        if ( !@args ) {
            @args = ($_);
        }

        $ret = CORE::mkdir( $args[0] );
    }

    if ( !$ret ) {
        $NS->__THROW( 'DirectoryCreate', path => $args[0], mask => $args[1] );
    }

    return $ret;
}

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

    #Perl's rmdir() doesn’t actually allow batching like this,
    #but we might as well prevent anyone from trying.
    die "Only one path at a time!" if @args > 1;

    if ( !@args ) {
        @args = ($_);
    }

    local ( $!, $^E );
    return CORE::rmdir( $args[0] ) || do {
        $NS->__THROW( 'DirectoryDelete', path => $args[0] );
    };
}

sub fork {
    my ($NS) = @_;

    my $pid = fork;

    $NS->__THROW('Fork') if !defined $pid;

    return $pid;
}

sub kill {
    my ( $NS, $sig, @list ) = @_;

    die "Only 1 process!" if @list > 1;

    local ( $!, $^E );
    my $ret = CORE::kill( $sig, @list );
    if ($!) {
        $NS->__THROW( 'Kill', signal => $sig, process => $list[0] );
    }

    return $ret;
}

sub exec {
    my ($NS, $progname) = @_;

    exec {$progname} $progname, @_ or do {
        $NS->__THROW( 'Exec', program => $progname, arguments => \@_ );
    };
}

sub pipe {
    my ( $NS, $read_r, $write_r ) = ( shift, \shift, \shift );

    local ( $!, $^E );
    return CORE::pipe( $$read_r, $$write_r ) || do {
        $NS->__THROW('Pipe');
    };
}

my $DEFAULT_BINMODE_LAYER = ':raw';    #cf. perldoc -f binmode

sub binmode {
    my ( $NS, $fh_r, $layer ) = @_;

    if ( !defined $layer ) {
        $layer = $DEFAULT_BINMODE_LAYER;
    }

    local ( $!, $^E );
    return binmode( $fh_r, $layer ) || do {
        $NS->__THROW( 'Binmode', layer => $layer );
    };
}

sub utime {
    my ( $NS, $atime, $mtime, @files ) = @_;

    local ( $!, $^E );
    return utime( $fh, $atime, $mtime, @files ) || do {
        $NS->__THROW('Utime', atime => $atime, mtime => $mtime, files => \@files);
    };
}

sub fcntl {
    my ( $NS, $fh, $func, $scalar ) = @_;

    local ( $!, $^E );
    return fcntl( $fh, $func, $scalar ) || do {
        $NS->__THROW('Fcntl');
    };
}

sub select {
    my ( $NS, $rbits_r, $wbits_r, $ebits_r, $timeout ) = ( shift, \$_[0], \$_[1], \$_[2], $_[3] );

    #Perl::Critic says not to use one-arg select() anyway.
    die "Need four args!" if @_ < 4;

    local ( $!, $^E );
    my ( $nfound, $timeleft ) = CORE::select( $$rbits_r, $$wbits_r, $$ebits_r, $timeout );

    if ($^E) {
        $NS->__THROW('Select');
    }

    return wantarray ? ( $nfound, $timeleft ) : $nfound;
}

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

sub socket {
    my ( $NS, $socket_r, $domain, $type, $protocol ) = ( shift, \shift, shift, shift, shift );

    local ( $!, $^E );
    return socket( $$socket_r, $domain, $type, $protocol ) || do {
        $NS->__THROW( 'SocketOpen', domain => $domain, type => $type, protocol => $protocol );
    };
}

sub socketpair {
    my ( $NS, $socket1_r, $socket2_r, $domain, $type, $protocol ) = ( \shift, shift, shift, shift );

    local ( $!, $^E );
    return socketpair( $$socket1_r, $$socket2_r, $domain, $type, $protocol ) || do {
        $NS->__THROW( 'SocketPair', domain => $domain, type => $type, protocol => $protocol );
    };
}

sub bind {
    my ( $NS, $socket, $name ) = @_;

    local ( $!, $^E );
    return CORE::bind( $socket, $name ) || do {
        $NS->__THROW( 'SocketBind', name => $name );
    };
}

sub connect {
    my ( $NS, $socket, $name ) = @_;

    local ( $!, $^E );
    return CORE::connect( $socket, $name ) || do {
        $NS->__THROW( 'SocketConnect', name => $name );
    };
}

sub accept {
    my ( $NS, $new_socket, $generic_socket ) = @_;

    local ( $!, $^E );
    return CORE::accept( $new_socket, $generic_socket ) || do {
        $NS->__THROW('SocketAccept');
    };
}

sub getsockopt {
    my ( $NS, $socket, $level, $optname ) = @_;

    local ( $!, $^E );
    my $res = CORE::getsockopt( $socket, $level, $optname );
    if ( !defined $res ) {
        $NS->__THROW( 'SocketGetOpt', level => $level, optname => $optname );
    }

    return $res;
}

sub setsockopt {
    my ( $NS, $socket, $level, $optname, $optval ) = @_;

    local ( $!, $^E );
    my $res = CORE::setsockopt( $socket, $level, $optname, $optval );
    if ( !defined $res ) {
        $NS->__THROW( 'SocketSetOpt', level => $level, optname => $optname, optval => $optval );
    }

    return $res;
}

sub listen {
    my ( $NS, $socket, $queuesize ) = @_;

    local ( $!, $^E );
    return CORE::listen( $socket, $queuesize ) || do {
        $NS->__THROW( 'SocketListen', queuesize => $queuesize );
    };
}

sub recv {
    my ( $NS, $socket, $scalar_r, $length, $flags ) = ( shift, \shift, @_ );

    local ( $!, $^E );
    my $res = CORE::recv( $socket, $$scalar_r, $length, $flags );
    if ( !defined $res ) {
        $NS->__THROW( 'SocketReceive', length => $length, flags => $flags );
    }

    return $res;
}

sub send {
    my ( $NS, $socket, $msg_r, $flags, $to ) = ( shift, \shift, @_ );

    local ( $!, $^E );
    my $res;
    if ( defined $to ) {
        $res = CORE::send( $socket, $$msg_r, $flags, $to );
    }
    else {
        $res = CORE::send( $socket, $$msg_r, $flags );
    }

    if ( !defined $res ) {
        $NS->__THROW( 'SocketSend', length => length($$msg_r), flags => $flags );
    }

    return $res;
}

sub shutdown {
    my ( $NS, $socket, $how ) = @_;

    local ($!, $^E);

    my $res = CORE::shutdown( $socket, $how );
    if ( !$res ) {
        die "Invalid filehandle!" if !defined $res;
        $NS->__THROW( 'SocketShutdown', how => $how );
    }

    return $res;
}

#----------------------------------------------------------------------
# CONVENIENCE
#

my $Fcntl_SEEK_CUR = 1;

#Note that, since we die() on error, this does NOT return "0 but true"
#as sysseek() does; instead it returns just a plain 0.
sub systell {
    my ($NS, $fh) = @_;

    #cf. perldoc -f tell
    return 0 + $NS->sysseek( $fh, 0, $Fcntl_SEEK_CUR );
}

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

__END__