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