Win32 build should scan cpan/ as well as ext/
[perl.git] / os2 / os2_pipe.t
1 #!/usr/bin/perl -w
2 BEGIN {
3     chdir 't' if -d 't';
4     @INC = '../lib';
5 }
6
7 use Test::More tests => 80;
8 use strict;
9 use IO::Handle;
10 use Fcntl;
11
12 my $pname = "/pipe/perl_pipe_test$$";
13
14 ok !eval {OS2::pipe $pname, 'wait'}, 'wait for non-existing pipe fails';
15 is 0 + $^E, 3, 'correct error code';
16 ok my $server_pipe = OS2::pipe($pname, 'rw'), 'create pipe, no connect';
17 ok((my $fd = fileno $server_pipe) >= 0, 'has a fileno');
18 is +(OS2::pipeCntl($server_pipe, 'readstate'))[0], 2, 'is listening';
19 is OS2::pipeCntl($server_pipe, 'state') & 0xFF, 1, 'max count=1';
20
21 ok 0 > OS2::pipeCntl($server_pipe, 'connect', !'wait'), 'connect nowait';
22
23 ok open(my $fh, '+<', $pname), 'open client end';
24 #ok sysopen($fh, $pname, O_RDWR), 'sysopen client end' . $^E;
25 #my ($fd1, $action) = OS2::open $pname, 0x2042 or warn $^E; # ERROR,SHARE,RDWR
26 is +(OS2::pipeCntl($server_pipe, 'readstate'))[0], 3, 'is connected';
27 ok 0 < OS2::pipeCntl($server_pipe, 'connect', !'wait'), 'connect nowait';
28 ok OS2::pipeCntl($server_pipe, 'connect', 'wait'), 'connect wait';
29 is $server_pipe->autoflush, 0, 'autoflush server'; # Returns the old value
30 is $fh->autoflush, 0, 'autoflush';      # Returns the old value
31 ok syswrite($server_pipe, "some string\n"), 'server write';
32 is scalar <$fh>, "some string\n", 'client read';
33 ok syswrite($fh, "another string\n"), 'client write';
34
35 is OS2::pipeCntl($server_pipe, 'peek'), "another string\n", 'peeking is fine';
36 my ($st, $bytesAvail, $bytesInMess) = OS2::pipeCntl($server_pipe, 'readstate');
37 my ($name, $remoteID, $outBuffer, $inBuffer, $maxInstance, $countInstance)
38   = OS2::pipeCntl($server_pipe, 'info');
39 is $bytesAvail, length("another string\n"), 'count bytes';
40 is $remoteID, 0, 'not remote';
41 is $maxInstance, 1, 'max count is 1';
42 is $countInstance, 1, 'count is 1';
43 #is $len, length($pname) + 1, 'length of name is 1 more than the actual';
44 (my $tmp = $pname) =~ s,/,\\,g;
45 is lc $name, lc $tmp, 'name is correct (up to case)';
46
47 # If do print() instead of syswrite(), this gets "some string\n" instead!!!
48 is scalar <$server_pipe>, "another string\n", 'server read';
49
50 ok !open(my $fh1, '+<', $pname), 'open client end fails';
51
52 # No new child present, return -1
53 ok 0 > OS2::pipeCntl($server_pipe, 'reset', !'wait'), 'server reset, no wait';
54 ok eof($fh), 'client EOF';
55 ok(($fh->clearerr, 1), 'client clear EOF');     # XXXX Returns void
56
57 $!=0; $^E = 0;
58 ok close $fh, 'close client';
59 #diag $!;
60 #diag $^E;
61 is fileno $fh, undef, 'was actually closed...';
62
63 ok open($fh, '+<', $pname), 'open client end';
64
65 is $fh->autoflush, 1, 'autoflush';      # Returns the old value
66 ok syswrite($server_pipe, "some string\n"), 'server write';
67 is scalar <$fh>, "some string\n", 'client read';
68 ok syswrite($fh, "another string\n"), 'client write';
69
70 # If do print() instead of syswrite(), this gets "some string\n" instead!!!
71 is scalar <$server_pipe>, "another string\n", 'server read';
72
73 ok syswrite($server_pipe, "some string\n"), 'server write';
74 ok syswrite($fh, "another string\n"), 'client write';
75 is scalar <$fh>, "some string\n", 'client read';
76
77 # If do print() instead of syswrite(), this gets "some string\n" instead!!!
78 is scalar <$server_pipe>, "another string\n", 'server read';
79
80 ok syswrite($server_pipe, "some string\n"), 'server write';
81 ok syswrite($fh, "another string\n"), 'client write';
82
83 ok((sysread $fh, my $in, 2000), 'client sysread');
84 is $in, "some string\n", 'client sysread correct';
85
86 # If do print() instead of syswrite(), this gets "some string\n" instead!!!
87 ok((sysread $server_pipe, $in, 2000), 'server sysread');
88 is $in, "another string\n", 'server sysread correct';
89
90 ok !open($fh1, '+<', $pname), 'open client end fails';
91
92 # XXXX Not needed???
93 #ok(($fh->clearerr, 1), 'client clear EOF');    # XXXX Returns void
94
95 ok close $fh, 'close client';
96 ok eof $server_pipe, 'server EOF';      # Creates an error condition
97
98 my $pid = system 4|0x40000, $^X, '-wle', <<'EOS', $pname; # SESSION|INDEPENDENT
99   my $success;
100   END {sleep($success ? 1 : 10);}
101   my $mess = '';
102   $SIG{TERM} = sub {die "kid1 error: Got SIGTERM\nmess=`$mess'"};
103   my $pn = shift;
104   my $fh;
105   eval {
106     $mess .= "Pipe open fails\n" unless open $fh, '+<', $pn;
107     my $t = time;               ### TIMESTAMP0
108     warn "kid1: Wait for pipe...\n";
109     $mess .= "Pipe became available\n" if OS2::pipe $pn, 'wait';
110     my $t1 = time() - $t;       ### TIMESTAMP1
111     $mess .= "Unexpected delay $t1\n" unless $t1 >= 1 and $t1 <= 3;
112     warn "kid1: sleep 4...\n";
113     sleep 4;
114     $mess .= "Pipe open\n" if open $fh, '+<', $pn;
115     binmode $fh;
116     1;                          ### TIMESTAMP2
117   } or warn $@;
118   warn "kid1: pipe opened...\n";
119   select $fh; $| = 1;
120   my $c = syswrite $fh, $mess or warn "print: $!";
121   warn "kid1: Wrote $c bytes\n";
122   warn $mess;
123   close $fh or die "kid1 error: close: $!";
124   $success = 1;
125 EOS
126
127 ok $pid > 0, 'kid pid';
128
129 ### TIMESTAMP0
130 sleep 2;
131 my $t = time;
132 ### TIMESTAMP1
133 # New child present; will clear error condition...
134 ok 0 < OS2::pipeCntl($server_pipe, 'reset', 'wait'), 'server reset, wait';
135 ### TIMESTAMP2
136 my $t1 = time() - $t;
137 ok $t1 <= 6 && $t1 >= 2, 'correct delay';
138
139 sleep 2;
140
141 ok binmode($server_pipe), 'binmode';
142 ok !eof $server_pipe, 'server: no EOF';
143 my @in = <$server_pipe>;
144 my @exp = ( "Pipe open fails\n", "Pipe became available\n", "Pipe open\n");
145
146 is "@in", "@exp", 'expected data';
147
148 # Can't switch to message mode if created in byte mode...
149 ok close $server_pipe, 'server close';
150 ok $server_pipe = OS2::pipe($pname, 'RW'), 'create pipe in message mode';
151 ok OS2::pipeCntl($server_pipe, 'byte'),    'can switch to byte mode';
152 ok OS2::pipeCntl($server_pipe, 'message'), 'can switch to message mode';
153
154 $pid = system 4|0x40000, $^X, '-wle', <<'EOS', $pname, $$; # SESSION|INDEPENDENT
155   END {sleep 2}
156   my ($name, $ppid) = (shift, shift);
157   $name =~ s,/,\\,g;
158   $name = uc $name;
159   warn "kid2: OS2::pipe $name, 'call', ...\n";
160   my $got = OS2::pipe $name, 'call', "Is your pid $ppid?\n";
161   my $ok = $got eq 'Yes';
162   warn "kid2: got `$got'\n";
163   OS2::pipe $name, 'call', $ok ? "fine\n" : "bad\n";
164 EOS
165
166 ok $pid, 'kid started';
167 sleep 2;                        # XXX How to syncronize with kid???
168 $in = scalar <$server_pipe>;
169 my $ok1 = ($in || '') eq "Is your pid $$?\n";
170 is $in, "Is your pid $$?\n", 'call in';
171 ok syswrite($server_pipe, $ok1 ? 'Yes' : 'No' ), 'server write';
172
173 ok 0 < OS2::pipeCntl($server_pipe, 'reset', 'wait'), 'server reset, wait';
174 $in = scalar <$server_pipe>;
175 is $in, "fine\n", 'call in';
176 ok syswrite($server_pipe, 'ending' ), 'server write';
177
178 ok close $server_pipe, 'server close';
179
180 ok $server_pipe = OS2::pipe($pname, 'W'), 'create pipe in message write mode';
181 ok !eval {OS2::pipeCntl($server_pipe, 'readstate'); 1}, 'readstate fails, as expected';
182 ok close $server_pipe, 'server close';
183
184 ok $server_pipe = OS2::pipe($pname, 'w'), 'create pipe in byte write mode';
185 ok !eval {OS2::pipeCntl($server_pipe, 'readstate'); 1}, 'readstate fails, as expected';
186 ok close $server_pipe, 'server close';
187
188 ok $server_pipe = OS2::pipe($pname, 'r'), 'create pipe in byte read mode';
189 is +(OS2::pipeCntl($server_pipe, 'readstate'))[0], 2, 'is listening';
190 ok close $server_pipe, 'server close';
191
192 ok $server_pipe = OS2::pipe($pname, 'r', 0), 'create-no-connect pipe in byte read mode';
193 is +(OS2::pipeCntl($server_pipe, 'readstate'))[0], 1, 'is disconnected';
194 ok close $server_pipe, 'server close';
195
196 ok $server_pipe = OS2::pipe($pname, 'R'), 'create pipe in message read mode';
197 is +(OS2::pipeCntl($server_pipe, 'readstate'))[0], 2, 'is listening';
198 ok close $server_pipe, 'server close';
199
200 #is waitpid($pid, 0), $pid, 'kid ended';
201 #is $?, 0, 'kid exitcode';