File Coverage

blib/lib/Command/Run.pm

Criterion	Covered	Total	%
statement	233	246	94.7
branch	119	172	69.1
condition	13	18	72.2
subroutine	27	28	96.4
pod	9	14	64.2
total	401	478	83.8

package Command::Run;

our $VERSION = "1.02";

use v5.14;
use warnings;
use utf8;
use Carp;
use Fcntl;
use IO::File;

use parent 'Command::Run::Tmpfile';

our $debug;
sub debug {
    my $obj = shift;
    @_ ? $debug = shift : $debug;
}

sub code_name {
    my $code = shift;
    require B;
    my $cv = B::svref_2object($code);
    return if $cv->GV->isa('B::SPECIAL');
    $cv->GV->NAME;
}

my %default_option = (
    stderr => undef,  # undef: pass-through, 'redirect': merge to stdout, 'capture': separate capture
);

sub new {
    my $class = shift;
    my $obj = $class->SUPER::new;
    $obj->{OPTION} = { %default_option };
    $obj->{RESULT} = {};
    $obj->configure(@_) if @_;
    $obj;
}

sub configure {
    my $obj = shift;
    my %args = @_;
    for my $key (keys %args) {
	my $val = $args{$key};
	if ($key eq 'command') {
	    $obj->command(ref $val eq 'ARRAY' ? @$val : $val);
	} elsif ($key eq 'stdin') {
	    $obj->_set_stdin($val);
	} elsif ($key eq 'stdout') {
	    $obj->{STDOUT_REF} = $val;
	} elsif ($key eq 'stderr') {
	    if (ref $val eq 'SCALAR') {
		$obj->{STDERR_REF} = $val;
		$obj->option(stderr => 'capture');
	    } else {
		$obj->option(stderr => $val);
	    }
	} else {
	    $obj->option($key => $val);
	}
    }
    $obj;
}

sub command {
    my $obj = shift;
    if (@_) {
	$obj->{COMMAND} = [ @_ ];
	$obj;
    } else {
	@{$obj->{COMMAND} // []};
    }
}

sub option {
    my $obj = shift;
    if (@_ == 1) {
	return $obj->{OPTION}->{+shift};
    } else {
	while (my($k, $v) = splice @_, 0, 2) {
	    $obj->{OPTION}->{$k} = $v;
	}
	return $obj;
    }
}

sub run {
    my $obj = shift;
    $obj->update(@_);
    if (my $ref = $obj->{STDOUT_REF}) {
	$$ref = $obj->data;
    }
    if (my $ref = $obj->{STDERR_REF}) {
	$$ref = $obj->error;
    }
    return $obj->result;
}

sub update {
    use Time::localtime;
    my $obj = shift;
    my @command = $obj->command;
    if (@command) {
	$obj->{RESULT} = $obj->execute(\@command, @_);
	# Store stdout in temp file for path access
	my $fh = $obj->fh;
	$fh->seek(0, 0)  or die "seek: $!\n";
	$fh->truncate(0) or die "truncate: $!\n";
	$fh->print($obj->{RESULT}->{data} // '');
	$fh->flush;
	$fh->seek(0, 0)  or die "seek: $!\n";
    }
    $obj->date(ctime());
    $obj;
}

sub result {
    my $obj = shift;
    $obj->{RESULT};
}

sub execute {
    my $obj = shift;
    my $command = shift;
    my %opt = (%{$obj->{OPTION}}, @_);
    my @command = ref $command eq 'ARRAY' ? @$command : ($command);

    # Use nofork path for code references when requested
    if ($opt{nofork} and ref $command[0] eq 'CODE') {
	return $obj->_execute_in_place(\@command, %opt);
    }

    my $stderr = $opt{stderr} // '';

    # Create pipes for stdout and stderr
    pipe(my $stdout_r, my $stdout_w) or die "pipe: $!\n";
    pipe(my $stderr_r, my $stderr_w) or die "pipe: $!\n" if $stderr eq 'capture';

    my $pid = fork // die "fork: $!\n";
    if ($pid == 0) {
	# Child process
	close $stdout_r;
	close $stderr_r if $stderr eq 'capture';

	if (exists $opt{stdin}) {
	    my $tmp = new_tmpfile IO::File or die "tmpfile: $!\n";
	    binmode $tmp, ':encoding(utf8)';
	    $tmp->print($opt{stdin});
	    $tmp->seek(0, 0) or die "seek: $!\n";
	    open STDIN, '<&', $tmp or die "dup: $!\n";
	    binmode STDIN, ':encoding(utf8)';
	} elsif (my $input = $obj->{INPUT}) {
	    open STDIN, "<&=", $input->fileno or die "open: $!\n";
	    binmode STDIN, ':encoding(utf8)';
	}

	open STDOUT, ">&=", $stdout_w->fileno or die "open stdout: $!\n";
	if ($stderr eq 'redirect') {
	    open STDERR, ">&STDOUT" or die "open stderr: $!\n";
	} elsif ($stderr eq 'capture') {
	    open STDERR, ">&=", $stderr_w->fileno or die "open stderr: $!\n";
	}
	# else: stderr passes through to terminal

	if (ref $command[0] eq 'CODE') {
	    my $code = shift @command;
	    @ARGV = @command;
	    if (my $name = code_name($code)) {
		$0 = $name;
	    }
	    $code->(@command);
	    exit 0;
	}
	exec @command;
	die "exec: $@\n";
    }

    # Parent process
    close $stdout_w;
    close $stderr_w if $stderr eq 'capture';

    binmode $stdout_r, ':encoding(utf8)';
    binmode $stderr_r, ':encoding(utf8)' if $stderr eq 'capture';

    my $stdout = do { local $/; <$stdout_r> };
    my $stderr_out = $stderr eq 'capture' ? do { local $/; <$stderr_r> } : '';

    close $stdout_r;
    close $stderr_r if $stderr eq 'capture';

    waitpid $pid, 0;
    my $result = $?;

    return {
	result => $result,
	data   => $stdout,
	error  => $stderr_out,
	pid    => $pid,
    };
}

sub _tmpfile {
    my ($obj, $key, %opt) = @_;
    $key .= '_RAW' if $opt{raw};
    my $fh = $obj->{$key} //= do {
	my $f = new_tmpfile IO::File or die "tmpfile: $!\n";
	binmode $f, $opt{raw} ? ':utf8' : ':encoding(utf8)';
	$f;
    };
    $fh->seek(0, 0)  or die "seek: $!\n";
    $fh->truncate(0) or die "truncate: $!\n";
    $fh;
}

##
## Remove an encoding layer pushed on the handle.  Re-opening a
## filehandle over a dup (open FH, '>&', ...) keeps the existing
## layer stack, so without this the layer pushed for each execution
## would accumulate indefinitely.
## See https://github.com/kaz-utashiro/perl-perlio-leak-bench
##
sub _pop_encoding {
    my $fh = shift;
    my @layers = PerlIO::get_layers($fh);
    if (grep { defined && /^encoding\b/ } @layers[-2 .. -1]) {
	binmode $fh, ':pop';
    }
}

sub _utf8_flagged {
    my $fh = shift;
    !! grep { $_ eq 'utf8' } PerlIO::get_layers($fh);
}

##
## Undo the layer change made for the execution: pop the :encoding
## layer (non-raw), or clear the :utf8 flag if we set it (raw).
##
sub _restore_encoding {
    my($fh, $raw, $was_utf8) = @_;
    if ($raw) {
	binmode $fh, ':bytes' unless $was_utf8;
    } else {
	_pop_encoding($fh);
    }
}

sub _execute_in_place {
    my $obj = shift;
    my $command = shift;
    my %opt = @_;
    my @command = @$command;
    my $stderr_mode = $opt{stderr} // '';
    my $raw = $opt{raw};

    my $code = shift @command;

    my $tmp_stdout = $obj->_tmpfile('NOFORK_STDOUT', raw => $raw);

    # Save and redirect STDOUT (always needed)
    open my $save_stdout, '>&', \*STDOUT or die "dup STDOUT: $!\n";
    my $stdout_was_utf8 = _utf8_flagged(\*STDOUT);
    open STDOUT, '>&', $tmp_stdout or die "redirect STDOUT: $!\n";
    binmode STDOUT, $raw ? ':utf8' : ':encoding(utf8)';

    # Handle STDERR — only save/redirect when needed
    my ($save_stderr, $tmp_stderr);
    if ($stderr_mode eq 'redirect') {
	open $save_stderr, '>&', \*STDERR or die "dup STDERR: $!\n";
	open STDERR, '>&', \*STDOUT or die "redirect STDERR: $!\n";
    } elsif ($stderr_mode eq 'capture') {
	$tmp_stderr = $obj->_tmpfile('NOFORK_STDERR', raw => $raw);
	open $save_stderr, '>&', \*STDERR or die "dup STDERR: $!\n";
	open STDERR, '>&', $tmp_stderr or die "redirect STDERR: $!\n";
    }

    # Handle STDIN — only save/redirect when needed
    my $save_stdin;
    my $stdin_was_utf8;
    if (exists $opt{stdin}) {
	my $tmp_stdin = $obj->_tmpfile('NOFORK_STDIN', raw => $raw);
	$tmp_stdin->print($opt{stdin});
	$tmp_stdin->seek(0, 0) or die "seek: $!\n";
	open $save_stdin, '<&', \*STDIN or die "dup STDIN: $!\n";
	$stdin_was_utf8 = _utf8_flagged(\*STDIN);
	open STDIN, '<&', $tmp_stdin or die "redirect STDIN: $!\n";
	binmode STDIN, $raw ? ':utf8' : ':encoding(utf8)';
    } elsif (my $input = $obj->{INPUT}) {
	$input->seek(0, 0) or die "seek: $!\n";
	open $save_stdin, '<&', \*STDIN or die "dup STDIN: $!\n";
	$stdin_was_utf8 = _utf8_flagged(\*STDIN);
	open STDIN, '<&', $input->fileno or die "redirect STDIN: $!\n";
	binmode STDIN, $raw ? ':utf8' : ':encoding(utf8)';
    }

    # Set global state
    local $_;
    local @ARGV = @command;
    my $orig_0;
    if (my $name = code_name($code)) {
	$orig_0 = $0;
	$0 = $name;
    }

    # Execute
    my $result = 0;
    eval { $code->(@command) };
    if ($@) {
	$result = -1;
    }

    # Flush and restore — only what was redirected.  Undo the layer
    # change made above; restoring by re-open keeps the layer stack,
    # so it would persist (and :encoding would accumulate on every
    # execution) otherwise.
    STDOUT->flush;
    _restore_encoding(\*STDOUT, $raw, $stdout_was_utf8);
    open STDOUT, '>&', $save_stdout or die "restore STDOUT: $!\n";
    if ($save_stderr) {
	STDERR->flush;
	open STDERR, '>&', $save_stderr or die "restore STDERR: $!\n";
    }
    if ($save_stdin) {
	_restore_encoding(\*STDIN, $raw, $stdin_was_utf8);
	open STDIN, '<&', $save_stdin or die "restore STDIN: $!\n";
    }
    if (defined $orig_0) {
	$0 = $orig_0;
    }

    # Read captured output from tmpfiles
    $tmp_stdout->seek(0, 0) or die "seek: $!\n";
    my $stdout_data = do { local $/; <$tmp_stdout> };

    my $stderr_data = '';
    if ($tmp_stderr) {
	$tmp_stderr->seek(0, 0) or die "seek: $!\n";
	$stderr_data = do { local $/; <$tmp_stderr> };
    }

    return {
	result => $result,
	data   => $stdout_data,
	error  => $stderr_data,
    };
}

sub data {
    my $obj = shift;
    if (@_) {
	my $data = shift;
	$obj->{RESULT}->{data} = $data;
	my $fh = $obj->fh;
	$fh->seek(0, 0)  or die "seek: $!\n";
	$fh->truncate(0) or die "truncate: $!\n";
	$fh->print($data);
	$fh->flush;
	$fh->seek(0, 0)  or die "seek: $!\n";
	return $obj;
    }
    $obj->{RESULT}->{data};
}

sub error {
    my $obj = shift;
    $obj->{RESULT}->{error};
}

sub date {
    my $obj = shift;
    @_ ? $obj->{DATE} = shift : $obj->{DATE};
}

sub _set_stdin {
    my $obj = shift;
    my $data = shift;
    my $input = $obj->_tmpfile('INPUT');
    $input->fcntl(F_SETFD, 0) or die "fcntl F_SETFD: $!\n";
    $input->print($data);
    $input->seek(0, 0)  or die "seek: $!\n";
    $obj;
}

sub with {
    my $obj = shift;
    $obj->configure(@_);
}

1;

__END__