t/io/pipe.t

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