File Coverage

blib/lib/File/stat/Extra.pm

Criterion	Covered	Total	%
statement	85	90	94.4
branch	17	26	65.3
condition			n/a
subroutine	31	31	100.0
pod	13	13	100.0
total	146	160	91.2

package File::stat::Extra;
use strict;
use warnings;
use warnings::register;

use 5.006;

# ABSTRACT: An extension of the File::stat module, provides additional methods.
our $VERSION = '0.007'; # VERSION

#pod =head1 SYNOPSIS
#pod
#pod =for test_synopsis
#pod my ($st, $file);
#pod
#pod   use File::stat::Extra;
#pod
#pod   $st = lstat($file) or die "No $file: $!";
#pod
#pod   if ($st->isLink) {
#pod       print "$file is a symbolic link";
#pod   }
#pod
#pod   if (-x $st) {
#pod       print "$file is executable";
#pod   }
#pod
#pod   use Fcntl 'S_IRUSR';
#pod   if ( $st->cando(S_IRUSR, 1) ) {
#pod       print "My effective uid can read $file";
#pod   }
#pod
#pod   if ($st == stat($file)) {
#pod       printf "%s and $file are the same", $st->file;
#pod   }
#pod
#pod =head1 DESCRIPTION
#pod
#pod This module's default exports override the core stat() and lstat()
#pod functions, replacing them with versions that return
#pod C objects when called in scalar context. In list
#pod context the same 13 item list is returned as with the original C
#pod and C functions.
#pod
#pod C is an extension of the L
#pod module.
#pod
#pod =for :list
#pod * Returns non-object result in list context.
#pod * You can now pass in bare file handles to C and C under C.
#pod * File tests C<-t> C<-T>, and C<-B> have been implemented too.
#pod * Convenience functions C and C for direct access to filetype and permission parts of the mode field.
#pod * Named access to common file tests (C / C, C, C, C, C, C / C, C).
#pod * Access to the name of the file / file handle used for the stat (C, C / C).
#pod
#pod =head1 SEE ALSO
#pod
#pod =for :list
#pod * L for the module for which C is the extension.
#pod * L and L for the original C and C functions.
#pod
#pod =head1 COMPATIBILITY
#pod
#pod As with L, you can no longer use the implicit C<$_> or the
#pod special filehandle C<_> with this module's versions of C and
#pod C.
#pod
#pod Currently C only provides an object interface, the
#pod L C<$st_*> variables and C funtion are not
#pod available. This may change in a future version of this module.
#pod
#pod =head1 WARNINGS
#pod
#pod When a file (handle) can not be (l)stat-ed, a warning C
#pod stat: %s>. To disable this warning, specify
#pod
#pod     no warnings "File::stat::Extra";
#pod
#pod The following warnings are inhereted from C, these can all
#pod be disabled with
#pod
#pod     no warnings "File::stat";
#pod
#pod =over 4
#pod
#pod =item File::stat ignores use filetest 'access'
#pod
#pod You have tried to use one of the C<-rwxRWX> filetests with C
#pod filetest 'access'> in effect. C will ignore the pragma, and
#pod just use the information in the C member as usual.
#pod
#pod =item File::stat ignores VMS ACLs
#pod
#pod VMS systems have a permissions structure that cannot be completely
#pod represented in a stat buffer, and unlike on other systems the builtin
#pod filetest operators respect this. The C overloads, however,
#pod do not, since the information required is not available.
#pod
#pod =back
#pod
#pod =cut

# Note: we are not defining File::stat::Extra as a subclass of File::stat
# as we need to add an additional field and can not rely on the fact that
# File::stat will always be implemented as an array (struct).

our @ISA = qw(Exporter);
our @EXPORT = qw(stat lstat);

use File::stat ();
use File::Spec ();
use Cwd ();
use Fcntl ();

require Carp;
$Carp::Internal{ (__PACKAGE__) }++; # To get warnings reported at correct caller level

#pod =func stat( I )
#pod
#pod =func stat( I )
#pod
#pod =func stat( I )
#pod
#pod =func lstat( I )
#pod
#pod =func lstat( I )
#pod
#pod =func lstat( I )
#pod
#pod When called in list context, these functions behave as the original
#pod C and C functions, returning the 13 element C list.
#pod When called in scalar context, a C object is
#pod returned with the methods as outlined below.
#pod
#pod =cut

# Runs stat or lstat on "file"
sub __stat_lstat {
    my $func = shift;
    my $file = shift;

    return $func eq 'lstat' ? CORE::lstat($file) : CORE::stat($file);
}

# Wrapper around stat/lstat, handles passing of file as a bare handle too
sub _stat_lstat {
    my $func = shift;
    my $file = shift;

    my @stat = __stat_lstat($func, $file);

    if (@stat) {
        # We have a file, so make it absolute (NOT resolving the symlinks)
        $file = File::Spec->rel2abs($file) if !ref $file;
    } else {
        # Try again, interpretting $file as handle
        no strict 'refs'; ## no critic (TestingAndDebugging::ProhibitNoStrict)
        local $! = undef;
        require Symbol;
        my $fh = \*{ Symbol::qualify($file, caller(1)) };
        if (defined fileno $fh) {
            @stat = __stat_lstat($func, $fh);
        }
        if (!@stat) {
            warnings::warnif("Unable to stat: $file");
            return;
        }
        # We have a (valid) file handle, so we make file point to it
        $file = $fh;
    }

    if (wantarray) {
        return @stat;
    } else {
        return bless [ File::stat::populate(@stat), $file ], 'File::stat::Extra';
    }
}

sub stat(*) { ## no critic (Subroutines::ProhibitSubroutinePrototypes)
    return _stat_lstat('stat', shift);
}

sub lstat(*) { ## no critic (Subroutines::ProhibitSubroutinePrototypes)
    return _stat_lstat('lstat', shift);
}

#pod =method dev
#pod
#pod =method ino
#pod
#pod =method mode
#pod
#pod =method nlink
#pod
#pod =method uid
#pod
#pod =method gid
#pod
#pod =method rdev
#pod
#pod =method size
#pod
#pod =method atime
#pod
#pod =method mtime
#pod
#pod =method ctime
#pod
#pod =method blksize
#pod
#pod =method blocks
#pod
#pod These methods provide named acced to the same fields in the original
#pod C result. Just like the original L.
#pod
#pod =method cando( I, I )
#pod
#pod Interprets the C, C and C fields, and returns whether
#pod or not the current process would be allowed the specified access.
#pod
#pod I is one of C, C or C from the
#pod L module, and I indicates whether to use
#pod effective (true) or real (false) ids.
#pod
#pod =cut

BEGIN {
    no strict 'refs'; ## no critic (TestingAndDebugging::ProhibitNoStrict)

    # Define the main field accessors and the cando method using the File::stat version
    for my $f (qw(dev ino mode nlink uid gid rdev size atime mtime ctime blksize blocks cando)) {
        *{$f} = sub { $_[0][0]->$f; }
    }

#pod =for Pod::Coverage S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISLNK S_ISREG S_ISSOCK
#pod
#pod =cut

    # Create own versions of these functions as they will croak on use
    # if the platform doesn't define them. It's important to avoid
    # inflicting that on the user.
    # Note: to stay (more) version independent, we do not rely on the
    # implementation in File::stat, but rather recreate here.
    for (qw(BLK CHR DIR LNK REG SOCK)) {
        *{"S_IS$_"} = defined eval { &{"Fcntl::S_IF$_"} } ? \&{"Fcntl::S_IS$_"} : sub { '' };
    }
    # FIFO flag and macro don't quite follow the S_IF/S_IS pattern above
    *{'S_ISFIFO'} = defined &Fcntl::S_IFIFO ? \&Fcntl::S_ISFIFO : sub { '' };
}

#pod =method file
#pod
#pod Returns the full path to the original file (or the filehandle) on which
#pod C or C was called.
#pod
#pod Note: Symlinks are not resolved. And, like C, neither are
#pod C constructs. Use the C / C methods to
#pod resolve these too.
#pod
#pod =cut

sub file {
    return $_[0][1];
}

#pod =method abs_file
#pod
#pod =method target
#pod
#pod Returns the absolute path of the file. In case of a file handle, this is returned unaltered.
#pod
#pod =cut

sub abs_file {
    return ref $_[0]->file ? $_[0]->file : Cwd::abs_path($_[0]->file);
}

*target = *abs_file;

#pod =method permissions
#pod
#pod Returns just the permissions (including setuid/setgid/sticky bits) of the C stat field.
#pod
#pod =cut

sub permissions {
    return Fcntl::S_IMODE($_[0]->mode);
}

#pod =method filetype
#pod
#pod Returns just the filetype of the C stat field.
#pod
#pod =cut

sub filetype {
    return Fcntl::S_IFMT($_[0]->mode);
}

#pod =method isFile
#pod
#pod =method isRegular
#pod
#pod Returns true if the file is a regular file (same as -f file test).
#pod
#pod =cut

sub isFile {
    return S_ISREG($_[0]->mode);
}

*isRegular = *isFile;

#pod =method isDir
#pod
#pod Returns true if the file is a directory (same as -d file test).
#pod
#pod =cut

sub isDir {
    return S_ISDIR($_[0]->mode);
}

#pod =method isLink
#pod
#pod Returns true if the file is a symbolic link (same as -l file test).
#pod
#pod Note: Only relevant when C was used!
#pod
#pod =cut

sub isLink {
    return S_ISLNK($_[0]->mode);
}

#pod =method isBlock
#pod
#pod Returns true if the file is a block special file (same as -b file test).
#pod
#pod =cut

sub isBlock {
    return S_ISBLK($_[0]->mode);
}

#pod =method isChar
#pod
#pod Returns true if the file is a character special file (same as -c file test).
#pod
#pod =cut

sub isChar {
    return S_ISCHR($_[0]->mode);
}

#pod =method isFIFO
#pod
#pod =method isPipe
#pod
#pod Returns true if the file is a FIFO file or, in case of a file handle, a pipe  (same as -p file test).
#pod
#pod =cut

sub isFIFO {
    return S_ISFIFO($_[0]->mode);
}

*isPipe = *isFIFO;

#pod =method isSocket
#pod
#pod Returns true if the file is a socket file (same as -S file test).
#pod
#pod =cut

sub isSocket {
    return S_ISSOCK($_[0]->mode);
}

#pod =method -X operator
#pod
#pod You can use the file test operators on the C object
#pod just as you would on a file (handle). However, instead of querying the
#pod file system, these operators will use the information from the
#pod object itself.
#pod
#pod The overloaded filetests are only supported from Perl version 5.12 and
#pod higer. The named access to these tests can still be used though.
#pod
#pod Note: in case of the special file tests C<-t>, C<-T>, and C<-B>, the
#pod file (handle) I tested the I time the operator is
#pod used. After the first time, the initial result is re-used and no
#pod further testing of the file (handle) is performed.
#pod
#pod =method Unary C<""> (stringification) operator
#pod
#pod The unary C<""> (stringification) operator is overloaded to return the the device and inode
#pod numbers separated by a C<.> (C.I>). This yields a uniqe file identifier (as string).
#pod
#pod =method Comparison operators C<< <=> >>, C, and C<~~>
#pod
#pod The comparison operators use the string representation of the
#pod C object. So, to see if two C
#pod object point to the same (hardlinked) file, you can simply say
#pod something like this:
#pod
#pod     print 'Same file' if $obj1 == $obj2;
#pod
#pod For objects created from an C of a symbolic link, the actual
#pod I of the link is used in the comparison! If you want to
#pod compare the actual symlink file, use C instead.
#pod
#pod Note: All comparisons (also the numeric versions) are performed on the
#pod full stringified versions of the object. This to prevent files on the
#pod same device, but with an inode number ending in a zero to compare
#pod equally while they aren't (e.g., 5.10 and 5.100 compare equal
#pod numerically but denote a different file).
#pod
#pod Note: the smartmatch C<~~> operator is only overloaded on Perl version
#pod 5.10 and above.
#pod
#pod =method Other operators
#pod
#pod As the other operators (C<+>, C<->, C<*>, etc.) are meaningless, they
#pod have not been overloaded and will cause a run-time error.
#pod
#pod =cut

my %op = (
    # Use the named version of these tests
    f => sub { $_[0]->isRegular },
    d => sub { $_[0]->isDir },
    l => sub { $_[0]->isLink },
    p => sub { $_[0]->isFIFO },
    S => sub { $_[0]->isSocket },
    b => sub { $_[0]->isBlock },
    c => sub { $_[0]->isChar },

    # Defer implementation of rest to File::stat
    r => sub { -r $_[0][0] },
    w => sub { -w $_[0][0] },
    x => sub { -x $_[0][0] },
    o => sub { -o $_[0][0] },

    R => sub { -R $_[0][0] },
    W => sub { -W $_[0][0] },
    X => sub { -X $_[0][0] },
    O => sub { -O $_[0][0] },

    e => sub { -e $_[0][0] },
    z => sub { -z $_[0][0] },
    s => sub { -s $_[0][0] },

    u => sub { -u $_[0][0] },
    g => sub { -g $_[0][0] },
    k => sub { -k $_[0][0] },

    M => sub { -M $_[0][0] },
    C => sub { -C $_[0][0] },
    A => sub { -A $_[0][0] },

    # Implement these operators by testing the underlying file, caching the result
    t => sub { defined $_[0][2] ? $_[0][2] : $_[0][2] = (-t $_[0]->file) || 0 }, ## no critic (InputOutput::ProhibitInteractiveTest)
    T => sub { defined $_[0][3] ? $_[0][3] : $_[0][3] = (-T $_[0]->file) || 0 },
    B => sub { defined $_[0][4] ? $_[0][4] : $_[0][4] = (-B $_[0]->file) || 0 },
);

sub _filetest {
    my ($s, $op) = @_;
    if ($op{$op}) {
        return $op{$op}->($s);
    } else {
        # We should have everything covered so this is just a safegauard
        Carp::croak "-$op is not implemented on a File::stat::Extra object";
    }
}

sub _dev_ino {
    return $_[0]->dev . "." . $_[0]->ino;
}

sub _compare {
    my $va = shift;
    my $vb = shift;
    my $swapped = shift;
    ($vb, $va) = ($va, $vb) if $swapped;

    return "$va" cmp "$vb"; # Force stringification when comparing
}

use overload
    # File test operators (as of Perl v5.12)
    $^V >= 5.012 ? (-X => \&_filetest) : (),

    # Unary "" returns the object as "dev.ino", this should be a
    # unique string for each file.
    '""' => \&_dev_ino,

    # Comparison is done based on the unique string created with the stringification
    '<=>' => \&_compare,
    'cmp' => \&_compare,

    # Smartmatch as of Perl v5.10
    $^V >= 5.010 ? ('~~' => \&_compare) : (),

    ;

1;

__END__