git.oblomov.eu Git - git/blob - t/t7006/test-terminal.perl

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