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