This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #75156] fix the return value and bits for removing a closed fh
[perl5.git] / dist / IO / t / io_sel.t
CommitLineData
35a60386 1#!./perl -w
7a4c00b4 2
7a4c00b4
PP
3select(STDERR); $| = 1;
4select(STDOUT); $| = 1;
5
3bfb0615 6print "1..27\n";
7a4c00b4
PP
7
8use IO::Select 1.09;
9
10my $sel = new IO::Select(\*STDIN);
11$sel->add(4, 5) == 2 or print "not ";
12print "ok 1\n";
13
14$sel->add([\*STDOUT, 'foo']) == 1 or print "not ";
15print "ok 2\n";
16
17@handles = $sel->handles;
18print "not " unless $sel->count == 4 && @handles == 4;
19print "ok 3\n";
20#print $sel->as_string, "\n";
21
22$sel->remove(\*STDIN) == 1 or print "not ";
23print "ok 4\n",
24;
25$sel->remove(\*STDIN, 5, 6) == 1 # two of there are not present
26 or print "not ";
27print "ok 5\n";
28
29print "not " unless $sel->count == 2;
30print "ok 6\n";
31#print $sel->as_string, "\n";
32
33$sel->remove(1, 4);
34print "not " unless $sel->count == 0 && !defined($sel->bits);
35print "ok 7\n";
36
37$sel = new IO::Select;
38print "not " unless $sel->count == 0 && !defined($sel->bits);
39print "ok 8\n";
40
41$sel->remove([\*STDOUT, 5]);
42print "not " unless $sel->count == 0 && !defined($sel->bits);
43print "ok 9\n";
44
4024c853 45if ( grep $^O eq $_, qw(MSWin32 NetWare dos VMS riscos beos) ) {
05f4e11e
MS
46 for (10 .. 15) {
47 print "ok $_ # skip: 4-arg select is only valid on sockets\n"
48 }
68dc0745
PP
49 $sel->add(\*STDOUT); # update
50 goto POST_SOCKET;
51}
52
c4a6f826 53@a = $sel->can_read(); # should return immediately
7a4c00b4
PP
54print "not " unless @a == 0;
55print "ok 10\n";
56
57# we assume that we can write to STDOUT :-)
58$sel->add([\*STDOUT, "ok 12\n"]);
59
60@a = $sel->can_write;
61print "not " unless @a == 1;
62print "ok 11\n";
63
64my($fd, $msg) = @{shift @a};
65print $fd $msg;
66
67$sel->add(\*STDOUT); # update
68
69@a = IO::Select::select(undef, $sel, undef, 1);
70print "not " unless @a == 3;
71print "ok 13\n";
72
73($r, $w, $e) = @a;
74
75print "not " unless @$r == 0 && @$w == 1 && @$e == 0;
76print "ok 14\n";
77
78$fd = $w->[0];
79print $fd "ok 15\n";
80
68dc0745 81POST_SOCKET:
7a4c00b4
PP
82# Test new exists() method
83$sel->exists(\*STDIN) and print "not ";
84print "ok 16\n";
85
86($sel->exists(0) || $sel->exists([\*STDERR])) and print "not ";
87print "ok 17\n";
88
89$fd = $sel->exists(\*STDOUT);
90if ($fd) {
91 print $fd "ok 18\n";
92} else {
93 print "not ok 18\n";
94}
95
96$fd = $sel->exists([1, 'foo']);
97if ($fd) {
98 print $fd "ok 19\n";
99} else {
100 print "not ok 19\n";
101}
102
103# Try self clearing
104$sel->add(5,6,7,8,9,10);
105print "not " unless $sel->count == 7;
106print "ok 20\n";
107
108$sel->remove($sel->handles);
109print "not " unless $sel->count == 0 && !defined($sel->bits);
110print "ok 21\n";
d3a7d8c7
GS
111
112# check warnings
113$SIG{__WARN__} = sub {
114 ++ $w
35a60386 115 if $_[0] =~ /^Call to deprecated method 'has_error', use 'has_exception'/ ;
d3a7d8c7
GS
116 } ;
117$w = 0 ;
35a60386
RGS
118{
119no warnings 'IO::Select' ;
d3a7d8c7 120IO::Select::has_error();
35a60386 121}
d3a7d8c7
GS
122print "not " unless $w == 0 ;
123$w = 0 ;
124print "ok 22\n" ;
35a60386 125{
d3a7d8c7
GS
126use warnings 'IO::Select' ;
127IO::Select::has_error();
35a60386 128}
d3a7d8c7
GS
129print "not " unless $w == 1 ;
130$w = 0 ;
131print "ok 23\n" ;
3bfb0615
TC
132
133{
134 # perl #75156 - test we can delete a closed handle
135 require IO::Socket::INET;
136 my $fh = IO::Socket::INET->new(
137 Listen => 5,
138 );
139 my $sel = IO::Select->new(\*STDIN);
140 $sel->add($fh);
141 my $oldbits = $sel->bits;
142 print "not " unless $sel->count == 2;
143 print "ok 24 - added socket\n";
144 close $fh;
145 print "not " unless $sel->remove($fh) == 1;
ff4a442c 146 print "ok 25 - removed closed socket\n";
3bfb0615
TC
147 print "not " unless $sel->count == 1;
148 print "ok 26 - count() updated\n";
149 print "not " unless $sel->bits ne $oldbits;
ff4a442c 150 print "ok 27 - bits() updated\n";
3bfb0615 151}