This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
POSIX: t/posix.t: avoid warning
[perl5.git] / ext / POSIX / t / posix.t
CommitLineData
a0d0e21e
LW
1#!./perl
2
3BEGIN {
a0d0e21e 4 require Config; import Config;
fa6b8193 5 if ($^O ne 'VMS' and $Config{'extensions'} !~ /\bPOSIX\b/) {
c764b42b 6 print "1..0\n";
a0d0e21e
LW
7 exit 0;
8 }
12144562 9 unshift @INC, "../../t";
ef9d5242 10 require 'loc_tools.pl';
a0d0e21e 11}
c07a80fd 12
693d95f3 13use Test::More tests => 96;
e6c299c8 14
212caf55 15use POSIX qw(fcntl_h signal_h limits_h _exit getcwd open read strftime write
1a917639 16 errno localeconv dup dup2 lseek access);
e6c299c8 17use strict 'subs';
0ee0b3d1 18use warnings;
a0d0e21e 19
849ddec1
NC
20sub next_test {
21 my $builder = Test::More->builder;
22 $builder->current_test($builder->current_test() + 1);
23}
24
c07a80fd 25$| = 1;
a0d0e21e 26
e6c299c8
JH
27$Is_W32 = $^O eq 'MSWin32';
28$Is_Dos = $^O eq 'dos';
e6c299c8
JH
29$Is_VMS = $^O eq 'VMS';
30$Is_OS2 = $^O eq 'os2';
31$Is_UWin = $^O eq 'uwin';
32$Is_OS390 = $^O eq 'os390';
6dead956 33
6a164b5b
JM
34my $vms_unix_rpt = 0;
35my $vms_efs = 0;
36my $unix_mode = 1;
37
38if ($Is_VMS) {
39 $unix_mode = 0;
40 if (eval 'require VMS::Feature') {
41 $vms_unix_rpt = VMS::Feature::current("filename_unix_report");
42 $vms_efs = VMS::Feature::current("efs_charset");
43 } else {
44 my $unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
45 my $efs_charset = $ENV{'DECC$EFS_CHARSET'} || '';
46 $vms_unix_rpt = $unix_rpt =~ /^[ET1]/i;
47 $vms_efs = $efs_charset =~ /^[ET1]/i;
48 }
49
50 # Traditional VMS mode only if VMS is not in UNIX compatible mode.
51 $unix_mode = ($vms_efs && $vms_unix_rpt);
52
53}
54
a572b909
NC
55my $testfd = open("Makefile.PL", O_RDONLY, 0);
56like($testfd, qr/\A\d+\z/, 'O_RDONLY with open');
7814eec4 57read($testfd, $buffer, 4) if $testfd > 2;
2adbc9b6 58is( $buffer, "# Ex", ' with read' );
c07a80fd 59
7814eec4
PM
60TODO:
61{
62 local $TODO = "read to array element not working";
63
64 read($testfd, $buffer[1], 5) if $testfd > 2;
65 is( $buffer[1], "perl\n", ' read to array element' );
66}
67
a572b909
NC
68my $test = next_test();
69write(1,"ok $test\nnot ok $test\n", 5);
e6c299c8
JH
70
71SKIP: {
72 skip("no pipe() support on DOS", 2) if $Is_Dos;
a0d0e21e 73
10de532f 74 @fds = POSIX::pipe();
a572b909 75 cmp_ok($fds[0], '>', $testfd, 'POSIX::pipe');
e6c299c8 76
fe54cd9c
TC
77 CORE::open(my $reader, "<&=".$fds[0]);
78 CORE::open(my $writer, ">&=".$fds[1]);
a572b909
NC
79 my $test = next_test();
80 print $writer "ok $test\n";
10de532f
JH
81 close $writer;
82 print <$reader>;
83 close $reader;
6bbf1b34 84}
a0d0e21e 85
e6c299c8
JH
86SKIP: {
87 skip("no sigaction support on win32/dos", 6) if $Is_W32 || $Is_Dos;
88
89 my $sigset = new POSIX::SigSet 1, 3;
90 $sigset->delset(1);
91 ok(! $sigset->ismember(1), 'POSIX::SigSet->delset' );
92 ok( $sigset->ismember(3), 'POSIX::SigSet->ismember' );
be4e88b6 93
a68a847e
TH
94 my $sigint_called = 0;
95
96 my $mask = new POSIX::SigSet &SIGINT;
97 my $action = new POSIX::SigAction 'main::SigHUP', $mask, 0;
98 sigaction(&SIGHUP, $action);
99 $SIG{'INT'} = 'SigINT';
100
101 # At least OpenBSD/i386 3.3 is okay, as is NetBSD 1.5.
102 # But not NetBSD 1.6 & 1.6.1: the test makes perl crash.
103 # So the kill() must not be done with this config in order to
104 # finish the test.
105 # For others (darwin & freebsd), let the test fail without crashing.
106 # the test passes at least from freebsd 8.1
107 my $todo = $^O eq 'netbsd' && $Config{osvers}=~/^1\.6/;
108 my $why_todo = "# TODO $^O $Config{osvers} seems to lose blocked signals";
109 if (!$todo) {
110 kill 'HUP', $$;
111 } else {
112 print "not ok 9 - sigaction SIGHUP ",$why_todo,"\n";
113 print "not ok 10 - sig mask delayed SIGINT ",$why_todo,"\n";
114 }
115 sleep 1;
10de532f 116
a68a847e
TH
117 $todo = 1 if ($^O eq 'freebsd' && $Config{osvers} < 8)
118 || ($^O eq 'darwin' && $Config{osvers} < '6.6');
119 printf "%s 11 - masked SIGINT received %s\n",
120 $sigint_called ? "ok" : "not ok",
121 $todo ? $why_todo : '';
e6c299c8 122
a68a847e
TH
123 print "ok 12 - signal masks successful\n";
124
125 sub SigHUP {
126 print "ok 9 - sigaction SIGHUP\n";
127 kill 'INT', $$;
128 sleep 2;
129 print "ok 10 - sig mask delayed SIGINT\n";
130 }
131
132 sub SigINT {
133 $sigint_called++;
d536870a 134 }
a68a847e
TH
135
136 # The order of the above tests is very important, so
137 # we use literal prints and hard coded numbers.
138 next_test() for 1..4;
6dead956 139}
a0d0e21e 140
e6c299c8 141SKIP: {
e6c299c8
JH
142 skip("_POSIX_OPEN_MAX undefined ($fds[1])", 1) unless &_POSIX_OPEN_MAX;
143
a572b909
NC
144 cmp_ok(&_POSIX_OPEN_MAX, '>=', 16,
145 "The minimum allowed values according to susv2" );
4e0f6e8c 146
c9ff6e92 147}
a0d0e21e 148
d536870a 149my $pat;
2adbc9b6
NC
150if ( $unix_mode ) {
151 $pat = qr#[\\/]POSIX$#i;
e6c299c8
JH
152}
153else {
92e8e650 154 $pat = qr/\.POSIX\]/i;
d536870a 155}
e6c299c8 156like( getcwd(), qr/$pat/, 'getcwd' );
a0d0e21e 157
a89d8a78 158# Check string conversion functions.
172b0a12 159my $weasel_words = "(though differences may be beyond the displayed digits)";
a89d8a78 160
e6c299c8 161SKIP: {
693d95f3 162 skip("strtod() not present", 3) unless $Config{d_strtod};
e6c299c8 163
629eeaee 164 if (locales_enabled('LC_NUMERIC')) {
3f1b8f9e
KW
165 $lc = &POSIX::setlocale(&POSIX::LC_NUMERIC);
166 &POSIX::setlocale(&POSIX::LC_NUMERIC, 'C');
167 }
e6c299c8
JH
168
169 # we're just checking that strtod works, not how accurate it is
a89d8a78 170 ($n, $x) = &POSIX::strtod('3.14159_OR_SO');
a572b909
NC
171 cmp_ok(abs("3.14159" - $n), '<', 1e-6, 'strtod works');
172 is($x, 6, 'strtod works');
e6c299c8 173
693d95f3 174 # If $Config{nvtype} is 'double' we check that strtod assigns the same value as
175 # perl for the input 8.87359152e-6.
176 # We check that value as it is known to have produced discrepancies in the past.
177 # If this check fails then perl's buggy atof has probably assigned the value,
178 # instead of the preferred Perl_strtod function.
179
180 $n = &POSIX::strtod('8.87359152e-6');
181 if($Config{nvtype} eq 'double' || ($Config{nvtype} eq 'long double' && $Config{longdblkind} == 0)) {
cbbebaa0 182 cmp_ok($n, '==', 8.87359152e-6, "strtod and perl agree $weasel_words");
693d95f3 183 }
184 else {
cbbebaa0 185 cmp_ok($n, '!=', 8.87359152e-6, "strtod and perl should differ $weasel_words");
693d95f3 186 }
187
629eeaee 188 &POSIX::setlocale(&POSIX::LC_NUMERIC, $lc) if locales_enabled('LC_NUMERIC');
e6c299c8
JH
189}
190
191SKIP: {
693d95f3 192 skip("strtold() not present", 3) unless $Config{d_strtold};
0ff7b9da 193
629eeaee 194 if (locales_enabled('LC_NUMERIC')) {
0ff7b9da
JH
195 $lc = &POSIX::setlocale(&POSIX::LC_NUMERIC);
196 &POSIX::setlocale(&POSIX::LC_NUMERIC, 'C');
197 }
198
199 # we're just checking that strtold works, not how accurate it is
e8f2a01e 200 ($n, $x) = &POSIX::strtold('2.718_ISH');
0ff7b9da
JH
201 cmp_ok(abs("2.718" - $n), '<', 1e-6, 'strtold works');
202 is($x, 4, 'strtold works');
203
693d95f3 204 # If $Config{nvtype} is 'long double' we check that strtold assigns the same value as
205 # perl for the input 9.81256119e4.
206 # We check that value as it is known to have produced discrepancies in the past.
207 # If this check fails then perl's buggy atof has probably assigned the value,
208 # instead of the preferred Perl_strtod function.
209
693d95f3 210 if($Config{nvtype} eq 'long double') {
fd8eff85 211 $n = &POSIX::strtold('9.81256119e4820');
cbbebaa0 212 cmp_ok($n, '==', 9.81256119e4820, "strtold and perl agree $weasel_words");
693d95f3 213 }
214 elsif($Config{nvtype} eq '__float128') {
fd8eff85 215 $n = &POSIX::strtold('9.81256119e4820');
693d95f3 216 if($Config{longdblkind} == 1 || $Config{longdblkind} == 2) {
cbbebaa0 217 cmp_ok($n, '==', 9.81256119e4820, "strtold and perl agree $weasel_words");
693d95f3 218 }
219 else {
cbbebaa0 220 cmp_ok($n, '!=', 9.81256119e4820, "strtold and perl should differ $weasel_words");
693d95f3 221 }
222 }
223 else { # nvtype is double ... don't try and make this into a meaningful test
224 cmp_ok(1, '==', 1, 'skipping comparison between strtold amd perl');
225 }
226
629eeaee 227 &POSIX::setlocale(&POSIX::LC_NUMERIC, $lc) if locales_enabled('LC_NUMERIC');
0ff7b9da
JH
228}
229
230SKIP: {
693d95f3 231 # We don't yet have a POSIX::strtoflt128 - but let's at least check that
232 # Perl_strtod, not perl's atof, is assigning the values on quadmath builds.
233 # Do this by checking that 3329232e296 (which is known to be assigned
234 # incorrectly by perl's atof) is assigned to its correct value.
235
236 skip("not a -Dusequadmath build", 1) unless $Config{nvtype} eq '__float128';
237 cmp_ok(scalar(reverse(unpack("h*", pack("F<", 3329232e296)))),
238 'eq','43ebf120d02ce967d48e180409b3f958',
239 '3329232e296 is assigned correctly');
240}
241
242SKIP: {
e6c299c8 243 skip("strtol() not present", 2) unless $Config{d_strtol};
a89d8a78 244
a89d8a78 245 ($n, $x) = &POSIX::strtol('21_PENGUINS');
e6c299c8
JH
246 is($n, 21, 'strtol() number');
247 is($x, 9, ' unparsed chars');
248}
249
250SKIP: {
251 skip("strtoul() not present", 2) unless $Config{d_strtoul};
a89d8a78 252
a89d8a78 253 ($n, $x) = &POSIX::strtoul('88_TEARS');
e6c299c8
JH
254 is($n, 88, 'strtoul() number');
255 is($x, 6, ' unparsed chars');
256}
a89d8a78 257
a0d0e21e 258# Pick up whether we're really able to dynamically load everything.
a572b909 259cmp_ok(&POSIX::acos(1.0), '==', 0.0, 'dynamic loading');
a0d0e21e 260
84ef74c4
AD
261# This can coredump if struct tm has a timezone field and we
262# didn't detect it. If this fails, try adding
263# -DSTRUCT_TM_HASZONE to your cflags when compiling ext/POSIX/POSIX.c.
264# See ext/POSIX/hints/sunos_4.pl and ext/POSIX/hints/linux.pl
a572b909
NC
265$test = next_test();
266print POSIX::strftime("ok $test # %H:%M, on %m/%d/%y\n", localtime());
84ef74c4 267
33c0e3ec
SB
268# If that worked, validate the mini_mktime() routine's normalisation of
269# input fields to strftime().
270sub try_strftime {
33c0e3ec
SB
271 my $expect = shift;
272 my $got = POSIX::strftime("%a %b %d %H:%M:%S %Y %j", @_);
61a515a6 273 is($got, $expect, "validating mini_mktime() and strftime(): $expect");
33c0e3ec
SB
274}
275
629eeaee 276if (locales_enabled('LC_TIME')) {
3f1b8f9e
KW
277 $lc = &POSIX::setlocale(&POSIX::LC_TIME);
278 &POSIX::setlocale(&POSIX::LC_TIME, 'C');
279}
280
e6c299c8 281try_strftime("Wed Feb 28 00:00:00 1996 059", 0,0,0, 28,1,96);
53059177 282SKIP: {
abbe0d1a 283 skip("VC++ 8 and Vista's CRTs regard 60 seconds as an invalid parameter", 1)
a48cc4c4
DD
284 if ($Is_W32
285 and (($Config{cc} eq 'cl' and
286 $Config{ccversion} =~ /^(\d+)/ and $1 >= 14)
287 or ($Config{cc} eq 'icl' and
288 `cl --version 2>&1` =~ /^.*Version\s+([\d.]+)/ and $1 >= 14)
289 or (Win32::GetOSVersion())[1] >= 6));
53059177
SH
290
291 try_strftime("Thu Feb 29 00:00:60 1996 060", 60,0,-24, 30,1,96);
292}
e6c299c8
JH
293try_strftime("Fri Mar 01 00:00:00 1996 061", 0,0,-24, 31,1,96);
294try_strftime("Sun Feb 28 00:00:00 1999 059", 0,0,0, 28,1,99);
295try_strftime("Mon Mar 01 00:00:00 1999 060", 0,0,24, 28,1,99);
296try_strftime("Mon Feb 28 00:00:00 2000 059", 0,0,0, 28,1,100);
297try_strftime("Tue Feb 29 00:00:00 2000 060", 0,0,0, 0,2,100);
298try_strftime("Wed Mar 01 00:00:00 2000 061", 0,0,0, 1,2,100);
299try_strftime("Fri Mar 31 00:00:00 2000 091", 0,0,0, 31,2,100);
a64f08cb
TC
300
301{ # rt 72232
302
303 # Std C/POSIX allows day/month to be negative and requires that
304 # wday/yday be adjusted as needed
305 # previously mini_mktime() would allow yday to dominate if mday and
306 # month were both non-positive
307 # check that yday doesn't dominate
308 try_strftime("Thu Dec 30 00:00:00 1999 364", 0,0,0, -1,0,100);
309 try_strftime("Thu Dec 30 00:00:00 1999 364", 0,0,0, -1,0,100,-1,10);
310 # it would also allow a positive wday to override the calculated value
311 # check that wday is recalculated too
312 try_strftime("Thu Dec 30 00:00:00 1999 364", 0,0,0, -1,0,100,0,10);
313}
314
629eeaee 315&POSIX::setlocale(&POSIX::LC_TIME, $lc) if locales_enabled('LC_TIME');
33c0e3ec 316
212caf55
TS
317{
318 for my $test (0, 1) {
319 $! = 0;
320 # POSIX::errno is autoloaded.
321 # Autoloading requires many system calls.
322 # errno() looks at $! to generate its result.
323 # Autoloading should not munge the value.
324 my $foo = $!;
325 my $errno = POSIX::errno();
e6c299c8 326
e6c299c8
JH
327 # Force numeric context.
328 is( $errno + 0, $foo + 0, 'autoloading and errno() mix' );
212caf55
TS
329 }
330}
331
a68a847e
TH
332is (eval "kill 0", 0, "check we have CORE::kill")
333 or print "\$\@ is " . _qq($@) . "\n";
d4742b2c
NC
334
335# Check that we can import the POSIX kill routine
336POSIX->import ('kill');
337my $result = eval "kill 0";
338is ($result, undef, "we should now have POSIX::kill");
339# Check usage.
340like ($@, qr/^Usage: POSIX::kill\(pid, sig\)/, "check its usage message");
341
342# Check unimplemented.
343$result = eval {POSIX::offsetof};
344is ($result, undef, "offsetof should fail");
19fc2965 345like ($@, qr/^Unimplemented: POSIX::offsetof\(\): C-specific/,
d4742b2c
NC
346 "check its unimplemented message");
347
348# Check reimplemented.
349$result = eval {POSIX::fgets};
350is ($result, undef, "fgets should fail");
19fc2965 351like ($@, qr/^Unimplemented: POSIX::fgets\(\): Use method IO::Handle::gets\(\) instead/,
d4742b2c
NC
352 "check its redef message");
353
840d0031
DM
354eval {
355 use strict;
356 no warnings 'uninitialized'; # S_ISBLK normally has an arg
357 POSIX->import("S_ISBLK");
358 my $x = S_ISBLK
359};
2ae48df0 360unlike( $@, qr/Can't use string .* as a symbol ref/, "Can import autoloaded constants" );
4a948f3f
NC
361
362SKIP: {
fe54cd9c 363 skip("locales not available", 26) unless locales_enabled([ qw(NUMERIC MONETARY) ]);
ef9d5242 364 skip("localeconv() not available", 26) unless $Config{d_locconv};
4a948f3f 365 my $conv = localeconv;
86c170d9 366 is(ref $conv, 'HASH', 'localeconv returns a hash reference');
4a948f3f
NC
367
368 foreach (qw(decimal_point thousands_sep grouping int_curr_symbol
369 currency_symbol mon_decimal_point mon_thousands_sep
370 mon_grouping positive_sign negative_sign)) {
371 SKIP: {
372 skip("localeconv has no result for $_", 1)
373 unless exists $conv->{$_};
374 unlike(delete $conv->{$_}, qr/\A\z/,
375 "localeconv returned a non-empty string for $_");
376 }
377 }
378
b15c1b56
AF
379 my @lconv = qw(
380 int_frac_digits frac_digits
381 p_cs_precedes p_sep_by_space
382 n_cs_precedes n_sep_by_space
383 p_sign_posn n_sign_posn
384 );
385
386 SKIP: {
387 skip('No HAS_LC_MONETARY_2008', 6) unless $Config{d_lc_monetary_2008};
388
389 push @lconv, qw(
390 int_p_cs_precedes int_p_sep_by_space
391 int_n_cs_precedes int_n_sep_by_space
392 int_p_sign_posn int_n_sign_posn
393 );
394 }
395
396 foreach (@lconv) {
4a948f3f
NC
397 SKIP: {
398 skip("localeconv has no result for $_", 1)
399 unless exists $conv->{$_};
400 like(delete $conv->{$_}, qr/\A-?\d+\z/,
401 "localeconv returned an integer for $_");
402 }
403 }
404 is_deeply([%$conv], [], 'no unexpected keys returned by localeconv');
405}
406
792480b6
NC
407my $fd1 = open("Makefile.PL", O_RDONLY, 0);
408like($fd1, qr/\A\d+\z/, 'O_RDONLY with open');
409cmp_ok($fd1, '>', $testfd);
410my $fd2 = dup($fd1);
411like($fd2, qr/\A\d+\z/, 'dup');
412cmp_ok($fd2, '>', $fd1);
413is(POSIX::close($fd1), '0 but true', 'close');
414is(POSIX::close($testfd), '0 but true', 'close');
415$! = 0;
416undef $buffer;
417is(read($fd1, $buffer, 4), undef, 'read on closed file handle fails');
418cmp_ok($!, '==', POSIX::EBADF);
419undef $buffer;
420read($fd2, $buffer, 4) if $fd2 > 2;
421is($buffer, "# Ex", 'read');
422# The descriptor $testfd was using is now free, and is lower than that which
423# $fd1 was using. Hence if dup2() behaves as dup(), we'll know :-)
424{
792480b6
NC
425 $testfd = dup2($fd2, $fd1);
426 is($testfd, $fd1, 'dup2');
427 undef $buffer;
428 read($testfd, $buffer, 4) if $testfd > 2;
429 is($buffer, 'pect', 'read');
430 is(lseek($testfd, 0, 0), 0, 'lseek back');
431 # The two should share file position:
432 undef $buffer;
433 read($fd2, $buffer, 4) if $fd2 > 2;
434 is($buffer, "# Ex", 'read');
435}
436
437# The FreeBSD man page warns:
438# The access() system call is a potential security hole due to race
439# conditions and should never be used.
440is(access('Makefile.PL', POSIX::F_OK), '0 but true', 'access');
441is(access('Makefile.PL', POSIX::R_OK), '0 but true', 'access');
442$! = 0;
443is(access('no such file', POSIX::F_OK), undef, 'access on missing file');
444cmp_ok($!, '==', POSIX::ENOENT);
445is(access('Makefile.PL/nonsense', POSIX::F_OK), undef,
446 'access on not-a-directory');
447SKIP: {
448 skip("$^O is insufficiently POSIX", 1)
e5da71f2 449 if $Is_W32 || $Is_VMS;
792480b6
NC
450 cmp_ok($!, '==', POSIX::ENOTDIR);
451}
452
f914a2ba
JH
453{ # tmpnam() has been removed as unsafe
454 my $x = eval { POSIX::tmpnam() };
455 is($x, undef, 'tmpnam has been removed');
456 like($@, qr/use File::Temp/, 'tmpnam advises File::Temp');
cae71c5d
TC
457}
458
404d038e
PG
459# Check that output is not flushed by _exit. This test should be last
460# in the file, and is not counted in the total number of tests.
461if ($^O eq 'vos') {
462 print "# TODO - hit VOS bug posix-885 - _exit flushes output buffers.\n";
463} else {
464 $| = 0;
465 # The following line assumes buffered output, which may be not true:
a68a847e 466 print '@#!*$@(!@#$' unless ($Is_OS2 || $Is_UWin || $Is_OS390 ||
e6c299c8 467 $Is_VMS ||
601f2d16
SB
468 (defined $ENV{PERLIO} &&
469 $ENV{PERLIO} eq 'unix' &&
470 $Config::Config{useperlio}));
404d038e
PG
471 _exit(0);
472}