Commit | Line | Data |
---|---|---|
9d419b5f IZ |
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'; | |
2391436b | 167 | sleep 2; # XXX How to synchronize with kid??? |
9d419b5f IZ |
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'; |