Commit | Line | Data |
9d419b5f |
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'; |