File Coverage

blib/lib/IPC/System/Simple.pm

Criterion	Covered	Total	%
statement	193	202	95.5
branch	38	44	86.3
condition	7	11	63.6
subroutine	44	46	95.6
pod	4	4	100.0
total	286	307	93.1

package IPC::System::Simple;

# ABSTRACT: Run commands simply, with detailed diagnostics

use 5.006;
use strict;
use warnings;
use re 'taint';
use Carp;
use List::Util qw(first);
use Scalar::Util qw(tainted);
use Config;
use constant WINDOWS => ($^O eq 'MSWin32');
use constant VMS     => ($^O eq 'VMS');

BEGIN {

    # It would be lovely to use the 'if' module here, but it didn't
    # enter core until 5.6.2, and we want to keep 5.6.0 compatibility.


    if (WINDOWS) {

        ## no critic (ProhibitStringyEval)

        eval q{
            use Win32::Process qw(INFINITE NORMAL_PRIORITY_CLASS);
            use File::Spec;
            use Win32;
            use Win32::ShellQuote;

            # This uses the same rules as the core win32.c/get_shell() call.
            use constant WINDOWS_SHELL => eval { Win32::IsWinNT() }
                ? [ File::Spec->catfile(Win32::GetFolderPath(Win32::CSIDL_SYSTEM), 'cmd.exe'), '/x/d/c' ]
                : [ File::Spec->catfile(Win32::GetFolderPath(Win32::CSIDL_SYSTEM), 'command.com'), '/c' ];

            # These are used when invoking _win32_capture
            use constant NO_SHELL  => 0;
            use constant USE_SHELL => 1;

        };

        ## use critic

        # Die nosily if any of the above broke.
        die $@ if $@;
    }
}

# Note that we don't use WIFSTOPPED because perl never uses
# the WUNTRACED flag, and hence will never return early from
# system() if the child processes is suspended with a SIGSTOP.

use POSIX qw(WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG);

use constant FAIL_START     => q{"%s" failed to start: "%s"};
use constant FAIL_PLUMBING  => q{Error in IPC::System::Simple plumbing: "%s" - "%s"};
use constant FAIL_CMD_BLANK => q{Entirely blank command passed: "%s"};
use constant FAIL_INTERNAL  => q{Internal error in IPC::System::Simple: "%s"};
use constant FAIL_TAINT     => q{%s called with tainted argument "%s"};
use constant FAIL_TAINT_ENV => q{%s called with tainted environment $ENV{%s}};
use constant FAIL_SIGNAL    => q{"%s" died to signal "%s" (%d)%s};
use constant FAIL_BADEXIT   => q{"%s" unexpectedly returned exit value %d};

use constant FAIL_UNDEF     => q{%s called with undefined command};


use constant FAIL_POSIX     => q{IPC::System::Simple does not understand the POSIX error '%s'.  Please check https://metacpan.org/pod/IPC::System::Simple to see if there is an updated version.  If not please report this as a bug to https://github.com/pjf/ipc-system-simple/issues};

# On Perl's older than 5.8.x we can't assume that there'll be a
# $^{TAINT} for us to check, so we assume that our args may always
# be tainted.
use constant ASSUME_TAINTED => ($] < 5.008);

use constant EXIT_ANY_CONST => -1;			# Used internally
use constant EXIT_ANY       => [ EXIT_ANY_CONST ];	# Exported

use constant UNDEFINED_POSIX_RE => qr{not (?:defined|a valid) POSIX macro|not implemented on this architecture};

require Exporter;
our @ISA = qw(Exporter);

our @EXPORT_OK = qw(
    capture  capturex
    run      runx
    system   systemx
    $EXITVAL EXIT_ANY
);

our $VERSION = '1.28_001';
$VERSION =~ tr/_//d;

our $EXITVAL = -1;

my @Signal_from_number = split(' ', $Config{sig_name});

# Environment variables we don't want to see tainted.
my @Check_tainted_env = qw(PATH IFS CDPATH ENV BASH_ENV);
if (WINDOWS) {
	push(@Check_tainted_env, 'PERL5SHELL');
}
if (VMS) {
	push(@Check_tainted_env, 'DCL$PATH');
}

# Not all systems implement the WIFEXITED calls, but POSIX
# will always export them (even if they're just stubs that
# die with an error).  Test for the presence of a working
# WIFEXITED and friends, or define our own.

eval { WIFEXITED(0); };

if ($@ =~ UNDEFINED_POSIX_RE) {
        no warnings 'redefine';  ## no critic
	*WIFEXITED   = sub { not $_[0] & 0xff };
	*WEXITSTATUS = sub { $_[0] >> 8  };
	*WIFSIGNALED = sub { $_[0] & 127 };
	*WTERMSIG    = sub { $_[0] & 127 };
} elsif ($@) {
	croak sprintf FAIL_POSIX, $@;
}

# None of the POSIX modules I've found define WCOREDUMP, although
# many systems define it.  Check the POSIX module in the hope that
# it may actually be there.


# TODO: Ideally, $NATIVE_WCOREDUMP should be a constant.

my $NATIVE_WCOREDUMP;

eval { POSIX::WCOREDUMP(1); };

if ($@ =~ UNDEFINED_POSIX_RE) {
	*WCOREDUMP = sub { $_[0] & 128 };
        $NATIVE_WCOREDUMP = 0;
} elsif ($@) {
	croak sprintf FAIL_POSIX, $@;
} else {
	# POSIX actually has it defined!  Huzzah!
	*WCOREDUMP = \&POSIX::WCOREDUMP;
        $NATIVE_WCOREDUMP = 1;
}

sub _native_wcoredump {
    return $NATIVE_WCOREDUMP;
}

# system simply calls run

no warnings 'once'; ## no critic
*system  = \&run;
*systemx = \&runx;
use warnings;

# run is our way of running a process with system() semantics

sub run {

	_check_taint(@_);

	my ($valid_returns, $command, @args) = _process_args(@_);

        # If we have arguments, we really want to call systemx,
        # so we do so.

	if (@args) {
                return systemx($valid_returns, $command, @args);
	}

    if (WINDOWS) {
        my $pid = _spawn_or_die(&WINDOWS_SHELL->[0], join ' ', @{&WINDOWS_SHELL}, $command);
        $pid->Wait(INFINITE);	# Wait for process exit.
        $pid->GetExitCode($EXITVAL);
        return _check_exit($command,$EXITVAL,$valid_returns);
    }

    # Without arguments, we're calling system, and checking
        # the results.

	# We're throwing our own exception on command not found, so
	# we don't need a warning from Perl.

        {
            # silence 'Statement unlikely to be reached' warning
            no warnings 'exec';             ## no critic
            CORE::system($command,@args);
        }

	return _process_child_error($?,$command,$valid_returns);
}

# runx is just like system/run, but *never* invokes the shell.

sub runx {
    _check_taint(@_);

    my ($valid_returns, $command, @args) = _process_args(@_);

    if (WINDOWS) {
        our $EXITVAL = -1;

        my $pid = _spawn_or_die($command, Win32::ShellQuote::quote_native($command, @args));

        $pid->Wait(INFINITE);	# Wait for process exit.
        $pid->GetExitCode($EXITVAL);
        return _check_exit($command,$EXITVAL,$valid_returns);
    }

    # If system() fails, we throw our own exception.  We don't
    # need to have perl complain about it too.

    no warnings; ## no critic

    CORE::system { $command } $command, @args;

    return _process_child_error($?, $command, $valid_returns);
}

# capture is our way of running a process with backticks/qx semantics

sub capture {
	_check_taint(@_);

	my ($valid_returns, $command, @args) = _process_args(@_);

        if (@args) {
            return capturex($valid_returns, $command, @args);
        }

        if (WINDOWS) {
            # USE_SHELL really means "You may use the shell if you need it."
            return _win32_capture(USE_SHELL, $valid_returns, $command);
        }

	our $EXITVAL = -1;

	my $wantarray = wantarray();

	# We'll produce our own warnings on failure to execute.
	no warnings 'exec';	## no critic

        if ($wantarray) {
                my @results = qx($command);
                _process_child_error($?,$command,$valid_returns);
                return @results;
        }

        my $results = qx($command);
        _process_child_error($?,$command,$valid_returns);
        return $results;
}

# _win32_capture implements the capture and capurex commands on Win32.
# We need to wrap the whole internals of this sub into
# an if (WINDOWS) block to avoid it being compiled on non-Win32 systems.

sub _win32_capture {
    if (not WINDOWS) {
        croak sprintf(FAIL_INTERNAL, "_win32_capture called when not under Win32");
    } else {

        my ($use_shell, $valid_returns, $command, @args) = @_;

        my $wantarray = wantarray();

        # Perl doesn't support multi-arg open under
        # Windows.  Perl also doesn't provide very good
        # feedback when normal backtails fail, either;
        # it returns exit status from the shell
        # (which is indistinguishable from the command
        # running and producing the same exit status).

        # As such, we essentially have to write our own
        # backticks.

        # We start by dup'ing STDOUT.

        open(my $saved_stdout, '>&', \*STDOUT)  ## no critic
                or croak sprintf(FAIL_PLUMBING, "Can't dup STDOUT", $!);

        # We now open up a pipe that will allow us to
        # communicate with the new process.

        pipe(my ($read_fh, $write_fh))
                or croak sprintf(FAIL_PLUMBING, "Can't create pipe", $!);

        # Allow CRLF sequences to become "\n", since
        # this is what Perl backticks do.

        binmode($read_fh, ':crlf');

        # Now we re-open our STDOUT to $write_fh...

        open(STDOUT, '>&', $write_fh)  ## no critic
                or croak sprintf(FAIL_PLUMBING, "Can't redirect STDOUT", $!);

        # If we have args, or we're told not to use the shell, then
        # we treat $command as our shell.  Otherwise we grub around
        # in our command to look for a command to run.
        #
        # Note that we don't actually *use* the shell (although in
        # a future version we might).  Being told not to use the shell
        # (capturex) means we treat our command as really being a command,
        # and not a command line.

        my $exe =   @args                      ? $command :
                    (! $use_shell)             ? $command :
                    $command =~ m{^"([^"]+)"}x ? $1       :
                    $command =~ m{(\S+)     }x ? $1       :
                    croak sprintf(FAIL_CMD_BLANK, $command);

        # And now we spawn our new process with inherited
        # filehandles.

        my $err;
        my $pid = eval {
                _spawn_or_die($exe, @args ? Win32::ShellQuote::quote_native($command, @args) : $command);
        }
        or do {
                $err = $@;
        };

        # Regardless of whether our command ran, we must restore STDOUT.
        # RT #48319
        open(STDOUT, '>&', $saved_stdout)  ## no critic
                or croak sprintf(FAIL_PLUMBING,"Can't restore STDOUT", $!);

        # And now, if there was an actual error , propagate it.
        die $err if defined $err;   # If there's an error from _spawn_or_die

        # Clean-up the filehandles we no longer need...

        close($write_fh)
                or croak sprintf(FAIL_PLUMBING,q{Can't close write end of pipe}, $!);
        close($saved_stdout)
                or croak sprintf(FAIL_PLUMBING,q{Can't close saved STDOUT}, $!);

        # Read the data from our child...

        my (@results, $result);

        if ($wantarray) {
                @results = <$read_fh>;
        } else {
                $result = join("",<$read_fh>);
        }

        # Tidy up our windows process and we're done!

        $pid->Wait(INFINITE);	# Wait for process exit.
        $pid->GetExitCode($EXITVAL);

        _check_exit($command,$EXITVAL,$valid_returns);

        return $wantarray ? @results : $result;

    }
}

# capturex() is just like backticks/qx, but never invokes the shell.

sub capturex {
	_check_taint(@_);

	my ($valid_returns, $command, @args) = _process_args(@_);

	our $EXITVAL = -1;

	my $wantarray = wantarray();

	if (WINDOWS) {
            return _win32_capture(NO_SHELL, $valid_returns, $command, @args);
        }

	# We can't use a multi-arg piped open here, since 5.6.x
	# doesn't like them.  Instead we emulate what 5.8.x does,
	# which is to create a pipe(), set the close-on-exec flag
	# on the child, and the fork/exec.  If the exec fails, the
	# child writes to the pipe.  If the exec succeeds, then
	# the pipe closes without data.

	pipe(my ($read_fh, $write_fh))
		or croak sprintf(FAIL_PLUMBING, "Can't create pipe", $!);

	# This next line also does an implicit fork.
	my $pid = open(my $pipe, '-|');	 ## no critic

	if (not defined $pid) {
		croak sprintf(FAIL_START, $command, $!);
	} elsif (not $pid) {
		# Child process, execs command.

		close($read_fh);

		# TODO: 'no warnings exec' doesn't get rid
		# of the 'unlikely to be reached' warnings.
		# This is a bug in perl / perldiag / perllexwarn / warnings.

		no warnings;   ## no critic

		CORE::exec { $command } $command, @args;

		# Oh no, exec fails!  Send the reason why to
		# the parent.

		print {$write_fh} int($!);
		exit(-1);
	}

	{
		# In parent process.

		close($write_fh);

		# Parent process, check for child error.
		my $error = <$read_fh>;

		# Tidy up our pipes.
		close($read_fh);

		# Check for error.
		if ($error) {
			# Setting $! to our child error number gives
			# us nice looking strings when printed.
			local $! = $error;
			croak sprintf(FAIL_START, $command, $!);
		}
	}

	# Parent process, we don't care about our pid, but we
	# do go and read our pipe.

	if ($wantarray) {
		my @results = <$pipe>;
		close($pipe);
		_process_child_error($?,$command,$valid_returns);
		return @results;
	}

	# NB: We don't check the return status on close(), since
	# on failure it sets $?, which we then inspect for more
	# useful information.

	my $results = join("",<$pipe>);
	close($pipe);
	_process_child_error($?,$command,$valid_returns);

	return $results;

}

# Tries really hard to spawn a process under Windows.  Returns
# the pid on success, or undef on error.

sub _spawn_or_die {

	# We need to wrap practically the entire sub in an
	# if block to ensure it doesn't get compiled under non-Win32
	# systems.  Compiling on these systems would not only be a
	# waste of time, but also results in complaints about
	# the NORMAL_PRIORITY_CLASS constant.

	if (not WINDOWS) {
		croak sprintf(FAIL_INTERNAL, "_spawn_or_die called when not under Win32");
	} else {
		my ($orig_exe, $cmdline) = @_;
		my $pid;

		my $exe = $orig_exe;

		# If our command doesn't have an extension, add one.
		$exe .= $Config{_exe} if ($exe !~ m{\.});

		Win32::Process::Create(
			$pid, $exe, $cmdline, 1, NORMAL_PRIORITY_CLASS, "."
		) and return $pid;

		my @path = split(/;/,$ENV{PATH});

		foreach my $dir (@path) {
			my $fullpath = File::Spec->catfile($dir,$exe);

			# We're using -x here on the assumption that stat()
			# is faster than spawn, so trying to spawn a process
			# for each path element will be unacceptably
			# inefficient.

			if (-x $fullpath) {
				Win32::Process::Create(
					$pid, $fullpath, $cmdline, 1,
					NORMAL_PRIORITY_CLASS, "."
				) and return $pid;
			}
		}

		croak sprintf(FAIL_START, $orig_exe, $^E);
	}
}

# Complain on tainted arguments or environment.
# ASSUME_TAINTED is true for 5.6.x, since it's missing ${^TAINT}

sub _check_taint {
	return if not (ASSUME_TAINTED or ${^TAINT});
	my $caller = (caller(1))[3];
	foreach my $var (@_) {
		if (tainted $var) {
			croak sprintf(FAIL_TAINT, $caller, $var);
		}
	}
	foreach my $var (@Check_tainted_env) {
		if (tainted $ENV{$var} ) {
			croak sprintf(FAIL_TAINT_ENV, $caller, $var);
		}
	}

	return;

}

# This subroutine performs the difficult task of interpreting
# $?.  It's not intended to be called directly, as it will
# croak on errors, and its implementation and interface may
# change in the future.

sub _process_child_error {
	my ($child_error, $command, $valid_returns) = @_;

	$EXITVAL = -1;

	my $coredump = WCOREDUMP($child_error);

        # There's a bug in perl 5.10.0 where if the system
        # does not provide a native WCOREDUMP, then $? will
        # never contain coredump information.  This code
        # checks to see if we have the bug, and works around
        # it if needed.

        if ($] >= 5.010 and not $NATIVE_WCOREDUMP) {
            $coredump ||= WCOREDUMP( ${^CHILD_ERROR_NATIVE} );
        }

	if ($child_error == -1) {
		croak sprintf(FAIL_START, $command, $!);

	} elsif ( WIFEXITED( $child_error ) ) {
		$EXITVAL = WEXITSTATUS( $child_error );

		return _check_exit($command,$EXITVAL,$valid_returns);

	} elsif ( WIFSIGNALED( $child_error ) ) {
		my $signal_no   = WTERMSIG( $child_error );
		my $signal_name = $Signal_from_number[$signal_no] || "UNKNOWN";

		croak sprintf FAIL_SIGNAL, $command, $signal_name, $signal_no, ($coredump ? " and dumped core" : "");


	}

	croak sprintf(FAIL_INTERNAL, qq{'$command' ran without exit value or signal});

}

# A simple subroutine for checking exit values.  Results in better
# assurance of consistent error messages, and better forward support
# for new features in I::S::S.

sub _check_exit {
	my ($command, $exitval, $valid_returns) = @_;

	# If we have a single-value list consisting of the EXIT_ANY
	# value, then we're happy with whatever exit value we're given.
	if (@$valid_returns == 1 and $valid_returns->[0] == EXIT_ANY_CONST) {
		return $exitval;
	}

	if (not defined first { $_ == $exitval } @$valid_returns) {
		croak sprintf FAIL_BADEXIT, $command, $exitval;
	}
	return $exitval;
}


# This subroutine simply determines a list of valid returns, the command
# name, and any arguments that we need to pass to it.

sub _process_args {
	my $valid_returns = [ 0 ];
	my $caller = (caller(1))[3];

	if (not @_) {
		croak "$caller called with no arguments";
	}

	if (ref $_[0] eq "ARRAY") {
		$valid_returns = shift(@_);
	}

	if (not @_) {
		croak "$caller called with no command";
	}

	my $command = shift(@_);

        if (not defined $command) {
                croak sprintf( FAIL_UNDEF, $caller );
        }

	return ($valid_returns,$command,@_);

}

1;

__END__