t/io/pipe.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     require Config; import Config;
   7     require './test.pl';
   8
   9     if (!$Config{'d_fork'}) {
  10         skip_all("fork required to pipe");
  11     }
  12     else {
  13         plan(tests => 24);
  14     }
  15 }
  16
  17 my $Perl = which_perl();
  18
  19
  20 $| = 1;
  21
  22 open(PIPE, "|-") || exec $Perl, '-pe', 'tr/YX/ko/';
  23
  24 printf PIPE "Xk %d - open |- || exec\n", curr_test();
  25 next_test();
  26 printf PIPE "oY %d -    again\n", curr_test();
  27 next_test();
  28 close PIPE;
  29
  30 SKIP: {
  31     # Technically this should be TODO.  Someone try it if you happen to
  32     # have a vmesa machine.
  33     skip "Doesn't work here yet", 6 if $^O eq 'vmesa';
  34
  35     if (open(PIPE, "-|")) {
  36         while(<PIPE>) {
  37             s/^not //;
  38             print;
  39         }
  40         close PIPE;        # avoid zombies
  41     }
  42     else {
  43         printf STDOUT "not ok %d - open -|\n", curr_test();
  44         next_test();
  45         my $tnum = curr_test;
  46         next_test();
  47         exec $Perl, '-le', "print q{not ok $tnum -     again}";
  48     }
  49
  50     # This has to be *outside* the fork
  51     next_test() for 1..2;
  52
  53     my $raw = "abc\nrst\rxyz\r\nfoo\n";
  54     if (open(PIPE, "-|")) {
  55         $_ = join '', <PIPE>;
  56         (my $raw1 = $_) =~ s/not ok \d+ - //;
  57         my @r  = map ord, split //, $raw;
  58         my @r1 = map ord, split //, $raw1;
  59         if ($raw1 eq $raw) {
  60             s/^not (ok \d+ -) .*/$1 '@r1' passes through '-|'\n/s;
  61         } else {
  62             s/^(not ok \d+ -) .*/$1 expect '@r', got '@r1'\n/s;
  63         }
  64         print;
  65         close PIPE;        # avoid zombies
  66     }
  67     else {
  68         printf STDOUT "not ok %d - $raw", curr_test();
  69         exec $Perl, '-e0';      # Do not run END()...
  70     }
  71
  72     # This has to be *outside* the fork
  73     next_test();
  74
  75     if (open(PIPE, "|-")) {
  76         printf PIPE "not ok %d - $raw", curr_test();
  77         close PIPE;        # avoid zombies
  78     }
  79     else {
  80         $_ = join '', <STDIN>;
  81         (my $raw1 = $_) =~ s/not ok \d+ - //;
  82         my @r  = map ord, split //, $raw;
  83         my @r1 = map ord, split //, $raw1;
  84         if ($raw1 eq $raw) {
  85             s/^not (ok \d+ -) .*/$1 '@r1' passes through '|-'\n/s;
  86         } else {
  87             s/^(not ok \d+ -) .*/$1 expect '@r', got '@r1'\n/s;
  88         }
  89         print;
  90         exec $Perl, '-e0';      # Do not run END()...
  91     }
  92
  93     # This has to be *outside* the fork
  94     next_test();
  95
  96     SKIP: {
  97         skip "fork required", 2 unless $Config{d_fork};
  98
  99         pipe(READER,WRITER) || die "Can't open pipe";
 100
 101         if ($pid = fork) {
 102             close WRITER;
 103             while(<READER>) {
 104                 s/^not //;
 105                 y/A-Z/a-z/;
 106                 print;
 107             }
 108             close READER;     # avoid zombies
 109         }
 110         else {
 111             die "Couldn't fork" unless defined $pid;
 112             close READER;
 113             printf WRITER "not ok %d - pipe & fork\n", curr_test;
 114             next_test;
 115
 116             open(STDOUT,">&WRITER") || die "Can't dup WRITER to STDOUT";
 117             close WRITER;
 118
 119             my $tnum = curr_test;
 120             next_test;
 121             exec $Perl, '-le', "print q{not ok $tnum -     with fh dup }";
 122         }
 123
 124         # This has to be done *outside* the fork.
 125         next_test() for 1..2;
 126     }
 127 }
 128 wait;                           # Collect from $pid
 129
 130 pipe(READER,WRITER) || die "Can't open pipe";
 131 close READER;
 132
 133 $SIG{'PIPE'} = 'broken_pipe';
 134
 135 sub broken_pipe {
 136     $SIG{'PIPE'} = 'IGNORE';       # loop preventer
 137     printf "ok %d - SIGPIPE\n", curr_test;
 138 }
 139
 140 printf WRITER "not ok %d - SIGPIPE\n", curr_test;
 141 close WRITER;
 142 sleep 1;
 143 next_test;
 144 pass();
 145
 146 # VMS doesn't like spawning subprocesses that are still connected to
 147 # STDOUT.  Someone should modify these tests to work with VMS.
 148
 149 SKIP: {
 150     skip "doesn't like spawning subprocesses that are still connected", 10
 151       if $^O eq 'VMS';
 152
 153     SKIP: {
 154         # Sfio doesn't report failure when closing a broken pipe
 155         # that has pending output.  Go figure.
 156         # BeOS will not write to broken pipes, either.
 157         # Nor does POSIX-BC.
 158         skip "Won't report failure on broken pipe", 1
 159           if $Config{d_sfio} || $^O eq 'beos' ||
 160              $^O eq 'posix-bc';
 161
 162         local $SIG{PIPE} = 'IGNORE';
 163         open NIL, qq{|$Perl -e "exit 0"} or die "open failed: $!";
 164         sleep 5;
 165         if (print NIL 'foo') {
 166             # If print was allowed we had better get an error on close
 167             ok( !close NIL,     'close error on broken pipe' );
 168         }
 169         else {
 170             ok(close NIL,       'print failed on broken pipe');
 171         }
 172     }
 173
 174     SKIP: {
 175         skip "Don't work yet", 9 if $^O eq 'vmesa';
 176
 177         # check that errno gets forced to 0 if the piped program exited
 178         # non-zero
 179         open NIL, qq{|$Perl -e "exit 23";} or die "fork failed: $!";
 180         $! = 1;
 181         ok(!close NIL,  'close failure on non-zero piped exit');
 182         is($!, '',      '       errno');
 183         isnt($?, 0,     '       status');
 184
 185         SKIP: {
 186             skip "Don't work yet", 6 if $^O eq 'mpeix';
 187
 188             # check that status for the correct process is collected
 189             my $zombie;
 190             unless( $zombie = fork ) {
 191                 $NO_ENDING=1;
 192                 exit 37;
 193             }
 194             my $pipe = open *FH, "sleep 2;exit 13|" or die "Open: $!\n";
 195             $SIG{ALRM} = sub { return };
 196             alarm(1);
 197             is( close FH, '',   'close failure for... umm, something' );
 198             is( $?, 13*256,     '       status' );
 199             is( $!, '',         '       errno');
 200
 201             my $wait = wait;
 202             is( $?, 37*256,     'status correct after wait' );
 203             is( $wait, $zombie, '       wait pid' );
 204             is( $!, '',         '       errno');
 205         }
 206     }
 207 }
 208
 209 # Test new semantics for missing command in piped open
 210 # 19990114 M-J. Dominus mjd@plover.com
 211 { local *P;
 212   no warnings 'pipe';
 213   ok( !open(P, "|    "),        'missing command in piped open input' );
 214   ok( !open(P, "     |"),       '                              output');
 215 }
 216
 217 # check that status is unaffected by implicit close
 218 {
 219     local(*NIL);
 220     open NIL, qq{|$Perl -e "exit 23"} or die "fork failed: $!";
 221     $? = 42;
 222     # NIL implicitly closed here
 223 }
 224 is($?, 42,      'status unaffected by implicit close');
 225 $? = 0;
 226
 227 # check that child is reaped if the piped program can't be executed
 228 SKIP: {
 229   skip "/no_such_process exists", 1 if -e "/no_such_process";
 230   open NIL, '/no_such_process |';
 231   close NIL;
 232
 233   my $child = 0;
 234   eval {
 235     local $SIG{ALRM} = sub { die; };
 236     alarm 2;
 237     $child = wait;
 238     alarm 0;
 239   };
 240
 241   is($child, -1, 'child reaped if piped program cannot be executed');
 242 }