1package File::stat; 2use 5.006; 3 4use strict; 5use warnings; 6use warnings::register; 7use Carp; 8use constant _IS_CYGWIN => $^O eq "cygwin"; 9 10BEGIN { *warnif = \&warnings::warnif } 11 12our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); 13 14our $VERSION = '1.13'; 15 16our @fields; 17our ( $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 24BEGIN { 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 37use Fcntl qw(S_IRUSR S_IWUSR S_IXUSR); 38 39BEGIN { 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 58sub _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 86if (grep $^O eq $_, qw/os2 MSWin32/) { 87 88 # from doio.c 89 *cando = sub { ($_[0][2] & $_[1]) ? 1 : "" }; 90} 91else { 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 129my %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 161use constant HINT_FILETEST_ACCESS => 0x00400000; 162 163# we need fallback=>1 or stringifying breaks 164use 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 189sub import { goto &Exporter::import } 190 191use Class::Struct qw(struct); 192struct 'File::stat' => [ 193 map { $_ => '$' } qw{ 194 dev ino mode nlink uid gid rdev size 195 atime mtime ctime blksize blocks 196 } 197]; 198 199sub 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 209sub lstat ($) { populate(CORE::lstat(shift)) } 210 211sub 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 2261; 227__END__ 228 229=head1 NAME 230 231File::stat - by-name interface to Perl's built-in stat() functions 232 233=head1 SYNOPSIS 234 235 use File::stat; 236 my $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 258This module's default exports override the core stat() 259and lstat() functions, replacing them with versions that return 260"File::stat" objects. This object has methods that 261return the similarly named structure field name from the 262stat(2) function; namely, 263dev, 264ino, 265mode, 266nlink, 267uid, 268gid, 269rdev, 270size, 271atime, 272mtime, 273ctime, 274blksize, 275and 276blocks. 277 278As of version 1.02 (provided with perl 5.12) the object provides C<"-X"> 279overloading, so you can call filetest operators (C<-f>, C<-x>, and so 280on) on it. It also provides a C<< ->cando >> method, called like 281 282 $st->cando( ACCESS, EFFECTIVE ) 283 284where I<ACCESS> is one of C<S_IRUSR>, C<S_IWUSR> or C<S_IXUSR> from the 285L<Fcntl|Fcntl> module, and I<EFFECTIVE> indicates whether to use 286effective (true) or real (false) ids. The method interprets the C<mode>, 287C<uid> and C<gid> fields, and returns whether or not the current process 288would be allowed the specified access. 289 290If you don't want to use the objects, you may import the C<< ->cando >> 291method into your namespace as a regular function called C<stat_cando>. 292This takes an arrayref containing the return values of C<stat> or 293C<lstat> as its first argument, and interprets it for you. 294 295You may also import all the structure fields directly into your namespace 296as regular variables using the :FIELDS import tag. (Note that this still 297overrides your stat() and lstat() functions.) Access these fields as 298variables named with a preceding C<st_> in front their method names. 299Thus, C<$stat_obj-E<gt>dev()> corresponds to $st_dev if you import 300the fields. 301 302To access this functionality without the core overrides, 303pass the C<use> an empty import list, and then access 304function functions with their full qualified names. 305On the other hand, the built-ins are still available 306via the C<CORE::> pseudo-package. 307 308=head1 BUGS 309 310As of Perl 5.8.0 after using this module you cannot use the implicit 311C<$_> or the special filehandle C<_> with stat() or lstat(), trying 312to do so leads into strange errors. The workaround is for C<$_> to 313be explicit 314 315 my $stat_obj = stat $_; 316 317and for C<_> to explicitly populate the object using the unexported 318and 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 328The filetest operators C<-t>, C<-T> and C<-B> are not implemented, as 329they require more information than just a stat buffer. 330 331=back 332 333=head1 WARNINGS 334 335These 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 343You have tried to use one of the C<-rwxRWX> filetests with C<use 344filetest 'access'> in effect. C<File::stat> will ignore the pragma, and 345just use the information in the C<mode> member as usual. 346 347=item File::stat ignores VMS ACLs 348 349VMS systems have a permissions structure that cannot be completely 350represented in a stat buffer, and unlike on other systems the builtin 351filetest operators respect this. The C<File::stat> overloads, however, 352do not, since the information required is not available. 353 354=back 355 356=head1 NOTE 357 358While this class is currently implemented using the Class::Struct 359module to build a struct-like class, you shouldn't rely upon this. 360 361=head1 AUTHOR 362 363Tom Christiansen 364