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