File Coverage

blib/lib/IPC/PrettyPipe/Stream.pm

Criterion	Covered	Total	%
statement	62	95	65.2
branch	11	34	32.3
condition	2	15	13.3
subroutine	16	25	64.0
pod	2	4	50.0
total	93	173	53.7

package IPC::PrettyPipe::Stream;

# ABSTRACT: An I/O stream for an B pipeline or command

use Carp;

use Types::Standard qw[ Bool Str ];

use IPC::PrettyPipe::Stream::Utils qw[ parse_spec ];

use String::ShellQuote 'shell_quote';
use IO::ReStoreFH;
use POSIX ();
use Fcntl qw[ O_RDONLY O_WRONLY O_CREAT O_TRUNC O_APPEND ];


use Moo;

our $VERSION = '0.11'; # TRIAL


with 'IPC::PrettyPipe::Queue::Element';

use namespace::clean;


my %fh_map = (
    0 => *STDIN,
    1 => *STDOUT,
    2 => *STDERR
);

my %op_map = (

    '<'  => O_RDONLY,
    '>'  => O_WRONLY | O_CREAT | O_TRUNC,
    '>>' => O_WRONLY | O_CREAT | O_APPEND

);

has N => (
    is        => 'rwp',
    predicate => 1,
    init_arg  => undef,
);
has M => (
    is        => 'rwp',
    predicate => 1,
    init_arg  => undef,
);
has Op => (
    is       => 'rwp',
    init_arg => undef,
);

has spec => (
    is       => 'rwp',
    isa      => Str,
    required => 1,
);

has file => (
    is        => 'rw',
    isa       => Str,
    predicate => 1,
);

has _type => (
    is       => 'rwp',
    isa      => Str,
    init_arg => undef,
);

has requires_file => (
    is       => 'rwp',
    init_arg => undef,
);

has strict => (
    is      => 'ro',
    isa     => Bool,
    default => sub { 1 } );





sub BUILDARGS {

    my $class = shift;

    if ( @_ == 1 ) {

        return $_[0] if 'HASH' eq ref( $_[0] );

        return { spec => $_[0][0], file => $_[0][1] }
          if 'ARRAY' eq ref( $_[0] ) && @{ $_[0] } == 2;

        return { spec => $_[0] };

    }

    return {@_};

}

sub BUILD {

    my $self = shift;

    ## no critic (ProhibitAccessOfPrivateData)

    my $opc = parse_spec( $self->spec );

    croak( __PACKAGE__, ': ', "cannot parse stream specification: ",
        $self->spec )
      unless defined $opc->{type};

    $self->_set_requires_file( $opc->{param} );
    $self->_set__type( $opc->{type} );

    $self->${ \"_set_$_" }( $opc->{$_} )
      for grep { exists $opc->{$_} } qw[ N M Op ];


    if ( $self->strict ) {

        croak( __PACKAGE__, ': ', "stream specification ",
            $self->spec, "requires a file\n" )
          if $self->requires_file && !$self->has_file;

        croak( __PACKAGE__, ': ', "stream specification ",
            $self->spec, "should not have a file\n" )
          if !$self->requires_file && $self->has_file;

    }

    return;
}

sub quoted_file { shell_quote( $_[0]->file ) }

sub _redirect {

    my ( $self, $N ) = @_;

    my $file = $self->file;

    my $sub;

    if ( defined $N ) {

        my $op = $self->Op;

        $sub = sub {
            open( $N, $op, $file ) or die( "unable to open ", $file, ": $!\n" );
        };
    }

    else {

        $N = $self->N;
        my $op = $op_map{ $self->Op }
          // croak( "error: unrecognized operator: ", $self->Op, "\n" );

        $sub = sub {
            my $nfd = POSIX::open( $file, $op, oct( 644 ) )
              or croak( 'error opening', $file, ": $!\n" );
            POSIX::dup2( $nfd, $N )
              or croak( "error in dup2( $nfd, $N ): $!\n" );
            POSIX::close( $nfd );
        };

    }

    return $sub, $N;
}

sub _dup {

    my ( $self, $N, $M ) = @_;

    $M //= $self->M;

    my $sub;

    # if $N is a known filehandle, we're in luck
    if ( defined $N ) {

        $sub = sub {
            open( $N, '>&', $M )
              or die( "error in open($N >& $M): $!\n" );
        };

    }

    else {

        $N = $self->N;
        $M = $self->M;

        $sub = sub {
            POSIX::dup2( $N, $M )
              or die( "error in dup2( $N, $M ): $!\n" );
        };

    }

    return $sub, $N;
}

sub _redirect_stdout_stderr {

    my $self = shift;

    ( undef, my $sub_redir ) = $self->_redirect( *STDOUT );
    ( undef, my $sub_dup ) = $self->_dup( *STDERR, *STDOUT );
    return sub { $sub_redir->(), $sub_dup->() }, *STDOUT, *STDERR;

}

sub _close {

    my ( $self, $N ) = @_;

    my $sub;

    if ( defined $N ) {

        $sub = sub { close( $N ) or die( "error in closing $N: $!\n" ); };

    }

    else {

        $N = $self->N;

        $sub = sub {
            POSIX::close( $N )
              or die( "error in closing $N: $!\n" );
        };

    }

    return $sub, $N;

}

sub apply {

    my $self = shift;

    my ( $N, $M ) = do {

        no warnings 'uninitialized';

        map { $fh_map{$_} } $self->N, $self->M;

    };

    my $mth = '_' . $self->_type;
    return $self->$mth( $N, $M );
}



1;

#
# This file is part of IPC-PrettyPipe
#
# This software is Copyright (c) 2018 by Smithsonian Astrophysical Observatory.
#
# This is free software, licensed under:
#
#   The GNU General Public License, Version 3, June 2007
#

__END__