t/win32/stat.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     require "./test.pl";
   7 }
   8
   9 use strict;
  10 use Fcntl ":seek";
  11
  12 Win32::FsType() eq 'NTFS'
  13     or skip_all("need NTFS");
  14
  15 my (undef, $maj, $min) = Win32::GetOSVersion();
  16
  17 my $vista_or_later = $maj >= 6;
  18
  19 my $tmpfile1 = tempfile();
  20
  21 # test some of the win32 specific stat code, since we
  22 # don't depend on the CRT for some of it
  23
  24 ok(link($0, $tmpfile1), "make a link to test nlink");
  25
  26 my @st = stat $0;
  27 open my $fh, "<", $0 or die;
  28 my @fst = stat $fh;
  29
  30 ok(seek($fh, 0, SEEK_END), "seek to end");
  31 my $size = tell($fh);
  32 close $fh;
  33
  34 # the ucrt stat() is inconsistent here, using an A=0 drive letter for stat()
  35 # and the fd for fstat(), I assume that's something backward compatible.
  36 #
  37 # I don't see anything we could reasonable populate it with either.
  38 $st[6] = $fst[6] = 0;
  39
  40 is("@st", "@fst", "check named stat vs handle stat");
  41
  42 ok($st[0], "we set dev by default now");
  43 ok($st[1], "and ino");
  44
  45 # unlikely, but someone else might have linked to win32/stat.t
  46 cmp_ok($st[3], '>', 1, "should be more than one link");
  47
  48 # we now populate all stat fields ourselves, so check what we can
  49 is($st[7], $size, "we fetch size correctly");
  50
  51 cmp_ok($st[9], '<=', time(), "modification time before or on now");
  52 ok(-f $0, "yes, we are a file");
  53 ok(-d "win32", "and win32 is a directory");
  54 pipe(my ($p1, $p2));
  55 ok(-p $p1, "a pipe is a pipe");
  56 close $p1; close $p2;
  57 ok(-r $0, "we are readable");
  58 ok(!-x $0, "but not executable");
  59 ok(-e $0, "we exist");
  60
  61 ok(open(my $nul, ">", "nul"), "open nul");
  62 ok(-c $nul, "nul is a character device");
  63 close $nul;
  64
  65 my $nlink = $st[3];
  66
  67 # check we get nlinks etc for a directory
  68 @st = stat("win32");
  69 ok($st[0], "got dev for a directory");
  70 ok($st[1], "got ino for a directory");
  71 ok($st[3], "got nlink for a directory");
  72
  73 # symbolic links
  74 unlink($tmpfile1); # no more hard link
  75
  76 if (open my $fh, ">", "$tmpfile1.bat") {
  77     ok(-x "$tmpfile1.bat", 'batch file is "executable"');
  78     SKIP: {
  79         skip "executable bit for handles needs vista or later", 1
  80             unless $vista_or_later;
  81         ok(-x $fh, 'batch file handle is "executable"');
  82     }
  83     close $fh;
  84     unlink "$tmpfile1.bat";
  85 }
  86
  87 # mklink is available from Vista onwards
  88 # this may only work in an admin shell
  89 # MKLINK [[/D] | [/H] | [/J]] Link Target
  90 if (system("mklink $tmpfile1 win32\\stat.t") == 0) {
  91     ok(-l $tmpfile1, "lstat sees a symlink");
  92
  93     # check stat on file vs symlink
  94     @st = stat $0;
  95     my @lst = stat $tmpfile1;
  96
  97     $st[6] = $lst[6] = 0;
  98
  99     is("@st", "@lst", "check stat on file vs link");
 100
 101     # our hard link no longer exists, check that is reflected in nlink
 102     is($st[3], $nlink-1, "check nlink updated");
 103
 104     unlink($tmpfile1);
 105 }
 106
 107 # similarly for a directory
 108 if (system("mklink /d $tmpfile1 win32") == 0) {
 109     ok(-l $tmpfile1, "lstat sees a symlink on the directory symlink");
 110
 111     # check stat on directory vs symlink
 112     @st = stat "win32";
 113     my @lst = stat $tmpfile1;
 114
 115     $st[6] = $lst[6] = 0;
 116
 117     is("@st", "@lst", "check stat on dir vs link");
 118
 119     # for now at least, we need to rmdir symlinks to directories
 120     rmdir( $tmpfile1 );
 121 }
 122
 123 # check a junction looks like a symlink
 124
 125 if (system("mklink /j $tmpfile1 win32") == 0) {
 126     ok(-l $tmpfile1, "lstat sees a symlink on the directory junction");
 127
 128     rmdir( $tmpfile1 );
 129 }
 130
 131 # test interaction between stat and utime
 132 if (ok(open(my $fh, ">", $tmpfile1), "make a work file")) {
 133     # make our test file
 134     close $fh;
 135
 136     my @st = stat $tmpfile1;
 137     ok(@st, "stat our work file");
 138
 139     # switch to the other half of the year, to flip from/to daylight
 140     # savings time.  It won't always do so, but it's close enough and
 141     # avoids having to deal with working out exactly when it
 142     # starts/ends (if it does), along with the hemisphere.
 143     #
 144     # By basing this on the current file times and using an offset
 145     # that's the multiple of an hour we ensure the filesystem
 146     # resolution supports the time we set.
 147     my $moffset = 6 * 30 * 24 * 3600;
 148     my $aoffset = $moffset - 24 * 3600;;
 149     my $mymt = $st[9] - $moffset;
 150     my $myat = $st[8] - $aoffset;
 151     ok(utime($myat, $mymt, $tmpfile1), "set access and mod times");
 152     my @mst = stat $tmpfile1;
 153     ok(@mst, "fetch stat after utime");
 154     is($mst[9], $mymt, "check mod time");
 155     is($mst[8], $myat, "check access time");
 156
 157     unlink $tmpfile1;
 158 }
 159
 160 # same for a directory
 161 if (ok(mkdir($tmpfile1), "make a work directory")) {
 162     my @st = stat $tmpfile1;
 163     ok(@st, "stat our work directory");
 164
 165     my $moffset = 6 * 30 * 24 * 3600;
 166     my $aoffset = $moffset - 24 * 3600;;
 167     my $mymt = $st[9] - $moffset;
 168     my $myat = $st[8] - $aoffset;
 169     ok(utime($myat, $mymt, $tmpfile1), "set access and mod times");
 170     my @mst = stat $tmpfile1;
 171     ok(@mst, "fetch stat after utime");
 172     is($mst[9], $mymt, "check mod time");
 173     is($mst[8], $myat, "check access time");
 174
 175     rmdir $tmpfile1;
 176 }
 177
 178 # Other stat issues possibly fixed by the stat() re-work
 179
 180 # https://github.com/Perl/perl5/issues/9025 - win32 - file test operators don't work for //?/UNC/server/file filenames
 181 # can't really make a reliable regression test for this
 182 # reproduced original problem with a gcc build
 183 # confirmed fixed with a gcc build
 184
 185 # https://github.com/Perl/perl5/issues/8502 - filetest problem with STDIN/OUT on Windows
 186
 187 {
 188     ok(-r *STDIN, "check stdin is readable");
 189     ok(-w *STDOUT, "check stdout is writable");
 190
 191     # CompareObjectHandles() could fix this, but requires Windows 10
 192     local our $TODO = "dupped *STDIN and *STDOUT not read/write";
 193     open my $dupin, "<&STDIN" or die;
 194     open my $dupout, ">&STDOUT" or die;
 195     ok(-r $dupin, "check duplicated stdin is readable");
 196     ok(-w $dupout, "check duplicated stdout is writable");
 197 }
 198
 199 # https://github.com/Perl/perl5/issues/6080 - Last mod time from stat() can be wrong on Windows NT/2000/XP
 200 # tested already
 201
 202 # https://github.com/Perl/perl5/issues/4145 - Problem with filetest -x _ on Win2k AS Perl build 626
 203 # tested already
 204
 205 # https://github.com/Perl/perl5/issues/14687 -  Function lstat behavior case differs between Windows and Unix #14687
 206
 207 {
 208     local our $TODO = "... .... treated as .. by Win32 API";
 209     ok(!-e ".....", "non-existing many dots shouldn't returned existence");
 210 }
 211
 212 # https://github.com/Perl/perl5/issues/7410 - -e tests not reliable under Win32
 213 {
 214     # there's to issues here:
 215     # 1) CreateFile() successfully opens " . . " when opened with backup
 216     # semantics/directory
 217     # 2) opendir(" . . ") becomes FindFirstFile(" . . /*") which fails
 218     #
 219     # So we end up with success for the first and failure for the second,
 220     # making them inconsistent, there may be a Vista level fix for this,
 221     # but if we expect -e " . . " to fail we need a more complex fix.
 222     local our $TODO = "strange space handling by Windows";
 223     ok(!-e " ", "filename ' ' shouldn't exist");
 224     ok(!-e " . . ", "filename ' . . ' shouldn't exist");
 225     ok(!-e " .. ", "filename ' .. ' shouldn't exist");
 226     ok(!-e " . ", "filename ' . ' shouldn't exist");
 227
 228     ok(!!-e " . . " == !!opendir(FOO, " . . "),
 229        "these should be consistent");
 230 }
 231
 232 # https://github.com/Perl/perl5/issues/12431 - Win32: -e '"' always returns true
 233
 234 {
 235     ok(!-e '"', qq(filename '"' shouldn't exist));
 236 }
 237
 238 done_testing();