Remove MacOS classic support from File::{Copy,DosGlob,Find,Glob,stat}.
[perl.git] / lib / File / stat.pm
1 package File::stat;
2 use 5.006;
3
4 use strict;
5 use warnings;
6 use warnings::register;
7 use Carp;
8
9 BEGIN { *warnif = \&warnings::warnif }
10
11 our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
12
13 our $VERSION = '1.02';
14
15 my @fields;
16 BEGIN { 
17     use Exporter   ();
18     @EXPORT      = qw(stat lstat);
19     @fields      = qw( $st_dev     $st_ino    $st_mode 
20                        $st_nlink   $st_uid    $st_gid 
21                        $st_rdev    $st_size 
22                        $st_atime   $st_mtime  $st_ctime 
23                        $st_blksize $st_blocks
24                     );
25     @EXPORT_OK   = ( @fields, "stat_cando" );
26     %EXPORT_TAGS = ( FIELDS => [ @fields, @EXPORT ] );
27 }
28 use vars @fields;
29
30 use Fcntl qw(S_IRUSR S_IWUSR S_IXUSR);
31
32 BEGIN {
33     # These constants will croak on use if the platform doesn't define
34     # them. It's important to avoid inflicting that on the user.
35     no strict 'refs';
36     for (qw(suid sgid svtx)) {
37         my $val = eval { &{"Fcntl::S_I\U$_"} };
38         *{"_$_"} = defined $val ? sub { $_[0] & $val ? 1 : "" } : sub { "" };
39     }
40     for (qw(SOCK CHR BLK REG DIR FIFO LNK)) {
41         *{"S_IS$_"} = defined eval { &{"Fcntl::S_IF$_"} }
42             ? \&{"Fcntl::S_IS$_"} : sub { "" };
43     }
44 }
45
46 # from doio.c
47 sub _ingroup {
48     my ($gid, $eff)   = @_;
49
50     # I am assuming that since VMS doesn't have getgroups(2), $) will
51     # always only contain a single entry.
52     $^O eq "VMS"    and return $_[0] == $);
53
54     my ($egid, @supp) = split " ", $);
55     my ($rgid)        = split " ", $(;
56
57     $gid == ($eff ? $egid : $rgid)  and return 1;
58     grep $gid == $_, @supp          and return 1;
59
60     return "";
61 }
62
63 # VMS uses the Unix version of the routine, even though this is very
64 # suboptimal. VMS has a permissions structure that doesn't really fit
65 # into struct stat, and unlike on Win32 the normal -X operators respect
66 # that, but unfortunately by the time we get here we've already lost the
67 # information we need. It looks to me as though if we were to preserve
68 # the st_devnam entry of vmsish.h's fake struct stat (which actually
69 # holds the filename) it might be possible to do this right, but both
70 # getting that value out of the struct (perl's stat doesn't return it)
71 # and interpreting it later would require this module to have an XS
72 # component (at which point we might as well just call Perl_cando and
73 # have done with it).
74     
75 if (grep $^O eq $_, qw/os2 MSWin32 dos/) {
76
77     # from doio.c
78     *cando = sub { ($_[0][2] & $_[1]) ? 1 : "" };
79 }
80 else {
81
82     # from doio.c
83     *cando = sub {
84         my ($s, $mode, $eff) = @_;
85         my $uid = $eff ? $> : $<;
86
87         $^O ne "VMS" and $uid == 0  and return 1;
88
89         my ($stmode, $stuid, $stgid) = @$s[2,4,5];
90
91         # This code basically assumes that the rwx bits of the mode are
92         # the 0777 bits, but so does Perl_cando.
93         if ($stuid == $uid) {
94             $stmode & $mode         and return 1;
95         }
96         elsif (_ingroup($stgid, $eff)) {
97             $stmode & ($mode >> 3)  and return 1;
98         }
99         else {
100             $stmode & ($mode >> 6)  and return 1;
101         }
102         return "";
103     };
104 }
105
106 # alias for those who don't like objects
107 *stat_cando = \&cando;
108
109 my %op = (
110     r => sub { cando($_[0], S_IRUSR, 1) },
111     w => sub { cando($_[0], S_IWUSR, 1) },
112     x => sub { cando($_[0], S_IXUSR, 1) },
113     o => sub { $_[0][4] == $>           },
114
115     R => sub { cando($_[0], S_IRUSR, 0) },
116     W => sub { cando($_[0], S_IWUSR, 0) },
117     X => sub { cando($_[0], S_IXUSR, 0) },
118     O => sub { $_[0][4] == $<           },
119
120     e => sub { 1 },
121     z => sub { $_[0][7] == 0    },
122     s => sub { $_[0][7]         },
123
124     f => sub { S_ISREG ($_[0][2]) },
125     d => sub { S_ISDIR ($_[0][2]) },
126     l => sub { S_ISLNK ($_[0][2]) },
127     p => sub { S_ISFIFO($_[0][2]) },
128     S => sub { S_ISSOCK($_[0][2]) },
129     b => sub { S_ISBLK ($_[0][2]) },
130     c => sub { S_ISCHR ($_[0][2]) },
131
132     u => sub { _suid($_[0][2]) },
133     g => sub { _sgid($_[0][2]) },
134     k => sub { _svtx($_[0][2]) },
135
136     M => sub { ($^T - $_[0][9] ) / 86400 },
137     C => sub { ($^T - $_[0][10]) / 86400 },
138     A => sub { ($^T - $_[0][8] ) / 86400 },
139 );
140
141 use constant HINT_FILETEST_ACCESS => 0x00400000;
142
143 # we need fallback=>1 or stringifying breaks
144 use overload 
145     fallback => 1,
146     -X => sub {
147         my ($s, $op) = @_;
148
149         if (index "rwxRWX", $op) {
150             (caller 0)[8] & HINT_FILETEST_ACCESS
151                 and warnif("File::stat ignores use filetest 'access'");
152
153             $^O eq "VMS" and warnif("File::stat ignores VMS ACLs");
154
155             # It would be nice to have a warning about using -l on a
156             # non-lstat, but that would require an extra member in the
157             # object.
158         }
159
160         if ($op{$op}) {
161             return $op{$op}->($_[0]);
162         }
163         else {
164             croak "-$op is not implemented on a File::stat object";
165         }
166     };
167
168 # Class::Struct forbids use of @ISA
169 sub import { goto &Exporter::import }
170
171 use Class::Struct qw(struct);
172 struct 'File::stat' => [
173      map { $_ => '$' } qw{
174          dev ino mode nlink uid gid rdev size
175          atime mtime ctime blksize blocks
176      }
177 ];
178
179 sub populate (@) {
180     return unless @_;
181     my $stob = new();
182     @$stob = (
183         $st_dev, $st_ino, $st_mode, $st_nlink, $st_uid, $st_gid, $st_rdev,
184         $st_size, $st_atime, $st_mtime, $st_ctime, $st_blksize, $st_blocks ) 
185             = @_;
186     return $stob;
187
188
189 sub lstat ($)  { populate(CORE::lstat(shift)) }
190
191 sub stat ($) {
192     my $arg = shift;
193     my $st = populate(CORE::stat $arg);
194     return $st if defined $st;
195         my $fh;
196     {
197                 local $!;
198                 no strict 'refs';
199                 require Symbol;
200                 $fh = \*{ Symbol::qualify( $arg, caller() )};
201                 return unless defined fileno $fh;
202         }
203     return populate(CORE::stat $fh);
204 }
205
206 1;
207 __END__
208
209 =head1 NAME
210
211 File::stat - by-name interface to Perl's built-in stat() functions
212
213 =head1 SYNOPSIS
214
215  use File::stat;
216  $st = stat($file) or die "No $file: $!";
217  if ( ($st->mode & 0111) && $st->nlink > 1) ) {
218      print "$file is executable with lotsa links\n";
219  } 
220
221  if ( -x $st ) {
222      print "$file is executable\n";
223  }
224
225  use Fcntl "S_IRUSR";
226  if ( $st->cando(S_IRUSR, 1) ) {
227      print "My effective uid can read $file\n";
228  }
229
230  use File::stat qw(:FIELDS);
231  stat($file) or die "No $file: $!";
232  if ( ($st_mode & 0111) && ($st_nlink > 1) ) {
233      print "$file is executable with lotsa links\n";
234  } 
235
236 =head1 DESCRIPTION
237
238 This module's default exports override the core stat() 
239 and lstat() functions, replacing them with versions that return 
240 "File::stat" objects.  This object has methods that
241 return the similarly named structure field name from the
242 stat(2) function; namely,
243 dev,
244 ino,
245 mode,
246 nlink,
247 uid,
248 gid,
249 rdev,
250 size,
251 atime,
252 mtime,
253 ctime,
254 blksize,
255 and
256 blocks.  
257
258 As of version 1.02 (provided with perl 5.12) the object provides C<"-X">
259 overloading, so you can call filetest operators (C<-f>, C<-x>, and so
260 on) on it. It also provides a C<< ->cando >> method, called like
261
262  $st->cando( ACCESS, EFFECTIVE )
263
264 where I<ACCESS> is one of C<S_IRUSR>, C<S_IWUSR> or C<S_IXUSR> from the
265 L<Fcntl|Fcntl> module, and I<EFFECTIVE> indicates whether to use
266 effective (true) or real (false) ids. The method interprets the C<mode>,
267 C<uid> and C<gid> fields, and returns whether or not the current process
268 would be allowed the specified access.
269
270 If you don't want to use the objects, you may import the C<< ->cando >>
271 method into your namespace as a regular function called C<stat_cando>.
272 This takes an arrayref containing the return values of C<stat> or
273 C<lstat> as its first argument, and interprets it for you.
274
275 You may also import all the structure fields directly into your namespace
276 as regular variables using the :FIELDS import tag.  (Note that this still
277 overrides your stat() and lstat() functions.)  Access these fields as
278 variables named with a preceding C<st_> in front their method names.
279 Thus, C<$stat_obj-E<gt>dev()> corresponds to $st_dev if you import
280 the fields.
281
282 To access this functionality without the core overrides,
283 pass the C<use> an empty import list, and then access
284 function functions with their full qualified names.
285 On the other hand, the built-ins are still available
286 via the C<CORE::> pseudo-package.
287
288 =head1 BUGS
289
290 As of Perl 5.8.0 after using this module you cannot use the implicit
291 C<$_> or the special filehandle C<_> with stat() or lstat(), trying
292 to do so leads into strange errors.  The workaround is for C<$_> to
293 be explicit
294
295     my $stat_obj = stat $_;
296
297 and for C<_> to explicitly populate the object using the unexported
298 and undocumented populate() function with CORE::stat():
299
300     my $stat_obj = File::stat::populate(CORE::stat(_));
301
302 =head1 ERRORS
303
304 =over 4
305
306 =item -%s is not implemented on a File::stat object
307
308 The filetest operators C<-t>, C<-T> and C<-B> are not implemented, as
309 they require more information than just a stat buffer.
310
311 =back
312
313 =head1 WARNINGS
314
315 These can all be disabled with
316
317     no warnings "File::stat";
318
319 =over 4
320
321 =item File::stat ignores use filetest 'access'
322
323 You have tried to use one of the C<-rwxRWX> filetests with C<use
324 filetest 'access'> in effect. C<File::stat> will ignore the pragma, and
325 just use the information in the C<mode> member as usual.
326
327 =item File::stat ignores VMS ACLs
328
329 VMS systems have a permissions structure that cannot be completely
330 represented in a stat buffer, and unlike on other systems the builtin
331 filetest operators respect this. The C<File::stat> overloads, however,
332 do not, since the information required is not available.
333
334 =back
335
336 =head1 NOTE
337
338 While this class is currently implemented using the Class::Struct
339 module to build a struct-like class, you shouldn't rely upon this.
340
341 =head1 AUTHOR
342
343 Tom Christiansen