t/io/pipe.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     unshift @INC, '../lib';
   6     require Config; import Config;
   7     unless ($Config{'d_fork'}) {
   8         print "1..0 # Skip: no fork\n";
   9         exit 0;
  10     }
  11 }
  12
  13 $| = 1;
  14 print "1..15\n";
  15
  16 # External program 'tr' assumed.
  17 open(PIPE, "|-") || (exec 'tr', 'YX', 'ko');
  18 print PIPE "Xk 1\n";
  19 print PIPE "oY 2\n";
  20 close PIPE;
  21
  22 if ($^O eq 'vmesa') {
  23     # Doesn't work, yet.
  24     for (3..6) {
  25         print "ok $_ # skipped\n";
  26     }
  27 } else {
  28     if (open(PIPE, "-|")) {
  29         while(<PIPE>) {
  30             s/^not //;
  31             print;
  32         }
  33         close PIPE;        # avoid zombies which disrupt test 12
  34     }
  35     else {
  36         # External program 'echo' assumed.
  37         print STDOUT "not ok 3\n";
  38         exec 'echo', 'not ok 4';
  39     }
  40
  41     pipe(READER,WRITER) || die "Can't open pipe";
  42
  43     if ($pid = fork) {
  44         close WRITER;
  45         while(<READER>) {
  46             s/^not //;
  47             y/A-Z/a-z/;
  48             print;
  49         }
  50         close READER;     # avoid zombies which disrupt test 12
  51     }
  52     else {
  53         die "Couldn't fork" unless defined $pid;
  54         close READER;
  55         print WRITER "not ok 5\n";
  56         open(STDOUT,">&WRITER") || die "Can't dup WRITER to STDOUT";
  57         close WRITER;
  58         # External program 'echo' assumed.
  59         exec 'echo', 'not ok 6';
  60     }
  61 }
  62 wait;                           # Collect from $pid
  63
  64 pipe(READER,WRITER) || die "Can't open pipe";
  65 close READER;
  66
  67 $SIG{'PIPE'} = 'broken_pipe';
  68
  69 sub broken_pipe {
  70     $SIG{'PIPE'} = 'IGNORE';       # loop preventer
  71     print "ok 7\n";
  72 }
  73
  74 print WRITER "not ok 7\n";
  75 close WRITER;
  76 sleep 1;
  77 print "ok 8\n";
  78
  79 # VMS doesn't like spawning subprocesses that are still connected to
  80 # STDOUT.  Someone should modify tests #9 to #12 to work with VMS.
  81
  82 if ($^O eq 'VMS') {
  83     print "ok 9 # skipped\n";
  84     print "ok 10 # skipped\n";
  85     print "ok 11 # skipped\n";
  86     print "ok 12 # skipped\n";
  87     exit;
  88 }
  89
  90 if ($Config{d_sfio} || $^O eq 'machten' || $^O eq 'beos' || $^O eq 'posix-bc') {
  91     # Sfio doesn't report failure when closing a broken pipe
  92     # that has pending output.  Go figure.  MachTen doesn't either,
  93     # but won't write to broken pipes, so nothing's pending at close.
  94     # BeOS will not write to broken pipes, either.
  95     # Nor does POSIX-BC.
  96     print "ok 9 # skipped\n";
  97 }
  98 else {
  99     local $SIG{PIPE} = 'IGNORE';
 100     open NIL, '|true'   or die "open failed: $!";
 101     sleep 2;
 102     print NIL 'foo'     or die "print failed: $!";
 103     if (close NIL) {
 104         print "not ok 9\n";
 105     }
 106     else {
 107         print "ok 9\n";
 108     }
 109 }
 110
 111 if ($^O eq 'vmesa') {
 112     # These don't work, yet.
 113     print "ok 10 # skipped\n";
 114     print "ok 11 # skipped\n";
 115     print "ok 12 # skipped\n";
 116     exit;
 117 }
 118
 119 # check that errno gets forced to 0 if the piped program exited non-zero
 120 open NIL, '|exit 23;' or die "fork failed: $!";
 121 $! = 1;
 122 if (close NIL) {
 123     print "not ok 10\n# successful close\n";
 124 }
 125 elsif ($! != 0) {
 126     print "not ok 10\n# errno $!\n";
 127 }
 128 elsif ($? == 0) {
 129     print "not ok 10\n# status 0\n";
 130 }
 131 else {
 132     print "ok 10\n";
 133 }
 134
 135 # check that status for the correct process is collected
 136 my $zombie = fork or exit 37;
 137 my $pipe = open *FH, "sleep 2;exit 13|" or die "Open: $!\n";
 138 $SIG{ALRM} = sub { return };
 139 alarm(1);
 140 my $close = close FH;
 141 if ($? == 13*256 && ! length $close && ! $!) {
 142     print "ok 11\n";
 143 } else {
 144     print "not ok 11\n# close $close\$?=$?   \$!=", $!+0, ":$!\n";
 145 };
 146 my $wait = wait;
 147 if ($? == 37*256 && $wait == $zombie && ! $!) {
 148     print "ok 12\n";
 149 } else {
 150     print "not ok 12\n# pid=$wait first=$pid pipe=$pipe zombie=$zombie me=$$ \$?=$?   \$!=", $!+0, ":$!\n";
 151 }
 152
 153 # Test new semantics for missing command in piped open
 154 # 19990114 M-J. Dominus mjd@plover.com
 155 { local *P;
 156   print (((open P, "|    " ) ? "not " : ""), "ok 13\n");
 157   print (((open P, "     |" ) ? "not " : ""), "ok 14\n");
 158 }
 159
 160 # check that status is unaffected by implicit close
 161 {
 162     local(*NIL);
 163     open NIL, '|exit 23;' or die "fork failed: $!";
 164     $? = 42;
 165     # NIL implicitly closed here
 166 }
 167 if ($? != 42) {
 168     print "# status $?, expected 42\nnot ";
 169 }
 170 print "ok 15\n";
 171 $? = 0;