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