t/op/sselect.t

   1 #!./perl
   2
   3 my $hires;
   4 BEGIN {
   5     chdir 't' if -d 't';
   6     @INC = ('.', '../lib');
   7     $hires = eval 'use Time::HiResx "time"; 1';
   8 }
   9
  10 require './test.pl';
  11
  12 skip_all("Win32 miniperl has no socket select")
  13   if $^O eq "MSWin32" && is_miniperl();
  14
  15 plan (15);
  16
  17 my $blank = "";
  18 eval {select undef, $blank, $blank, 0};
  19 is ($@, "", 'select undef  $blank $blank 0');
  20 eval {select $blank, undef, $blank, 0};
  21 is ($@, "", 'select $blank undef  $blank 0');
  22 eval {select $blank, $blank, undef, 0};
  23 is ($@, "", 'select $blank $blank undef  0');
  24
  25 eval {select "", $blank, $blank, 0};
  26 is ($@, "", 'select ""     $blank $blank 0');
  27 eval {select $blank, "", $blank, 0};
  28 is ($@, "", 'select $blank ""     $blank 0');
  29 eval {select $blank, $blank, "", 0};
  30 is ($@, "", 'select $blank $blank ""     0');
  31
  32 # Test with read-only copy-on-write empty string
  33 my($rocow) = keys%{{""=>undef}};
  34 Internals::SvREADONLY($rocow,1);
  35 eval {select $rocow, $blank, $blank, 0};
  36 is ($@, "", 'select $rocow     $blank $blank 0');
  37 eval {select $blank, $rocow, $blank, 0};
  38 is ($@, "", 'select $blank $rocow     $blank 0');
  39 eval {select $blank, $blank, $rocow, 0};
  40 is ($@, "", 'select $blank $blank $rocow     0');
  41
  42 eval {select "a", $blank, $blank, 0};
  43 like ($@, qr/^Modification of a read-only value attempted/,
  44             'select "a"    $blank $blank 0');
  45 eval {select $blank, "a", $blank, 0};
  46 like ($@, qr/^Modification of a read-only value attempted/,
  47             'select $blank "a"    $blank 0');
  48 eval {select $blank, $blank, "a", 0};
  49 like ($@, qr/^Modification of a read-only value attempted/,
  50             'select $blank $blank "a"    0');
  51
  52 my $sleep = 3;
  53 # Actual sleep time on Windows may be rounded down to an integral
  54 # multiple of the system clock tick interval.  Clock tick interval
  55 # is configurable, but usually about 15.625 milliseconds.
  56 # time() however (if we haven;t loaded Time::HiRes), doesn't return
  57 # fractional values, so the observed delay may be 1 second short.
  58 #
  59 # There is also a report that old linux kernels may return 0.5ms early:
  60 # <20110520081714.GC17549@mars.tony.develop-help.com>.
  61 #
  62
  63 my $under = $hires ? 0.1 : 1;
  64
  65 my $t0 = time;
  66 select(undef, undef, undef, $sleep);
  67 my $t1 = time;
  68 my $diff = $t1-$t0;
  69 ok($diff >= $sleep-$under, "select(u,u,u,\$sleep):  at least $sleep seconds have passed");
  70 note("diff=$diff under=$under");
  71
  72 my $empty = "";
  73 vec($empty,0,1) = 0;
  74 $t0 = time;
  75 select($empty, undef, undef, $sleep);
  76 $t1 = time;
  77 $diff = $t1-$t0;
  78 ok($diff >= $sleep-$under, "select(\$e,u,u,\$sleep): at least $sleep seconds have passed");
  79 note("diff=$diff under=$under");
  80
  81 # [perl #120102] CORE::select ignoring timeout var's magic
  82
  83 {
  84     package RT120102;
  85
  86     my $count = 0;
  87
  88     sub TIESCALAR { bless [] }
  89     sub FETCH { $count++; 0.1 }
  90
  91     my $sleep;
  92
  93     tie $sleep, 'RT120102';
  94     select (undef, undef, undef, $sleep);
  95     ::is($count, 1, 'RT120102');
  96 }