f4609b896f
This also bumps the stable nixpkgs to 20.09 as of 2020-11-21, because there is some breakage in the git build related to the netrc credentials helper which someone has taken care of in nixpkgs. The stable channel is not used for anything other than git, so this should be fine. Change-Id: I3575a19dab09e1e9556cf8231d717de9890484fb
105 lines
2.3 KiB
Perl
Executable file
105 lines
2.3 KiB
Perl
Executable file
#!/usr/bin/perl
|
|
use 5.008;
|
|
use strict;
|
|
use warnings;
|
|
use IO::Pty;
|
|
use File::Copy;
|
|
|
|
# Run @$argv in the background with stdio redirected to $in, $out and $err.
|
|
sub start_child {
|
|
my ($argv, $in, $out, $err) = @_;
|
|
my $pid = fork;
|
|
if (not defined $pid) {
|
|
die "fork failed: $!"
|
|
} elsif ($pid == 0) {
|
|
open STDIN, "<&", $in;
|
|
open STDOUT, ">&", $out;
|
|
open STDERR, ">&", $err;
|
|
close $in;
|
|
close $out;
|
|
exec(@$argv) or die "cannot exec '$argv->[0]': $!"
|
|
}
|
|
return $pid;
|
|
}
|
|
|
|
# Wait for $pid to finish.
|
|
sub finish_child {
|
|
# Simplified from wait_or_whine() in run-command.c.
|
|
my ($pid) = @_;
|
|
|
|
my $waiting = waitpid($pid, 0);
|
|
if ($waiting < 0) {
|
|
die "waitpid failed: $!";
|
|
} elsif ($? & 127) {
|
|
my $code = $? & 127;
|
|
warn "died of signal $code";
|
|
return $code + 128;
|
|
} else {
|
|
return $? >> 8;
|
|
}
|
|
}
|
|
|
|
sub xsendfile {
|
|
my ($out, $in) = @_;
|
|
|
|
# Note: the real sendfile() cannot read from a terminal.
|
|
|
|
# It is unspecified by POSIX whether reads
|
|
# from a disconnected terminal will return
|
|
# EIO (as in AIX 4.x, IRIX, and Linux) or
|
|
# end-of-file. Either is fine.
|
|
copy($in, $out, 4096) or $!{EIO} or die "cannot copy from child: $!";
|
|
}
|
|
|
|
sub copy_stdin {
|
|
my ($in) = @_;
|
|
my $pid = fork;
|
|
if (!$pid) {
|
|
xsendfile($in, \*STDIN);
|
|
exit 0;
|
|
}
|
|
close($in);
|
|
return $pid;
|
|
}
|
|
|
|
sub copy_stdio {
|
|
my ($out, $err) = @_;
|
|
my $pid = fork;
|
|
defined $pid or die "fork failed: $!";
|
|
if (!$pid) {
|
|
close($out);
|
|
xsendfile(\*STDERR, $err);
|
|
exit 0;
|
|
}
|
|
close($err);
|
|
xsendfile(\*STDOUT, $out);
|
|
finish_child($pid) == 0
|
|
or exit 1;
|
|
}
|
|
|
|
if ($#ARGV < 1) {
|
|
die "usage: test-terminal program args";
|
|
}
|
|
$ENV{TERM} = 'vt100';
|
|
my $parent_in = new IO::Pty;
|
|
my $parent_out = new IO::Pty;
|
|
my $parent_err = new IO::Pty;
|
|
$parent_in->set_raw();
|
|
$parent_out->set_raw();
|
|
$parent_err->set_raw();
|
|
$parent_in->slave->set_raw();
|
|
$parent_out->slave->set_raw();
|
|
$parent_err->slave->set_raw();
|
|
my $pid = start_child(\@ARGV, $parent_in->slave, $parent_out->slave, $parent_err->slave);
|
|
close $parent_in->slave;
|
|
close $parent_out->slave;
|
|
close $parent_err->slave;
|
|
my $in_pid = copy_stdin($parent_in);
|
|
copy_stdio($parent_out, $parent_err);
|
|
my $ret = finish_child($pid);
|
|
# If the child process terminates before our copy_stdin() process is able to
|
|
# write all of its data to $parent_in, the copy_stdin() process could stall.
|
|
# Send SIGTERM to it to ensure it terminates.
|
|
kill 'TERM', $in_pid;
|
|
finish_child($in_pid);
|
|
exit($ret);
|