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