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