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