This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fixes test case failure introduced by #12071, the warning is
[perl5.git] / ext / IO / lib / IO / t / io_sel.t
CommitLineData
7a4c00b4
PP
1#!./perl
2
3BEGIN {
4 unless(grep /blib/, @INC) {
5 chdir 't' if -d 't';
20822f61 6 @INC = '../lib';
7a4c00b4
PP
7 }
8}
9
10select(STDERR); $| = 1;
11select(STDOUT); $| = 1;
12
d3a7d8c7 13print "1..23\n";
7a4c00b4
PP
14
15use IO::Select 1.09;
16
17my $sel = new IO::Select(\*STDIN);
18$sel->add(4, 5) == 2 or print "not ";
19print "ok 1\n";
20
21$sel->add([\*STDOUT, 'foo']) == 1 or print "not ";
22print "ok 2\n";
23
24@handles = $sel->handles;
25print "not " unless $sel->count == 4 && @handles == 4;
26print "ok 3\n";
27#print $sel->as_string, "\n";
28
29$sel->remove(\*STDIN) == 1 or print "not ";
30print "ok 4\n",
31;
32$sel->remove(\*STDIN, 5, 6) == 1 # two of there are not present
33 or print "not ";
34print "ok 5\n";
35
36print "not " unless $sel->count == 2;
37print "ok 6\n";
38#print $sel->as_string, "\n";
39
40$sel->remove(1, 4);
41print "not " unless $sel->count == 0 && !defined($sel->bits);
42print "ok 7\n";
43
44$sel = new IO::Select;
45print "not " unless $sel->count == 0 && !defined($sel->bits);
46print "ok 8\n";
47
48$sel->remove([\*STDOUT, 5]);
49print "not " unless $sel->count == 0 && !defined($sel->bits);
50print "ok 9\n";
51
2986a63f 52if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'dos') { # 4-arg select is only valid on sockets
68dc0745
PP
53 print "# skipping tests 10..15\n";
54 for (10 .. 15) { print "ok $_\n" }
55 $sel->add(\*STDOUT); # update
56 goto POST_SOCKET;
57}
58
7a4c00b4
PP
59@a = $sel->can_read(); # should return imediately
60print "not " unless @a == 0;
61print "ok 10\n";
62
63# we assume that we can write to STDOUT :-)
64$sel->add([\*STDOUT, "ok 12\n"]);
65
66@a = $sel->can_write;
67print "not " unless @a == 1;
68print "ok 11\n";
69
70my($fd, $msg) = @{shift @a};
71print $fd $msg;
72
73$sel->add(\*STDOUT); # update
74
75@a = IO::Select::select(undef, $sel, undef, 1);
76print "not " unless @a == 3;
77print "ok 13\n";
78
79($r, $w, $e) = @a;
80
81print "not " unless @$r == 0 && @$w == 1 && @$e == 0;
82print "ok 14\n";
83
84$fd = $w->[0];
85print $fd "ok 15\n";
86
68dc0745 87POST_SOCKET:
7a4c00b4
PP
88# Test new exists() method
89$sel->exists(\*STDIN) and print "not ";
90print "ok 16\n";
91
92($sel->exists(0) || $sel->exists([\*STDERR])) and print "not ";
93print "ok 17\n";
94
95$fd = $sel->exists(\*STDOUT);
96if ($fd) {
97 print $fd "ok 18\n";
98} else {
99 print "not ok 18\n";
100}
101
102$fd = $sel->exists([1, 'foo']);
103if ($fd) {
104 print $fd "ok 19\n";
105} else {
106 print "not ok 19\n";
107}
108
109# Try self clearing
110$sel->add(5,6,7,8,9,10);
111print "not " unless $sel->count == 7;
112print "ok 20\n";
113
114$sel->remove($sel->handles);
115print "not " unless $sel->count == 0 && !defined($sel->bits);
116print "ok 21\n";
d3a7d8c7
GS
117
118# check warnings
119$SIG{__WARN__} = sub {
120 ++ $w
87e7c081 121 if $_[0] =~ /^Call to deprecated method 'has_error', use 'has_exception'/
d3a7d8c7
GS
122 } ;
123$w = 0 ;
124IO::Select::has_error();
125print "not " unless $w == 0 ;
126$w = 0 ;
127print "ok 22\n" ;
128use warnings 'IO::Select' ;
129IO::Select::has_error();
130print "not " unless $w == 1 ;
131$w = 0 ;
132print "ok 23\n" ;