1#!./perl
2
3# Four-argument select
4
5my $hires;
6BEGIN {
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
13skip_all("Win32 miniperl has no socket select")
14  if $^O eq "MSWin32" && is_miniperl();
15
16plan (16);
17
18my $blank = "";
19eval {select undef, $blank, $blank, 0};
20is ($@, "", 'select undef  $blank $blank 0');
21eval {select $blank, undef, $blank, 0};
22is ($@, "", 'select $blank undef  $blank 0');
23eval {select $blank, $blank, undef, 0};
24is ($@, "", 'select $blank $blank undef  0');
25
26eval {select "", $blank, $blank, 0};
27is ($@, "", 'select ""     $blank $blank 0');
28eval {select $blank, "", $blank, 0};
29is ($@, "", 'select $blank ""     $blank 0');
30eval {select $blank, $blank, "", 0};
31is ($@, "", 'select $blank $blank ""     0');
32
33# Test with read-only copy-on-write empty string
34my($rocow) = keys%{{""=>undef}};
35Internals::SvREADONLY($rocow,1);
36eval {select $rocow, $blank, $blank, 0};
37is ($@, "", 'select $rocow     $blank $blank 0');
38eval {select $blank, $rocow, $blank, 0};
39is ($@, "", 'select $blank $rocow     $blank 0');
40eval {select $blank, $blank, $rocow, 0};
41is ($@, "", 'select $blank $blank $rocow     0');
42
43eval {select "a", $blank, $blank, 0};
44like ($@, qr/^Modification of a read-only value attempted/,
45	    'select "a"    $blank $blank 0');
46eval {select $blank, "a", $blank, 0};
47like ($@, qr/^Modification of a read-only value attempted/,
48	    'select $blank "a"    $blank 0');
49eval {select $blank, $blank, "a", 0};
50like ($@, qr/^Modification of a read-only value attempted/,
51	    'select $blank $blank "a"    0');
52
53my $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
64my $under = $hires ? 0.1 : 1;
65
66my $t0 = time;
67select(undef, undef, undef, $sleep);
68my $t1 = time;
69my $diff = $t1-$t0;
70ok($diff >= $sleep-$under, "select(u,u,u,\$sleep):  at least $sleep seconds have passed");
71note("diff=$diff under=$under");
72
73my $empty = "";
74vec($empty,0,1) = 0;
75$t0 = time;
76select($empty, undef, undef, $sleep);
77$t1 = time;
78$diff = $t1-$t0;
79ok($diff >= $sleep-$under, "select(\$e,u,u,\$sleep): at least $sleep seconds have passed");
80note("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
99package _131645{
100    sub TIESCALAR { bless [] }
101    sub FETCH     { 0        }
102    sub STORE     {          }
103}
104tie $tie, _131645::;
105select ($tie, undef, undef, $tie);
106ok("no crash from select $numeric_tie, undef, undef, $numeric_tie")
107