mirror of
https://github.com/git/git
synced 2024-10-30 14:03:28 +00:00
d13a73e383
The following commit will make use of a Getopt::Long feature which is
only present in Perl >= 5.8.1. Document that as the minimum version we
support.
Many of our Perl scripts will continue to run with 5.8.0 but this change
allows us to adjust them as needed without breaking any promises to our
users.
The Perl requirement was last changed in d48b284183 (perl: bump the
required Perl version to 5.8 from 5.6.[21], 2010-09-24). At that time,
5.8.0 was 8 years old. It is now over 21 years old.
Signed-off-by: Todd Zullinger <tmz@pobox.com>
Signed-off-by: Junio C Hamano <gitster@pobox.com>
105 lines
2.3 KiB
Perl
Executable file
105 lines
2.3 KiB
Perl
Executable file
#!/usr/bin/perl
|
|
use 5.008001;
|
|
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);
|