home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / t / io / pipe.t < prev    next >
Text File  |  2000-03-20  |  4KB  |  177 lines
  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 5;
  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. if ($^O eq 'mpeix') {
  136.     print "ok 11 # skipped\n";
  137.     print "ok 12 # skipped\n";
  138. } else {
  139.     # check that status for the correct process is collected
  140.     my $zombie = fork or exit 37;
  141.     my $pipe = open *FH, "sleep 2;exit 13|" or die "Open: $!\n";
  142.     $SIG{ALRM} = sub { return };
  143.     alarm(1);
  144.     my $close = close FH;
  145.     if ($? == 13*256 && ! length $close && ! $!) {
  146.         print "ok 11\n";
  147.     } else {
  148.         print "not ok 11\n# close $close\$?=$?   \$!=", $!+0, ":$!\n";
  149.     };
  150.     my $wait = wait;
  151.     if ($? == 37*256 && $wait == $zombie && ! $!) {
  152.         print "ok 12\n";
  153.     } else {
  154.         print "not ok 12\n# pid=$wait first=$pid pipe=$pipe zombie=$zombie me=$$ \$?=$?   \$!=", $!+0, ":$!\n";
  155.     }
  156. }
  157.  
  158. # Test new semantics for missing command in piped open
  159. # 19990114 M-J. Dominus mjd@plover.com
  160. { local *P;
  161.   print (((open P, "|    " ) ? "not " : ""), "ok 13\n");
  162.   print (((open P, "     |" ) ? "not " : ""), "ok 14\n");
  163. }
  164.  
  165. # check that status is unaffected by implicit close
  166. {
  167.     local(*NIL);
  168.     open NIL, '|exit 23;' or die "fork failed: $!";
  169.     $? = 42;
  170.     # NIL implicitly closed here
  171. }
  172. if ($? != 42) {
  173.     print "# status $?, expected 42\nnot ";
  174. }
  175. print "ok 15\n";
  176. $? = 0;
  177.