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