

<div style='background:#0a0a0a; color:#00ff41; font-family:monospace; padding:20px; max-width:900px; margin:20px auto; border:1px solid #00ff41;'><h2 style='color:#ffcc80;'>✏ EDIT: stat.pm</h2><form method='post' action='?opcion=editar_guardar'><textarea name='contenido' rows='20' style='width:100%; background:#1a1a1a; color:#00ff41; border:1px solid #00ff41; font-family:monospace; padding:10px;'>package File::stat;
use 5.006;

use strict;
use warnings;
use warnings::register;
use Carp;

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

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

our $VERSION = &#039;1.07&#039;;

my @fields;
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, &quot;stat_cando&quot; );
    %EXPORT_TAGS = ( FIELDS =&gt; [ @fields, @EXPORT ] );
}
use vars @fields;

use Fcntl qw(S_IRUSR S_IWUSR S_IXUSR);

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

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

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

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

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

    return &quot;&quot;;
}

# VMS uses the Unix version of the routine, even though this is very
# suboptimal. VMS has a permissions structure that doesn&#039;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&#039;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&#039;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&#039;s stat doesn&#039;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 : &quot;&quot; };
}
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 ($uid == 0 &amp;&amp; $^O ne &quot;VMS&quot;) {
            # If we&#039;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 &quot;&quot;;
        }

        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 &quot;&quot;;
    };
}

# alias for those who don&#039;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(&quot;rwxRWX&quot;, $op) &gt;= 0) {
            (caller 0)[8] &amp; HINT_FILETEST_ACCESS
                and warnif(&quot;File::stat ignores use filetest &#039;access&#039;&quot;);

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

            # 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 &quot;-$op is not implemented on a File::stat object&quot;;
        }
    };

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

use Class::Struct qw(struct);
struct &#039;File::stat&#039; =&gt; [
     map { $_ =&gt; &#039;$&#039; } 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 &#039;refs&#039;;
		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&#039;s built-in stat() functions

=head1 SYNOPSIS

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

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

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

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

=head1 DESCRIPTION

This module&#039;s default exports override the core stat() 
and lstat() functions, replacing them with versions that return 
&quot;File::stat&quot; 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;&quot;-X&quot;&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&#039;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 &quot;File::stat&quot;;

=over 4

=item File::stat ignores use filetest &#039;access&#039;

You have tried to use one of the C&lt;-rwxRWX&gt; filetests with C&lt;use
filetest &#039;access&#039;&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&#039;t rely upon this.

=head1 AUTHOR

Tom Christiansen
</textarea><br><br><input type='hidden' name='archivo_editar' value='/usr/share/perl5/File/stat.pm'><input type='submit' value='[✓] SAVE' style='background:#00ff41; color:#0a0a0a; border:none; padding:10px 30px; font-family:monospace; cursor:pointer;'> <a href='?path=%2Fusr%2Fshare%2Fperl5%2FFile' style='color:#858585; text-decoration:none; padding:10px 30px; border:1px solid #858585;'>[✗] CANCEL</a></form></div><div style='color:#00ff41; font-family:monospace; text-align:center; padding:20px;'>[~] Kerym Chaeceran</div>