File Coverage

blib/lib/IPC/RunExternal.pm

Criterion	Covered	Total	%
statement	88	105	83.8
branch	23	36	63.8
condition	6	15	40.0
subroutine	11	11	100.0
pod	1	1	100.0
total	129	168	76.7

## no critic (ControlStructures::ProhibitDeepNests)
## no critic (ValuesAndExpressions::ProhibitMagicNumbers)

package IPC::RunExternal;

use strict;
use warnings;
use 5.010000;

# ABSTRACT: Execute an external command conveniently by hiding the details of IPC::Open3.

our $VERSION = '0.102'; # VERSION: generated by DZP::OurPkgVersion


use English '-no_match_vars';
use Carp 'croak';
use IPC::Open3;
use IO::Select; # for select
use Symbol 'gensym'; # for gensym

use Exporter 'import';
our @EXPORT_OK   = qw(runexternal);
our @EXPORT      = qw(runexternal); ## no critic (Modules::ProhibitAutomaticExportation)
our %EXPORT_TAGS = ( all => [ qw(runexternal) ] );

use autodie;

# CONSTANTS for this module
my $TRUE = 1;
my $FALSE = 0;
my $EMPTY_STR = q{};

my $DEFAULT_PRINT_PROGRESS_INDICATOR = $FALSE;
my $DEFAULT_PROGRESS_INDICATOR_CHARACTER = q{.};
my $DEFAULT_EXECUTE_EVERY_SECOND_ROUTINE_POINTER = $FALSE;
my $EXIT_STATUS_OK = 1;
my $EXIT_STATUS_TIMEOUT = 0;
my $EXIT_STATUS_FAILED = -1;
my $SIGKILL = 9;

# GLOBALS
# No global variables




sub runexternal { ## no critic (Subroutines::ProhibitExcessComplexity)

    # Parameters
    my ($command, $input, $timeout, $parameter_tags) = @_;

    if(!defined $command) {
        croak('Parameter \'command\' is not initialised!');
    }
    if(!defined $input) {
        croak('Parameter \'input\' is not initialised!');
    }
    if($timeout < 0) {
        croak('Parameter \'timeout\' is not valid!');
    }

    my $print_progress_indicator = $DEFAULT_PRINT_PROGRESS_INDICATOR;
    if(exists $parameter_tags->{'print_progress_indicator'}) {
        if($parameter_tags->{'print_progress_indicator'} == $FALSE ||
                $parameter_tags->{'print_progress_indicator'} == $TRUE) {
            $print_progress_indicator = $parameter_tags->{'print_progress_indicator'};
        }
        else {
            croak('Parameter \'print_progress_indicator\' is not valid (must be 1/0)!');
        }
    }

    my $progress_indicator_char = $DEFAULT_PROGRESS_INDICATOR_CHARACTER;
    if(exists $parameter_tags->{'progress_indicator_char'}) {
        $progress_indicator_char = $parameter_tags->{'progress_indicator_char'};
    }

    my $execute_every_second = $DEFAULT_EXECUTE_EVERY_SECOND_ROUTINE_POINTER;
    if(exists $parameter_tags->{'execute_every_second'}) {
        if(ref($parameter_tags->{'execute_every_second'}) eq 'CODE') {
            $execute_every_second = $parameter_tags->{'execute_every_second'};
        }
        else {
            croak('Parameter execute_every_second is not a code reference!');
        }
    }

    # Variables
    my $command_exit_status = $EXIT_STATUS_OK;
    my $output_std = $EMPTY_STR;
    my $output_error = $EMPTY_STR;
    my $output_all = $EMPTY_STR;

    # Validity check
    if(
            $command ne $EMPTY_STR
            #&& defined($input)
            && $timeout >= 0
    )
    {
        local $OUTPUT_AUTOFLUSH = $TRUE; # Equals to var $|. Flushes always after writing.
        my ($infh,$outfh,$errfh); # these are the FHs for our child
        $errfh = gensym(); # we create a symbol for the errfh
                           # because open3 will not do that for us
        my $pid;
        # Read Perl::Critic::Policy::ErrorHandling::RequireCheckingReturnValueOfEval
        # for an evil eval weakness and a dasdardly difficult eval handling.
        my $eval_ok = 1;
        eval {
            $pid = open3($infh, $outfh, $errfh, $command);
            # To cover the possiblity that an operation may correctly return a
            # false value, end the block with "1":
            1;
        } or do {
            $eval_ok = 0;
        };
        if($eval_ok) {
            print {$infh} $input; ## no critic (InputOutput::RequireCheckedSyscalls)
            close $infh;
            my $sel = IO::Select->new(); # create a select object to notify
                                         # us on reads on our FHs
            $sel->add($outfh, $errfh);   # add the FHs we're interested in
            my $out_handles_open = 2;
            ## no critic (ControlStructures::ProhibitCStyleForLoops)
            for(my $slept_secs = -1; $out_handles_open > 0 && $slept_secs < $timeout; $slept_secs++) {
                while(my @ready = $sel->can_read(1)) { # read ready, timeout after 1 second.
                    foreach my $fh (@ready) {
                        my $line = <$fh>;        # read one line from this fh
                        if( !(defined $line) ){   # EOF on this FH
                            $sel->remove($fh);   # remove it from the list
                            $out_handles_open -= 1;
                            next;                # and go handle the next FH
                        }
                        if($fh == $outfh) {      # if we read from the outfh
                            $output_std .= $line;
                            $output_all .= $line;
                        } elsif($fh == $errfh) { # do the same for errfh
                            $output_error .= $line;
                            $output_all .= $line;
                        } else {                 # we read from something else?!?!
                            croak "Shouldn't be here!\n";
                        }
                    }
                }
                if($timeout == 0) {
                    # No timeout, so we lower the counter by one to keep it forever under 0.
                    # Only the closing of the output handles ($out_handles_open == 0) can break the loop
                    $slept_secs--;
                }
                if($print_progress_indicator == $TRUE && $out_handles_open > 0) {
                    print {*STDOUT} $progress_indicator_char; ## no critic (InputOutput::RequireCheckedSyscalls)
                }
                if($execute_every_second && $out_handles_open > 0) {
                    &{$execute_every_second}($slept_secs);
                }
            }
            # It is safe to kill in all circumstances.
            # Anyway, we must reap the child process.
            my $killed = kill $SIGKILL, $pid;
            my $command_return_status = $CHILD_ERROR >> 8;
            if($out_handles_open > 0) {
                $output_error .= 'Timeout';
                $output_all .= 'Timeout';
                $command_exit_status = $EXIT_STATUS_TIMEOUT;
            }
        }
        else {
            # open3 failed!
            $output_error .= 'Could not run command';
            $output_all .= 'Could not run command';
            $command_exit_status = $EXIT_STATUS_FAILED;
        }
    }
    else {
        # Parameter check
        $output_error .= 'Invalid parameters';
        $output_all .= 'Invalid parameters';
        $command_exit_status = $EXIT_STATUS_FAILED;
    }

    return ($command_exit_status, $output_std, $output_error, $output_all);
}

1;

__END__