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