| Server IP : 170.10.162.208 / Your IP : 216.73.216.181 Web Server : LiteSpeed System : Linux altar19.supremepanel19.com 4.18.0-553.69.1.lve.el8.x86_64 #1 SMP Wed Aug 13 19:53:59 UTC 2025 x86_64 User : deltahospital ( 1806) PHP Version : 7.4.33 Disable Function : NONE MySQL : OFF | cURL : ON | WGET : ON | Perl : ON | Python : ON | Sudo : OFF | Pkexec : OFF Directory : /home/deltahospital/test.delta-hospital.com/ |
Upload File : |
GlobMapper.pm 0000644 00000036476 15051130046 0007145 0 ustar 00 package File::GlobMapper;
use strict;
use warnings;
use Carp;
our ($CSH_GLOB);
BEGIN
{
if ($] < 5.006)
{
require File::BSDGlob; import File::BSDGlob qw(:glob) ;
$CSH_GLOB = File::BSDGlob::GLOB_CSH() ;
*globber = \&File::BSDGlob::csh_glob;
}
else
{
require File::Glob; import File::Glob qw(:glob) ;
$CSH_GLOB = File::Glob::GLOB_CSH() ;
#*globber = \&File::Glob::bsd_glob;
*globber = \&File::Glob::csh_glob;
}
}
our ($Error);
our ($VERSION, @EXPORT_OK);
$VERSION = '1.001';
@EXPORT_OK = qw( globmap );
our ($noPreBS, $metachars, $matchMetaRE, %mapping, %wildCount);
$noPreBS = '(?<!\\\)' ; # no preceding backslash
$metachars = '.*?[](){}';
$matchMetaRE = '[' . quotemeta($metachars) . ']';
%mapping = (
'*' => '([^/]*)',
'?' => '([^/])',
'.' => '\.',
'[' => '([',
'(' => '(',
')' => ')',
);
%wildCount = map { $_ => 1 } qw/ * ? . { ( [ /;
sub globmap ($$;)
{
my $inputGlob = shift ;
my $outputGlob = shift ;
my $obj = new File::GlobMapper($inputGlob, $outputGlob, @_)
or croak "globmap: $Error" ;
return $obj->getFileMap();
}
sub new
{
my $class = shift ;
my $inputGlob = shift ;
my $outputGlob = shift ;
# TODO -- flags needs to default to whatever File::Glob does
my $flags = shift || $CSH_GLOB ;
#my $flags = shift ;
$inputGlob =~ s/^\s*\<\s*//;
$inputGlob =~ s/\s*\>\s*$//;
$outputGlob =~ s/^\s*\<\s*//;
$outputGlob =~ s/\s*\>\s*$//;
my %object =
( InputGlob => $inputGlob,
OutputGlob => $outputGlob,
GlobFlags => $flags,
Braces => 0,
WildCount => 0,
Pairs => [],
Sigil => '#',
);
my $self = bless \%object, ref($class) || $class ;
$self->_parseInputGlob()
or return undef ;
$self->_parseOutputGlob()
or return undef ;
my @inputFiles = globber($self->{InputGlob}, $flags) ;
if (GLOB_ERROR)
{
$Error = $!;
return undef ;
}
#if (whatever)
{
my $missing = grep { ! -e $_ } @inputFiles ;
if ($missing)
{
$Error = "$missing input files do not exist";
return undef ;
}
}
$self->{InputFiles} = \@inputFiles ;
$self->_getFiles()
or return undef ;
return $self;
}
sub _retError
{
my $string = shift ;
$Error = "$string in input fileglob" ;
return undef ;
}
sub _unmatched
{
my $delimeter = shift ;
_retError("Unmatched $delimeter");
return undef ;
}
sub _parseBit
{
my $self = shift ;
my $string = shift ;
my $out = '';
my $depth = 0 ;
while ($string =~ s/(.*?)$noPreBS(,|$matchMetaRE)//)
{
$out .= quotemeta($1) ;
$out .= $mapping{$2} if defined $mapping{$2};
++ $self->{WildCount} if $wildCount{$2} ;
if ($2 eq ',')
{
return _unmatched("(")
if $depth ;
$out .= '|';
}
elsif ($2 eq '(')
{
++ $depth ;
}
elsif ($2 eq ')')
{
return _unmatched(")")
if ! $depth ;
-- $depth ;
}
elsif ($2 eq '[')
{
# TODO -- quotemeta & check no '/'
# TODO -- check for \] & other \ within the []
$string =~ s#(.*?\])##
or return _unmatched("[");
$out .= "$1)" ;
}
elsif ($2 eq ']')
{
return _unmatched("]");
}
elsif ($2 eq '{' || $2 eq '}')
{
return _retError("Nested {} not allowed");
}
}
$out .= quotemeta $string;
return _unmatched("(")
if $depth ;
return $out ;
}
sub _parseInputGlob
{
my $self = shift ;
my $string = $self->{InputGlob} ;
my $inGlob = '';
# Multiple concatenated *'s don't make sense
#$string =~ s#\*\*+#*# ;
# TODO -- Allow space to delimit patterns?
#my @strings = split /\s+/, $string ;
#for my $str (@strings)
my $out = '';
my $depth = 0 ;
while ($string =~ s/(.*?)$noPreBS($matchMetaRE)//)
{
$out .= quotemeta($1) ;
$out .= $mapping{$2} if defined $mapping{$2};
++ $self->{WildCount} if $wildCount{$2} ;
if ($2 eq '(')
{
++ $depth ;
}
elsif ($2 eq ')')
{
return _unmatched(")")
if ! $depth ;
-- $depth ;
}
elsif ($2 eq '[')
{
# TODO -- quotemeta & check no '/' or '(' or ')'
# TODO -- check for \] & other \ within the []
$string =~ s#(.*?\])##
or return _unmatched("[");
$out .= "$1)" ;
}
elsif ($2 eq ']')
{
return _unmatched("]");
}
elsif ($2 eq '}')
{
return _unmatched("}");
}
elsif ($2 eq '{')
{
# TODO -- check no '/' within the {}
# TODO -- check for \} & other \ within the {}
my $tmp ;
unless ( $string =~ s/(.*?)$noPreBS\}//)
{
return _unmatched("{");
}
#$string =~ s#(.*?)\}##;
#my $alt = join '|',
# map { quotemeta $_ }
# split "$noPreBS,", $1 ;
my $alt = $self->_parseBit($1);
defined $alt or return 0 ;
$out .= "($alt)" ;
++ $self->{Braces} ;
}
}
return _unmatched("(")
if $depth ;
$out .= quotemeta $string ;
$self->{InputGlob} =~ s/$noPreBS[\(\)]//g;
$self->{InputPattern} = $out ;
#print "# INPUT '$self->{InputGlob}' => '$out'\n";
return 1 ;
}
sub _parseOutputGlob
{
my $self = shift ;
my $string = $self->{OutputGlob} ;
my $maxwild = $self->{WildCount};
if ($self->{GlobFlags} & GLOB_TILDE)
#if (1)
{
$string =~ s{
^ ~ # find a leading tilde
( # save this in $1
[^/] # a non-slash character
* # repeated 0 or more times (0 means me)
)
}{
$1
? (getpwnam($1))[7]
: ( $ENV{HOME} || $ENV{LOGDIR} )
}ex;
}
# max #1 must be == to max no of '*' in input
while ( $string =~ m/#(\d)/g )
{
croak "Max wild is #$maxwild, you tried #$1"
if $1 > $maxwild ;
}
my $noPreBS = '(?<!\\\)' ; # no preceding backslash
#warn "noPreBS = '$noPreBS'\n";
#$string =~ s/${noPreBS}\$(\d)/\${$1}/g;
$string =~ s/${noPreBS}#(\d)/\${$1}/g;
$string =~ s#${noPreBS}\*#\${inFile}#g;
$string = '"' . $string . '"';
#print "OUTPUT '$self->{OutputGlob}' => '$string'\n";
$self->{OutputPattern} = $string ;
return 1 ;
}
sub _getFiles
{
my $self = shift ;
my %outInMapping = ();
my %inFiles = () ;
foreach my $inFile (@{ $self->{InputFiles} })
{
next if $inFiles{$inFile} ++ ;
my $outFile = $inFile ;
if ( $inFile =~ m/$self->{InputPattern}/ )
{
no warnings 'uninitialized';
eval "\$outFile = $self->{OutputPattern};" ;
if (defined $outInMapping{$outFile})
{
$Error = "multiple input files map to one output file";
return undef ;
}
$outInMapping{$outFile} = $inFile;
push @{ $self->{Pairs} }, [$inFile, $outFile];
}
}
return 1 ;
}
sub getFileMap
{
my $self = shift ;
return $self->{Pairs} ;
}
sub getHash
{
my $self = shift ;
return { map { $_->[0] => $_->[1] } @{ $self->{Pairs} } } ;
}
1;
__END__
=head1 NAME
File::GlobMapper - Extend File Glob to Allow Input and Output Files
=head1 SYNOPSIS
use File::GlobMapper qw( globmap );
my $aref = globmap $input => $output
or die $File::GlobMapper::Error ;
my $gm = new File::GlobMapper $input => $output
or die $File::GlobMapper::Error ;
=head1 DESCRIPTION
This module needs Perl5.005 or better.
This module takes the existing C<File::Glob> module as a starting point and
extends it to allow new filenames to be derived from the files matched by
C<File::Glob>.
This can be useful when carrying out batch operations on multiple files that
have both an input filename and output filename and the output file can be
derived from the input filename. Examples of operations where this can be
useful include, file renaming, file copying and file compression.
=head2 Behind The Scenes
To help explain what C<File::GlobMapper> does, consider what code you
would write if you wanted to rename all files in the current directory
that ended in C<.tar.gz> to C<.tgz>. So say these files are in the
current directory
alpha.tar.gz
beta.tar.gz
gamma.tar.gz
and they need renamed to this
alpha.tgz
beta.tgz
gamma.tgz
Below is a possible implementation of a script to carry out the rename
(error cases have been omitted)
foreach my $old ( glob "*.tar.gz" )
{
my $new = $old;
$new =~ s#(.*)\.tar\.gz$#$1.tgz# ;
rename $old => $new
or die "Cannot rename '$old' to '$new': $!\n;
}
Notice that a file glob pattern C<*.tar.gz> was used to match the
C<.tar.gz> files, then a fairly similar regular expression was used in
the substitute to allow the new filename to be created.
Given that the file glob is just a cut-down regular expression and that it
has already done a lot of the hard work in pattern matching the filenames,
wouldn't it be handy to be able to use the patterns in the fileglob to
drive the new filename?
Well, that's I<exactly> what C<File::GlobMapper> does.
Here is same snippet of code rewritten using C<globmap>
for my $pair (globmap '<*.tar.gz>' => '<#1.tgz>' )
{
my ($from, $to) = @$pair;
rename $from => $to
or die "Cannot rename '$old' to '$new': $!\n;
}
So how does it work?
Behind the scenes the C<globmap> function does a combination of a
file glob to match existing filenames followed by a substitute
to create the new filenames.
Notice how both parameters to C<globmap> are strings that are delimited by <>.
This is done to make them look more like file globs - it is just syntactic
sugar, but it can be handy when you want the strings to be visually
distinctive. The enclosing <> are optional, so you don't have to use them - in
fact the first thing globmap will do is remove these delimiters if they are
present.
The first parameter to C<globmap>, C<*.tar.gz>, is an I<Input File Glob>.
Once the enclosing "< ... >" is removed, this is passed (more or
less) unchanged to C<File::Glob> to carry out a file match.
Next the fileglob C<*.tar.gz> is transformed behind the scenes into a
full Perl regular expression, with the additional step of wrapping each
transformed wildcard metacharacter sequence in parenthesis.
In this case the input fileglob C<*.tar.gz> will be transformed into
this Perl regular expression
([^/]*)\.tar\.gz
Wrapping with parenthesis allows the wildcard parts of the Input File
Glob to be referenced by the second parameter to C<globmap>, C<#1.tgz>,
the I<Output File Glob>. This parameter operates just like the replacement
part of a substitute command. The difference is that the C<#1> syntax
is used to reference sub-patterns matched in the input fileglob, rather
than the C<$1> syntax that is used with perl regular expressions. In
this case C<#1> is used to refer to the text matched by the C<*> in the
Input File Glob. This makes it easier to use this module where the
parameters to C<globmap> are typed at the command line.
The final step involves passing each filename matched by the C<*.tar.gz>
file glob through the derived Perl regular expression in turn and
expanding the output fileglob using it.
The end result of all this is a list of pairs of filenames. By default
that is what is returned by C<globmap>. In this example the data structure
returned will look like this
( ['alpha.tar.gz' => 'alpha.tgz'],
['beta.tar.gz' => 'beta.tgz' ],
['gamma.tar.gz' => 'gamma.tgz']
)
Each pair is an array reference with two elements - namely the I<from>
filename, that C<File::Glob> has matched, and a I<to> filename that is
derived from the I<from> filename.
=head2 Limitations
C<File::GlobMapper> has been kept simple deliberately, so it isn't intended to
solve all filename mapping operations. Under the hood C<File::Glob> (or for
older versions of Perl, C<File::BSDGlob>) is used to match the files, so you
will never have the flexibility of full Perl regular expression.
=head2 Input File Glob
The syntax for an Input FileGlob is identical to C<File::Glob>, except
for the following
=over 5
=item 1.
No nested {}
=item 2.
Whitespace does not delimit fileglobs.
=item 3.
The use of parenthesis can be used to capture parts of the input filename.
=item 4.
If an Input glob matches the same file more than once, only the first
will be used.
=back
The syntax
=over 5
=item B<~>
=item B<~user>
=item B<.>
Matches a literal '.'.
Equivalent to the Perl regular expression
\.
=item B<*>
Matches zero or more characters, except '/'. Equivalent to the Perl
regular expression
[^/]*
=item B<?>
Matches zero or one character, except '/'. Equivalent to the Perl
regular expression
[^/]?
=item B<\>
Backslash is used, as usual, to escape the next character.
=item B<[]>
Character class.
=item B<{,}>
Alternation
=item B<()>
Capturing parenthesis that work just like perl
=back
Any other character it taken literally.
=head2 Output File Glob
The Output File Glob is a normal string, with 2 glob-like features.
The first is the '*' metacharacter. This will be replaced by the complete
filename matched by the input file glob. So
*.c *.Z
The second is
Output FileGlobs take the
=over 5
=item "*"
The "*" character will be replaced with the complete input filename.
=item #1
Patterns of the form /#\d/ will be replaced with the
=back
=head2 Returned Data
=head1 EXAMPLES
=head2 A Rename script
Below is a simple "rename" script that uses C<globmap> to determine the
source and destination filenames.
use File::GlobMapper qw(globmap) ;
use File::Copy;
die "rename: Usage rename 'from' 'to'\n"
unless @ARGV == 2 ;
my $fromGlob = shift @ARGV;
my $toGlob = shift @ARGV;
my $pairs = globmap($fromGlob, $toGlob)
or die $File::GlobMapper::Error;
for my $pair (@$pairs)
{
my ($from, $to) = @$pair;
move $from => $to ;
}
Here is an example that renames all c files to cpp.
$ rename '*.c' '#1.cpp'
=head2 A few example globmaps
Below are a few examples of globmaps
To copy all your .c file to a backup directory
'</my/home/*.c>' '</my/backup/#1.c>'
If you want to compress all
'</my/home/*.[ch]>' '<*.gz>'
To uncompress
'</my/home/*.[ch].gz>' '</my/home/#1.#2>'
=head1 SEE ALSO
L<File::Glob|File::Glob>
=head1 AUTHOR
The I<File::GlobMapper> module was written by Paul Marquess, F<pmqs@cpan.org>.
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2005 Paul Marquess. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
Compare.pm 0000644 00000010354 15051130046 0006466 0 ustar 00 package File::Compare;
use 5.006;
use strict;
use warnings;
our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $Too_Big);
require Exporter;
$VERSION = '1.1006';
@ISA = qw(Exporter);
@EXPORT = qw(compare);
@EXPORT_OK = qw(cmp compare_text);
$Too_Big = 1024 * 1024 * 2;
sub croak {
require Carp;
goto &Carp::croak;
}
sub compare {
croak("Usage: compare( file1, file2 [, buffersize]) ")
unless(@_ == 2 || @_ == 3);
my ($from,$to,$size) = @_;
my $text_mode = defined($size) && (ref($size) eq 'CODE' || $size < 0);
my ($fromsize,$closefrom,$closeto);
local (*FROM, *TO);
croak("from undefined") unless (defined $from);
croak("to undefined") unless (defined $to);
if (ref($from) &&
(UNIVERSAL::isa($from,'GLOB') || UNIVERSAL::isa($from,'IO::Handle'))) {
*FROM = *$from;
} elsif (ref(\$from) eq 'GLOB') {
*FROM = $from;
} else {
open(FROM,"<",$from) or goto fail_open1;
unless ($text_mode) {
binmode FROM;
$fromsize = -s FROM;
}
$closefrom = 1;
}
if (ref($to) &&
(UNIVERSAL::isa($to,'GLOB') || UNIVERSAL::isa($to,'IO::Handle'))) {
*TO = *$to;
} elsif (ref(\$to) eq 'GLOB') {
*TO = $to;
} else {
open(TO,"<",$to) or goto fail_open2;
binmode TO unless $text_mode;
$closeto = 1;
}
if (!$text_mode && $closefrom && $closeto) {
# If both are opened files we know they differ if their size differ
goto fail_inner if $fromsize != -s TO;
}
if ($text_mode) {
local $/ = "\n";
my ($fline,$tline);
while (defined($fline = <FROM>)) {
goto fail_inner unless defined($tline = <TO>);
if (ref $size) {
# $size contains ref to comparison function
goto fail_inner if &$size($fline, $tline);
} else {
goto fail_inner if $fline ne $tline;
}
}
goto fail_inner if defined($tline = <TO>);
}
else {
unless (defined($size) && $size > 0) {
$size = $fromsize || -s TO || 0;
$size = 1024 if $size < 512;
$size = $Too_Big if $size > $Too_Big;
}
my ($fr,$tr,$fbuf,$tbuf);
$fbuf = $tbuf = '';
while(defined($fr = read(FROM,$fbuf,$size)) && $fr > 0) {
unless (defined($tr = read(TO,$tbuf,$fr)) && $tbuf eq $fbuf) {
goto fail_inner;
}
}
goto fail_inner if defined($tr = read(TO,$tbuf,$size)) && $tr > 0;
}
close(TO) || goto fail_open2 if $closeto;
close(FROM) || goto fail_open1 if $closefrom;
return 0;
# All of these contortions try to preserve error messages...
fail_inner:
close(TO) || goto fail_open2 if $closeto;
close(FROM) || goto fail_open1 if $closefrom;
return 1;
fail_open2:
if ($closefrom) {
my $status = $!;
$! = 0;
close FROM;
$! = $status unless $!;
}
fail_open1:
return -1;
}
sub cmp;
*cmp = \&compare;
sub compare_text {
my ($from,$to,$cmp) = @_;
croak("Usage: compare_text( file1, file2 [, cmp-function])")
unless @_ == 2 || @_ == 3;
croak("Third arg to compare_text() function must be a code reference")
if @_ == 3 && ref($cmp) ne 'CODE';
# Using a negative buffer size puts compare into text_mode too
$cmp = -1 unless defined $cmp;
compare($from, $to, $cmp);
}
1;
__END__
=head1 NAME
File::Compare - Compare files or filehandles
=head1 SYNOPSIS
use File::Compare;
if (compare("file1","file2") == 0) {
print "They're equal\n";
}
=head1 DESCRIPTION
The File::Compare::compare function compares the contents of two
sources, each of which can be a file or a file handle. It is exported
from File::Compare by default.
File::Compare::cmp is a synonym for File::Compare::compare. It is
exported from File::Compare only by request.
File::Compare::compare_text does a line by line comparison of the two
files. It stops as soon as a difference is detected. compare_text()
accepts an optional third argument: This must be a CODE reference to
a line comparison function, which returns 0 when both lines are considered
equal. For example:
compare_text($file1, $file2)
is basically equivalent to
compare_text($file1, $file2, sub {$_[0] ne $_[1]} )
=head1 RETURN
File::Compare::compare and its sibling functions return 0 if the files
are equal, 1 if the files are unequal, or -1 if an error was encountered.
=head1 AUTHOR
File::Compare was written by Nick Ing-Simmons.
Its original documentation was written by Chip Salzenberg.
=cut
stat.pm 0000644 00000023536 15051130046 0006061 0 ustar 00 package File::stat;
use 5.006;
use strict;
use warnings;
use warnings::register;
use Carp;
BEGIN { *warnif = \&warnings::warnif }
our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
our $VERSION = '1.07';
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, "stat_cando" );
%EXPORT_TAGS = ( FIELDS => [ @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't define
# them. It's important to avoid inflicting that on the user.
no strict 'refs';
for (qw(suid sgid svtx)) {
my $val = eval { &{"Fcntl::S_I\U$_"} };
*{"_$_"} = defined $val ? sub { $_[0] & $val ? 1 : "" } : sub { "" };
}
for (qw(SOCK CHR BLK REG DIR LNK)) {
*{"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
# RT #111638
*{"S_ISFIFO"} = defined &Fcntl::S_IFIFO
? \&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] & $_[1]) ? 1 : "" };
}
else {
# from doio.c
*cando = sub {
my ($s, $mode, $eff) = @_;
my $uid = $eff ? $> : $<;
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 && $^O ne "VMS") {
# If we're root on unix
# not testing for executable status => all file tests are true
return 1 if !($mode & 0111);
# testing for executable status =>
# for a file, any x bit will do
# for a directory, always true
return 1 if $stmode & 0111 || S_ISDIR($stmode);
return "";
}
if ($stuid == $uid) {
$stmode & $mode and return 1;
}
elsif (_ingroup($stgid, $eff)) {
$stmode & ($mode >> 3) and return 1;
}
else {
$stmode & ($mode >> 6) and return 1;
}
return "";
};
}
# alias for those who don't like objects
*stat_cando = \&cando;
my %op = (
r => sub { cando($_[0], S_IRUSR, 1) },
w => sub { cando($_[0], S_IWUSR, 1) },
x => sub { cando($_[0], S_IXUSR, 1) },
o => sub { $_[0][4] == $> },
R => sub { cando($_[0], S_IRUSR, 0) },
W => sub { cando($_[0], S_IWUSR, 0) },
X => sub { cando($_[0], S_IXUSR, 0) },
O => sub { $_[0][4] == $< },
e => sub { 1 },
z => sub { $_[0][7] == 0 },
s => sub { $_[0][7] },
f => sub { S_ISREG ($_[0][2]) },
d => sub { S_ISDIR ($_[0][2]) },
l => sub { S_ISLNK ($_[0][2]) },
p => sub { S_ISFIFO($_[0][2]) },
S => sub { S_ISSOCK($_[0][2]) },
b => sub { S_ISBLK ($_[0][2]) },
c => sub { S_ISCHR ($_[0][2]) },
u => sub { _suid($_[0][2]) },
g => sub { _sgid($_[0][2]) },
k => sub { _svtx($_[0][2]) },
M => sub { ($^T - $_[0][9] ) / 86400 },
C => sub { ($^T - $_[0][10]) / 86400 },
A => sub { ($^T - $_[0][8] ) / 86400 },
);
use constant HINT_FILETEST_ACCESS => 0x00400000;
# we need fallback=>1 or stringifying breaks
use overload
fallback => 1,
-X => sub {
my ($s, $op) = @_;
if (index("rwxRWX", $op) >= 0) {
(caller 0)[8] & 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}->($_[0]);
}
else {
croak "-$op is not implemented on a File::stat object";
}
};
# Class::Struct forbids use of @ISA
sub import { goto &Exporter::import }
use Class::Struct qw(struct);
struct 'File::stat' => [
map { $_ => '$' } 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->mode & 0111) && $st->nlink > 1) ) {
print "$file is executable with lotsa links\n";
}
if ( -x $st ) {
print "$file is executable\n";
}
use Fcntl "S_IRUSR";
if ( $st->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 & 0111) && ($st_nlink > 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<"-X">
overloading, so you can call filetest operators (C<-f>, C<-x>, and so
on) on it. It also provides a C<< ->cando >> method, called like
$st->cando( ACCESS, EFFECTIVE )
where I<ACCESS> is one of C<S_IRUSR>, C<S_IWUSR> or C<S_IXUSR> from the
L<Fcntl|Fcntl> module, and I<EFFECTIVE> indicates whether to use
effective (true) or real (false) ids. The method interprets the C<mode>,
C<uid> and C<gid> 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<< ->cando >>
method into your namespace as a regular function called C<stat_cando>.
This takes an arrayref containing the return values of C<stat> or
C<lstat> 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<st_> in front their method names.
Thus, C<$stat_obj-E<gt>dev()> corresponds to $st_dev if you import
the fields.
To access this functionality without the core overrides,
pass the C<use> 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<CORE::> pseudo-package.
=head1 BUGS
As of Perl 5.8.0 after using this module you cannot use the implicit
C<$_> or the special filehandle C<_> with stat() or lstat(), trying
to do so leads into strange errors. The workaround is for C<$_> to
be explicit
my $stat_obj = stat $_;
and for C<_> 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<-t>, C<-T> and C<-B> 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<-rwxRWX> filetests with C<use
filetest 'access'> in effect. C<File::stat> will ignore the pragma, and
just use the information in the C<mode> 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<File::stat> 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
Copy.pm 0000644 00000037434 15051130046 0006022 0 ustar 00