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 => 22);
  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", 4 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     SKIP: {
  54         skip "fork required", 2 unless $Config{d_fork};
  55
  56         pipe(READER,WRITER) || die "Can't open pipe";
  57
  58         if ($pid = fork) {
  59             close WRITER;
  60             while(<READER>) {
  61                 s/^not //;
  62                 y/A-Z/a-z/;
  63                 print;
  64             }
  65             close READER;     # avoid zombies
  66         }
  67         else {
  68             die "Couldn't fork" unless defined $pid;
  69             close READER;
  70             printf WRITER "not ok %d - pipe & fork\n", curr_test;
  71             next_test;
  72
  73             open(STDOUT,">&WRITER") || die "Can't dup WRITER to STDOUT";
  74             close WRITER;
  75
  76             my $tnum = curr_test;
  77             next_test;
  78             exec $Perl, '-le', "print q{not ok $tnum -     with fh dup }";
  79         }
  80
  81         # This has to be done *outside* the fork.
  82         next_test() for 1..2;
  83     }
  84 }
  85 wait;                           # Collect from $pid
  86
  87 pipe(READER,WRITER) || die "Can't open pipe";
  88 close READER;
  89
  90 $SIG{'PIPE'} = 'broken_pipe';
  91
  92 sub broken_pipe {
  93     $SIG{'PIPE'} = 'IGNORE';       # loop preventer
  94     printf "ok %d - SIGPIPE\n", curr_test;
  95 }
  96
  97 printf WRITER "not ok %d - SIGPIPE\n", curr_test;
  98 close WRITER;
  99 sleep 1;
 100 next_test;
 101 pass();
 102
 103 # VMS doesn't like spawning subprocesses that are still connected to
 104 # STDOUT.  Someone should modify these tests to work with VMS.
 105
 106 SKIP: {
 107     skip "doesn't like spawning subprocesses that are still connected", 10
 108       if $^O eq 'VMS';
 109
 110     SKIP: {
 111         # Sfio doesn't report failure when closing a broken pipe
 112         # that has pending output.  Go figure.  MachTen doesn't either,
 113         # but won't write to broken pipes, so nothing's pending at close.
 114         # BeOS will not write to broken pipes, either.
 115         # Nor does POSIX-BC.
 116         skip "Won't report failure on broken pipe", 1
 117           if $Config{d_sfio} || $^O eq 'machten' || $^O eq 'beos' ||
 118              $^O eq 'posix-bc';
 119
 120         local $SIG{PIPE} = 'IGNORE';
 121         open NIL, qq{|$Perl -e "exit 0"} or die "open failed: $!";
 122         sleep 5;
 123         if (print NIL 'foo') {
 124             # If print was allowed we had better get an error on close
 125             ok( !close NIL,     'close error on broken pipe' );
 126         }
 127         else {
 128             ok(close NIL,       'print failed on broken pipe');
 129         }
 130     }
 131
 132     SKIP: {
 133         skip "Don't work yet", 9 if $^O eq 'vmesa';
 134
 135         # check that errno gets forced to 0 if the piped program exited
 136         # non-zero
 137         open NIL, qq{|$Perl -e "exit 23";} or die "fork failed: $!";
 138         $! = 1;
 139         ok(!close NIL,  'close failure on non-zero piped exit');
 140         is($!, '',      '       errno');
 141         isnt($?, 0,     '       status');
 142
 143         SKIP: {
 144             skip "Don't work yet", 6 if $^O eq 'mpeix';
 145
 146             # check that status for the correct process is collected
 147             my $zombie;
 148             unless( $zombie = fork ) {
 149                 $NO_ENDING=1;
 150                 exit 37;
 151             }
 152             my $pipe = open *FH, "sleep 2;exit 13|" or die "Open: $!\n";
 153             $SIG{ALRM} = sub { return };
 154             alarm(1);
 155             is( close FH, '',   'close failure for... umm, something' );
 156             is( $?, 13*256,     '       status' );
 157             is( $!, '',         '       errno');
 158
 159             my $wait = wait;
 160             is( $?, 37*256,     'status correct after wait' );
 161             is( $wait, $zombie, '       wait pid' );
 162             is( $!, '',         '       errno');
 163         }
 164     }
 165 }
 166
 167 # Test new semantics for missing command in piped open
 168 # 19990114 M-J. Dominus mjd@plover.com
 169 { local *P;
 170   ok( !open(P, "|    "),        'missing command in piped open input' );
 171   ok( !open(P, "     |"),       '                              output');
 172 }
 173
 174 # check that status is unaffected by implicit close
 175 {
 176     local(*NIL);
 177     open NIL, qq{|$Perl -e "exit 23"} or die "fork failed: $!";
 178     $? = 42;
 179     # NIL implicitly closed here
 180 }
 181 is($?, 42,      'status unaffected by implicit close');
 182 $? = 0;
 183
 184 # check that child is reaped if the piped program can't be executed
 185 {
 186   open NIL, '/no_such_process |';
 187   close NIL;
 188
 189   my $child = 0;
 190   eval {
 191     local $SIG{ALRM} = sub { die; };
 192     alarm 2;
 193     $child = wait;
 194     alarm 0;
 195   };
 196
 197   is($child, -1, 'child reaped if piped program cannot be executed');
 198 }