This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Win32: add lstat(), fetch st_dev and st_ino and fetch st_nlink for fstat
[perl5.git] / t / op / stat.t
CommitLineData
8d063cd8
LW
1#!./perl
2
ea368a7c
CS
3BEGIN {
4 chdir 't' if -d 't';
2bc69dc4 5 require './test.pl'; # for which_perl() etc
624c42e2 6 set_up_inc('../lib');
ea368a7c
CS
7}
8
c7be253f
DIM
9use strict;
10use warnings;
ea368a7c 11use Config;
563ff921
NC
12
13my ($Null, $Curdir);
14if(eval {require File::Spec; 1}) {
15 $Null = File::Spec->devnull;
16 $Curdir = File::Spec->curdir;
17} else {
18 die $@ unless is_miniperl();
19 $Curdir = '.';
20 diag("miniperl failed to load File::Spec, error is:\n$@");
21 diag("\ncontinuing, assuming '.' for current directory. Some tests will be skipped.");
22}
23
f0c73bbb
TC
24if ($^O eq 'MSWin32') {
25 # under minitest, buildcustomize sets this to 1, which means
26 # nlinks isn't populated properly, allow nlinks tests to pass
27 ${^WIN32_SLOPPY_STAT} = 0;
28}
ea368a7c 29
a155eb05 30plan tests => 110;
8d063cd8 31
2bc69dc4 32my $Perl = which_perl();
b5fe401b 33
d4046c48
NC
34$ENV{LC_ALL} = 'C'; # Forge English error messages.
35$ENV{LANGUAGE} = 'C'; # Ditto in GNU.
36
c7be253f
DIM
37my $Is_Amiga = $^O eq 'amigaos';
38my $Is_Cygwin = $^O eq 'cygwin';
39my $Is_Darwin = $^O eq 'darwin';
40my $Is_Dos = $^O eq 'dos';
41my $Is_MSWin32 = $^O eq 'MSWin32';
42my $Is_NetWare = $^O eq 'NetWare';
43my $Is_OS2 = $^O eq 'os2';
44my $Is_Solaris = $^O eq 'solaris';
45my $Is_VMS = $^O eq 'VMS';
46my $Is_MPRAS = $^O =~ /svr4/ && -f '/etc/.relid';
47my $Is_Android = $^O =~ /android/;
48my $Is_Dfly = $^O eq 'dragonfly';
cc25fa79 49
c7be253f 50my $Is_Dosish = $Is_Dos || $Is_OS2 || $Is_MSWin32 || $Is_NetWare;
cc25fa79 51
c7be253f 52my $ufs_no_ctime = ($Is_Dfly || $Is_Darwin) && (() = `df -t ufs . 2>/dev/null`) == 2;
be4e88b6 53
2430d10f
N
54my $Is_linux_container = is_linux_container();
55
3442c4b3 56if ($Is_Cygwin && !is_miniperl) {
b595cd4b
RU
57 require Win32;
58 Win32->import;
59}
60
cc25fa79
MS
61my($DEV, $INO, $MODE, $NLINK, $UID, $GID, $RDEV, $SIZE,
62 $ATIME, $MTIME, $CTIME, $BLKSIZE, $BLOCKS) = (0..12);
d48672a2 63
1c25d394
NC
64my $tmpfile = tempfile();
65my $tmpfile_link = tempfile();
4435c477 66
295d5f02 67chmod 0666, $tmpfile;
c291be4e 68unlink_all $tmpfile;
c4fbe247 69open(FOO, ">$tmpfile") || DIE("Can't open temp test file: $!");
de5a37b2 70close FOO;
8d220878 71
c4fbe247 72open(FOO, ">$tmpfile") || DIE("Can't open temp test file: $!");
4435c477 73
cc25fa79 74my($nlink, $mtime, $ctime) = (stat(FOO))[$NLINK, $MTIME, $CTIME];
16ed4686 75
67fcfcf9
JL
76# The clock on a network filesystem might be different from the
77# system clock.
78my $Filesystem_Time_Offset = abs($mtime - time);
79
9accb295 80#nlink should if link support configured in Perl.
b5bfebd7 81SKIP: {
9accb295
CB
82 skip "No link count - Hard link support not built in.", 1
83 unless $Config{d_link};
b5bfebd7
MS
84
85 is($nlink, 1, 'nlink on regular file');
86}
8d220878 87
cc25fa79 88SKIP: {
d5b53b20 89 skip "mtime and ctime not reliable", 2
7b903762 90 if $Is_MSWin32 or $Is_NetWare or $Is_Cygwin or $Is_Dos or $Is_Darwin;
cc25fa79
MS
91
92 ok( $mtime, 'mtime' );
93 is( $mtime, $ctime, 'mtime == ctime' );
4435c477 94}
8d063cd8 95
cc25fa79
MS
96
97# Cygwin seems to have a 3 second granularity on its timestamps.
98my $funky_FAT_timestamps = $Is_Cygwin;
99sleep 3 if $funky_FAT_timestamps;
100
101print FOO "Now is the time for all good men to come to.\n";
102close(FOO);
103
151269f6 104sleep 2;
cc25fa79 105
e08070a0
TC
106my $has_link = 1;
107my $inaccurate_atime = 0;
108if (defined &Win32::IsWinNT && Win32::IsWinNT()) {
109 if (Win32::FsType() ne 'NTFS') {
110 $has_link = 0;
111 $inaccurate_atime = 1;
112 }
113}
cc25fa79
MS
114
115SKIP: {
e08070a0 116 skip "No link on this filesystem", 6 unless $has_link;
cc25fa79 117 unlink $tmpfile_link;
de5a37b2
MS
118 my $lnk_result = eval { link $tmpfile, $tmpfile_link };
119 skip "link() unimplemented", 6 if $@ =~ /unimplemented/;
cc25fa79 120
de5a37b2
MS
121 is( $@, '', 'link() implemented' );
122 ok( $lnk_result, 'linked tmp testfile' );
cc25fa79
MS
123 ok( chmod(0644, $tmpfile), 'chmoded tmp testfile' );
124
125 my($nlink, $mtime, $ctime) = (stat($tmpfile))[$NLINK, $MTIME, $CTIME];
126
127 SKIP: {
128 skip "No link count", 1 if $Config{dont_use_nlink};
f672c027 129 skip "Cygwin9X fakes hard links by copying", 1
7d38e28d 130 if $Config{myuname} =~ /^cygwin_(?:9\d|me)\b/i;
f672c027 131
cc25fa79
MS
132 is($nlink, 2, 'Link count on hard linked file' );
133 }
134
135 SKIP: {
563ff921 136 skip_if_miniperl("File::Spec not built for minitest", 2);
de5a37b2 137 my $cwd = File::Spec->rel2abs($Curdir);
d5b53b20
NIS
138 skip "Solaris tmpfs has different mtime/ctime link semantics", 2
139 if $Is_Solaris and $cwd =~ m#^/tmp# and
cc25fa79
MS
140 $mtime && $mtime == $ctime;
141 skip "AFS has different mtime/ctime link semantics", 2
142 if $cwd =~ m#$Config{'afsroot'}/#;
143 skip "AmigaOS has different mtime/ctime link semantics", 2
144 if $Is_Amiga;
d5b53b20
NIS
145 # Win32 could pass $mtime test but as FAT and NTFS have
146 # no ctime concept $ctime is ALWAYS == $mtime
147 # expect netware to be the same ...
148 skip "No ctime concept on this OS", 2
a4ea1387 149 if $Is_MSWin32 || $ufs_no_ctime;
a28aea8e
TC
150 my $ok_mtime = ok($mtime, 'hard link mtime');
151 local our $TODO;
152 # https://bugs.dragonflybsd.org/issues/3251
153 # this might be hammer/hammer2 specific
154 $TODO = "DragonFly BSD doesn't touch ctime on link()/chmod"
155 if $^O eq "dragonfly" && $Config{myuname} =~ /5\.8/;
156 if(!$ok_mtime ||
cc25fa79 157 !isnt($mtime, $ctime, 'hard link ctime != mtime') ) {
be4e88b6 158 print STDERR <<DIAG;
d5b53b20 159# Check if you are on a tmpfs of some sort. Building in /tmp sometimes
61967be2 160# has this problem. Building on the ClearCase VOBS filesystem may also
cc25fa79 161# cause this failure.
61967be2 162#
a4ea1387
TK
163# Some UFS implementations don't have a ctime concept, and thus are
164# expected to fail this test.
cc25fa79
MS
165DIAG
166 }
167 }
168
3fe9a6f1 169}
8d063cd8 170
cc25fa79 171# truncate and touch $tmpfile.
c4fbe247 172open(F, ">$tmpfile") || DIE("Can't open temp test file: $!");
bda6ed21
PM
173ok(-z \*F, '-z on empty filehandle');
174ok(! -s \*F, ' and -s');
cc25fa79
MS
175close F;
176
177ok(-z $tmpfile, '-z on empty file');
178ok(! -s $tmpfile, ' and -s');
179
c4fbe247 180open(F, ">$tmpfile") || DIE("Can't open temp test file: $!");
cc25fa79
MS
181print F "hi\n";
182close F;
183
bda6ed21
PM
184open(F, "<$tmpfile") || DIE("Can't open temp test file: $!");
185ok(!-z *F, '-z on empty filehandle');
186ok( -s *F, ' and -s');
187close F;
188
cc25fa79
MS
189ok(! -z $tmpfile, '-z on non-empty file');
190ok(-s $tmpfile, ' and -s');
191
192
193# Strip all access rights from the file.
194ok( chmod(0000, $tmpfile), 'chmod 0000' );
195
196SKIP: {
de5a37b2 197 skip "-r, -w and -x have different meanings on VMS", 3 if $Is_VMS;
cc25fa79
MS
198
199 SKIP: {
de5a37b2
MS
200 # Going to try to switch away from root. Might not work.
201 my $olduid = $>;
202 eval { $> = 1; };
d5b53b20 203 skip "Can't test -r or -w meaningfully if you're superuser", 2
14f229c7 204 if ($Is_Cygwin ? _ingroup(544, 1) : $> == 0);
de5a37b2
MS
205
206 SKIP: {
b595cd4b 207 skip "Can't test -r meaningfully?", 1 if $Is_Dos;
de5a37b2
MS
208 ok(!-r $tmpfile, " -r");
209 }
cc25fa79 210
de5a37b2 211 ok(!-w $tmpfile, " -w");
cc25fa79 212
de5a37b2
MS
213 # switch uid back (may not be implemented)
214 eval { $> = $olduid; };
215 }
216
217 ok(! -x $tmpfile, ' -x');
a245ea2d 218}
cc25fa79 219
de5a37b2 220
cc25fa79 221
cc25fa79
MS
222ok(chmod(0700,$tmpfile), 'chmod 0700');
223ok(-r $tmpfile, ' -r');
224ok(-w $tmpfile, ' -w');
225
226SKIP: {
61967be2 227 skip "-x simply determines if a file ends in an executable suffix", 1
7b903762 228 if $Is_Dosish;
cc25fa79
MS
229
230 ok(-x $tmpfile, ' -x');
6eb13c3b 231}
cc25fa79
MS
232
233ok( -f $tmpfile, ' -f');
234ok(! -d $tmpfile, ' !-d');
235
236# Is this portable?
563ff921
NC
237ok( -d '.', '-d cwd' );
238ok(! -f '.', '!-f cwd' );
de5a37b2 239
cc25fa79
MS
240
241SKIP: {
de5a37b2
MS
242 unlink($tmpfile_link);
243 my $symlink_rslt = eval { symlink $tmpfile, $tmpfile_link };
244 skip "symlink not implemented", 3 if $@ =~ /unimplemented/;
cc25fa79 245
de5a37b2
MS
246 is( $@, '', 'symlink() implemented' );
247 ok( $symlink_rslt, 'symlink() ok' );
248 ok(-l $tmpfile_link, '-l');
6eb13c3b 249}
cc25fa79
MS
250
251ok(-o $tmpfile, '-o');
252
253ok(-e $tmpfile, '-e');
de5a37b2
MS
254
255unlink($tmpfile_link);
cc25fa79
MS
256ok(! -e $tmpfile_link, ' -e on unlinked file');
257
258SKIP: {
feef4889 259 skip "No character, socket or block special files", 6
cc25fa79 260 if $Is_MSWin32 || $Is_NetWare || $Is_Dos;
feef4889 261 skip "/dev isn't available to test against", 6
3fcc9fea 262 unless -d '/dev' && -r '/dev' && -x '/dev';
61967be2 263 skip "Skipping: unexpected ls output in MP-RAS", 6
ca37ab50 264 if $Is_MPRAS;
de5a37b2 265
16ed4686
JM
266 # VMS problem: If GNV or other UNIX like tool is installed, then
267 # sometimes Perl will find /bin/ls, and will try to run it.
268 # But since Perl on VMS does not know to run it under Bash, it will
269 # try to run the DCL verb LS. And if the VMS product Language
270 # Sensitive Editor is installed, or some other LS verb, that will
271 # be run instead. So do not do this until we can teach Perl
272 # when to use BASH on VMS.
273 skip "ls command not available to Perl in OpenVMS right now.", 6
274 if $Is_VMS;
275
3aa1294d 276 delete $ENV{CLICOLOR_FORCE};
7e0262e5 277 my $LS = $Config{d_readlink} && !$Is_Android ? "ls -lL" : "ls -l";
eb1102fc 278 my $CMD = "$LS /dev 2>/dev/null";
a7ec4029
JH
279 my $DEV = qx($CMD);
280
feef4889 281 skip "$CMD failed", 6 if $DEV eq '';
a7ec4029 282
3fcc9fea
JH
283 my @DEV = do { my $dev; opendir($dev, "/dev") ? readdir($dev) : () };
284
feef4889 285 skip "opendir failed: $!", 6 if @DEV == 0;
3fcc9fea 286
9aa9a1a6 287 # /dev/stdout might be either character special or a named pipe,
db8ab41e
JH
288 # or a symlink, or a socket, depending on which OS and how are
289 # you running the test, so let's censor that one away.
6320a86a 290 # Similar remarks hold for stderr.
db8ab41e 291 $DEV =~ s{^[cpls].+?\sstdout$}{}m;
267513dc 292 @DEV = grep { $_ ne 'stdout' } @DEV;
6320a86a
AD
293 $DEV =~ s{^[cpls].+?\sstderr$}{}m;
294 @DEV = grep { $_ ne 'stderr' } @DEV;
267513dc 295
c7974a0a
JH
296 # /dev/printer is also naughty: in IRIX it shows up as
297 # Srwx-----, not srwx------.
298 $DEV =~ s{^.+?\sprinter$}{}m;
299 @DEV = grep { $_ ne 'printer' } @DEV;
300
267513dc
JH
301 # If running as root, we will see .files in the ls result,
302 # and readdir() will see them always. Potential for conflict,
303 # so let's weed them out.
304 $DEV =~ s{^.+?\s\..+?$}{}m;
305 @DEV = grep { ! m{^\..+$} } @DEV;
9aa9a1a6 306
a872d7f5
CW
307 # sometimes files cannot be stat'd on cygwin, making inspecting pointless
308 # remove them from both @DEV and $DEV
309 @DEV = grep $DEV =~ s/^.\?{9}.*\s$_(?: -> .*)?$//m ? () : $_, @DEV
310 if $Is_Cygwin;
311
085a16fc
JH
312 # Irix ls -l marks sockets with 'S' while 's' is a 'XENIX semaphore'.
313 if ($^O eq 'irix') {
314 $DEV =~ s{^S(.+?)}{s$1}mg;
315 }
316
3fcc9fea 317 my $try = sub {
9f966f7a 318 my @c1 = eval qq[\$DEV =~ /^$_[0].*/mg];
3fcc9fea
JH
319 my @c2 = eval qq[grep { $_[1] "/dev/\$_" } \@DEV];
320 my $c1 = scalar @c1;
321 my $c2 = scalar @c2;
a872d7f5
CW
322 diag "= before", $DEV, "-", @DEV, "= after", @c1, "-", @c2, "="
323 unless is($c1, $c2, "ls and $_[1] agreeing on /dev ($c1 $c2)");
3fcc9fea
JH
324 };
325
8d87852b 326{
3fcc9fea
JH
327 $try->('b', '-b');
328 $try->('c', '-c');
329 $try->('s', '-S');
378cc40b
LW
330}
331
3fcc9fea 332ok(! -b $Curdir, '!-b cwd');
de5a37b2
MS
333ok(! -c $Curdir, '!-c cwd');
334ok(! -S $Curdir, '!-S cwd');
cc25fa79 335
95036ac7
JH
336}
337
cc25fa79 338SKIP: {
cc25fa79
MS
339 my($cnt, $uid);
340 $cnt = $uid = 0;
341
342 # Find a set of directories that's very likely to have setuid files
343 # but not likely to be *all* setuid files.
344 my @bin = grep {-d && -r && -x} qw(/sbin /usr/sbin /bin /usr/bin);
de5a37b2 345 skip "Can't find a setuid file to test with", 3 unless @bin;
cc25fa79
MS
346
347 for my $bin (@bin) {
348 opendir BIN, $bin or die "Can't opendir $bin: $!";
349 while (defined($_ = readdir BIN)) {
350 $_ = "$bin/$_";
351 $cnt++;
352 $uid++ if -u;
353 last if $uid && $uid < $cnt;
354 }
355 }
356 closedir BIN;
357
2304a331
JH
358 skip "No setuid programs", 3 if $uid == 0;
359
360 isnt($cnt, 0, 'found some programs');
361 isnt($uid, 0, ' found some setuid programs');
362 ok($uid < $cnt, " they're not all setuid");
378cc40b 363}
b8440792 364
378cc40b 365
3e3baf6d
TB
366# To assist in automated testing when a controlling terminal (/dev/tty)
367# may not be available (at, cron rsh etc), the PERL_SKIP_TTY_TEST env var
368# can be set to skip the tests that need a tty.
cc25fa79
MS
369SKIP: {
370 skip "These tests require a TTY", 4 if $ENV{PERL_SKIP_TTY_TEST};
2430d10f 371 skip "Skipping TTY tests on linux containers", 4 if $Is_linux_container;
cc25fa79 372
7eb35c03 373 my $TTY = "/dev/tty";
cc25fa79
MS
374
375 SKIP: {
376 skip "Test uses unixisms", 2 if $Is_MSWin32 || $Is_NetWare;
377 skip "No TTY to test -t with", 2 unless -e $TTY;
378
d5b53b20 379 open(TTY, $TTY) ||
cc25fa79
MS
380 warn "Can't open $TTY--run t/TEST outside of make.\n";
381 ok(-t TTY, '-t');
382 ok(-c TTY, 'tty is -c');
383 close(TTY);
3e3baf6d 384 }
cc25fa79 385 ok(! -t TTY, '!-t on closed TTY filehandle');
28e8237b
MS
386
387 {
c7be253f 388 local our $TODO = 'STDIN not a tty when output is to pipe' if $Is_VMS;
28e8237b
MS
389 ok(-t, '-t on STDIN');
390 }
68dc0745 391}
cc25fa79 392
cc25fa79 393SKIP: {
de5a37b2 394 skip "No null device to test with", 1 unless -e $Null;
d5b53b20 395 skip "We know Win32 thinks '$Null' is a TTY", 1 if $Is_MSWin32;
cc25fa79 396
c4fbe247 397 open(NULL, $Null) or DIE("Can't open $Null: $!");
de5a37b2 398 ok(! -t NULL, 'null device is not a TTY');
cc25fa79 399 close(NULL);
378cc40b 400}
cc25fa79 401
378cc40b
LW
402
403# These aren't strictly "stat" calls, but so what?
563ff921 404my $statfile = './op/stat.t';
dc459aad
JH
405ok( -T $statfile, '-T');
406ok(! -B $statfile, '!-B');
b5fe401b
MS
407ok(-B $Perl, '-B');
408ok(! -T $Perl, '!-T');
378cc40b 409
dc459aad 410open(FOO,$statfile);
cc25fa79
MS
411SKIP: {
412 eval { -T FOO; };
de5a37b2 413 skip "-T/B on filehandle not implemented", 15 if $@ =~ /not implemented/;
cc25fa79
MS
414
415 is( $@, '', '-T on filehandle causes no errors' );
416
417 ok(-T FOO, ' -T');
418 ok(! -B FOO, ' !-B');
419
f0fcb552 420 $_ = <FOO>;
1d662fb6 421 like($_, qr/perl/, 'after readline');
cc25fa79
MS
422 ok(-T FOO, ' still -T');
423 ok(! -B FOO, ' still -B');
f0fcb552
LW
424 close(FOO);
425
dc459aad 426 open(FOO,$statfile);
f0fcb552 427 $_ = <FOO>;
1d662fb6 428 like($_, qr/perl/, 'reopened and after readline');
cc25fa79
MS
429 ok(-T FOO, ' still -T');
430 ok(! -B FOO, ' still !-B');
431
432 ok(seek(FOO,0,0), 'after seek');
de5a37b2
MS
433 ok(-T FOO, ' still -T');
434 ok(! -B FOO, ' still !-B');
435
436 # It's documented this way in perlfunc *shrug*
437 () = <FOO>;
438 ok(eof FOO, 'at EOF');
439 ok(-T FOO, ' still -T');
440 ok(-B FOO, ' now -B');
f0fcb552
LW
441}
442close(FOO);
378cc40b 443
cc25fa79 444
de5a37b2
MS
445SKIP: {
446 skip "No null device to test with", 2 unless -e $Null;
447
448 ok(-T $Null, 'null device is -T');
449 ok(-B $Null, ' and -B');
450}
cc25fa79 451
108ed793
SM
452
453# and now, a few parsing tests:
cc25fa79
MS
454$_ = $tmpfile;
455ok(-f, 'bare -f uses $_');
456ok(-f(), ' -f() "');
108ed793 457
cc25fa79 458unlink $tmpfile or print "# unlink failed: $!\n";
58d95175 459
ee95e30c 460# bug id 20011101.069 (#7861)
dc459aad 461my @r = \stat($Curdir);
cc25fa79 462is(scalar @r, 13, 'stat returns full 13 elements');
5c9aa243 463
049f818b
YST
464stat $0;
465eval { lstat _ };
466like( $@, qr/^The stat preceding lstat\(\) wasn't an lstat/,
467 'lstat _ croaks after stat' );
109c43ed
FC
468eval { lstat *_ };
469like( $@, qr/^The stat preceding lstat\(\) wasn't an lstat/,
470 'lstat *_ croaks after stat' );
471eval { lstat \*_ };
472like( $@, qr/^The stat preceding lstat\(\) wasn't an lstat/,
473 'lstat \*_ croaks after stat' );
049f818b
YST
474eval { -l _ };
475like( $@, qr/^The stat preceding -l _ wasn't an lstat/,
476 '-l _ croaks after stat' );
477
478lstat $0;
479eval { lstat _ };
480is( "$@", "", "lstat _ ok after lstat" );
481eval { -l _ };
482is( "$@", "", "-l _ ok after lstat" );
020cc77c 483
84f93674 484eval { lstat "test.pl" };
020cc77c
FC
485{
486 open my $fh, "test.pl";
487 stat *$fh{IO};
488 eval { lstat _ }
489}
490like $@, qr/^The stat preceding lstat\(\) wasn't an lstat at /,
491'stat $ioref resets stat type';
0d5064f1
FC
492
493{
5a3240c1
DM
494 open(FOO, ">$tmpfile") || DIE("Can't open temp test file: $!");
495 my @statbuf = stat FOO;
0d5064f1 496 stat "test.pl";
c7be253f 497 no warnings 'io';
5a3240c1 498 my @lstatbuf = lstat *FOO{IO};
0d5064f1 499 is "@lstatbuf", "@statbuf", 'lstat $ioref reverts to regular fstat';
48bbb9f8 500 close(FOO);
5a3240c1 501 unlink $tmpfile or print "# unlink failed: $!\n";
0d5064f1 502}
049f818b 503
5c9aa243 504SKIP: {
92b3a3eb 505 skip "No lstat", 2 unless $Config{d_lstat} && $Config{d_symlink};
5c9aa243 506
ee95e30c 507 # bug id 20020124.004 (#8334)
bee528ec 508 my $linkname = 'stat-' . rand =~ y/.//dr;
102411b6
CB
509 my $target = $Perl;
510 $target =~ s/;\d+\z// if $Is_VMS; # symlinks don't like version numbers
92b3a3eb
TC
511 unless (symlink $target, $linkname) {
512 if ($^O eq "MSWin32") {
513 # likely we don't have permission
514 skip "symlink failed: $!", 2;
515 }
516 die "# Can't symlink $0: $!";
517 }
5c9aa243
RGS
518 lstat $linkname;
519 -T _;
520 eval { lstat _ };
3db621ff 521 like( $@, qr/^The stat preceding lstat\(\) wasn't an lstat/,
5c9aa243
RGS
522 'lstat croaks after -T _' );
523 eval { -l _ };
3db621ff 524 like( $@, qr/^The stat preceding -l _ wasn't an lstat/,
5c9aa243
RGS
525 '-l _ croaks after -T _' );
526 unlink $linkname or print "# unlink $linkname failed: $!\n";
527}
98a392ec 528
67fcfcf9
JL
529SKIP: {
530 skip "Too much clock skew between system and filesystem", 5
531 if ($Filesystem_Time_Offset > 5);
532 print "# Zzz...\n";
533 sleep($Filesystem_Time_Offset+1);
534 my $f = 'tstamp.tmp';
535 unlink $f;
536 ok (open(S, "> $f"), 'can create tmp file');
537 close S or die;
538 my @a = stat $f;
539 print "# time=$^T, stat=(@a)\n";
540 my @b = (-M _, -A _, -C _);
541 print "# -MAC=(@b)\n";
542 ok( (-M _) < 0, 'negative -M works');
e08070a0
TC
543 SKIP:
544 {
545 skip "Access timestamps inaccurate", 1 if $inaccurate_atime;
546 ok( (-A _) < 0, 'negative -A works');
547 }
67fcfcf9
JL
548 ok( (-C _) < 0, 'negative -C works');
549 ok(unlink($f), 'unlink tmp file');
550}
a80d47c2 551
7b64ff23 552# [perl #4253]
25988e07
NE
553{
554 ok(open(F, ">", $tmpfile), 'can create temp file');
555 close F;
556 chmod 0077, $tmpfile;
557 my @a = stat($tmpfile);
558 my $s1 = -s _;
559 -T _;
560 my $s2 = -s _;
561 is($s1, $s2, q(-T _ doesn't break the statbuffer));
84f93674 562 SKIP: {
3442c4b3 563 my $root_uid = $Is_Cygwin ? 18 : 0;
84f93674 564 skip "No lstat", 1 unless $Config{d_lstat};
3442c4b3
RU
565 skip "uid=0", 1 if $< == $root_uid or $> == $root_uid;
566 skip "Can't check if admin user in miniperl", 1
567 if $^O =~ /^(cygwin|MSWin32|msys)$/ && is_miniperl();
568 skip "Readable by group/other means readable by me on $^O", 1 if $^O eq 'VMS'
569 or ($^O =~ /^(cygwin|MSWin32|msys)$/ and Win32::IsAdminUser());
84f93674
FC
570 lstat($tmpfile);
571 -T _;
572 ok(eval { lstat _ },
573 q(-T _ doesn't break lstat for unreadable file));
574 }
8ca3c3a5 575 unlink $tmpfile;
25988e07
NE
576}
577
5228a96c 578SKIP: {
2a794dcf 579 skip "No dirfd()", 4 unless $Config{d_dirfd} || $Config{d_dir_dd_fd};
586251be
SP
580 ok(opendir(DIR, "."), 'Can open "." dir') || diag "Can't open '.': $!";
581 ok(stat(DIR), "stat() on dirhandle works");
5228a96c 582 ok(-d -r _ , "chained -x's on dirhandle");
6d6dd8fe 583 ok(-d DIR, "-d on a dirhandle works");
6d6dd8fe 584 closedir DIR or die $!;
586251be
SP
585}
586
587{
588 # RT #8244: *FILE{IO} does not behave like *FILE for stat() and -X() operators
589 ok(open(F, ">", $tmpfile), 'can create temp file');
590 my @thwap = stat *F{IO};
591 ok(@thwap, "stat(*F{IO}) works");
592 ok( -f *F{IO} , "single file tests work with *F{IO}");
c84ba4c0 593 close F;
586251be
SP
594 unlink $tmpfile;
595
596 #PVIO's hold dirhandle information, so let's test them too.
597
598 SKIP: {
2a794dcf 599 skip "No dirfd()", 4 unless $Config{d_dirfd} || $Config{d_dir_dd_fd};
586251be
SP
600 ok(opendir(DIR, "."), 'Can open "." dir') || diag "Can't open '.': $!";
601 ok(stat(*DIR{IO}), "stat() on *DIR{IO} works");
20c932f8 602 ok(-d _ , "The special file handle _ is set correctly");
586251be 603 ok(-d -r *DIR{IO} , "chained -x's on *DIR{IO}");
20c932f8 604 closedir DIR or die $!;
586251be 605 }
5228a96c
SP
606}
607
daa30a68
FC
608# [perl #71002]
609{
daa30a68
FC
610 my $w;
611 local $SIG{__WARN__} = sub { warn shift; ++$w };
612 stat 'prepeinamehyparcheiarcheiometoonomaavto';
613 stat _;
614 is $w, undef, 'no unopened warning from stat _';
615}
616
87ebf1e3
HS
617{
618 # [perl #123816]
619 # Inappropriate stacking of l?stat with filetests should either work or
620 # give a syntax error, they shouldn't crash.
621 eval { stat -t };
622 ok(1, 'can "stat -t" without crashing');
623 eval { lstat -t };
624 ok(1, 'can "lstat -t" without crashing');
625}
626
7f399b40
FC
627# [perl #126064] stat stat stack busting
628is join("-", 1,2,3,(stat stat stat),4,5,6), "1-2-3-4-5-6",
629 'stat inside stat gets scalar context';
630
8f6eb0aa 631# [perl #126162] stat an array should not work
6405d2ef 632# skip if -e '2'.
edc12fc2
TC
633SKIP:
634{
6405d2ef
KW
635 skip "There is a file named '2', which invalidates this test", 2 if -e '2';
636
637 my $Errno_loaded = eval { require Errno };
638 my @statarg = ($statfile, $statfile);
c7be253f 639 no warnings 'syntax';
6405d2ef
KW
640 ok !stat(@statarg),
641 'stat on an array of valid paths should warn and should not return any data';
642 my $error = 0+$!;
edc12fc2
TC
643 skip "Errno not available", 1
644 unless $Errno_loaded;
645 is $error, &Errno::ENOENT,
646 'stat on an array of valid paths should return ENOENT';
647}
8f6eb0aa 648
a155eb05 649# [perl #131895] stat() doesn't fail on filenames containing \0 / NUL
c7be253f
DIM
650{
651 no warnings 'syscalls';
652 ok !stat("TEST\0-"), 'stat on filename with \0';
653}
a155eb05 654SKIP: {
2281c846 655 my $link = "stat_t_$$\_TEST.symlink";
a155eb05
TC
656 my $can_symlink = eval { symlink "TEST", $link };
657 skip "cannot symlink", 1 unless $can_symlink;
c7be253f 658 no warnings 'syscalls';
a155eb05
TC
659 ok !lstat("$link\0-"), 'lstat on filename with \0';
660 unlink $link;
661}
662
98a392ec 663END {
295d5f02 664 chmod 0666, $tmpfile;
c291be4e 665 unlink_all $tmpfile;
98a392ec 666}
14f229c7
TC
667
668sub _ingroup {
669 my ($gid, $eff) = @_;
670
671 $^O eq "VMS" and return $_[0] == $);
672
673 my ($egid, @supp) = split " ", $);
674 my ($rgid) = split " ", $(;
675
676 $gid == ($eff ? $egid : $rgid) and return 1;
677 grep $gid == $_, @supp and return 1;
678
679 return "";
680}