X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Fop%2Fstat.t;h=f00bd284ca86e38333026ebdf3edac22d0d53dd6;hb=21fa6956243df9cb622bebfa0934ea7923519b4f;hp=9306d2ffa20e02ceadfa73749b8e24c106030161;hpb=feef4889caac92ce6464e457e1d3f16b87a5fa09;p=p5sagit%2Fp5-mst-13.2.git diff --git a/t/op/stat.t b/t/op/stat.t index 9306d2f..f00bd28 100755 --- a/t/op/stat.t +++ b/t/op/stat.t @@ -9,13 +9,15 @@ BEGIN { use Config; use File::Spec; -plan tests => 73; +plan tests => 107; my $Perl = which_perl(); $Is_Amiga = $^O eq 'amigaos'; $Is_Cygwin = $^O eq 'cygwin'; +$Is_Darwin = $^O eq 'darwin'; $Is_Dos = $^O eq 'dos'; +$Is_MacOS = $^O eq 'MacOS'; $Is_MPE = $^O eq 'mpeix'; $Is_MSWin32 = $^O eq 'MSWin32'; $Is_NetWare = $^O eq 'NetWare'; @@ -23,9 +25,13 @@ $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_Rhapsody= $^O eq 'rhapsody'; $Is_Dosish = $Is_Dos || $Is_OS2 || $Is_MSWin32 || $Is_NetWare || $Is_Cygwin; +$Is_UFS = $Is_Darwin && (() = `df -t ufs . 2>/dev/null`) == 2; + my($DEV, $INO, $MODE, $NLINK, $UID, $GID, $RDEV, $SIZE, $ATIME, $MTIME, $CTIME, $BLKSIZE, $BLOCKS) = (0..12); @@ -35,14 +41,16 @@ my $Curdir = File::Spec->curdir; my $tmpfile = 'Op_stat.tmp'; my $tmpfile_link = $tmpfile.'2'; - -unlink $tmpfile; +chmod 0666, $tmpfile; +1 while unlink $tmpfile; open(FOO, ">$tmpfile") || DIE("Can't open temp test file: $!"); close FOO; open(FOO, ">$tmpfile") || DIE("Can't open temp test file: $!"); my($nlink, $mtime, $ctime) = (stat(FOO))[$NLINK, $MTIME, $CTIME]; + +#VMS Fix-me: nlink should work on VMS if applicable link support configured. SKIP: { skip "No link count", 1 if $Is_VMS; @@ -51,7 +59,7 @@ SKIP: { SKIP: { skip "mtime and ctime not reliable", 2 - if $Is_MSWin32 or $Is_NetWare or $Is_Cygwin or $Is_Dos; + if $Is_MSWin32 or $Is_NetWare or $Is_Cygwin or $Is_Dos or $Is_MacOS or $Is_Darwin; ok( $mtime, 'mtime' ); is( $mtime, $ctime, 'mtime == ctime' ); @@ -65,7 +73,7 @@ sleep 3 if $funky_FAT_timestamps; print FOO "Now is the time for all good men to come to.\n"; close(FOO); -sleep 2 unless $funky_FAT_timestamps; +sleep 2; SKIP: { @@ -100,15 +108,18 @@ SKIP: { # no ctime concept $ctime is ALWAYS == $mtime # expect netware to be the same ... skip "No ctime concept on this OS", 2 - if $Is_MSWin32; + if $Is_MSWin32 || + ($Is_Darwin && $Is_UFS); + if( !ok($mtime, 'hard link mtime') || !isnt($mtime, $ctime, 'hard link ctime != mtime') ) { - print <$tmpfile") || DIE("Can't open temp test file: $!"); +ok(-z \*F, '-z on empty filehandle'); +ok(! -s \*F, ' and -s'); close F; ok(-z $tmpfile, '-z on empty file'); @@ -126,6 +139,11 @@ open(F, ">$tmpfile") || DIE("Can't open temp test file: $!"); print F "hi\n"; close F; +open(F, "<$tmpfile") || DIE("Can't open temp test file: $!"); +ok(!-z *F, '-z on empty filehandle'); +ok( -s *F, ' and -s'); +close F; + ok(! -z $tmpfile, '-z on non-empty file'); ok(-s $tmpfile, ' and -s'); @@ -159,18 +177,13 @@ SKIP: { - -# in ms windows, $tmpfile inherits owner uid from directory -# not sure about os/2, but chown is harmless anyway -eval { chown $>,$tmpfile; 1 } or print "# $@" ; - ok(chmod(0700,$tmpfile), 'chmod 0700'); ok(-r $tmpfile, ' -r'); ok(-w $tmpfile, ' -w'); SKIP: { - skip "-x simply determins if a file ends in an executable suffix", 1 - if $Is_Dosish; + skip "-x simply determines if a file ends in an executable suffix", 1 + if $Is_Dosish || $Is_MacOS; ok(-x $tmpfile, ' -x'); } @@ -205,6 +218,18 @@ SKIP: { if $Is_MSWin32 || $Is_NetWare || $Is_Dos; skip "/dev isn't available to test against", 6 unless -d '/dev' && -r '/dev' && -x '/dev'; + skip "Skipping: unexpected ls output in MP-RAS", 6 + if $Is_MPRAS; + + # VMS problem: If GNV or other UNIX like tool is installed, then + # sometimes Perl will find /bin/ls, and will try to run it. + # But since Perl on VMS does not know to run it under Bash, it will + # try to run the DCL verb LS. And if the VMS product Language + # Sensitive Editor is installed, or some other LS verb, that will + # be run instead. So do not do this until we can teach Perl + # when to use BASH on 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"; my $CMD = "$LS /dev 2>/dev/null"; @@ -236,6 +261,11 @@ SKIP: { $DEV =~ s{^.+?\s\..+?$}{}m; @DEV = grep { ! m{^\..+$} } @DEV; + # Irix ls -l marks sockets with 'S' while 's' is a 'XENIX semaphore'. + if ($^O eq 'irix') { + $DEV =~ s{^S(.+?)}{s$1}mg; + } + my $try = sub { my @c1 = eval qq[\$DEV =~ /^$_[0].*/mg]; my @c2 = eval qq[grep { $_[1] "/dev/\$_" } \@DEV]; @@ -293,7 +323,7 @@ SKIP: { SKIP: { skip "These tests require a TTY", 4 if $ENV{PERL_SKIP_TTY_TEST}; - my $TTY = $^O eq 'rhapsody' ? "/dev/ttyp0" : "/dev/tty"; + my $TTY = $Is_Rhapsody ? "/dev/ttyp0" : "/dev/tty"; SKIP: { skip "Test uses unixisms", 2 if $Is_MSWin32 || $Is_NetWare; @@ -325,9 +355,9 @@ SKIP: { # These aren't strictly "stat" calls, but so what? - -ok(-T 'op/stat.t', '-T'); -ok(! -B 'op/stat.t', '!-B'); +my $statfile = File::Spec->catfile($Curdir, 'op', 'stat.t'); +ok( -T $statfile, '-T'); +ok(! -B $statfile, '!-B'); SKIP: { skip("DG/UX", 1) if $Is_DGUX; @@ -336,7 +366,7 @@ ok(-B $Perl, '-B'); ok(! -T $Perl, '!-T'); -open(FOO,'op/stat.t'); +open(FOO,$statfile); SKIP: { eval { -T FOO; }; skip "-T/B on filehandle not implemented", 15 if $@ =~ /not implemented/; @@ -352,7 +382,7 @@ SKIP: { ok(! -B FOO, ' still -B'); close(FOO); - open(FOO,'op/stat.t'); + open(FOO,$statfile); $_ = ; like($_, qr/perl/, 'reopened and after readline'); ok(-T FOO, ' still -T'); @@ -387,19 +417,25 @@ ok(-f(), ' -f() "'); unlink $tmpfile or print "# unlink failed: $!\n"; # bug id 20011101.069 -my @r = \stat("."); +my @r = \stat($Curdir); is(scalar @r, 13, 'stat returns full 13 elements'); +stat $0; +eval { lstat _ }; +like( $@, qr/^The stat preceding lstat\(\) wasn't an lstat/, + 'lstat _ croaks after stat' ); +eval { -l _ }; +like( $@, qr/^The stat preceding -l _ wasn't an lstat/, + '-l _ croaks after stat' ); + +lstat $0; +eval { lstat _ }; +is( "$@", "", "lstat _ ok after lstat" ); +eval { -l _ }; +is( "$@", "", "-l _ ok after lstat" ); + SKIP: { - skip "No lstat", 4 unless $Config{d_lstat}; - - stat $0; - eval { lstat _ }; - like( $@, qr/^The stat preceding lstat\(\) wasn't an lstat/, - 'lstat _ croaks after stat' ); - eval { -l _ }; - like( $@, qr/^The stat preceding -l _ wasn't an lstat/, - '-l _ croaks after stat' ); + skip "No lstat", 2 unless $Config{d_lstat}; # bug id 20020124.004 # If we have d_lstat, we should have symlink() @@ -415,3 +451,86 @@ SKIP: { '-l _ croaks after -T _' ); unlink $linkname or print "# unlink $linkname failed: $!\n"; } + +print "# Zzz...\n"; +sleep(3); +my $f = 'tstamp.tmp'; +unlink $f; +ok (open(S, "> $f"), 'can create tmp file'); +close S or die; +my @a = stat $f; +print "# time=$^T, stat=(@a)\n"; +my @b = (-M _, -A _, -C _); +print "# -MAC=(@b)\n"; +ok( (-M _) < 0, 'negative -M works'); +ok( (-A _) < 0, 'negative -A works'); +ok( (-C _) < 0, 'negative -C works'); +ok(unlink($f), 'unlink tmp file'); + +{ + ok(open(F, ">", $tmpfile), 'can create temp file'); + close F; + chmod 0077, $tmpfile; + my @a = stat($tmpfile); + my $s1 = -s _; + -T _; + my $s2 = -s _; + is($s1, $s2, q(-T _ doesn't break the statbuffer)); + unlink $tmpfile; +} + +SKIP: { + skip "No dirfd()", 9 unless $Config{d_dirfd} || $Config{d_dir_dd_fd}; + ok(opendir(DIR, "."), 'Can open "." dir') || diag "Can't open '.': $!"; + ok(stat(DIR), "stat() on dirhandle works"); + ok(-d -r _ , "chained -x's on dirhandle"); + ok(-d DIR, "-d on a dirhandle works"); + + # And now for the ambigious bareword case + ok(open(DIR, "TEST"), 'Can open "TEST" dir') + || diag "Can't open 'TEST': $!"; + my $size = (stat(DIR))[7]; + ok(defined $size, "stat() on bareword works"); + is($size, -s "TEST", "size returned by stat of bareword is for the file"); + ok(-f _, "ambiguous bareword uses file handle, not dir handle"); + ok(-f DIR); + closedir DIR or die $!; + close DIR or die $!; +} + +{ + # RT #8244: *FILE{IO} does not behave like *FILE for stat() and -X() operators + ok(open(F, ">", $tmpfile), 'can create temp file'); + my @thwap = stat *F{IO}; + ok(@thwap, "stat(*F{IO}) works"); + ok( -f *F{IO} , "single file tests work with *F{IO}"); + close F; + unlink $tmpfile; + + #PVIO's hold dirhandle information, so let's test them too. + + SKIP: { + skip "No dirfd()", 9 unless $Config{d_dirfd} || $Config{d_dir_dd_fd}; + ok(opendir(DIR, "."), 'Can open "." dir') || diag "Can't open '.': $!"; + ok(stat(*DIR{IO}), "stat() on *DIR{IO} works"); + ok(-d _ , "The special file handle _ is set correctly"); + ok(-d -r *DIR{IO} , "chained -x's on *DIR{IO}"); + + # And now for the ambigious bareword case + ok(open(DIR, "TEST"), 'Can open "TEST" dir') + || diag "Can't open 'TEST': $!"; + my $size = (stat(*DIR{IO}))[7]; + ok(defined $size, "stat() on *THINGY{IO} works"); + is($size, -s "TEST", + "size returned by stat of *THINGY{IO} is for the file"); + ok(-f _, "ambiguous *THINGY{IO} uses file handle, not dir handle"); + ok(-f *DIR{IO}); + closedir DIR or die $!; + close DIR or die $!; + } +} + +END { + chmod 0666, $tmpfile; + 1 while unlink $tmpfile; +}