lib/File/stat.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6 }
   7
   8 use strict;
   9 use warnings;
  10 use Test::More;
  11 use Config qw( %Config );
  12
  13 my $file;
  14
  15 BEGIN {
  16     # Check whether the build is configured with -Dmksymlinks
  17     our $Dmksymlinks =
  18         grep { /^config_arg\d+$/ && $Config{$_} eq '-Dmksymlinks' }
  19         keys %Config;
  20
  21     # Resolve symlink to ./lib/File/stat.t if this build is configured
  22     # with -Dmksymlinks
  23     # Originally we worked with ./TEST, but other test scripts read from
  24     # that file and modify its access time.
  25     $file = '../lib/File/stat.t';
  26     if ( $Dmksymlinks ) {
  27         $file = readlink $file;
  28         die "Can't readlink(../lib/File/stat.t): $!" if ! defined $file;
  29     }
  30 }
  31
  32 # Originally this was done in the BEGIN block, but perl is still
  33 # compiling (and hence reading) the script at that point, which can
  34 # change the file's access time, causing a different in the comparison
  35 # tests if the clock ticked over the second between the stat() and the
  36 # final read.
  37 # At this point all of the reading is done.
  38 our @stat = stat $file; # This is the function stat.
  39 unless (@stat) { plan skip_all => "1..0 # Skip: no file $file"; exit 0 }
  40
  41 require File::stat;
  42
  43 my $stat = File::stat::stat( $file ); # This is the OO stat.
  44 isa_ok($stat, 'File::stat', 'should build a stat object' );
  45
  46 my $i = 0;
  47 foreach ([dev => 'device number'],
  48          [ino => 'inode number'],
  49          [mode => 'file mode'],
  50          [nlink => 'number of links'],
  51          [uid => 'owner uid'],
  52          [gid => 'group id'],
  53          [rdev => 'device identifier'],
  54          [size => 'file size'],
  55          [atime => 'last access time'],
  56          [mtime => 'last modify time'],
  57          [ctime => 'change time'],
  58          [blksize => 'IO block size'],
  59          [blocks => 'number of blocks']) {
  60     my ($meth, $desc) = @$_;
  61     # On OS/2 (fake) ino is not constant, it is incremented each time
  62  SKIP: {
  63         skip('inode number is not constant on OS/2', 1)
  64             if $i == 1 && $^O eq 'os2';
  65         is($stat->$meth, $stat[$i], "$desc in position $i");
  66     }
  67     ++$i;
  68 }
  69
  70 for my $op (split //, "rwxoRWXOezsfdlpSbcugkMCA") {
  71     for my $access ('', 'use filetest "access";') {
  72         my ($warnings, $awarn, $vwarn, $rv);
  73         my $desc = $access
  74             ? "for -$op under use filetest 'access'" : "for -$op";
  75         {
  76             local $SIG{__WARN__} = sub {
  77                 my $w = shift;
  78                 if ($w =~ /^File::stat ignores VMS ACLs/) {
  79                     ++$vwarn;
  80                 } elsif ($w =~ /^File::stat ignores use filetest 'access'/) {
  81                     ++$awarn;
  82                 } else {
  83                     $warnings .= $w;
  84                 }
  85             };
  86             $rv = eval "$access; -$op \$stat";
  87         }
  88         is($@, '', "Overload succeeds $desc");
  89
  90         if ($^O eq "VMS" && $op =~ /[rwxRWX]/) {
  91             is($vwarn, 1, "warning about VMS ACLs $desc");
  92         } else {
  93             is($rv, eval "-$op \$file", "correct overload $desc")
  94                 unless $access;
  95             is($vwarn, undef, "no warnings about VMS ACLs $desc");
  96         }
  97
  98         # 111640 - File::stat bogus index check in overload
  99         if ($access && $op =~ /[rwxRXW]/) {
 100             # these should all warn with filetest access
 101             is($awarn, 1,
 102                "produced the right warning $desc");
 103         } else {
 104             # -d and others shouldn't warn
 105             is($awarn, undef, "should be no warning $desc")
 106         }
 107
 108         is($warnings, undef, "no other warnings seen $desc");
 109     }
 110 }
 111
 112 SKIP: {
 113     my $file = '../perl';
 114     -e $file && -x $file or skip "$file is not present and executable", 4;
 115     $^O eq "VMS" and skip "File::stat ignores VMS ACLs", 4;
 116
 117     my $stat = File::stat::stat( $file ); # This is the OO stat.
 118     foreach (qw/x X/) {
 119     my $rv = eval "-$_ \$stat";
 120     ok( !$@,                            "-$_ overload succeeds" )
 121       or diag( $@ );
 122     is( $rv, eval "-$_ \$file",         "correct -$_ overload" );
 123   }
 124 }
 125
 126
 127 for (split //, "tTB") {
 128     eval "-$_ \$stat";
 129     like( $@, qr/\Q-$_ is not implemented/, "-$_ overload fails" );
 130 }
 131
 132 SKIP: {
 133         local *STAT;
 134         skip("Could not open file: $!", 2) unless open(STAT, $file);
 135         ok( File::stat::stat('STAT'), '... should be able to find filehandle' );
 136
 137         package foo;
 138         local *STAT = *main::STAT;
 139         main::ok( my $stat2 = File::stat::stat('STAT'),
 140                 '... and filehandle in another package' );
 141         close STAT;
 142
 143 #       VOS open() updates atime; ignore this error (posix-975).
 144         my $stat3 = $stat2;
 145         if ($^O eq 'vos') {
 146                 $$stat3[8] = $$stat[8];
 147         }
 148
 149         main::skip("Win32: different stat-info on filehandle", 1) if $^O eq 'MSWin32';
 150         main::skip("dos: inode number is fake on dos", 1) if $^O eq 'dos';
 151
 152         main::skip("OS/2: inode number is not constant on os/2", 1) if $^O eq 'os2';
 153
 154         main::is( "@$stat", "@$stat3", '... and must match normal stat' );
 155 }
 156
 157 SKIP:
 158 {   # RT #111638
 159     skip "We can't check for FIFOs", 2 unless defined &Fcntl::S_ISFIFO;
 160     skip "No pipes", 2 unless defined $Config{d_pipe};
 161     pipe my ($rh, $wh)
 162       or skip "Couldn't create a pipe: $!", 2;
 163     skip "Built-in -p doesn't detect a pipe", 2 unless -p $rh;
 164
 165     my $pstat = File::stat::stat($rh);
 166     ok(!-p($stat), "-p should be false on a file");
 167     ok(-p($pstat), "check -p detects a pipe");
 168 }
 169
 170 local $!;
 171 $stat = stat '/notafile';
 172 isnt( $!, '', 'should populate $!, given invalid file' );
 173
 174 # Testing pretty much anything else is unportable.
 175
 176 done_testing;
 177
 178 # Local variables:
 179 # cperl-indent-level: 4
 180 # indent-tabs-mode: nil
 181 # End:
 182 #
 183 # ex: set ts=8 sts=4 sw=4 et: