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