File Coverage

lib/IPC/Open3/Utils.pm

Criterion	Covered	Total	%
statement	154	177	87.0
branch	105	144	72.9
condition	32	54	59.2
subroutine	17	19	89.4
pod	8	8	100.0
total	316	402	78.6

package IPC::Open3::Utils;

use strict;
use warnings;

$IPC::Open3::Utils::VERSION = '0.91';

require Exporter;
@IPC::Open3::Utils::ISA       = qw(Exporter);
@IPC::Open3::Utils::EXPORT    = qw(run_cmd put_cmd_in);
@IPC::Open3::Utils::EXPORT_OK = qw(
  run_cmd                 put_cmd_in
  child_error_ok          child_error_failed_to_execute
  child_error_exit_signal child_error_seg_faulted
  child_error_core_dumped child_error_exit_value
  create_ipc_open3_utils_wrap_script
);
%IPC::Open3::Utils::EXPORT_TAGS = (
    'all' => \@IPC::Open3::Utils::EXPORT_OK,
    'cmd' => [qw(run_cmd put_cmd_in)],
    'err' => [
        qw(
          child_error_ok          child_error_failed_to_execute
          child_error_exit_signal child_error_seg_faulted
          child_error_core_dumped child_error_exit_value
          )
    ],
);

require IO::Select;
require IPC::Open3;
require IO::Handle;

sub run_cmd {
    my @cmd = @_;
    my $arg_hr = ref $cmd[-1] eq 'HASH' ? pop(@cmd) : {};
    $arg_hr->{'ignore_handle'} ||= '';

    if ( ref $arg_hr->{'handler'} ne 'CODE' ) {
        $arg_hr->{'handler'} = sub {
            my ( $cur_line, $stdin, $is_stderr, $is_open3_err, $short_circuit_loop_sr ) = @_;
            if ($is_stderr) {
                print STDERR $cur_line;
            }
            else {
                print STDOUT $cur_line;
            }

            return 1;
        };
    }

    my $stdout = IO::Handle->new();
    my $stderr = IO::Handle->new();    # TODO ? $arg_hr->{'combine_fhs'} ? $stdout : IO::Handle->new(); && then  no select()
    my $stdin  = IO::Handle->new();
    my $sel    = IO::Select->new();

    if ( ref $arg_hr->{'autoflush'} eq 'HASH' ) {
        $stdout->autoflush(1) if $arg_hr->{'autoflush'}{'stdout'};
        $stderr->autoflush(1) if $arg_hr->{'autoflush'}{'stderr'};
        $stdin->autoflush(1)  if $arg_hr->{'autoflush'}{'stdin'};
    }

    # this is a hack to work around an exit-before-use race condition
    local $SIG{'PIPE'} = exists $SIG{'PIPE'} && defined $SIG{'PIPE'} ? $SIG{'PIPE'} : '';
    my $current_sig_pipe = $SIG{'PIPE'};
    if ( exists $arg_hr->{'pre_read_print_to_stdin'} ) {
        $SIG{'PIPE'} = sub {

            # my $oserr = $!;
            # my $cherr = $?;
            $stdin->close if defined $stdin && ref $stdin eq 'IO::Handle';    #  && !$arg_hr->{'close_stdin'};
            $stdout->close;
            $stderr->close;

            # $! = $oserr;
            # $? = $cherr;
            $current_sig_pipe->() if $current_sig_pipe && ref $current_sig_pipe eq 'CODE';
        };
    }

    # ensure these are always re-set at the beginning of an execution
    $! = 0;
    $? = 0;

    my $child_pid;
    eval { $child_pid = IPC::Open3::open3( $stdin, $stdout, $stderr, @cmd ) };
    if ($@) {
        if ( $@ =~ m{not enough arguments} ) {
            $! = 22;       # Invalid argument
            $? = 65280;    # system();print $?;
        }
        elsif ( $@ =~ m{open3: exec of .* failed at} ) {
            $? = -1;
        }

        if ( ref $arg_hr->{'open3_error'} eq 'SCALAR' ) {
            ${ $arg_hr->{'open3_error'} } = $@;
        }
        else {
            $arg_hr->{'open3_error'} = $@;
        }

        if ( $arg_hr->{'carp_open3_errors'} ) {
            require Carp;
            Carp::carp($@);
        }

        return;
    }

    $arg_hr->{'timeout'} = exists $arg_hr->{'timeout'} ? abs( $arg_hr->{'timeout'} ) : 0;

    my $alarm;
    my $original_alarm;

    # small hack to avoid uninitialized value warnings w/ out lots of warning.pm voo-doo to
    #    keep the "no warnings 'uninitialized'" scoped to this assignment but the local() scoped from here on
    # local $SIG{'ALRM'} = $SIG{'ALRM'};# this gives uninitialized value warnings
    my $no_unit_warnings = $SIG{'ALRM'};
    local $SIG{'ALRM'} ||= '';
    if ( $arg_hr->{'timeout'} ) {
        if ( $arg_hr->{'timeout_is_microseconds'} ) {
            if ( defined &Time::HiRes::ualarm ) {
                $alarm = \&Time::HiRes::ualarm;
            }
            else {
                $alarm = defined &Time::HiRes::alarm ? \&Time::HiRes::alarm : sub { alarm( $_[0] ) };    # \&CORE::alarm, \&CORE::GLOBAL::alarm, etc don't work ...
                $arg_hr->{'timeout'}                 = $arg_hr->{'timeout'} / 1_000_000;
                $arg_hr->{'timeout'}                 = 1 if $arg_hr->{'timeout'} < 1;
                $arg_hr->{'timeout_is_microseconds'} = 0;
            }
        }
        else {
            $alarm = defined &Time::HiRes::alarm ? \&Time::HiRes::alarm : sub { alarm( $_[0] ) };        # \&CORE::alarm, \&CORE::GLOBAL::alarm, etc don't work ...
        }

        $SIG{'ALRM'} = sub { die 'Alarm clock' };
        $original_alarm = $alarm->( $arg_hr->{'timeout'} );

        # undocumented, for testing purposes only
        if ( exists $arg_hr->{'_timeout_info'} && ref( $arg_hr->{'_timeout_info'} ) eq 'HASH' ) {
            %{ $arg_hr->{'_timeout_info'} } = (
                'timeout'                 => $arg_hr->{'timeout'},
                'timeout_is_microseconds' => $arg_hr->{'timeout_is_microseconds'},
                'Time::Hires'             => $INC{'Time/HiRes.pm'},
                'Time::Hires::ualarm'     => defined &Time::HiRes::ualarm ? 1 : 0,
                'Time::Hires::alarm'      => defined &Time::HiRes::alarm ? 1 : 0,
                'original_alarm'          => $original_alarm,
            );
        }
    }
    else {
        no warnings 'uninitialized';    # at least we can scopt it here ...
        $SIG{'ALRM'} = $no_unit_warnings;
    }

    my $is_open3_err       = 0;
    my $open3_err_is_exec  = 0;
    my $return_bool        = 1;
    my $short_circuit_loop = 0;

    eval {

        if ( exists $arg_hr->{'_pre_run_sleep'} ) {
            if ( my $sec = int( $arg_hr->{'_pre_run_sleep'} ) ) {
                sleep $sec;    # undocumented, only for testing
            }
        }

        $sel->add($stdout);    # unless exists $arg_hr->{'ignore_handle'} && $arg_hr->{'ignore_handle'} eq 'stdout';
        $sel->add($stderr);    # unless exists $arg_hr->{'ignore_handle'} && $arg_hr->{'ignore_handle'} eq 'stderr';

        if ( exists $arg_hr->{'pre_read_print_to_stdin'} ) {
            if ( my $type = ref( $arg_hr->{'pre_read_print_to_stdin'} ) ) {
                if ( $type eq 'ARRAY' ) {
                    for my $line ( @{ $arg_hr->{'pre_read_print_to_stdin'} } ) {
                        $stdin->printflush($line);
                    }
                }
                elsif ( $type eq 'CODE' ) {
                    for my $line ( $arg_hr->{'pre_read_print_to_stdin'}->() ) {
                        $stdin->printflush($line);
                    }
                }
            }
            else {
                $stdin->printflush( $arg_hr->{'pre_read_print_to_stdin'} );
            }
        }

        if ( $arg_hr->{'close_stdin'} ) {
            $stdin->close();
            undef $stdin;
        }

        local *_;

        # to avoid "Modification of readonly value attempted" errors with @_
        # You ask, "Do you mean the _open3()'s or while()'s @_? " and the answer is: "exactly!" ;p

        my $get_next = sub { readline(shift) };

        if ( my $byte_size = int( $arg_hr->{'read_length_bytes'} || 0 ) ) {
            my $buffer;
            $byte_size = 128 if $byte_size < 128;
            $get_next = sub { shift->sysread( $buffer, $byte_size ); return $buffer; };
        }

        my $odd_errno = int($!);

      READ_LOOP:
        while ( my @ready = $sel->can_read ) {
          HANDLE:
            for my $fh (@ready) {
                if ( $fh->eof ) {
                    $sel->remove($fh);
                    $fh->close;
                    next HANDLE;
                }

                my $is_stderr = $fh eq $stderr ? 1 : 0;

              CMD_OUTPUT:
                while ( my $cur_line = $get_next->($fh) ) {
                    next CMD_OUTPUT if $arg_hr->{'ignore_handle'} eq ( $is_stderr ? 'stderr' : 'stdout' );

                    $is_open3_err = 1 if $is_stderr && $cur_line =~ m{^open3:};
                    if ($is_open3_err) {
                        if ( ref $arg_hr->{'open3_error'} eq 'SCALAR' ) {
                            ${ $arg_hr->{'open3_error'} } = $cur_line;
                        }
                        else {
                            $arg_hr->{'open3_error'} = $cur_line;
                        }

                        if ( $arg_hr->{'carp_open3_errors'} ) {
                            require Carp;
                            Carp::carp($cur_line);
                        }

                        if ( $cur_line =~ m{open3: exec of .* failed at} ) {
                            $open3_err_is_exec = 1;
                        }
                    }

                    $return_bool = $arg_hr->{'handler'}->( $cur_line, $stdin, $is_stderr, $is_open3_err, \$short_circuit_loop );

                    last READ_LOOP if !$return_bool;
                    last READ_LOOP if $is_open3_err && $arg_hr->{'stop_read_on_open3_err'};    # this is probably the last one anyway
                    last READ_LOOP if $short_circuit_loop;
                }
            }

            $odd_errno = int($!);
        }

        $! = 0 if $odd_errno == 0 && $! == 9;

        # my $oserr = $!;
        # my $cherr = $?;
        $stdout->close if $stdout->opened;
        $stderr->close if $stderr->opened;
        $stdin->close  if defined $stdin && ref $stdin eq 'IO::Handle' && $stdin->opened;    #  && !$arg_hr->{'close_stdin'};

        # $! = $oserr;
        # $? = $cherr;

        waitpid $child_pid, 0;

    };

    if ( $arg_hr->{'timeout'} && defined $original_alarm ) {
        $alarm->($original_alarm);
    }

    if ($@) {

        # if ($@ =~ m/^Alarm clock /) {
        #     $! = 60;
        #     # $? = ??;
        # }
        return;
    }

    if ( $is_open3_err && $open3_err_is_exec && $? != -1 ) {
        $? = -1;
    }

    return if $is_open3_err || !$return_bool || !child_error_ok($?);
    return 1;
}

sub put_cmd_in {
    my (@cmd) = @_;

    my $arg_hr = ref $cmd[-1] eq 'HASH' ? pop(@cmd) : {};

    # not being this strict allows us to do "no" output ref quietness
    # return if @cmd < 2;
    # return if defined $cmd[-1] && !ref $cmd[-1];
    # my $err = pop(@cmd);

    my $err = !defined $cmd[-1] || ref $cmd[-1] ? pop(@cmd) : undef;
    my $out = !defined $cmd[-1] || ref $cmd[-1] ? pop(@cmd) : $err;

    $arg_hr->{'handler'} = sub {
        my ( $cur_line, $stdin, $is_stderr, $is_open3_err, $short_circuit_loop_sr ) = @_;

        my $mod = $is_stderr ? $err : $out;
        return 1 if !defined $mod;

        if ( ref $mod eq 'SCALAR' ) {
            ${$mod} .= $cur_line;
        }
        else {
            push @{$mod}, $cur_line;
        }

        return 1;
    };

    return run_cmd( @cmd, $arg_hr );
}

#####################
#### child_error_* ##
#####################

sub child_error_ok {
    my $sysrc = @_ ? shift() : $?;
    return 1 if $sysrc == 0;
    return;
}

sub child_error_failed_to_execute {
    my $sysrc = @_ ? shift() : $?;
    return $sysrc == -1;
}

sub child_error_seg_faulted {
    my $sysrc = @_ ? shift() : $?;
    return if child_error_failed_to_execute($sysrc);
    return child_error_exit_signal($sysrc) == 11;
}

sub child_error_core_dumped {
    my $sysrc = @_ ? shift() : $?;
    return if child_error_failed_to_execute($sysrc);
    return $sysrc & 128;
}

sub child_error_exit_signal {
    my $sysrc = @_ ? shift() : $?;
    return if child_error_failed_to_execute($sysrc);
    return $sysrc & 127;
}

sub child_error_exit_value {
    my $sysrc = @_ ? shift() : $?;
    return if child_error_failed_to_execute($sysrc);
    return $sysrc >> 8;
}

1;

__END__