This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
7a45a7c2983ac5d456b30f8bd9c16c4cb803d542
[perl5.git] / ext / IO / t / io_pipe.t
1 #!./perl
2
3 my $perl;
4
5 BEGIN {
6     unless(grep /blib/, @INC) {
7         $perl = './perl';
8         chdir 't' if -d 't';
9         @INC = '../lib';
10     }
11     else {
12         $perl = $^X;
13     }
14 }
15
16 use Config;
17
18 BEGIN {
19     my $reason;
20     if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bIO\b/) {
21         $reason = 'IO extension unavailable';
22     }
23     elsif (! $Config{'d_fork'}) {
24         $reason = 'no fork';
25     }
26     if ($reason) {
27         print "1..0 # Skip: $reason\n";
28         exit 0;
29     }
30 }
31
32 use IO::Pipe;
33
34
35 $| = 1;
36 print "1..10\n";
37
38 $pipe = new IO::Pipe->reader($perl, '-e', 'print "not ok 1\n"');
39 while (<$pipe>) {
40   s/^not //;
41   print;
42 }
43 $pipe->close or print "# \$!=$!\nnot ";
44 print "ok 2\n";
45
46 $cmd = 'BEGIN{$SIG{ALRM} = sub {print "not ok 4\n"; exit}; alarm 10} s/not //';
47 $pipe = new IO::Pipe->writer($perl, '-pe', $cmd);
48 print $pipe "not ok 3\n" ;
49 $pipe->close or print "# \$!=$!\nnot ";
50 print "ok 4\n";
51
52 # Check if can fork with dynamic extensions (bug in CRT):
53 if ($^O eq 'os2' and
54     system "$^X -I../lib -MOpcode -e 'defined fork or die'  > /dev/null 2>&1") {
55     print "ok $_ # skipped: broken fork\n" for 5..10;
56     exit 0;
57 }
58
59 $pipe = new IO::Pipe;
60
61 $pid = fork();
62
63 if($pid)
64  {
65   $pipe->writer;
66   print $pipe "Xk 5\n";
67   print $pipe "oY 6\n";
68   $pipe->close;
69   wait;
70  }
71 elsif(defined $pid)
72  {
73   $pipe->reader;
74   $stdin = bless \*STDIN, "IO::Handle";
75   $stdin->fdopen($pipe,"r");
76   exec 'tr', 'YX', 'ko';
77  }
78 else
79  {
80   die "# error = $!";
81  }
82
83 $pipe = new IO::Pipe;
84 $pid = fork();
85
86 if($pid)
87  {
88   $pipe->reader;
89   while(<$pipe>) {
90       s/^not //;
91       print;
92   }
93   $pipe->close;
94   wait;
95  }
96 elsif(defined $pid)
97  {
98   $pipe->writer;
99
100   $stdout = bless \*STDOUT, "IO::Handle";
101   $stdout->fdopen($pipe,"w");
102   print STDOUT "not ok 7\n";
103   exec 'echo', 'not ok 8';
104  }
105 else
106  {
107   die;
108  }
109
110 $pipe = new IO::Pipe;
111 $pipe->writer;
112
113 $SIG{'PIPE'} = 'broken_pipe';
114
115 sub broken_pipe {
116     print "ok 9\n";
117 }
118
119 print $pipe "not ok 9\n";
120 $pipe->close;
121
122 sleep 1;
123
124 print "ok 10\n";
125