ext/IO/t/io_sel.t

   1 #!./perl -w
   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 ( grep $^O eq $_, qw(MSWin32 NetWare dos VMS riscos beos) ) {
  53     for (10 .. 15) {
  54         print "ok $_ # skip: 4-arg select is only valid on sockets\n"
  55     }
  56     $sel->add(\*STDOUT);  # update
  57     goto POST_SOCKET;
  58 }
  59
  60 @a = $sel->can_read();  # should return imediately
  61 print "not " unless @a == 0;
  62 print "ok 10\n";
  63
  64 # we assume that we can write to STDOUT :-)
  65 $sel->add([\*STDOUT, "ok 12\n"]);
  66
  67 @a = $sel->can_write;
  68 print "not " unless @a == 1;
  69 print "ok 11\n";
  70
  71 my($fd, $msg) = @{shift @a};
  72 print $fd $msg;
  73
  74 $sel->add(\*STDOUT);  # update
  75
  76 @a = IO::Select::select(undef, $sel, undef, 1);
  77 print "not " unless @a == 3;
  78 print "ok 13\n";
  79
  80 ($r, $w, $e) = @a;
  81
  82 print "not " unless @$r == 0 && @$w == 1 && @$e == 0;
  83 print "ok 14\n";
  84
  85 $fd = $w->[0];
  86 print $fd "ok 15\n";
  87
  88 POST_SOCKET:
  89 # Test new exists() method
  90 $sel->exists(\*STDIN) and print "not ";
  91 print "ok 16\n";
  92
  93 ($sel->exists(0) || $sel->exists([\*STDERR])) and print "not ";
  94 print "ok 17\n";
  95
  96 $fd = $sel->exists(\*STDOUT);
  97 if ($fd) {
  98     print $fd "ok 18\n";
  99 } else {
 100     print "not ok 18\n";
 101 }
 102
 103 $fd = $sel->exists([1, 'foo']);
 104 if ($fd) {
 105     print $fd "ok 19\n";
 106 } else {
 107     print "not ok 19\n";
 108 }
 109
 110 # Try self clearing
 111 $sel->add(5,6,7,8,9,10);
 112 print "not " unless $sel->count == 7;
 113 print "ok 20\n";
 114
 115 $sel->remove($sel->handles);
 116 print "not " unless $sel->count == 0 && !defined($sel->bits);
 117 print "ok 21\n";
 118
 119 # check warnings
 120 $SIG{__WARN__} = sub {
 121     ++ $w
 122       if $_[0] =~ /^Call to deprecated method 'has_error', use 'has_exception'/ ;
 123     } ;
 124 $w = 0 ;
 125 {
 126 no warnings 'IO::Select' ;
 127 IO::Select::has_error();
 128 }
 129 print "not " unless $w == 0 ;
 130 $w = 0 ;
 131 print "ok 22\n" ;
 132 {
 133 use warnings 'IO::Select' ;
 134 IO::Select::has_error();
 135 }
 136 print "not " unless $w == 1 ;
 137 $w = 0 ;
 138 print "ok 23\n" ;