]>
Commit | Line | Data |
---|---|---|
1 | #!/usr/bin/perl | |
2 | use 5.008001; | |
3 | use strict; | |
4 | use warnings; | |
5 | use IO::Pty; | |
6 | use File::Copy; | |
7 | ||
8 | # Run @$argv in the background with stdio redirected to $out and $err. | |
9 | sub start_child { | |
10 | my ($argv, $out, $err) = @_; | |
11 | my $pid = fork; | |
12 | if (not defined $pid) { | |
13 | die "fork failed: $!" | |
14 | } elsif ($pid == 0) { | |
15 | open STDOUT, ">&", $out; | |
16 | open STDERR, ">&", $err; | |
17 | close $out; | |
18 | exec(@$argv) or die "cannot exec '$argv->[0]': $!" | |
19 | } | |
20 | return $pid; | |
21 | } | |
22 | ||
23 | # Wait for $pid to finish. | |
24 | sub finish_child { | |
25 | # Simplified from wait_or_whine() in run-command.c. | |
26 | my ($pid) = @_; | |
27 | ||
28 | my $waiting = waitpid($pid, 0); | |
29 | if ($waiting < 0) { | |
30 | die "waitpid failed: $!"; | |
31 | } elsif ($? & 127) { | |
32 | my $code = $? & 127; | |
33 | warn "died of signal $code"; | |
34 | return $code + 128; | |
35 | } else { | |
36 | return $? >> 8; | |
37 | } | |
38 | } | |
39 | ||
40 | sub xsendfile { | |
41 | my ($out, $in) = @_; | |
42 | ||
43 | # Note: the real sendfile() cannot read from a terminal. | |
44 | ||
45 | # It is unspecified by POSIX whether reads | |
46 | # from a disconnected terminal will return | |
47 | # EIO (as in AIX 4.x, IRIX, and Linux) or | |
48 | # end-of-file. Either is fine. | |
49 | copy($in, $out, 4096) or $!{EIO} or die "cannot copy from child: $!"; | |
50 | } | |
51 | ||
52 | sub copy_stdio { | |
53 | my ($out, $err) = @_; | |
54 | my $pid = fork; | |
55 | defined $pid or die "fork failed: $!"; | |
56 | if (!$pid) { | |
57 | close($out); | |
58 | xsendfile(\*STDERR, $err); | |
59 | exit 0; | |
60 | } | |
61 | close($err); | |
62 | xsendfile(\*STDOUT, $out); | |
63 | finish_child($pid) == 0 | |
64 | or exit 1; | |
65 | } | |
66 | ||
67 | if ($#ARGV < 1) { | |
68 | die "usage: test-terminal program args"; | |
69 | } | |
70 | $ENV{TERM} = 'vt100'; | |
71 | my $parent_out = new IO::Pty; | |
72 | my $parent_err = new IO::Pty; | |
73 | $parent_out->set_raw(); | |
74 | $parent_err->set_raw(); | |
75 | $parent_out->slave->set_raw(); | |
76 | $parent_err->slave->set_raw(); | |
77 | my $pid = start_child(\@ARGV, $parent_out->slave, $parent_err->slave); | |
78 | close $parent_out->slave; | |
79 | close $parent_err->slave; | |
80 | copy_stdio($parent_out, $parent_err); | |
81 | my $ret = finish_child($pid); | |
82 | exit($ret); |