<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">package File::stat;
use 5.006;

use strict;
use warnings;
use warnings::register;
use Carp;
use constant _IS_CYGWIN =&gt; $^O eq "cygwin";

BEGIN { *warnif = \&amp;warnings::warnif }

our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);

our $VERSION = '1.09';

our @fields;
our ( $st_dev, $st_ino, $st_mode,
    $st_nlink, $st_uid, $st_gid,
    $st_rdev, $st_size,
    $st_atime, $st_mtime, $st_ctime,
    $st_blksize, $st_blocks
);

BEGIN { 
    use Exporter   ();
    @EXPORT      = qw(stat lstat);
    @fields      = qw( $st_dev	   $st_ino    $st_mode 
		       $st_nlink   $st_uid    $st_gid 
		       $st_rdev    $st_size 
		       $st_atime   $st_mtime  $st_ctime 
		       $st_blksize $st_blocks
		    );
    @EXPORT_OK   = ( @fields, "stat_cando" );
    %EXPORT_TAGS = ( FIELDS =&gt; [ @fields, @EXPORT ] );
}

use Fcntl qw(S_IRUSR S_IWUSR S_IXUSR);

BEGIN {
    # These constants will croak on use if the platform doesn't define
    # them. It's important to avoid inflicting that on the user.
    no strict 'refs';
    for (qw(suid sgid svtx)) {
        my $val = eval { &amp;{"Fcntl::S_I\U$_"} };
        *{"_$_"} = defined $val ? sub { $_[0] &amp; $val ? 1 : "" } : sub { "" };
    }
    for (qw(SOCK CHR BLK REG DIR LNK)) {
        *{"S_IS$_"} = defined eval { &amp;{"Fcntl::S_IF$_"} }
            ? \&amp;{"Fcntl::S_IS$_"} : sub { "" };
    }
    # FIFO flag and macro don't quite follow the S_IF/S_IS pattern above
    # RT #111638
    *{"S_ISFIFO"} = defined &amp;Fcntl::S_IFIFO
      ? \&amp;Fcntl::S_ISFIFO : sub { "" };
}

# from doio.c
sub _ingroup {
    my ($gid, $eff)   = @_;

    # I am assuming that since VMS doesn't have getgroups(2), $) will
    # always only contain a single entry.
    $^O eq "VMS"    and return $_[0] == $);

    my ($egid, @supp) = split " ", $);
    my ($rgid)        = split " ", $(;

    $gid == ($eff ? $egid : $rgid)  and return 1;
    grep $gid == $_, @supp          and return 1;

    return "";
}

# VMS uses the Unix version of the routine, even though this is very
# suboptimal. VMS has a permissions structure that doesn't really fit
# into struct stat, and unlike on Win32 the normal -X operators respect
# that, but unfortunately by the time we get here we've already lost the
# information we need. It looks to me as though if we were to preserve
# the st_devnam entry of vmsish.h's fake struct stat (which actually
# holds the filename) it might be possible to do this right, but both
# getting that value out of the struct (perl's stat doesn't return it)
# and interpreting it later would require this module to have an XS
# component (at which point we might as well just call Perl_cando and
# have done with it).
    
if (grep $^O eq $_, qw/os2 MSWin32 dos/) {

    # from doio.c
    *cando = sub { ($_[0][2] &amp; $_[1]) ? 1 : "" };
}
else {

    # from doio.c
    *cando = sub {
        my ($s, $mode, $eff) = @_;
        my $uid = $eff ? $&gt; : $&lt;;
        my ($stmode, $stuid, $stgid) = @$s[2,4,5];

        # This code basically assumes that the rwx bits of the mode are
        # the 0777 bits, but so does Perl_cando.

        if (_IS_CYGWIN ? _ingroup(544, $eff) : ($uid == 0 &amp;&amp; $^O ne "VMS")) {
            # If we're root on unix
            # not testing for executable status =&gt; all file tests are true
            return 1 if !($mode &amp; 0111);
            # testing for executable status =&gt;
            # for a file, any x bit will do
            # for a directory, always true
            return 1 if $stmode &amp; 0111 || S_ISDIR($stmode);
            return "";
        }

        if ($stuid == $uid) {
            $stmode &amp; $mode         and return 1;
        }
        elsif (_ingroup($stgid, $eff)) {
            $stmode &amp; ($mode &gt;&gt; 3)  and return 1;
        }
        else {
            $stmode &amp; ($mode &gt;&gt; 6)  and return 1;
        }
        return "";
    };
}

# alias for those who don't like objects
*stat_cando = \&amp;cando;

my %op = (
    r =&gt; sub { cando($_[0], S_IRUSR, 1) },
    w =&gt; sub { cando($_[0], S_IWUSR, 1) },
    x =&gt; sub { cando($_[0], S_IXUSR, 1) },
    o =&gt; sub { $_[0][4] == $&gt;           },

    R =&gt; sub { cando($_[0], S_IRUSR, 0) },
    W =&gt; sub { cando($_[0], S_IWUSR, 0) },
    X =&gt; sub { cando($_[0], S_IXUSR, 0) },
    O =&gt; sub { $_[0][4] == $&lt;           },

    e =&gt; sub { 1 },
    z =&gt; sub { $_[0][7] == 0    },
    s =&gt; sub { $_[0][7]         },

    f =&gt; sub { S_ISREG ($_[0][2]) },
    d =&gt; sub { S_ISDIR ($_[0][2]) },
    l =&gt; sub { S_ISLNK ($_[0][2]) },
    p =&gt; sub { S_ISFIFO($_[0][2]) },
    S =&gt; sub { S_ISSOCK($_[0][2]) },
    b =&gt; sub { S_ISBLK ($_[0][2]) },
    c =&gt; sub { S_ISCHR ($_[0][2]) },

    u =&gt; sub { _suid($_[0][2]) },
    g =&gt; sub { _sgid($_[0][2]) },
    k =&gt; sub { _svtx($_[0][2]) },

    M =&gt; sub { ($^T - $_[0][9] ) / 86400 },
    C =&gt; sub { ($^T - $_[0][10]) / 86400 },
    A =&gt; sub { ($^T - $_[0][8] ) / 86400 },
);

use constant HINT_FILETEST_ACCESS =&gt; 0x00400000;

# we need fallback=&gt;1 or stringifying breaks
use overload 
    fallback =&gt; 1,
    -X =&gt; sub {
        my ($s, $op) = @_;

        if (index("rwxRWX", $op) &gt;= 0) {
            (caller 0)[8] &amp; HINT_FILETEST_ACCESS
                and warnif("File::stat ignores use filetest 'access'");

            $^O eq "VMS" and warnif("File::stat ignores VMS ACLs");

            # It would be nice to have a warning about using -l on a
            # non-lstat, but that would require an extra member in the
            # object.
        }

        if ($op{$op}) {
            return $op{$op}-&gt;($_[0]);
        }
        else {
            croak "-$op is not implemented on a File::stat object";
        }
    };

# Class::Struct forbids use of @ISA
sub import { goto &amp;Exporter::import }

use Class::Struct qw(struct);
struct 'File::stat' =&gt; [
     map { $_ =&gt; '$' } qw{
	 dev ino mode nlink uid gid rdev size
	 atime mtime ctime blksize blocks
     }
];

sub populate (@) {
    return unless @_;
    my $stob = new();
    @$stob = (
	$st_dev, $st_ino, $st_mode, $st_nlink, $st_uid, $st_gid, $st_rdev,
        $st_size, $st_atime, $st_mtime, $st_ctime, $st_blksize, $st_blocks ) 
	    = @_;
    return $stob;
} 

sub lstat ($)  { populate(CORE::lstat(shift)) }

sub stat ($) {
    my $arg = shift;
    my $st = populate(CORE::stat $arg);
    return $st if defined $st;
	my $fh;
    {
		local $!;
		no strict 'refs';
		require Symbol;
		$fh = \*{ Symbol::qualify( $arg, caller() )};
		return unless defined fileno $fh;
	}
    return populate(CORE::stat $fh);
}

1;
__END__

=head1 NAME

File::stat - by-name interface to Perl's built-in stat() functions

=head1 SYNOPSIS

 use File::stat;
 $st = stat($file) or die "No $file: $!";
 if ( ($st-&gt;mode &amp; 0111) &amp;&amp; $st-&gt;nlink &gt; 1) ) {
     print "$file is executable with lotsa links\n";
 } 

 if ( -x $st ) {
     print "$file is executable\n";
 }

 use Fcntl "S_IRUSR";
 if ( $st-&gt;cando(S_IRUSR, 1) ) {
     print "My effective uid can read $file\n";
 }

 use File::stat qw(:FIELDS);
 stat($file) or die "No $file: $!";
 if ( ($st_mode &amp; 0111) &amp;&amp; ($st_nlink &gt; 1) ) {
     print "$file is executable with lotsa links\n";
 } 

=head1 DESCRIPTION

This module's default exports override the core stat() 
and lstat() functions, replacing them with versions that return 
"File::stat" objects.  This object has methods that
return the similarly named structure field name from the
stat(2) function; namely,
dev,
ino,
mode,
nlink,
uid,
gid,
rdev,
size,
atime,
mtime,
ctime,
blksize,
and
blocks.  

As of version 1.02 (provided with perl 5.12) the object provides C&lt;"-X"&gt;
overloading, so you can call filetest operators (C&lt;-f&gt;, C&lt;-x&gt;, and so
on) on it. It also provides a C&lt;&lt; -&gt;cando &gt;&gt; method, called like

 $st-&gt;cando( ACCESS, EFFECTIVE )

where I&lt;ACCESS&gt; is one of C&lt;S_IRUSR&gt;, C&lt;S_IWUSR&gt; or C&lt;S_IXUSR&gt; from the
L&lt;Fcntl|Fcntl&gt; module, and I&lt;EFFECTIVE&gt; indicates whether to use
effective (true) or real (false) ids. The method interprets the C&lt;mode&gt;,
C&lt;uid&gt; and C&lt;gid&gt; fields, and returns whether or not the current process
would be allowed the specified access.

If you don't want to use the objects, you may import the C&lt;&lt; -&gt;cando &gt;&gt;
method into your namespace as a regular function called C&lt;stat_cando&gt;.
This takes an arrayref containing the return values of C&lt;stat&gt; or
C&lt;lstat&gt; as its first argument, and interprets it for you.

You may also import all the structure fields directly into your namespace
as regular variables using the :FIELDS import tag.  (Note that this still
overrides your stat() and lstat() functions.)  Access these fields as
variables named with a preceding C&lt;st_&gt; in front their method names.
Thus, C&lt;$stat_obj-E&lt;gt&gt;dev()&gt; corresponds to $st_dev if you import
the fields.

To access this functionality without the core overrides,
pass the C&lt;use&gt; an empty import list, and then access
function functions with their full qualified names.
On the other hand, the built-ins are still available
via the C&lt;CORE::&gt; pseudo-package.

=head1 BUGS

As of Perl 5.8.0 after using this module you cannot use the implicit
C&lt;$_&gt; or the special filehandle C&lt;_&gt; with stat() or lstat(), trying
to do so leads into strange errors.  The workaround is for C&lt;$_&gt; to
be explicit

    my $stat_obj = stat $_;

and for C&lt;_&gt; to explicitly populate the object using the unexported
and undocumented populate() function with CORE::stat():

    my $stat_obj = File::stat::populate(CORE::stat(_));

=head1 ERRORS

=over 4

=item -%s is not implemented on a File::stat object

The filetest operators C&lt;-t&gt;, C&lt;-T&gt; and C&lt;-B&gt; are not implemented, as
they require more information than just a stat buffer.

=back

=head1 WARNINGS

These can all be disabled with

    no warnings "File::stat";

=over 4

=item File::stat ignores use filetest 'access'

You have tried to use one of the C&lt;-rwxRWX&gt; filetests with C&lt;use
filetest 'access'&gt; in effect. C&lt;File::stat&gt; will ignore the pragma, and
just use the information in the C&lt;mode&gt; member as usual.

=item File::stat ignores VMS ACLs

VMS systems have a permissions structure that cannot be completely
represented in a stat buffer, and unlike on other systems the builtin
filetest operators respect this. The C&lt;File::stat&gt; overloads, however,
do not, since the information required is not available.

=back

=head1 NOTE

While this class is currently implemented using the Class::Struct
module to build a struct-like class, you shouldn't rely upon this.

=head1 AUTHOR

Tom Christiansen
</pre></body></html>