File Coverage

blib/lib/Shell/Run.pm

Criterion	Covered	Total	%
statement	121	131	92.3
branch	36	58	62.0
condition	8	20	40.0
subroutine	15	15	100.0
pod	2	2	100.0
total	182	226	80.5

package Shell::Run;

use strict;
use warnings;

use Exporter::Tiny;
use IPC::Open2;
use IO::Select;
use IO::String;
use File::Which;
use Carp;

use constant BLKSIZE => 1024;

our
	$VERSION = '0.08';

our @ISA = qw(Exporter::Tiny);

sub new {
	my $class = shift;
	my @cmd;

	my $shell = _get_shell(@_);
	return bless $shell, $class;
}

sub _exporter_expand_sub {
	my $class = shift;
	my ($name, $args, $globals) = @_;
	my $as = $args->{as} || $name;
	croak "$as: not a valid subroutine name" unless $as =~ /^[a-z][\w]*$/;
	my $shell = $class->new(name => $name, %$args);
	return ($as => sub {return $shell->run(@_);});
}

sub _get_shell {
	my %args = @_;
	my @cmd;

	if ($args{exe}) {
		croak "$args{exe}: not an excutable file" unless -x $args{exe};
		$cmd[0] = $args{exe};
	} else {
		my $name = $args{name} || 'sh';
		$cmd[0] = which $name;
		croak "$name: not found in PATH" unless $cmd[0];
	}

	if (defined $args{args}) {
		push @cmd, @{$args{args}};
	} else {
		push @cmd, '-c';
	}

	my $shell;
	$shell->{shell} = \@cmd;
	$shell->{debug} = $args{debug};
	return $shell;
}

sub run {
	my $self = shift;
	# command to execute
	my $cmd = shift;
	print STDERR "using shell: @{$self->{shell}}\n" if $self->{debug};
	print STDERR "executing cmd:\n$cmd\n" if $self->{debug};

	# cmd output, make $output an alias to the second argument
	our $output;
	local *output = \$_[0];
	$output = '';
	shift;

	# cmd input
	my $input = shift;
	my $inh = IO::String->new;
	$inh->open($input);
	print STDERR "have input data\n" if $self->{debug} && $input;

	# additional environment entries for use as shell variables
	my %env = @_;
	local %ENV = %ENV;
	$ENV{$_} = $env{$_} foreach keys %env;
	if ($self->{debug} && %env) {
		print STDERR "setting env variables:\n";
		print STDERR "$_=$env{$_}\n" foreach keys %env;
	}

	# start cmd
	my ($c_in, $c_out);
	$c_in = '' unless $input;
	my $pid = open2($c_out, $c_in, @{$self->{shell}}, $cmd);

	# ensure filehandles are blocking
	$c_in->blocking(1);
	$c_out->blocking(1);

	# create selectors for read and write filehandles
	my $sin = IO::Select->new;
	$sin->add($c_out);
	my $sout = IO::Select->new;
	$sout->add($c_in) if $input;

	# catch SIGPIPE on input pipe to cmd
	my $pipe_closed;
	local $SIG{PIPE} = sub {
		$pipe_closed = 1;
		print STDERR "got SIGPIPE\n" if $self->{debug};
	};

	print STDERR "\n" if $self->{debug};
	loop:
	while (1) {
		# get filehandles ready to read or write
		my ($read, $write) = IO::Select->select($sin, $sout, undef);

		# read from cmd
		foreach my $rh (@$read) {
			my $data;
			my $bytes =	sysread $rh, $data, BLKSIZE;
			unless (defined $bytes) {
				print STDERR "read from cmd failed\n" if $self->{debug};
				carp "read from cmd failed";
				return 1;
			}
			print STDERR "read $bytes bytes from cmd\n"
				if $self->{debug} && $bytes;
			$output .= $data;

			# finish on eof from cmd
			if (! $bytes) {
				print STDERR "closing output from cmd\n" if $self->{debug};
				close($rh);
				$sin->remove($rh);
				last loop;
			}
		}

		# write to cmd
		foreach my $wh (@$write) {
			# stop writing to input on write error / SIGPIPE
			if ($pipe_closed) {
				print STDERR "closing input to cmd as pipe is closed\n"
					if $self->{debug};
				close $wh;
				$sout->remove($wh);
				next loop;
			}

			# save position in case of partial writes
			my $pos = $inh->getpos;

			# try to write chunk of data
			my $data = $inh->getline;
			my $to_be_written = length($data) < BLKSIZE ?
				length($data) : BLKSIZE;
			print STDERR "writing $to_be_written bytes to cmd\n"
				if $self->{debug} && $data;
			my $bytes = syswrite $wh, $data, BLKSIZE;

			# write failure mostly because of broken pipe
			unless (defined $bytes) {
				print STDERR "write to cmd failed\n" if $self->{debug};
				carp "write to cmd failed";
				$pipe_closed = 1;
				next loop;
			}

			# log partial write
			print STDERR "wrote $bytes bytes to cmd\n"
				if $self->{debug} && $bytes < $to_be_written;

			# adjust input data position
			if ($bytes < length($data)) {
				$inh->setpos($pos + $bytes);
			}

			# close cmd input when data is exhausted
			if (eof($inh)) {
				print STDERR "closing input to cmd on end of data\n"
					if $self->{debug};
				close $wh;
				$sout->remove($wh);
			}
		}

	}

	# avoid zombies and get return status
	waitpid $pid, 0;
	my $status = $? >> 8;
	print STDERR "cmd exited with rc=$status\n\n" if $self->{debug};

	return ($status, !$status);
}

1;

# vi:ts=4:
__END__