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
|
#!./perl -w
BEGIN {
unless(grep /blib/, @INC) {
chdir 't' if -d 't';
@INC = '../lib';
}
}
select(STDERR); $| = 1;
select(STDOUT); $| = 1;
print "1..23\n";
use IO::Select 1.09;
my $sel = new IO::Select(\*STDIN);
$sel->add(4, 5) == 2 or print "not ";
print "ok 1\n";
$sel->add([\*STDOUT, 'foo']) == 1 or print "not ";
print "ok 2\n";
@handles = $sel->handles;
print "not " unless $sel->count == 4 && @handles == 4;
print "ok 3\n";
#print $sel->as_string, "\n";
$sel->remove(\*STDIN) == 1 or print "not ";
print "ok 4\n",
;
$sel->remove(\*STDIN, 5, 6) == 1 # two of there are not present
or print "not ";
print "ok 5\n";
print "not " unless $sel->count == 2;
print "ok 6\n";
#print $sel->as_string, "\n";
$sel->remove(1, 4);
print "not " unless $sel->count == 0 && !defined($sel->bits);
print "ok 7\n";
$sel = new IO::Select;
print "not " unless $sel->count == 0 && !defined($sel->bits);
print "ok 8\n";
$sel->remove([\*STDOUT, 5]);
print "not " unless $sel->count == 0 && !defined($sel->bits);
print "ok 9\n";
if ( grep $^O eq $_, qw(MSWin32 NetWare dos VMS riscos beos) ) {
for (10 .. 15) {
print "ok $_ # skip: 4-arg select is only valid on sockets\n"
}
$sel->add(\*STDOUT); # update
goto POST_SOCKET;
}
@a = $sel->can_read(); # should return imediately
print "not " unless @a == 0;
print "ok 10\n";
# we assume that we can write to STDOUT :-)
$sel->add([\*STDOUT, "ok 12\n"]);
@a = $sel->can_write;
print "not " unless @a == 1;
print "ok 11\n";
my($fd, $msg) = @{shift @a};
print $fd $msg;
$sel->add(\*STDOUT); # update
@a = IO::Select::select(undef, $sel, undef, 1);
print "not " unless @a == 3;
print "ok 13\n";
($r, $w, $e) = @a;
print "not " unless @$r == 0 && @$w == 1 && @$e == 0;
print "ok 14\n";
$fd = $w->[0];
print $fd "ok 15\n";
POST_SOCKET:
# Test new exists() method
$sel->exists(\*STDIN) and print "not ";
print "ok 16\n";
($sel->exists(0) || $sel->exists([\*STDERR])) and print "not ";
print "ok 17\n";
$fd = $sel->exists(\*STDOUT);
if ($fd) {
print $fd "ok 18\n";
} else {
print "not ok 18\n";
}
$fd = $sel->exists([1, 'foo']);
if ($fd) {
print $fd "ok 19\n";
} else {
print "not ok 19\n";
}
# Try self clearing
$sel->add(5,6,7,8,9,10);
print "not " unless $sel->count == 7;
print "ok 20\n";
$sel->remove($sel->handles);
print "not " unless $sel->count == 0 && !defined($sel->bits);
print "ok 21\n";
# check warnings
$SIG{__WARN__} = sub {
++ $w
if $_[0] =~ /^Call to deprecated method 'has_error', use 'has_exception'/ ;
} ;
$w = 0 ;
{
no warnings 'IO::Select' ;
IO::Select::has_error();
}
print "not " unless $w == 0 ;
$w = 0 ;
print "ok 22\n" ;
{
use warnings 'IO::Select' ;
IO::Select::has_error();
}
print "not " unless $w == 1 ;
$w = 0 ;
print "ok 23\n" ;
|
