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