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
1 #!./perl
2
3 BEGIN {
4     unless(grep /blib/, @INC) {
5         chdir 't' if -d 't';
6         @INC = '../lib';
7     }
8 }
9
10 select(STDERR); $| = 1;
11 select(STDOUT); $| = 1;
12
13 print "1..23\n";
14
15 use IO::Select 1.09;
16
17 my $sel = new IO::Select(\*STDIN);
18 $sel->add(4, 5) == 2 or print "not ";
19 print "ok 1\n";
20
21 $sel->add([\*STDOUT, 'foo']) == 1 or print "not ";
22 print "ok 2\n";
23
24 @handles = $sel->handles;
25 print "not " unless $sel->count == 4 && @handles == 4;
26 print "ok 3\n";
27 #print $sel->as_string, "\n";
28
29 $sel->remove(\*STDIN) == 1 or print "not ";
30 print "ok 4\n",
31 ;
32 $sel->remove(\*STDIN, 5, 6) == 1  # two of there are not present
33   or print "not ";
34 print "ok 5\n";
35
36 print "not " unless $sel->count == 2;
37 print "ok 6\n";
38 #print $sel->as_string, "\n";
39
40 $sel->remove(1, 4);
41 print "not " unless $sel->count == 0 && !defined($sel->bits);
42 print "ok 7\n";
43
44 $sel = new IO::Select;
45 print "not " unless $sel->count == 0 && !defined($sel->bits);
46 print "ok 8\n";
47
48 $sel->remove([\*STDOUT, 5]);
49 print "not " unless $sel->count == 0 && !defined($sel->bits);
50 print "ok 9\n";
51
52 if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'dos') {  # 4-arg select is only valid on sockets
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
59 @a = $sel->can_read();  # should return imediately
60 print "not " unless @a == 0;
61 print "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;
67 print "not " unless @a == 1;
68 print "ok 11\n";
69
70 my($fd, $msg) = @{shift @a};
71 print $fd $msg;
72
73 $sel->add(\*STDOUT);  # update
74
75 @a = IO::Select::select(undef, $sel, undef, 1);
76 print "not " unless @a == 3;
77 print "ok 13\n";
78
79 ($r, $w, $e) = @a;
80
81 print "not " unless @$r == 0 && @$w == 1 && @$e == 0;
82 print "ok 14\n";
83
84 $fd = $w->[0];
85 print $fd "ok 15\n";
86
87 POST_SOCKET:
88 # Test new exists() method
89 $sel->exists(\*STDIN) and print "not ";
90 print "ok 16\n";
91
92 ($sel->exists(0) || $sel->exists([\*STDERR])) and print "not ";
93 print "ok 17\n";
94
95 $fd = $sel->exists(\*STDOUT);
96 if ($fd) {
97     print $fd "ok 18\n";
98 } else {
99     print "not ok 18\n";
100 }
101
102 $fd = $sel->exists([1, 'foo']);
103 if ($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);
111 print "not " unless $sel->count == 7;
112 print "ok 20\n";
113
114 $sel->remove($sel->handles);
115 print "not " unless $sel->count == 0 && !defined($sel->bits);
116 print "ok 21\n";
117
118 # check warnings
119 $SIG{__WARN__} = sub { 
120     ++ $w 
121       if $_[0] =~ /^Call to deprecated method 'has_error', use 'has_exception'/ 
122     } ;
123 $w = 0 ;
124 IO::Select::has_error();
125 print "not " unless $w == 0 ;
126 $w = 0 ;
127 print "ok 22\n" ;
128 use warnings 'IO::Select' ;
129 IO::Select::has_error();
130 print "not " unless $w == 1 ;
131 $w = 0 ;
132 print "ok 23\n" ;