-
Notifications
You must be signed in to change notification settings - Fork 26
/
01_sysrw.t
296 lines (222 loc) · 7.12 KB
/
01_sysrw.t
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
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
#!/usr/bin/perl -w
# vim: filetype=perl
use strict;
use Test::More tests => 17;
use POE::Pipe::OneWay;
BEGIN { use_ok("POE::Driver::SysRW") }
# Start with some errors.
eval { my $d = POE::Driver::SysRW->new( BlockSize => 0 ) };
ok(
$@ && $@ =~ /BlockSize must be greater than 0/,
"disallow zero or negative block sizes"
);
eval { my $d = POE::Driver::SysRW->new( 0 ) };
ok(
$@ && $@ =~ /requires an even number of parameters/,
"disallow zero or negative block sizes"
);
eval { my $d = POE::Driver::SysRW->new( Booga => 1 ) };
ok(
$@ && $@ =~ /unknown parameter.*Booga/,
"disallow unknown parameters"
);
# This block of tests also exercises the driver with its default
# constructor parameters.
{ my $d = POE::Driver::SysRW->new();
use Symbol qw(gensym);
my $fh = gensym();
open $fh, ">deleteme.now" or die $!;
$! = 0;
open(SAVE_STDERR, ">&STDERR") or die $!;
close(STDERR) or die $!;
my $get_ret = $d->get($fh);
ok(!defined($get_ret), "get() returns undef on error");
ok($!, "get() sets \$! on error ($!)");
open(STDERR, ">&SAVE_STDERR") or die $!;
close(SAVE_STDERR) or die $!;
close $fh;
unlink "deleteme.now";
}
my $d = POE::Driver::SysRW->new( BlockSize => 1024 );
# Empty put().
{ my $octets_left = $d->put([ ]);
ok( $octets_left == 0, "buffered 0 octets on empty put()" );
}
ok( $d->get_out_messages_buffered() == 0, "no messages buffered" );
# The number of octets we expect in the driver's put() buffer.
my $expected = 0;
# Put() returns the correct number of octets.
{ my $string_to_put = "test" x 10;
my $length_to_put = length($string_to_put);
$expected += $length_to_put;
my $octets_left = $d->put([ $string_to_put ]);
ok(
$octets_left == $expected,
"first put: buffer contains $octets_left octets (should be $expected)"
);
}
# Only one message buffered.
ok( $d->get_out_messages_buffered() == 1, "one message buffered" );
# Put() returns the correct number of octets on a subsequent call.
{ my $string_to_put = "more test" x 5;
my $length_to_put = length($string_to_put);
$expected += $length_to_put;
my $octets_left = $d->put([ $string_to_put ]);
ok(
$octets_left == $expected,
"second put: buffer contains $octets_left octets (should be $expected)"
);
}
# Remaining tests require some live handles.
# cygwin seems to block on syswrite() and close() even though a handle
# is non-blocking. Force the pipe to use Internet domain sockets.
# This solves the syswrite() problem. Later we call shutdown(2) on
# the write side rather than close(), which solves that end of things.
my ($r, $w);
if ($^O eq "cygwin") {
($r, $w) = POE::Pipe::OneWay->new("inet");
}
else {
($r, $w) = POE::Pipe::OneWay->new();
}
die "can't open a pipe: $!" unless $r;
nonblocking($w);
nonblocking($r);
# Number of flushed octets == number of read octets.
{ my $flushed_count = write_until_pipe_is_full($d, $w);
my $read_count = read_until_pipe_is_empty($d, $r);
ok(
$flushed_count == $read_count,
"flushed $flushed_count octets == read $read_count octets"
);
}
# Flush the buffer and the pipe.
while (flush_remaining_buffer($d, $w)) {
read_until_pipe_is_empty($d, $r);
}
{
my $out_messages = $d->get_out_messages_buffered();
ok($out_messages == 0, "buffer exhausted (got $out_messages wanted 0)");
}
# Get() returns undef ($! == 0) on EOF.
{ write_until_pipe_is_full($d, $w);
if ($^O eq "cygwin") {
shutdown($w, 2);
}
else {
close($w);
}
open(SAVE_STDERR, ">&STDERR") or die $!;
close(STDERR) or die $!;
while (1) {
$! = 1;
last unless defined $d->get($r);
}
pass("driver returns undef on eof");
ok($! == 0, "\$! is clear on eof");
open(STDERR, ">&SAVE_STDERR") or die $!;
close(SAVE_STDERR) or die $!;
}
# Flush() returns the number of octets remaining, and sets $! to
# nonzero on major error.
{ open(SAVE_STDERR, ">&STDERR") or die $!;
close(STDERR) or die $!;
# Make sure $w is closed. Sometimes, like on Cygwin, it isn't.
close $w;
$! = 0;
my $error_left = $d->flush($w);
ok($error_left, "put() returns octets left on error");
ok($!, "put() sets \$! nonzero on error");
open(STDERR, ">&SAVE_STDERR") or die $!;
close(SAVE_STDERR) or die $!;
}
exit 0;
# Buffer data, and flush it, until the pipe refuses to hold more data.
# This should also cause the driver to experience an EAGAIN or
# EWOULDBLOCK on write.
sub write_until_pipe_is_full {
my ($driver, $handle) = @_;
my $big_chunk = "*" x (1024 * 1024);
my $flushed = 0;
my $full = 0;
while (1) {
# Put a big chunk into the buffer.
my $buffered = $driver->put([ $big_chunk ]);
# Try to flush it.
my $after_flush = $driver->flush($handle);
# Flushed amount.
$flushed += $buffered - $after_flush;
# The pipe is full if there's data after the flush.
last if $after_flush;
}
return $flushed;
}
# Assume the driven has buffered data. This makes sure it's flushed,
# or at least the pipe is clogged. Combine it with
# read_until_pipe_is_empty() to flush the driver and the pipe.
sub flush_remaining_buffer {
my ($driver, $handle) = @_;
my $before_flush = $driver->get_out_messages_buffered();
$driver->flush($handle);
return $before_flush;
}
# Read until there's nothing left to read from the pipe. This should
# exercise the driver's EAGAIN/EWOULDBLOCK code on the read side.
sub read_until_pipe_is_empty {
my ($driver, $handle) = @_;
my $read_octets = 0;
# SunOS catalogue1 5.11 snv_101b i86pc i386 i86pc
# Sometimes returns "empty" when there's data in the pipe.
# Looping again seems to fetch the remaining data, though.
for (1..3) {
while (1) {
my $data = $driver->get($handle);
last unless defined($data) and @$data;
$read_octets += length() foreach @$data;
}
}
return $read_octets;
}
# Portable nonblocking sub. blocking(0) doesn't do it all the time,
# everywhere, and it sucks.
#
# This sub sucks, too. The code is lifted almost verbatim from
# POE::Resource::FileHandles. That code should probably be made a
# library function, but where should it go?
sub nonblocking {
my $handle = shift;
# For DOSISH systems like OS/2. Wrapped in eval{} in case it's a
# tied handle that doesn't support binmode.
eval { binmode *$handle };
# Turn off blocking unless it's tied or a plain file.
unless (tied *$handle or -f $handle) {
use POSIX;
use Fcntl;
unless ($^O eq "MSWin32") {
if ($] >= 5.008) {
$handle->blocking(0);
}
else {
# Long, drawn out, POSIX way.
my $flags = fcntl($handle, F_GETFL, 0)
or die "fcntl($handle, F_GETFL, etc.) fails: $!\n";
until (fcntl($handle, F_SETFL, $flags | O_NONBLOCK)) {
die "fcntl($handle, FSETFL, etc) fails: $!"
unless $! == EAGAIN or $! == EWOULDBLOCK;
}
}
}
else {
# Do it the Win32 way.
my $set_it = "1";
# 126 is FIONBIO (some docs say 0x7F << 16)
ioctl( $handle,
0x80000000 | (4 << 16) | (ord('f') << 8) | 126,
$set_it
)
or die "ioctl($handle, FIONBIO, $set_it) fails: $!\n";
}
}
# Turn off buffering.
CORE::select((CORE::select($handle), $| = 1)[0]);
}