xref: /openbsd-src/gnu/usr.bin/perl/t/op/sselect.t (revision e068048151d29f2562a32185e21a8ba885482260) 
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 (23);
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
108SKIP: {
109    skip "Can't load modules under miniperl", 4 if is_miniperl;
110    my $SKIP_CR = sub {
111        skip shift, 4;
112    };
113
114    if ($^O =~ m<win32|vms>i) {
115        $SKIP_CR->("Perl's 4-arg select() in $^O only works with sockets.");
116    }
117
118    eval { require POSIX } or do {
119        $SKIP_CR->("Failed to load POSIX.pm: $@");
120    };
121
122    my $mask;
123
124    for (my $f=0; $f<100; $f++) {
125        my $fd = POSIX::dup(fileno \*STDOUT);
126
127        if (!defined $fd) {
128            $SKIP_CR->("dup(STDOUT): $!");
129            last UTF8TEST;
130        }
131
132        vec( my $curmask, $fd, 1 ) = 1;
133
134        if ($curmask =~ tr<\x80-\xff><>) {
135            note("FD = $fd");
136            $mask = $curmask;
137            last;
138        }
139    }
140
141
142    if (defined $mask) {
143        utf8::downgrade($mask);
144        my $mask2;
145
146        my $result = select $mask2 = $mask, undef, undef, 0;
147
148        isnt( $result, -1, 'select() read on non-utf8-flagged mask' );
149
150        utf8::upgrade($mask);
151        $result = select $mask2 = $mask, undef, undef, 0;
152
153        isnt( $result, -1, 'select() read on utf8-flagged mask' );
154
155        # ----------------------------------------
156
157        utf8::downgrade($mask);
158        $result = select undef, $mask2 = $mask, undef, 0;
159
160        isnt( $result, -1, 'select() write on non-utf8-flagged mask' );
161
162        utf8::upgrade($mask);
163        $result = select undef, $mask2 = $mask, undef, 0;
164
165        isnt( $result, -1, 'select() write on utf8-flagged mask' );
166    }
167    else {
168        $SKIP_CR->("No suitable file descriptor for UTF-8-flag test found.");
169    }
170}
171
172{
173    my $badmask = "\x{100}";
174
175    eval { select $badmask, undef, undef, 0 };
176    ok( $@, 'select() read fails when given a wide character' );
177
178    eval { select undef, $badmask, undef, 0 };
179    ok( $@, 'select() write fails when given a wide character' );
180
181    eval { select undef, undef, $badmask, 0 };
182    ok( $@, 'select() exception fails when given a wide character' );
183}
184