This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
[perl #123816] fix stat stacking
[perl5.git] / t / op / stat.t
diff --git a/t/op/stat.t b/t/op/stat.t
index ee6ea47..ad94b3f 100644 (file)
--- a/t/op/stat.t
+++ b/t/op/stat.t
@@ -19,30 +19,36 @@ if(eval {require File::Spec; 1}) {
     diag("\ncontinuing, assuming '.' for current directory. Some tests will be skipped.");
 }
 
     diag("\ncontinuing, assuming '.' for current directory. Some tests will be skipped.");
 }
 
+if ($^O eq 'MSWin32') {
+    # under minitest, buildcustomize sets this to 1, which means
+    # nlinks isn't populated properly, allow nlinks tests to pass
+    ${^WIN32_SLOPPY_STAT} = 0;
+}
 
 
-plan tests => 113;
+plan tests => 115;
 
 my $Perl = which_perl();
 
 
 my $Perl = which_perl();
 
+$ENV{LC_ALL}   = 'C';          # Forge English error messages.
+$ENV{LANGUAGE} = 'C';          # Ditto in GNU.
+
 $Is_Amiga   = $^O eq 'amigaos';
 $Is_Cygwin  = $^O eq 'cygwin';
 $Is_Darwin  = $^O eq 'darwin';
 $Is_Dos     = $^O eq 'dos';
 $Is_Amiga   = $^O eq 'amigaos';
 $Is_Cygwin  = $^O eq 'cygwin';
 $Is_Darwin  = $^O eq 'darwin';
 $Is_Dos     = $^O eq 'dos';
-$Is_MPE     = $^O eq 'mpeix';
 $Is_MSWin32 = $^O eq 'MSWin32';
 $Is_NetWare = $^O eq 'NetWare';
 $Is_OS2     = $^O eq 'os2';
 $Is_Solaris = $^O eq 'solaris';
 $Is_VMS     = $^O eq 'VMS';
 $Is_MSWin32 = $^O eq 'MSWin32';
 $Is_NetWare = $^O eq 'NetWare';
 $Is_OS2     = $^O eq 'os2';
 $Is_Solaris = $^O eq 'solaris';
 $Is_VMS     = $^O eq 'VMS';
-$Is_DGUX    = $^O eq 'dgux';
 $Is_MPRAS   = $^O =~ /svr4/ && -f '/etc/.relid';
 $Is_MPRAS   = $^O =~ /svr4/ && -f '/etc/.relid';
-$Is_Rhapsody= $^O eq 'rhapsody';
+$Is_Android = $^O =~ /android/;
 
 $Is_Dosish  = $Is_Dos || $Is_OS2 || $Is_MSWin32 || $Is_NetWare;
 
 $Is_UFS     = $Is_Darwin && (() = `df -t ufs . 2>/dev/null`) == 2;
 
 
 $Is_Dosish  = $Is_Dos || $Is_OS2 || $Is_MSWin32 || $Is_NetWare;
 
 $Is_UFS     = $Is_Darwin && (() = `df -t ufs . 2>/dev/null`) == 2;
 
-if ($Is_Cygwin) {
+if ($Is_Cygwin && !is_miniperl) {
   require Win32;
   Win32->import;
 }
   require Win32;
   Win32->import;
 }
@@ -92,8 +98,17 @@ close(FOO);
 
 sleep 2;
 
 
 sleep 2;
 
+my $has_link = 1;
+my $inaccurate_atime = 0;
+if (defined &Win32::IsWinNT && Win32::IsWinNT()) {
+    if (Win32::FsType() ne 'NTFS') {
+        $has_link            = 0;
+       $inaccurate_atime    = 1;
+    }
+}
 
 SKIP: {
 
 SKIP: {
+    skip "No link on this filesystem", 6 unless $has_link;
     unlink $tmpfile_link;
     my $lnk_result = eval { link $tmpfile, $tmpfile_link };
     skip "link() unimplemented", 6 if $@ =~ /unimplemented/;
     unlink $tmpfile_link;
     my $lnk_result = eval { link $tmpfile, $tmpfile_link };
     skip "link() unimplemented", 6 if $@ =~ /unimplemented/;
@@ -176,6 +191,8 @@ SKIP: {
         # Going to try to switch away from root.  Might not work.
         my $olduid = $>;
         eval { $> = 1; };
         # Going to try to switch away from root.  Might not work.
         my $olduid = $>;
         eval { $> = 1; };
+       skip "Can't test if an admin user in miniperl", 2,
+         if $Is_Cygwin && is_miniperl();
         skip "Can't test -r or -w meaningfully if you're superuser", 2
           if ($Is_Cygwin ? Win32::IsAdminUser : $> == 0);
 
         skip "Can't test -r or -w meaningfully if you're superuser", 2
           if ($Is_Cygwin ? Win32::IsAdminUser : $> == 0);
 
@@ -249,7 +266,8 @@ SKIP: {
     skip "ls command not available to Perl in OpenVMS right now.", 6
       if $Is_VMS;
 
     skip "ls command not available to Perl in OpenVMS right now.", 6
       if $Is_VMS;
 
-    my $LS  = $Config{d_readlink} ? "ls -lL" : "ls -l";
+    delete $ENV{CLICOLOR_FORCE};
+    my $LS  = $Config{d_readlink} && !$Is_Android ? "ls -lL" : "ls -l";
     my $CMD = "$LS /dev 2>/dev/null";
     my $DEV = qx($CMD);
 
     my $CMD = "$LS /dev 2>/dev/null";
     my $DEV = qx($CMD);
 
@@ -292,13 +310,10 @@ SKIP: {
        is($c1, $c2, "ls and $_[1] agreeing on /dev ($c1 $c2)");
     };
 
        is($c1, $c2, "ls and $_[1] agreeing on /dev ($c1 $c2)");
     };
 
-SKIP: {
-    skip("DG/UX ls -L broken", 3) if $Is_DGUX;
-
+{
     $try->('b', '-b');
     $try->('c', '-c');
     $try->('s', '-S');
     $try->('b', '-b');
     $try->('c', '-c');
     $try->('s', '-S');
-
 }
 
 ok(! -b $Curdir,    '!-b cwd');
 }
 
 ok(! -b $Curdir,    '!-b cwd');
@@ -341,7 +356,7 @@ SKIP: {
 SKIP: {
     skip "These tests require a TTY", 4 if $ENV{PERL_SKIP_TTY_TEST};
 
 SKIP: {
     skip "These tests require a TTY", 4 if $ENV{PERL_SKIP_TTY_TEST};
 
-    my $TTY = $Is_Rhapsody ? "/dev/ttyp0" : "/dev/tty";
+    my $TTY = "/dev/tty";
 
     SKIP: {
         skip "Test uses unixisms", 2 if $Is_MSWin32 || $Is_NetWare;
 
     SKIP: {
         skip "Test uses unixisms", 2 if $Is_MSWin32 || $Is_NetWare;
@@ -375,12 +390,7 @@ SKIP: {
 my $statfile = './op/stat.t';
 ok(  -T $statfile,    '-T');
 ok(! -B $statfile,    '!-B');
 my $statfile = './op/stat.t';
 ok(  -T $statfile,    '-T');
 ok(! -B $statfile,    '!-B');
-
-SKIP: {
-     skip("DG/UX", 1) if $Is_DGUX;
 ok(-B $Perl,      '-B');
 ok(-B $Perl,      '-B');
-}
-
 ok(! -T $Perl,    '!-T');
 
 open(FOO,$statfile);
 ok(! -T $Perl,    '!-T');
 
 open(FOO,$statfile);
@@ -467,10 +477,13 @@ like $@, qr/^The stat preceding lstat\(\) wasn't an lstat at /,
 'stat $ioref resets stat type';
 
 {
 'stat $ioref resets stat type';
 
 {
-    my @statbuf = stat STDOUT;
+    open(FOO, ">$tmpfile") || DIE("Can't open temp test file: $!");
+    my @statbuf = stat FOO;
     stat "test.pl";
     stat "test.pl";
-    my @lstatbuf = lstat *STDOUT{IO};
+    my @lstatbuf = lstat *FOO{IO};
     is "@lstatbuf", "@statbuf", 'lstat $ioref reverts to regular fstat';
     is "@lstatbuf", "@statbuf", 'lstat $ioref reverts to regular fstat';
+    close(FOO);
+    unlink $tmpfile or print "# unlink failed: $!\n";
 }
   
 SKIP: {
 }
   
 SKIP: {
@@ -507,7 +520,11 @@ SKIP: {
     my @b = (-M _, -A _, -C _);
     print "# -MAC=(@b)\n";
     ok( (-M _) < 0, 'negative -M works');
     my @b = (-M _, -A _, -C _);
     print "# -MAC=(@b)\n";
     ok( (-M _) < 0, 'negative -M works');
-    ok( (-A _) < 0, 'negative -A works');
+  SKIP:
+    {
+        skip "Access timestamps inaccurate", 1 if $inaccurate_atime;
+        ok( (-A _) < 0, 'negative -A works');
+    }
     ok( (-C _) < 0, 'negative -C works');
     ok(unlink($f), 'unlink tmp file');
 }
     ok( (-C _) < 0, 'negative -C works');
     ok(unlink($f), 'unlink tmp file');
 }
@@ -523,8 +540,13 @@ SKIP: {
     my $s2 = -s _;
     is($s1, $s2, q(-T _ doesn't break the statbuffer));
     SKIP: {
     my $s2 = -s _;
     is($s1, $s2, q(-T _ doesn't break the statbuffer));
     SKIP: {
+       my $root_uid = $Is_Cygwin ? 18 : 0;
        skip "No lstat", 1 unless $Config{d_lstat};
        skip "No lstat", 1 unless $Config{d_lstat};
-       skip "uid=0", 1 unless $<&&$>;
+       skip "uid=0", 1 if $< == $root_uid or $> == $root_uid;
+       skip "Can't check if admin user in miniperl", 1
+         if $^O =~ /^(cygwin|MSWin32|msys)$/ && is_miniperl();
+       skip "Readable by group/other means readable by me on $^O", 1 if $^O eq 'VMS'
+          or ($^O =~ /^(cygwin|MSWin32|msys)$/ and Win32::IsAdminUser());
        lstat($tmpfile);
        -T _;
        ok(eval { lstat _ },
        lstat($tmpfile);
        -T _;
        ok(eval { lstat _ },
@@ -600,6 +622,16 @@ SKIP: {
     is $w, undef, 'no unopened warning from stat _';
 }
 
     is $w, undef, 'no unopened warning from stat _';
 }
 
+{
+    # [perl #123816]
+    # Inappropriate stacking of l?stat with filetests should either work or
+    # give a syntax error, they shouldn't crash.
+    eval { stat -t };
+    ok(1, 'can "stat -t" without crashing');
+       eval { lstat -t };
+    ok(1, 'can "lstat -t" without crashing');
+}
+
 END {
     chmod 0666, $tmpfile;
     unlink_all $tmpfile;
 END {
     chmod 0666, $tmpfile;
     unlink_all $tmpfile;
Unnamed repository; edit this file 'description' to name the repository.