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