ext/POSIX/t/wrappers.t

   1 #!./perl -w
   2
   3 use strict;
   4 use Test::More;
   5 use Config;
   6
   7 plan(skip_all => "POSIX is unavailable")
   8     unless $Config{extensions} =~ /\bPOSIX\b/;
   9
  10 require POSIX;
  11 require Symbol;
  12 require File::Temp;
  13 unshift @INC, "../../t";
  14 require 'loc_tools.pl';
  15
  16 use constant NOT_HERE => 'this-file-should-not-exist';
  17
  18 # Object destruction causes the file to be deleted.
  19 my $temp_fh = File::Temp->new();
  20 my $temp_file = $temp_fh->filename;
  21
  22 # localtime and gmtime in time.t.
  23 # exit, fork, waitpid, sleep in waitpid.t
  24 # errno in posix.t
  25
  26 if ($Config{d_setlocale} && defined &POSIX::LC_MESSAGES) {
  27     my $non_english_locale;
  28     local $! = 1;
  29     my $english_message = "$!"; # Should be C locale since not in scope of
  30                                 # "use locale"
  31     for $non_english_locale (find_locales(&POSIX::LC_MESSAGES,
  32                                           'reasonable_locales_only'))
  33     {
  34         use locale;
  35         setlocale(&POSIX::LC_MESSAGES, $non_english_locale);
  36         $! = 1;
  37         last if "$!" ne $english_message;
  38     }
  39
  40     # If we found a locale whose message wasn't in English, we have
  41     # setlocale() to it.
  42 }
  43
  44 is(POSIX::abs(-42), 42, 'abs');
  45 is(POSIX::abs(-3.14), 3.14, 'abs');
  46 is(POSIX::abs(POSIX::exp(1)), CORE::exp(1), 'abs');
  47 is(POSIX::alarm(0), 0, 'alarm');
  48 is(eval {POSIX::assert(1); 1}, 1, 'assert(1)');
  49 is(eval {POSIX::assert(0); 1}, undef, 'assert(0)');
  50 like($@, qr/Assertion failed at/, 'assert throws an error');
  51 is(POSIX::atan2(0, 1), 0, 'atan2');
  52 is(POSIX::cos(0), 1, 'cos');
  53 is(POSIX::exp(0), 1, 'exp');
  54 is(POSIX::fabs(-42), 42, 'fabs');
  55 is(POSIX::fabs(-3.14), 3.14, 'fabs');
  56
  57 is(do {local $^W;
  58        POSIX::fcntl(Symbol::geniosym(), 0, 0);
  59        1;
  60    }, 1, 'fcntl');
  61
  62 SKIP: {
  63     # Win32 doesn't like me trying to fstat STDIN. Bothersome thing.
  64     skip("Can't open $temp_file: $!", 1) unless open my $fh, '<', $temp_file;
  65
  66     is_deeply([POSIX::fstat(fileno $fh)], [stat $fh], 'fstat');
  67 }
  68
  69 is(POSIX::getegid(), 0 + $), 'getegid');
  70 is(POSIX::geteuid(), 0 + $>, 'geteuid');
  71 is(POSIX::getgid(), 0 + $(, 'getgid');
  72 is(POSIX::getenv('PATH'), $ENV{PATH}, 'getenv');
  73
  74 SKIP: {
  75     my $name = eval {getgrgid $(};
  76     skip("getgrgid not available", 2) unless defined $name;
  77     is_deeply([POSIX::getgrgid($()], [CORE::getgrgid($()], "getgrgid($()");
  78     is_deeply([POSIX::getgrnam($name)], [CORE::getgrnam($name)],
  79               "getgrnam('$name')");
  80 }
  81
  82 cmp_ok((length join ' ', POSIX::getgroups()), '<=', length $), 'getgroups');
  83 is(POSIX::getlogin(), CORE::getlogin, 'getlogin');
  84
  85 SKIP: {
  86     skip('getpgrp not available', 1) unless $Config{d_getpgrp};
  87     is(POSIX::getpgrp(), CORE::getpgrp(), 'getpgrp');
  88 }
  89
  90 is(POSIX::getpid(), $$, 'getpid');
  91
  92 SKIP: {
  93     my $name = eval {getpwuid $<};
  94     skip('getpwuid not available', 2) unless defined $name;
  95     is_deeply([POSIX::getpwuid($<)], [CORE::getpwuid($<)], "getgrgid($<)");
  96     is_deeply([POSIX::getpwnam($name)], [CORE::getpwnam($name)],
  97               "getpwnam('$name')");
  98 }
  99
 100 SKIP: {
 101     skip('STDIN is not a tty', 1) unless -t STDIN;
 102     is(POSIX::isatty(*STDIN), 1, 'isatty');
 103 }
 104
 105 is(POSIX::getuid(), $<, 'getuid');
 106 is(POSIX::log(1), 0, 'log');
 107 is(POSIX::pow(2, 31), 0x80000000, 'pow');
 108 #    usage "printf(pattern, args...)" if @_ < 1;
 109
 110 {
 111     my $buffer;
 112     package Capture;
 113     use parent 'Tie::StdHandle';
 114
 115     sub WRITE {
 116         $buffer .= $_[1];
 117         42;
 118     }
 119
 120     package main;
 121     tie *STDOUT, 'Capture';
 122     is(POSIX::printf('%s %s%c', 'Hello', 'World', ord "\n"), 42, 'printf');
 123     is($buffer, "Hello World\n", 'captured print output');
 124     untie *STDOUT;
 125 }
 126
 127 is(do {local $^W;
 128        POSIX::rewind(Symbol::geniosym());
 129        1;
 130    }, 1, 'rewind');
 131
 132 is(POSIX::sin(0), 0, 'sin');
 133 is(POSIX::sleep(0), 0, 'sleep');
 134 is(POSIX::sprintf('%o', 42), '52', 'sprintf');
 135 is(POSIX::sqrt(256), 16, 'sqrt');
 136 is_deeply([POSIX::stat($temp_file)], [stat $temp_file], 'stat');
 137 {
 138     use locale;
 139     local $! = 2;
 140     my $error = "$!";
 141     no locale;
 142     is(POSIX::strerror(2), $error, 'strerror');
 143 }
 144
 145 is(POSIX::strstr('BBFRPRAFPGHPP', 'FP'), 7, 'strstr');
 146 SKIP: {
 147     my $true;
 148     foreach (qw(/bin/true /usr/bin/true)) {
 149         if (-x $_) {
 150             $true = $_;
 151             last;
 152         }
 153     }
 154     skip("Can't find true", 1) unless $true;
 155     is(POSIX::system($true), 0, 'system');
 156 }
 157
 158 {
 159     my $past = CORE::time;
 160     my $present = POSIX::time();
 161     my $future = CORE::time;
 162     # Shakes fist at virtual machines
 163     cmp_ok($past, '<=', $present, 'time');
 164     cmp_ok($present, '<=', $future, 'time');
 165 }
 166
 167 is(POSIX::tolower('Perl Rules'), 'perl rules', 'tolower');
 168 is(POSIX::toupper('oi!'), 'OI!', 'toupper');
 169
 170 is(-e NOT_HERE, undef, NOT_HERE . ' does not exist');
 171
 172 foreach ([undef, 0, 'chdir', NOT_HERE],
 173          [undef, 0, 'chmod', 0, NOT_HERE],
 174          ['d_chown', 0, 'chown', 0, 0, NOT_HERE],
 175          [undef, undef, 'creat', NOT_HERE . '/crash', 0],
 176          ['d_link', 0, 'link', NOT_HERE, 'ouch'],
 177          [undef, 0, 'remove', NOT_HERE],
 178          [undef, 0, 'rename', NOT_HERE, 'z_zwapp'],
 179          [undef, 0, 'remove', NOT_HERE],
 180          [undef, 0, 'unlink', NOT_HERE],
 181          [undef, 0, 'utime', NOT_HERE, 0, 0],
 182         ) {
 183     my ($skip, $expect, $name, @args) = @$_;
 184     my $func = do {no strict 'refs'; \&{"POSIX::$name"}};
 185
 186  SKIP: {
 187         skip("$name() is not available", 2) if $skip && !$Config{$skip};
 188         $! = 0;
 189         is(&$func(@args), $expect, $name);
 190         isnt($!, '', "$name reported an error");
 191     }
 192 }
 193
 194 {
 195     my $dir = "./HiC_$$";
 196     is(-e $dir, undef, "$dir does not exist");
 197
 198     is(POSIX::mkdir($dir, 0755), 1, 'mkdir');
 199     is(-d $dir, 1, "$dir now exists");
 200
 201     my $dh = POSIX::opendir($dir);
 202     isnt($dh, undef, 'opendir');
 203
 204     my @first = POSIX::readdir($dh);
 205     is(POSIX::rewinddir($dh), 1, 'rewinddir');
 206     my @second = POSIX::readdir($dh);
 207
 208     is_deeply(\@first, \@second, 'readdir,rewinddir,readdir');
 209
 210     is(POSIX::closedir($dh), 1, 'rewinddir');
 211
 212     is(POSIX::rmdir($dir), 1, 'rmdir');
 213     is(-e $dir, undef, "$dir does not exist");
 214 }
 215
 216 SKIP: {
 217     skip("No \$SIG{USR1} on $^O", 4) unless exists $SIG{USR1};
 218     my $gotit = 0;
 219     $SIG{USR1} = sub { $gotit++ };
 220     is(POSIX::kill($$, 'SIGUSR1'), 1, 'kill');
 221     is($gotit, 1, 'got first signal');
 222     is(POSIX::raise('SIGUSR1'), 1, 'raise');
 223     is($gotit, 2, 'got second signal');
 224 }
 225
 226 SKIP: {
 227     foreach (qw(fork pipe)) {
 228         skip("no $_", 8) unless $Config{"d_$_"};
 229     }
 230     # die with an uncaught SIGARLM if something goes wrong
 231     is(CORE::alarm(60), 0, 'no alarm set previously');
 232
 233     is((pipe *STDIN, my $w), 1, 'pipe');
 234     my $pid = POSIX::fork();
 235     fail("fork failed: $!") unless defined $pid;
 236
 237     if ($pid) {
 238         close $w;
 239         is(POSIX::getc(*STDIN), '1', 'getc');
 240         is(POSIX::getchar(), '2', 'getchar');
 241         is(POSIX::gets(), "345\n", 'gets');
 242         my $ppid = <STDIN>;
 243         chomp $ppid;
 244         is($ppid, $$, 'getppid');
 245         is(POSIX::wait(), $pid, 'wait');
 246         is(POSIX::WIFEXITED(${^CHILD_ERROR_NATIVE}), 1, 'child exited cleanly');
 247         is(POSIX::WEXITSTATUS(${^CHILD_ERROR_NATIVE}), 1,
 248            'child exited with 1 (the retun value of its close call)');
 249     } else {
 250         # Child
 251         close *STDIN;
 252         print $w "12345\n", POSIX::getppid(), "\n";
 253         POSIX::_exit(close $w);
 254     }
 255 }
 256
 257 my $umask = CORE::umask;
 258 is(POSIX::umask($umask), $umask, 'umask');
 259
 260 done_testing();