Initial Commit
This commit is contained in:
Riley Schneider
402
database/perl/lib/File/Basename.pm
Normal file
402
database/perl/lib/File/Basename.pm
Normal file
@@ -0,0 +1,402 @@
|
||||
=head1 NAME
|
||||
|
||||
File::Basename - Parse file paths into directory, filename and suffix.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use File::Basename;
|
||||
|
||||
($name,$path,$suffix) = fileparse($fullname,@suffixlist);
|
||||
$name = fileparse($fullname,@suffixlist);
|
||||
|
||||
$basename = basename($fullname,@suffixlist);
|
||||
$dirname = dirname($fullname);
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
These routines allow you to parse file paths into their directory, filename
|
||||
and suffix.
|
||||
|
||||
B<NOTE>: C<dirname()> and C<basename()> emulate the behaviours, and
|
||||
quirks, of the shell and C functions of the same name. See each
|
||||
function's documentation for details. If your concern is just parsing
|
||||
paths it is safer to use L<File::Spec>'s C<splitpath()> and
|
||||
C<splitdir()> methods.
|
||||
|
||||
It is guaranteed that
|
||||
|
||||
# Where $path_separator is / for Unix, \ for Windows, etc...
|
||||
dirname($path) . $path_separator . basename($path);
|
||||
|
||||
is equivalent to the original path for all systems but VMS.
|
||||
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
package File::Basename;
|
||||
|
||||
# File::Basename is used during the Perl build, when the re extension may
|
||||
# not be available, but we only actually need it if running under tainting.
|
||||
BEGIN {
|
||||
if (${^TAINT}) {
|
||||
require re;
|
||||
re->import('taint');
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
use strict;
|
||||
use 5.006;
|
||||
use warnings;
|
||||
our(@ISA, @EXPORT, $VERSION, $Fileparse_fstype, $Fileparse_igncase);
|
||||
require Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(fileparse fileparse_set_fstype basename dirname);
|
||||
$VERSION = "2.85";
|
||||
|
||||
fileparse_set_fstype($^O);
|
||||
|
||||
|
||||
=over 4
|
||||
|
||||
=item C<fileparse>
|
||||
X<fileparse>
|
||||
|
||||
my($filename, $dirs, $suffix) = fileparse($path);
|
||||
my($filename, $dirs, $suffix) = fileparse($path, @suffixes);
|
||||
my $filename = fileparse($path, @suffixes);
|
||||
|
||||
The C<fileparse()> routine divides a file path into its $dirs, $filename
|
||||
and (optionally) the filename $suffix.
|
||||
|
||||
$dirs contains everything up to and including the last
|
||||
directory separator in the $path including the volume (if applicable).
|
||||
The remainder of the $path is the $filename.
|
||||
|
||||
# On Unix returns ("baz", "/foo/bar/", "")
|
||||
fileparse("/foo/bar/baz");
|
||||
|
||||
# On Windows returns ("baz", 'C:\foo\bar\', "")
|
||||
fileparse('C:\foo\bar\baz');
|
||||
|
||||
# On Unix returns ("", "/foo/bar/baz/", "")
|
||||
fileparse("/foo/bar/baz/");
|
||||
|
||||
If @suffixes are given each element is a pattern (either a string or a
|
||||
C<qr//>) matched against the end of the $filename. The matching
|
||||
portion is removed and becomes the $suffix.
|
||||
|
||||
# On Unix returns ("baz", "/foo/bar/", ".txt")
|
||||
fileparse("/foo/bar/baz.txt", qr/\.[^.]*/);
|
||||
|
||||
If type is non-Unix (see L</fileparse_set_fstype>) then the pattern
|
||||
matching for suffix removal is performed case-insensitively, since
|
||||
those systems are not case-sensitive when opening existing files.
|
||||
|
||||
You are guaranteed that C<$dirs . $filename . $suffix> will
|
||||
denote the same location as the original $path.
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
sub fileparse {
|
||||
my($fullname,@suffices) = @_;
|
||||
|
||||
unless (defined $fullname) {
|
||||
require Carp;
|
||||
Carp::croak("fileparse(): need a valid pathname");
|
||||
}
|
||||
|
||||
my $orig_type = '';
|
||||
my($type,$igncase) = ($Fileparse_fstype, $Fileparse_igncase);
|
||||
|
||||
my($taint) = substr($fullname,0,0); # Is $fullname tainted?
|
||||
|
||||
if ($type eq "VMS" and $fullname =~ m{/} ) {
|
||||
# We're doing Unix emulation
|
||||
$orig_type = $type;
|
||||
$type = 'Unix';
|
||||
}
|
||||
|
||||
my($dirpath, $basename);
|
||||
|
||||
if (grep { $type eq $_ } qw(MSDOS DOS MSWin32 Epoc)) {
|
||||
($dirpath,$basename) = ($fullname =~ /^((?:.*[:\\\/])?)(.*)/s);
|
||||
$dirpath .= '.\\' unless $dirpath =~ /[\\\/]\z/;
|
||||
}
|
||||
elsif ($type eq "OS2") {
|
||||
($dirpath,$basename) = ($fullname =~ m#^((?:.*[:\\/])?)(.*)#s);
|
||||
$dirpath = './' unless $dirpath; # Can't be 0
|
||||
$dirpath .= '/' unless $dirpath =~ m#[\\/]\z#;
|
||||
}
|
||||
elsif ($type eq "MacOS") {
|
||||
($dirpath,$basename) = ($fullname =~ /^(.*:)?(.*)/s);
|
||||
$dirpath = ':' unless $dirpath;
|
||||
}
|
||||
elsif ($type eq "AmigaOS") {
|
||||
($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/s);
|
||||
$dirpath = './' unless $dirpath;
|
||||
}
|
||||
elsif ($type eq 'VMS' ) {
|
||||
($dirpath,$basename) = ($fullname =~ /^(.*[:>\]])?(.*)/s);
|
||||
$dirpath ||= ''; # should always be defined
|
||||
}
|
||||
else { # Default to Unix semantics.
|
||||
($dirpath,$basename) = ($fullname =~ m{^(.*/)?(.*)}s);
|
||||
if ($orig_type eq 'VMS' and $fullname =~ m{^(/[^/]+/000000(/|$))(.*)}) {
|
||||
# dev:[000000] is top of VMS tree, similar to Unix '/'
|
||||
# so strip it off and treat the rest as "normal"
|
||||
my $devspec = $1;
|
||||
my $remainder = $3;
|
||||
($dirpath,$basename) = ($remainder =~ m{^(.*/)?(.*)}s);
|
||||
$dirpath ||= ''; # should always be defined
|
||||
$dirpath = $devspec.$dirpath;
|
||||
}
|
||||
$dirpath = './' unless $dirpath;
|
||||
}
|
||||
|
||||
|
||||
my $tail = '';
|
||||
my $suffix = '';
|
||||
if (@suffices) {
|
||||
foreach $suffix (@suffices) {
|
||||
my $pat = ($igncase ? '(?i)' : '') . "($suffix)\$";
|
||||
if ($basename =~ s/$pat//s) {
|
||||
$taint .= substr($suffix,0,0);
|
||||
$tail = $1 . $tail;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Ensure taint is propagated from the path to its pieces.
|
||||
$tail .= $taint;
|
||||
wantarray ? ($basename .= $taint, $dirpath .= $taint, $tail)
|
||||
: ($basename .= $taint);
|
||||
}
|
||||
|
||||
|
||||
|
||||
=item C<basename>
|
||||
X<basename> X<filename>
|
||||
|
||||
my $filename = basename($path);
|
||||
my $filename = basename($path, @suffixes);
|
||||
|
||||
This function is provided for compatibility with the Unix shell command
|
||||
C<basename(1)>. It does B<NOT> always return the file name portion of a
|
||||
path as you might expect. To be safe, if you want the file name portion of
|
||||
a path use C<fileparse()>.
|
||||
|
||||
C<basename()> returns the last level of a filepath even if the last
|
||||
level is clearly directory. In effect, it is acting like C<pop()> for
|
||||
paths. This differs from C<fileparse()>'s behaviour.
|
||||
|
||||
# Both return "bar"
|
||||
basename("/foo/bar");
|
||||
basename("/foo/bar/");
|
||||
|
||||
@suffixes work as in C<fileparse()> except all regex metacharacters are
|
||||
quoted.
|
||||
|
||||
# These two function calls are equivalent.
|
||||
my $filename = basename("/foo/bar/baz.txt", ".txt");
|
||||
my $filename = fileparse("/foo/bar/baz.txt", qr/\Q.txt\E/);
|
||||
|
||||
Also note that in order to be compatible with the shell command,
|
||||
C<basename()> does not strip off a suffix if it is identical to the
|
||||
remaining characters in the filename.
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
sub basename {
|
||||
my($path) = shift;
|
||||
|
||||
# From BSD basename(1)
|
||||
# The basename utility deletes any prefix ending with the last slash '/'
|
||||
# character present in string (after first stripping trailing slashes)
|
||||
_strip_trailing_sep($path);
|
||||
|
||||
my($basename, $dirname, $suffix) = fileparse( $path, map("\Q$_\E",@_) );
|
||||
|
||||
# From BSD basename(1)
|
||||
# The suffix is not stripped if it is identical to the remaining
|
||||
# characters in string.
|
||||
if( length $suffix and !length $basename ) {
|
||||
$basename = $suffix;
|
||||
}
|
||||
|
||||
# Ensure that basename '/' == '/'
|
||||
if( !length $basename ) {
|
||||
$basename = $dirname;
|
||||
}
|
||||
|
||||
return $basename;
|
||||
}
|
||||
|
||||
|
||||
|
||||
=item C<dirname>
|
||||
X<dirname>
|
||||
|
||||
This function is provided for compatibility with the Unix shell
|
||||
command C<dirname(1)> and has inherited some of its quirks. In spite of
|
||||
its name it does B<NOT> always return the directory name as you might
|
||||
expect. To be safe, if you want the directory name of a path use
|
||||
C<fileparse()>.
|
||||
|
||||
Only on VMS (where there is no ambiguity between the file and directory
|
||||
portions of a path) and AmigaOS (possibly due to an implementation quirk in
|
||||
this module) does C<dirname()> work like C<fileparse($path)>, returning just the
|
||||
$dirs.
|
||||
|
||||
# On VMS and AmigaOS
|
||||
my $dirs = dirname($path);
|
||||
|
||||
When using Unix or MSDOS syntax this emulates the C<dirname(1)> shell function
|
||||
which is subtly different from how C<fileparse()> works. It returns all but
|
||||
the last level of a file path even if the last level is clearly a directory.
|
||||
In effect, it is not returning the directory portion but simply the path one
|
||||
level up acting like C<chop()> for file paths.
|
||||
|
||||
Also unlike C<fileparse()>, C<dirname()> does not include a trailing slash on
|
||||
its returned path.
|
||||
|
||||
# returns /foo/bar. fileparse() would return /foo/bar/
|
||||
dirname("/foo/bar/baz");
|
||||
|
||||
# also returns /foo/bar despite the fact that baz is clearly a
|
||||
# directory. fileparse() would return /foo/bar/baz/
|
||||
dirname("/foo/bar/baz/");
|
||||
|
||||
# returns '.'. fileparse() would return 'foo/'
|
||||
dirname("foo/");
|
||||
|
||||
Under VMS, if there is no directory information in the $path, then the
|
||||
current default device and directory is used.
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
sub dirname {
|
||||
my $path = shift;
|
||||
|
||||
my($type) = $Fileparse_fstype;
|
||||
|
||||
if( $type eq 'VMS' and $path =~ m{/} ) {
|
||||
# Parse as Unix
|
||||
local($File::Basename::Fileparse_fstype) = '';
|
||||
return dirname($path);
|
||||
}
|
||||
|
||||
my($basename, $dirname) = fileparse($path);
|
||||
|
||||
if ($type eq 'VMS') {
|
||||
$dirname ||= $ENV{DEFAULT};
|
||||
}
|
||||
elsif ($type eq 'MacOS') {
|
||||
if( !length($basename) && $dirname !~ /^[^:]+:\z/) {
|
||||
_strip_trailing_sep($dirname);
|
||||
($basename,$dirname) = fileparse $dirname;
|
||||
}
|
||||
$dirname .= ":" unless $dirname =~ /:\z/;
|
||||
}
|
||||
elsif (grep { $type eq $_ } qw(MSDOS DOS MSWin32 OS2)) {
|
||||
_strip_trailing_sep($dirname);
|
||||
unless( length($basename) ) {
|
||||
($basename,$dirname) = fileparse $dirname;
|
||||
_strip_trailing_sep($dirname);
|
||||
}
|
||||
}
|
||||
elsif ($type eq 'AmigaOS') {
|
||||
if ( $dirname =~ /:\z/) { return $dirname }
|
||||
chop $dirname;
|
||||
$dirname =~ s{[^:/]+\z}{} unless length($basename);
|
||||
}
|
||||
else {
|
||||
_strip_trailing_sep($dirname);
|
||||
unless( length($basename) ) {
|
||||
($basename,$dirname) = fileparse $dirname;
|
||||
_strip_trailing_sep($dirname);
|
||||
}
|
||||
}
|
||||
|
||||
$dirname;
|
||||
}
|
||||
|
||||
|
||||
# Strip the trailing path separator.
|
||||
sub _strip_trailing_sep {
|
||||
my $type = $Fileparse_fstype;
|
||||
|
||||
if ($type eq 'MacOS') {
|
||||
$_[0] =~ s/([^:]):\z/$1/s;
|
||||
}
|
||||
elsif (grep { $type eq $_ } qw(MSDOS DOS MSWin32 OS2)) {
|
||||
$_[0] =~ s/([^:])[\\\/]*\z/$1/;
|
||||
}
|
||||
else {
|
||||
$_[0] =~ s{(.)/*\z}{$1}s;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
=item C<fileparse_set_fstype>
|
||||
X<filesystem>
|
||||
|
||||
my $type = fileparse_set_fstype();
|
||||
my $previous_type = fileparse_set_fstype($type);
|
||||
|
||||
Normally File::Basename will assume a file path type native to your current
|
||||
operating system (ie. /foo/bar style on Unix, \foo\bar on Windows, etc...).
|
||||
With this function you can override that assumption.
|
||||
|
||||
Valid $types are "MacOS", "VMS", "AmigaOS", "OS2", "RISCOS",
|
||||
"MSWin32", "DOS" (also "MSDOS" for backwards bug compatibility),
|
||||
"Epoc" and "Unix" (all case-insensitive). If an unrecognized $type is
|
||||
given "Unix" will be assumed.
|
||||
|
||||
If you've selected VMS syntax, and the file specification you pass to
|
||||
one of these routines contains a "/", they assume you are using Unix
|
||||
emulation and apply the Unix syntax rules instead, for that function
|
||||
call only.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
BEGIN {
|
||||
|
||||
my @Ignore_Case = qw(MacOS VMS AmigaOS OS2 RISCOS MSWin32 MSDOS DOS Epoc);
|
||||
my @Types = (@Ignore_Case, qw(Unix));
|
||||
|
||||
sub fileparse_set_fstype {
|
||||
my $old = $Fileparse_fstype;
|
||||
|
||||
if (@_) {
|
||||
my $new_type = shift;
|
||||
|
||||
$Fileparse_fstype = 'Unix'; # default
|
||||
foreach my $type (@Types) {
|
||||
$Fileparse_fstype = $type if $new_type =~ /^$type/i;
|
||||
}
|
||||
|
||||
$Fileparse_igncase =
|
||||
(grep $Fileparse_fstype eq $_, @Ignore_Case) ? 1 : 0;
|
||||
}
|
||||
|
||||
return $old;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<dirname(1)>, L<basename(1)>, L<File::Spec>
|
||||
182
database/perl/lib/File/Compare.pm
Normal file
182
database/perl/lib/File/Compare.pm
Normal file
@@ -0,0 +1,182 @@
|
||||
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
|
||||
|
||||
513
database/perl/lib/File/Copy.pm
Normal file
513
database/perl/lib/File/Copy.pm
Normal file
@@ -0,0 +1,513 @@
|
||||
# File/Copy.pm. Written in 1994 by Aaron Sherman <ajs@ajs.com>. This
|
||||
# source code has been placed in the public domain by the author.
|
||||
# Please be kind and preserve the documentation.
|
||||
#
|
||||
# Additions copyright 1996 by Charles Bailey. Permission is granted
|
||||
# to distribute the revised code under the same terms as Perl itself.
|
||||
|
||||
package File::Copy;
|
||||
|
||||
use 5.006;
|
||||
use strict;
|
||||
use warnings; no warnings 'newline';
|
||||
use File::Spec;
|
||||
use Config;
|
||||
# During perl build, we need File::Copy but Scalar::Util might not be built yet
|
||||
# And then we need these games to avoid loading overload, as that will
|
||||
# confuse miniperl during the bootstrap of perl.
|
||||
my $Scalar_Util_loaded = eval q{ require Scalar::Util; require overload; 1 };
|
||||
# We want HiRes stat and utime if available
|
||||
BEGIN { eval q{ use Time::HiRes qw( stat utime ) } };
|
||||
our(@ISA, @EXPORT, @EXPORT_OK, $VERSION, $Too_Big, $Syscopy_is_copy);
|
||||
sub copy;
|
||||
sub syscopy;
|
||||
sub cp;
|
||||
sub mv;
|
||||
|
||||
$VERSION = '2.34';
|
||||
|
||||
require Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(copy move);
|
||||
@EXPORT_OK = qw(cp mv);
|
||||
|
||||
$Too_Big = 1024 * 1024 * 2;
|
||||
|
||||
sub croak {
|
||||
require Carp;
|
||||
goto &Carp::croak;
|
||||
}
|
||||
|
||||
sub carp {
|
||||
require Carp;
|
||||
goto &Carp::carp;
|
||||
}
|
||||
|
||||
sub _catname {
|
||||
my($from, $to) = @_;
|
||||
if (not defined &basename) {
|
||||
require File::Basename;
|
||||
import File::Basename 'basename';
|
||||
}
|
||||
|
||||
return File::Spec->catfile($to, basename($from));
|
||||
}
|
||||
|
||||
# _eq($from, $to) tells whether $from and $to are identical
|
||||
sub _eq {
|
||||
my ($from, $to) = map {
|
||||
$Scalar_Util_loaded && Scalar::Util::blessed($_)
|
||||
&& overload::Method($_, q{""})
|
||||
? "$_"
|
||||
: $_
|
||||
} (@_);
|
||||
return '' if ( (ref $from) xor (ref $to) );
|
||||
return $from == $to if ref $from;
|
||||
return $from eq $to;
|
||||
}
|
||||
|
||||
sub copy {
|
||||
croak("Usage: copy(FROM, TO [, BUFFERSIZE]) ")
|
||||
unless(@_ == 2 || @_ == 3);
|
||||
|
||||
my $from = shift;
|
||||
my $to = shift;
|
||||
|
||||
my $size;
|
||||
if (@_) {
|
||||
$size = shift(@_) + 0;
|
||||
croak("Bad buffer size for copy: $size\n") unless ($size > 0);
|
||||
}
|
||||
|
||||
my $from_a_handle = (ref($from)
|
||||
? (ref($from) eq 'GLOB'
|
||||
|| UNIVERSAL::isa($from, 'GLOB')
|
||||
|| UNIVERSAL::isa($from, 'IO::Handle'))
|
||||
: (ref(\$from) eq 'GLOB'));
|
||||
my $to_a_handle = (ref($to)
|
||||
? (ref($to) eq 'GLOB'
|
||||
|| UNIVERSAL::isa($to, 'GLOB')
|
||||
|| UNIVERSAL::isa($to, 'IO::Handle'))
|
||||
: (ref(\$to) eq 'GLOB'));
|
||||
|
||||
if (_eq($from, $to)) { # works for references, too
|
||||
carp("'$from' and '$to' are identical (not copied)");
|
||||
return 0;
|
||||
}
|
||||
|
||||
if (!$from_a_handle && !$to_a_handle && -d $to && ! -d $from) {
|
||||
$to = _catname($from, $to);
|
||||
}
|
||||
|
||||
if ((($Config{d_symlink} && $Config{d_readlink}) || $Config{d_link}) &&
|
||||
!($^O eq 'MSWin32' || $^O eq 'os2')) {
|
||||
my @fs = stat($from);
|
||||
if (@fs) {
|
||||
my @ts = stat($to);
|
||||
if (@ts && $fs[0] == $ts[0] && $fs[1] == $ts[1] && !-p $from) {
|
||||
carp("'$from' and '$to' are identical (not copied)");
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif (_eq($from, $to)) {
|
||||
carp("'$from' and '$to' are identical (not copied)");
|
||||
return 0;
|
||||
}
|
||||
|
||||
if (defined &syscopy && !$Syscopy_is_copy
|
||||
&& !$to_a_handle
|
||||
&& !($from_a_handle && $^O eq 'os2' ) # OS/2 cannot handle handles
|
||||
&& !($from_a_handle && $^O eq 'MSWin32')
|
||||
&& !($from_a_handle && $^O eq 'NetWare')
|
||||
)
|
||||
{
|
||||
if ($^O eq 'VMS' && -e $from
|
||||
&& ! -d $to && ! -d $from) {
|
||||
|
||||
# VMS natively inherits path components from the source of a
|
||||
# copy, but we want the Unixy behavior of inheriting from
|
||||
# the current working directory. Also, default in a trailing
|
||||
# dot for null file types.
|
||||
|
||||
$to = VMS::Filespec::rmsexpand(VMS::Filespec::vmsify($to), '.');
|
||||
|
||||
# Get rid of the old versions to be like UNIX
|
||||
1 while unlink $to;
|
||||
}
|
||||
|
||||
return syscopy($from, $to) || 0;
|
||||
}
|
||||
|
||||
my $closefrom = 0;
|
||||
my $closeto = 0;
|
||||
my ($status, $r, $buf);
|
||||
local($\) = '';
|
||||
|
||||
my $from_h;
|
||||
if ($from_a_handle) {
|
||||
$from_h = $from;
|
||||
} else {
|
||||
open $from_h, "<", $from or goto fail_open1;
|
||||
binmode $from_h or die "($!,$^E)";
|
||||
$closefrom = 1;
|
||||
}
|
||||
|
||||
# Seems most logical to do this here, in case future changes would want to
|
||||
# make this croak for some reason.
|
||||
unless (defined $size) {
|
||||
$size = tied(*$from_h) ? 0 : -s $from_h || 0;
|
||||
$size = 1024 if ($size < 512);
|
||||
$size = $Too_Big if ($size > $Too_Big);
|
||||
}
|
||||
|
||||
my $to_h;
|
||||
if ($to_a_handle) {
|
||||
$to_h = $to;
|
||||
} else {
|
||||
$to_h = \do { local *FH }; # XXX is this line obsolete?
|
||||
open $to_h, ">", $to or goto fail_open2;
|
||||
binmode $to_h or die "($!,$^E)";
|
||||
$closeto = 1;
|
||||
}
|
||||
|
||||
$! = 0;
|
||||
for (;;) {
|
||||
my ($r, $w, $t);
|
||||
defined($r = sysread($from_h, $buf, $size))
|
||||
or goto fail_inner;
|
||||
last unless $r;
|
||||
for ($w = 0; $w < $r; $w += $t) {
|
||||
$t = syswrite($to_h, $buf, $r - $w, $w)
|
||||
or goto fail_inner;
|
||||
}
|
||||
}
|
||||
|
||||
close($to_h) || goto fail_open2 if $closeto;
|
||||
close($from_h) || goto fail_open1 if $closefrom;
|
||||
|
||||
# Use this idiom to avoid uninitialized value warning.
|
||||
return 1;
|
||||
|
||||
# All of these contortions try to preserve error messages...
|
||||
fail_inner:
|
||||
if ($closeto) {
|
||||
$status = $!;
|
||||
$! = 0;
|
||||
close $to_h;
|
||||
$! = $status unless $!;
|
||||
}
|
||||
fail_open2:
|
||||
if ($closefrom) {
|
||||
$status = $!;
|
||||
$! = 0;
|
||||
close $from_h;
|
||||
$! = $status unless $!;
|
||||
}
|
||||
fail_open1:
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub cp {
|
||||
my($from,$to) = @_;
|
||||
my(@fromstat) = stat $from;
|
||||
my(@tostat) = stat $to;
|
||||
my $perm;
|
||||
|
||||
return 0 unless copy(@_) and @fromstat;
|
||||
|
||||
if (@tostat) {
|
||||
$perm = $tostat[2];
|
||||
} else {
|
||||
$perm = $fromstat[2] & ~(umask || 0);
|
||||
@tostat = stat $to;
|
||||
}
|
||||
# Might be more robust to look for S_I* in Fcntl, but we're
|
||||
# trying to avoid dependence on any XS-containing modules,
|
||||
# since File::Copy is used during the Perl build.
|
||||
$perm &= 07777;
|
||||
if ($perm & 06000) {
|
||||
croak("Unable to check setuid/setgid permissions for $to: $!")
|
||||
unless @tostat;
|
||||
|
||||
if ($perm & 04000 and # setuid
|
||||
$fromstat[4] != $tostat[4]) { # owner must match
|
||||
$perm &= ~06000;
|
||||
}
|
||||
|
||||
if ($perm & 02000 && $> != 0) { # if not root, setgid
|
||||
my $ok = $fromstat[5] == $tostat[5]; # group must match
|
||||
if ($ok) { # and we must be in group
|
||||
$ok = grep { $_ == $fromstat[5] } split /\s+/, $)
|
||||
}
|
||||
$perm &= ~06000 unless $ok;
|
||||
}
|
||||
}
|
||||
return 0 unless @tostat;
|
||||
return 1 if $perm == ($tostat[2] & 07777);
|
||||
return eval { chmod $perm, $to; } ? 1 : 0;
|
||||
}
|
||||
|
||||
sub _move {
|
||||
croak("Usage: move(FROM, TO) ") unless @_ == 3;
|
||||
|
||||
my($from,$to,$fallback) = @_;
|
||||
|
||||
my($fromsz,$tosz1,$tomt1,$tosz2,$tomt2,$sts,$ossts);
|
||||
|
||||
if (-d $to && ! -d $from) {
|
||||
$to = _catname($from, $to);
|
||||
}
|
||||
|
||||
($tosz1,$tomt1) = (stat($to))[7,9];
|
||||
$fromsz = -s $from;
|
||||
if ($^O eq 'os2' and defined $tosz1 and defined $fromsz) {
|
||||
# will not rename with overwrite
|
||||
unlink $to;
|
||||
}
|
||||
|
||||
if ($^O eq 'VMS' && -e $from
|
||||
&& ! -d $to && ! -d $from) {
|
||||
|
||||
# VMS natively inherits path components from the source of a
|
||||
# copy, but we want the Unixy behavior of inheriting from
|
||||
# the current working directory. Also, default in a trailing
|
||||
# dot for null file types.
|
||||
|
||||
$to = VMS::Filespec::rmsexpand(VMS::Filespec::vmsify($to), '.');
|
||||
|
||||
# Get rid of the old versions to be like UNIX
|
||||
1 while unlink $to;
|
||||
}
|
||||
|
||||
return 1 if rename $from, $to;
|
||||
|
||||
# Did rename return an error even though it succeeded, because $to
|
||||
# is on a remote NFS file system, and NFS lost the server's ack?
|
||||
return 1 if defined($fromsz) && !-e $from && # $from disappeared
|
||||
(($tosz2,$tomt2) = (stat($to))[7,9]) && # $to's there
|
||||
((!defined $tosz1) || # not before or
|
||||
($tosz1 != $tosz2 or $tomt1 != $tomt2)) && # was changed
|
||||
$tosz2 == $fromsz; # it's all there
|
||||
|
||||
($tosz1,$tomt1) = (stat($to))[7,9]; # just in case rename did something
|
||||
|
||||
{
|
||||
local $@;
|
||||
eval {
|
||||
local $SIG{__DIE__};
|
||||
$fallback->($from,$to) or die;
|
||||
my($atime, $mtime) = (stat($from))[8,9];
|
||||
utime($atime, $mtime, $to);
|
||||
unlink($from) or die;
|
||||
};
|
||||
return 1 unless $@;
|
||||
}
|
||||
($sts,$ossts) = ($! + 0, $^E + 0);
|
||||
|
||||
($tosz2,$tomt2) = ((stat($to))[7,9],0,0) if defined $tomt1;
|
||||
unlink($to) if !defined($tomt1) or $tomt1 != $tomt2 or $tosz1 != $tosz2;
|
||||
($!,$^E) = ($sts,$ossts);
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub move { _move(@_,\©); }
|
||||
sub mv { _move(@_,\&cp); }
|
||||
|
||||
# &syscopy is an XSUB under OS/2
|
||||
unless (defined &syscopy) {
|
||||
if ($^O eq 'VMS') {
|
||||
*syscopy = \&rmscopy;
|
||||
} elsif ($^O eq 'MSWin32' && defined &DynaLoader::boot_DynaLoader) {
|
||||
# Win32::CopyFile() fill only work if we can load Win32.xs
|
||||
*syscopy = sub {
|
||||
return 0 unless @_ == 2;
|
||||
return Win32::CopyFile(@_, 1);
|
||||
};
|
||||
} else {
|
||||
$Syscopy_is_copy = 1;
|
||||
*syscopy = \©
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::Copy - Copy files or filehandles
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use File::Copy;
|
||||
|
||||
copy("sourcefile","destinationfile") or die "Copy failed: $!";
|
||||
copy("Copy.pm",\*STDOUT);
|
||||
move("/dev1/sourcefile","/dev2/destinationfile");
|
||||
|
||||
use File::Copy "cp";
|
||||
|
||||
$n = FileHandle->new("/a/file","r");
|
||||
cp($n,"x");
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The File::Copy module provides two basic functions, C<copy> and
|
||||
C<move>, which are useful for getting the contents of a file from
|
||||
one place to another.
|
||||
|
||||
=over 4
|
||||
|
||||
=item copy
|
||||
X<copy> X<cp>
|
||||
|
||||
The C<copy> function takes two
|
||||
parameters: a file to copy from and a file to copy to. Either
|
||||
argument may be a string, a FileHandle reference or a FileHandle
|
||||
glob. Obviously, if the first argument is a filehandle of some
|
||||
sort, it will be read from, and if it is a file I<name> it will
|
||||
be opened for reading. Likewise, the second argument will be
|
||||
written to. If the second argument does not exist but the parent
|
||||
directory does exist, then it will be created. Trying to copy
|
||||
a file into a non-existent directory is an error.
|
||||
Trying to copy a file on top of itself is also an error.
|
||||
C<copy> will not overwrite read-only files.
|
||||
|
||||
If the destination (second argument) already exists and is a directory,
|
||||
and the source (first argument) is not a filehandle, then the source
|
||||
file will be copied into the directory specified by the destination,
|
||||
using the same base name as the source file. It's a failure to have a
|
||||
filehandle as the source when the destination is a directory.
|
||||
|
||||
B<Note that passing in
|
||||
files as handles instead of names may lead to loss of information
|
||||
on some operating systems; it is recommended that you use file
|
||||
names whenever possible.> Files are opened in binary mode where
|
||||
applicable. To get a consistent behaviour when copying from a
|
||||
filehandle to a file, use C<binmode> on the filehandle.
|
||||
|
||||
An optional third parameter can be used to specify the buffer
|
||||
size used for copying. This is the number of bytes from the
|
||||
first file, that will be held in memory at any given time, before
|
||||
being written to the second file. The default buffer size depends
|
||||
upon the file, but will generally be the whole file (up to 2MB), or
|
||||
1k for filehandles that do not reference files (eg. sockets).
|
||||
|
||||
You may use the syntax C<use File::Copy "cp"> to get at the C<cp>
|
||||
alias for this function. The syntax is I<exactly> the same. The
|
||||
behavior is nearly the same as well: as of version 2.15, C<cp> will
|
||||
preserve the source file's permission bits like the shell utility
|
||||
C<cp(1)> would do, while C<copy> uses the default permissions for the
|
||||
target file (which may depend on the process' C<umask>, file
|
||||
ownership, inherited ACLs, etc.). If an error occurs in setting
|
||||
permissions, C<cp> will return 0, regardless of whether the file was
|
||||
successfully copied.
|
||||
|
||||
=item move
|
||||
X<move> X<mv> X<rename>
|
||||
|
||||
The C<move> function also takes two parameters: the current name
|
||||
and the intended name of the file to be moved. If the destination
|
||||
already exists and is a directory, and the source is not a
|
||||
directory, then the source file will be renamed into the directory
|
||||
specified by the destination.
|
||||
|
||||
If possible, move() will simply rename the file. Otherwise, it copies
|
||||
the file to the new location and deletes the original. If an error occurs
|
||||
during this copy-and-delete process, you may be left with a (possibly partial)
|
||||
copy of the file under the destination name.
|
||||
|
||||
You may use the C<mv> alias for this function in the same way that
|
||||
you may use the C<cp> alias for C<copy>.
|
||||
|
||||
=item syscopy
|
||||
X<syscopy>
|
||||
|
||||
File::Copy also provides the C<syscopy> routine, which copies the
|
||||
file specified in the first parameter to the file specified in the
|
||||
second parameter, preserving OS-specific attributes and file
|
||||
structure. For Unix systems, this is equivalent to the simple
|
||||
C<copy> routine, which doesn't preserve OS-specific attributes. For
|
||||
VMS systems, this calls the C<rmscopy> routine (see below). For OS/2
|
||||
systems, this calls the C<syscopy> XSUB directly. For Win32 systems,
|
||||
this calls C<Win32::CopyFile>.
|
||||
|
||||
B<Special behaviour if C<syscopy> is defined (OS/2, VMS and Win32)>:
|
||||
|
||||
If both arguments to C<copy> are not file handles,
|
||||
then C<copy> will perform a "system copy" of
|
||||
the input file to a new output file, in order to preserve file
|
||||
attributes, indexed file structure, I<etc.> The buffer size
|
||||
parameter is ignored. If either argument to C<copy> is a
|
||||
handle to an opened file, then data is copied using Perl
|
||||
operators, and no effort is made to preserve file attributes
|
||||
or record structure.
|
||||
|
||||
The system copy routine may also be called directly under VMS and OS/2
|
||||
as C<File::Copy::syscopy> (or under VMS as C<File::Copy::rmscopy>, which
|
||||
is the routine that does the actual work for syscopy).
|
||||
|
||||
=item rmscopy($from,$to[,$date_flag])
|
||||
X<rmscopy>
|
||||
|
||||
The first and second arguments may be strings, typeglobs, typeglob
|
||||
references, or objects inheriting from IO::Handle;
|
||||
they are used in all cases to obtain the
|
||||
I<filespec> of the input and output files, respectively. The
|
||||
name and type of the input file are used as defaults for the
|
||||
output file, if necessary.
|
||||
|
||||
A new version of the output file is always created, which
|
||||
inherits the structure and RMS attributes of the input file,
|
||||
except for owner and protections (and possibly timestamps;
|
||||
see below). All data from the input file is copied to the
|
||||
output file; if either of the first two parameters to C<rmscopy>
|
||||
is a file handle, its position is unchanged. (Note that this
|
||||
means a file handle pointing to the output file will be
|
||||
associated with an old version of that file after C<rmscopy>
|
||||
returns, not the newly created version.)
|
||||
|
||||
The third parameter is an integer flag, which tells C<rmscopy>
|
||||
how to handle timestamps. If it is E<lt> 0, none of the input file's
|
||||
timestamps are propagated to the output file. If it is E<gt> 0, then
|
||||
it is interpreted as a bitmask: if bit 0 (the LSB) is set, then
|
||||
timestamps other than the revision date are propagated; if bit 1
|
||||
is set, the revision date is propagated. If the third parameter
|
||||
to C<rmscopy> is 0, then it behaves much like the DCL COPY command:
|
||||
if the name or type of the output file was explicitly specified,
|
||||
then no timestamps are propagated, but if they were taken implicitly
|
||||
from the input filespec, then all timestamps other than the
|
||||
revision date are propagated. If this parameter is not supplied,
|
||||
it defaults to 0.
|
||||
|
||||
C<rmscopy> is VMS specific and cannot be exported; it must be
|
||||
referenced by its full name, e.g.:
|
||||
|
||||
File::Copy::rmscopy($from, $to) or die $!;
|
||||
|
||||
Like C<copy>, C<rmscopy> returns 1 on success. If an error occurs,
|
||||
it sets C<$!>, deletes the output file, and returns 0.
|
||||
|
||||
=back
|
||||
|
||||
=head1 RETURN
|
||||
|
||||
All functions return 1 on success, 0 on failure.
|
||||
$! will be set if an error was encountered.
|
||||
|
||||
=head1 NOTES
|
||||
|
||||
Before calling copy() or move() on a filehandle, the caller should
|
||||
close or flush() the file to avoid writes being lost. Note that this
|
||||
is the case even for move(), because it may actually copy the file,
|
||||
depending on the OS-specific implementation, and the underlying
|
||||
filesystem(s).
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
File::Copy was written by Aaron Sherman I<E<lt>ajs@ajs.comE<gt>> in 1995,
|
||||
and updated by Charles Bailey I<E<lt>bailey@newman.upenn.eduE<gt>> in 1996.
|
||||
|
||||
=cut
|
||||
|
||||
304
database/perl/lib/File/DosGlob.pm
Normal file
304
database/perl/lib/File/DosGlob.pm
Normal file
@@ -0,0 +1,304 @@
|
||||
#!perl -w
|
||||
|
||||
#
|
||||
# Documentation at the __END__
|
||||
#
|
||||
|
||||
package File::DosGlob;
|
||||
|
||||
our $VERSION = '1.12';
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
require XSLoader;
|
||||
XSLoader::load();
|
||||
|
||||
sub doglob {
|
||||
my $cond = shift;
|
||||
my @retval = ();
|
||||
my $fix_drive_relative_paths;
|
||||
OUTER:
|
||||
for my $pat (@_) {
|
||||
my @matched = ();
|
||||
my @globdirs = ();
|
||||
my $head = '.';
|
||||
my $sepchr = '/';
|
||||
my $tail;
|
||||
next OUTER unless defined $pat and $pat ne '';
|
||||
# if arg is within quotes strip em and do no globbing
|
||||
if ($pat =~ /^"(.*)"\z/s) {
|
||||
$pat = $1;
|
||||
if ($cond eq 'd') { push(@retval, $pat) if -d $pat }
|
||||
else { push(@retval, $pat) if -e $pat }
|
||||
next OUTER;
|
||||
}
|
||||
# wildcards with a drive prefix such as h:*.pm must be changed
|
||||
# to h:./*.pm to expand correctly
|
||||
if ($pat =~ m|^([A-Za-z]:)[^/\\]|s) {
|
||||
substr($pat,0,2) = $1 . "./";
|
||||
$fix_drive_relative_paths = 1;
|
||||
}
|
||||
if ($pat =~ m|^(.*)([\\/])([^\\/]*)\z|s) {
|
||||
($head, $sepchr, $tail) = ($1,$2,$3);
|
||||
push (@retval, $pat), next OUTER if $tail eq '';
|
||||
if ($head =~ /[*?]/) {
|
||||
@globdirs = doglob('d', $head);
|
||||
push(@retval, doglob($cond, map {"$_$sepchr$tail"} @globdirs)),
|
||||
next OUTER if @globdirs;
|
||||
}
|
||||
$head .= $sepchr if $head eq '' or $head =~ /^[A-Za-z]:\z/s;
|
||||
$pat = $tail;
|
||||
}
|
||||
#
|
||||
# If file component has no wildcards, we can avoid opendir
|
||||
unless ($pat =~ /[*?]/) {
|
||||
$head = '' if $head eq '.';
|
||||
$head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr;
|
||||
$head .= $pat;
|
||||
if ($cond eq 'd') { push(@retval,$head) if -d $head }
|
||||
else { push(@retval,$head) if -e $head }
|
||||
next OUTER;
|
||||
}
|
||||
opendir(D, $head) or next OUTER;
|
||||
my @leaves = readdir D;
|
||||
closedir D;
|
||||
|
||||
# VMS-format filespecs, especially if they contain extended characters,
|
||||
# are unlikely to match patterns correctly, so Unixify them.
|
||||
if ($^O eq 'VMS') {
|
||||
require VMS::Filespec;
|
||||
@leaves = map {$_ =~ s/\.$//; VMS::Filespec::unixify($_)} @leaves;
|
||||
}
|
||||
$head = '' if $head eq '.';
|
||||
$head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr;
|
||||
|
||||
# escape regex metachars but not glob chars
|
||||
$pat =~ s:([].+^\-\${}()[|]):\\$1:g;
|
||||
# and convert DOS-style wildcards to regex
|
||||
$pat =~ s/\*/.*/g;
|
||||
$pat =~ s/\?/.?/g;
|
||||
|
||||
my $matchsub = sub { $_[0] =~ m|^$pat\z|is };
|
||||
INNER:
|
||||
for my $e (@leaves) {
|
||||
next INNER if $e eq '.' or $e eq '..';
|
||||
next INNER if $cond eq 'd' and ! -d "$head$e";
|
||||
push(@matched, "$head$e"), next INNER if &$matchsub($e);
|
||||
#
|
||||
# [DOS compatibility special case]
|
||||
# Failed, add a trailing dot and try again, but only
|
||||
# if name does not have a dot in it *and* pattern
|
||||
# has a dot *and* name is shorter than 9 chars.
|
||||
#
|
||||
if (index($e,'.') == -1 and length($e) < 9
|
||||
and index($pat,'\\.') != -1) {
|
||||
push(@matched, "$head$e"), next INNER if &$matchsub("$e.");
|
||||
}
|
||||
}
|
||||
push @retval, @matched if @matched;
|
||||
}
|
||||
if ($fix_drive_relative_paths) {
|
||||
s|^([A-Za-z]:)\./|$1| for @retval;
|
||||
}
|
||||
return @retval;
|
||||
}
|
||||
|
||||
#
|
||||
# this can be used to override CORE::glob in a specific
|
||||
# package by saying C<use File::DosGlob 'glob';> in that
|
||||
# namespace.
|
||||
#
|
||||
|
||||
# context (keyed by second cxix arg provided by core)
|
||||
our %entries;
|
||||
|
||||
sub glob {
|
||||
my($pat,$cxix) = ($_[0], _callsite());
|
||||
my @pat;
|
||||
|
||||
# glob without args defaults to $_
|
||||
$pat = $_ unless defined $pat;
|
||||
|
||||
# if we're just beginning, do it all first
|
||||
if (!$entries{$cxix}) {
|
||||
# extract patterns
|
||||
if ($pat =~ /\s/) {
|
||||
require Text::ParseWords;
|
||||
@pat = Text::ParseWords::parse_line('\s+',0,$pat);
|
||||
}
|
||||
else {
|
||||
push @pat, $pat;
|
||||
}
|
||||
|
||||
# Mike Mestnik: made to do abc{1,2,3} == abc1 abc2 abc3.
|
||||
# abc3 will be the original {3} (and drop the {}).
|
||||
# abc1 abc2 will be put in @appendpat.
|
||||
# This was just the easiest way, not nearly the best.
|
||||
REHASH: {
|
||||
my @appendpat = ();
|
||||
for (@pat) {
|
||||
# There must be a "," I.E. abc{efg} is not what we want.
|
||||
while ( /^(.*)(?<!\\)\{(.*?)(?<!\\)\,.*?(?<!\\)\}(.*)$/ ) {
|
||||
my ($start, $match, $end) = ($1, $2, $3);
|
||||
#print "Got: \n\t$start\n\t$match\n\t$end\n";
|
||||
my $tmp = "$start$match$end";
|
||||
while ( $tmp =~ s/^(.*?)(?<!\\)\{(?:.*(?<!\\)\,)?(.*\Q$match\E.*?)(?:(?<!\\)\,.*)?(?<!\\)\}(.*)$/$1$2$3/ ) {
|
||||
# these expansions will be performed by the original,
|
||||
# when we call REHASH.
|
||||
}
|
||||
push @appendpat, ("$tmp");
|
||||
s/^\Q$start\E(?<!\\)\{\Q$match\E(?<!\\)\,/$start\{/;
|
||||
if ( /^\Q$start\E(?<!\\)\{(?!.*?(?<!\\)\,.*?\Q$end\E$)(.*)(?<!\\)\}\Q$end\E$/ ) {
|
||||
$match = $1;
|
||||
#print "GOT: \n\t$start\n\t$match\n\t$end\n\n";
|
||||
$_ = "$start$match$end";
|
||||
}
|
||||
}
|
||||
#print "Sould have "GOT" vs "Got"!\n";
|
||||
#FIXME: There should be checking for this.
|
||||
# How or what should be done about failure is beyond me.
|
||||
}
|
||||
if ( $#appendpat != -1
|
||||
) {
|
||||
#FIXME: Max loop, no way! :")
|
||||
for ( @appendpat ) {
|
||||
push @pat, $_;
|
||||
}
|
||||
goto REHASH;
|
||||
}
|
||||
}
|
||||
for ( @pat ) {
|
||||
s/\\([{},])/$1/g;
|
||||
}
|
||||
|
||||
$entries{$cxix} = [doglob(1,@pat)];
|
||||
}
|
||||
|
||||
# chuck it all out, quick or slow
|
||||
if (wantarray) {
|
||||
return @{delete $entries{$cxix}};
|
||||
}
|
||||
else {
|
||||
if (scalar @{$entries{$cxix}}) {
|
||||
return shift @{$entries{$cxix}};
|
||||
}
|
||||
else {
|
||||
# return undef for EOL
|
||||
delete $entries{$cxix};
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
{
|
||||
no strict 'refs';
|
||||
|
||||
sub import {
|
||||
my $pkg = shift;
|
||||
return unless @_;
|
||||
my $sym = shift;
|
||||
my $callpkg = ($sym =~ s/^GLOBAL_//s ? 'CORE::GLOBAL' : caller(0));
|
||||
*{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym} if $sym eq 'glob';
|
||||
}
|
||||
}
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::DosGlob - DOS like globbing and then some
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
require 5.004;
|
||||
|
||||
# override CORE::glob in current package
|
||||
use File::DosGlob 'glob';
|
||||
|
||||
# override CORE::glob in ALL packages (use with extreme caution!)
|
||||
use File::DosGlob 'GLOBAL_glob';
|
||||
|
||||
@perlfiles = glob "..\\pe?l/*.p?";
|
||||
print <..\\pe?l/*.p?>;
|
||||
|
||||
# from the command line (overrides only in main::)
|
||||
> perl -MFile::DosGlob=glob -e "print <../pe*/*p?>"
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
A module that implements DOS-like globbing with a few enhancements.
|
||||
It is largely compatible with perlglob.exe (the M$ setargv.obj
|
||||
version) in all but one respect--it understands wildcards in
|
||||
directory components.
|
||||
|
||||
For example, C<< <..\\l*b\\file/*glob.p?> >> will work as expected (in
|
||||
that it will find something like '..\lib\File/DosGlob.pm' alright).
|
||||
Note that all path components are case-insensitive, and that
|
||||
backslashes and forward slashes are both accepted, and preserved.
|
||||
You may have to double the backslashes if you are putting them in
|
||||
literally, due to double-quotish parsing of the pattern by perl.
|
||||
|
||||
Spaces in the argument delimit distinct patterns, so
|
||||
C<glob('*.exe *.dll')> globs all filenames that end in C<.exe>
|
||||
or C<.dll>. If you want to put in literal spaces in the glob
|
||||
pattern, you can escape them with either double quotes, or backslashes.
|
||||
e.g. C<glob('c:/"Program Files"/*/*.dll')>, or
|
||||
C<glob('c:/Program\ Files/*/*.dll')>. The argument is tokenized using
|
||||
C<Text::ParseWords::parse_line()>, so see L<Text::ParseWords> for details
|
||||
of the quoting rules used.
|
||||
|
||||
Extending it to csh patterns is left as an exercise to the reader.
|
||||
|
||||
=head1 EXPORTS (by request only)
|
||||
|
||||
glob()
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
Should probably be built into the core, and needs to stop
|
||||
pandering to DOS habits. Needs a dose of optimization too.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Gurusamy Sarathy <gsar@activestate.com>
|
||||
|
||||
=head1 HISTORY
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
Support for globally overriding glob() (GSAR 3-JUN-98)
|
||||
|
||||
=item *
|
||||
|
||||
Scalar context, independent iterator context fixes (GSAR 15-SEP-97)
|
||||
|
||||
=item *
|
||||
|
||||
A few dir-vs-file optimizations result in glob importation being
|
||||
10 times faster than using perlglob.exe, and using perlglob.bat is
|
||||
only twice as slow as perlglob.exe (GSAR 28-MAY-97)
|
||||
|
||||
=item *
|
||||
|
||||
Several cleanups prompted by lack of compatible perlglob.exe
|
||||
under Borland (GSAR 27-MAY-97)
|
||||
|
||||
=item *
|
||||
|
||||
Initial version (GSAR 20-FEB-97)
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
perl
|
||||
|
||||
perlglob.bat
|
||||
|
||||
Text::ParseWords
|
||||
|
||||
=cut
|
||||
|
||||
1738
database/perl/lib/File/Fetch.pm
Normal file
1738
database/perl/lib/File/Fetch.pm
Normal file
File diff suppressed because it is too large
Load Diff
1127
database/perl/lib/File/Find.pm
Normal file
1127
database/perl/lib/File/Find.pm
Normal file
File diff suppressed because it is too large
Load Diff
921
database/perl/lib/File/Find/Object.pm
Normal file
921
database/perl/lib/File/Find/Object.pm
Normal file
@@ -0,0 +1,921 @@
|
||||
package File::Find::Object;
|
||||
$File::Find::Object::VERSION = '0.3.5';
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
package File::Find::Object::DeepPath;
|
||||
$File::Find::Object::DeepPath::VERSION = '0.3.5';
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use 5.008;
|
||||
|
||||
use integer;
|
||||
|
||||
use parent 'File::Find::Object::PathComp';
|
||||
|
||||
use File::Spec ();
|
||||
|
||||
sub new
|
||||
{
|
||||
my ( $class, $top, $from ) = @_;
|
||||
|
||||
my $self = {};
|
||||
bless $self, $class;
|
||||
|
||||
$self->_stat_ret( $top->_top_stat_copy() );
|
||||
|
||||
my $find = { %{ $from->_inodes() } };
|
||||
if ( my $inode = $self->_inode )
|
||||
{
|
||||
$find->{ join( ",", $self->_dev(), $inode ) } =
|
||||
$#{ $top->_dir_stack() };
|
||||
}
|
||||
$self->_set_inodes($find);
|
||||
|
||||
$self->_last_dir_scanned(undef);
|
||||
|
||||
$top->_fill_actions($self);
|
||||
|
||||
push @{ $top->_curr_comps() }, "";
|
||||
|
||||
return $top->_open_dir() ? $self : undef;
|
||||
}
|
||||
|
||||
sub _move_next
|
||||
{
|
||||
my ( $self, $top ) = @_;
|
||||
|
||||
if (
|
||||
defined(
|
||||
$self->_curr_file( $top->_current_father()->_next_traverse_to() )
|
||||
)
|
||||
)
|
||||
{
|
||||
$top->_curr_comps()->[-1] = $self->_curr_file();
|
||||
$top->_calc_curr_path();
|
||||
|
||||
$top->_fill_actions($self);
|
||||
$top->_mystat();
|
||||
|
||||
return 1;
|
||||
}
|
||||
else
|
||||
{
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
|
||||
package File::Find::Object::TopPath;
|
||||
$File::Find::Object::TopPath::VERSION = '0.3.5';
|
||||
use parent 'File::Find::Object::PathComp';
|
||||
|
||||
sub new
|
||||
{
|
||||
my $class = shift;
|
||||
my $top = shift;
|
||||
|
||||
my $self = {};
|
||||
bless $self, $class;
|
||||
|
||||
$top->_fill_actions($self);
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub _move_to_next_target
|
||||
{
|
||||
my $self = shift;
|
||||
my $top = shift;
|
||||
|
||||
my $target = $self->_curr_file( $top->_calc_next_target() );
|
||||
@{ $top->_curr_comps() } = ($target);
|
||||
$top->_calc_curr_path();
|
||||
|
||||
return $target;
|
||||
}
|
||||
|
||||
sub _move_next
|
||||
{
|
||||
my $self = shift;
|
||||
my $top = shift;
|
||||
|
||||
while ( $top->_increment_target_index() )
|
||||
{
|
||||
if ( -e $self->_move_to_next_target($top) )
|
||||
{
|
||||
$top->_fill_actions($self);
|
||||
$top->_mystat();
|
||||
$self->_stat_ret( $top->_top_stat_copy() );
|
||||
$top->_dev( $self->_dev );
|
||||
|
||||
my $inode = $self->_inode();
|
||||
$self->_set_inodes(
|
||||
( $inode == 0 )
|
||||
? {}
|
||||
: {
|
||||
join( ",", $self->_dev(), $inode ) => 0,
|
||||
},
|
||||
);
|
||||
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
package File::Find::Object;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use parent 'File::Find::Object::Base';
|
||||
|
||||
use File::Find::Object::Result ();
|
||||
|
||||
use Fcntl ':mode';
|
||||
use List::Util ();
|
||||
|
||||
sub _get_options_ids
|
||||
{
|
||||
my $class = shift;
|
||||
return [
|
||||
qw(
|
||||
callback
|
||||
depth
|
||||
filter
|
||||
followlink
|
||||
nocrossfs
|
||||
)
|
||||
];
|
||||
}
|
||||
|
||||
# _curr_comps are the components (comps) of the master object's current path.
|
||||
# _curr_path is the concatenated path itself.
|
||||
|
||||
use Class::XSAccessor accessors => {
|
||||
(
|
||||
map { $_ => $_ } (
|
||||
qw(
|
||||
_check_subdir_h
|
||||
_curr_comps
|
||||
_current
|
||||
_curr_path
|
||||
_def_actions
|
||||
_dev
|
||||
_dir_stack
|
||||
item_obj
|
||||
_target_index
|
||||
_targets
|
||||
_top_is_dir
|
||||
_top_is_link
|
||||
_top_stat
|
||||
),
|
||||
@{ __PACKAGE__->_get_options_ids() }
|
||||
)
|
||||
)
|
||||
};
|
||||
|
||||
__PACKAGE__->_make_copy_methods(
|
||||
[
|
||||
qw(
|
||||
_top_stat
|
||||
)
|
||||
]
|
||||
);
|
||||
|
||||
use Carp;
|
||||
|
||||
sub new
|
||||
{
|
||||
my ( $class, $options, @targets ) = @_;
|
||||
|
||||
# The *existence* of an _st key inside the struct
|
||||
# indicates that the stack is full.
|
||||
# So now it's empty.
|
||||
my $tree = {
|
||||
_dir_stack => [],
|
||||
_curr_comps => [],
|
||||
};
|
||||
|
||||
bless( $tree, $class );
|
||||
|
||||
foreach my $opt ( @{ $tree->_get_options_ids() } )
|
||||
{
|
||||
$tree->$opt( $options->{$opt} );
|
||||
}
|
||||
|
||||
$tree->_gen_check_subdir_helper();
|
||||
|
||||
$tree->_targets( \@targets );
|
||||
$tree->_target_index(-1);
|
||||
|
||||
$tree->_calc_default_actions();
|
||||
|
||||
push @{ $tree->_dir_stack() },
|
||||
$tree->_current( File::Find::Object::TopPath->new($tree) );
|
||||
|
||||
$tree->_last_dir_scanned(undef);
|
||||
|
||||
return $tree;
|
||||
}
|
||||
|
||||
sub _curr_not_a_dir
|
||||
{
|
||||
return !shift->_top_is_dir();
|
||||
}
|
||||
|
||||
# Calculates _curr_path from $self->_curr_comps().
|
||||
# Must be called whenever _curr_comps is modified.
|
||||
sub _calc_curr_path
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
$self->_curr_path( File::Spec->catfile( @{ $self->_curr_comps() } ) );
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub _calc_current_item_obj
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
my @comps = @{ $self->_curr_comps() };
|
||||
|
||||
my $ret = {
|
||||
path => scalar( $self->_curr_path() ),
|
||||
dir_components => \@comps,
|
||||
base => shift(@comps),
|
||||
stat_ret => scalar( $self->_top_stat_copy() ),
|
||||
is_file => scalar( -f _ ),
|
||||
is_dir => scalar( -d _ ),
|
||||
is_link => $self->_top_is_link(),
|
||||
};
|
||||
|
||||
if ( $self->_curr_not_a_dir() )
|
||||
{
|
||||
$ret->{basename} = pop(@comps);
|
||||
}
|
||||
|
||||
return bless $ret, "File::Find::Object::Result";
|
||||
}
|
||||
|
||||
sub next_obj
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
until (
|
||||
$self->_process_current || ( ( !$self->_master_move_to_next() )
|
||||
&& $self->_me_die() )
|
||||
)
|
||||
{
|
||||
# Do nothing
|
||||
}
|
||||
|
||||
return $self->item_obj();
|
||||
}
|
||||
|
||||
sub next
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
$self->next_obj();
|
||||
|
||||
return $self->item();
|
||||
}
|
||||
|
||||
sub item
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
return $self->item_obj() ? $self->item_obj()->path() : undef;
|
||||
}
|
||||
|
||||
sub _current_father
|
||||
{
|
||||
return shift->_dir_stack->[-2];
|
||||
}
|
||||
|
||||
sub _increment_target_index
|
||||
{
|
||||
my $self = shift;
|
||||
$self->_target_index( $self->_target_index() + 1 );
|
||||
|
||||
return ( $self->_target_index() < scalar( @{ $self->_targets() } ) );
|
||||
}
|
||||
|
||||
sub _calc_next_target
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
my $target = $self->_targets()->[ $self->_target_index() ];
|
||||
|
||||
return defined($target) ? File::Spec->canonpath($target) : undef;
|
||||
}
|
||||
|
||||
sub _master_move_to_next
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
return $self->_current()->_move_next($self);
|
||||
}
|
||||
|
||||
sub _me_die
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
if ( exists( $self->{_st} ) )
|
||||
{
|
||||
return $self->_become_default();
|
||||
}
|
||||
|
||||
$self->item_obj( undef() );
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _become_default
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
my $st = $self->_dir_stack();
|
||||
|
||||
pop(@$st);
|
||||
$self->_current( $st->[-1] );
|
||||
pop( @{ $self->_curr_comps() } );
|
||||
|
||||
if ( @$st == 1 )
|
||||
{
|
||||
delete( $self->{_st} );
|
||||
}
|
||||
else
|
||||
{
|
||||
# If depth is false, then we no longer need the _curr_path
|
||||
# of the directories above the previously-set value, because we
|
||||
# already traversed them.
|
||||
if ( $self->depth() )
|
||||
{
|
||||
$self->_calc_curr_path();
|
||||
}
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub _calc_default_actions
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
my @calc_obj =
|
||||
$self->callback()
|
||||
? (qw(_run_cb))
|
||||
: (qw(_set_obj));
|
||||
|
||||
my @rec = qw(_recurse);
|
||||
|
||||
$self->_def_actions(
|
||||
[
|
||||
$self->depth()
|
||||
? ( @rec, @calc_obj )
|
||||
: ( @calc_obj, @rec )
|
||||
]
|
||||
);
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub _fill_actions
|
||||
{
|
||||
my $self = shift;
|
||||
my $other = shift;
|
||||
|
||||
$other->_actions( [ @{ $self->_def_actions() } ] );
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub _mystat
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
$self->_top_stat( [ lstat( $self->_curr_path() ) ] );
|
||||
|
||||
$self->_top_is_dir( scalar( -d _ ) );
|
||||
|
||||
if ( $self->_top_is_link( scalar( -l _ ) ) )
|
||||
{
|
||||
stat( $self->_curr_path() );
|
||||
$self->_top_is_dir( scalar( -d _ ) );
|
||||
}
|
||||
|
||||
return "SKIP";
|
||||
}
|
||||
|
||||
sub _next_action
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
return shift( @{ $self->_current->_actions() } );
|
||||
}
|
||||
|
||||
sub _check_process_current
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
return ( defined( $self->_current->_curr_file() )
|
||||
&& $self->_filter_wrapper() );
|
||||
}
|
||||
|
||||
# Return true if there is something next
|
||||
sub _process_current
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
if ( !$self->_check_process_current() )
|
||||
{
|
||||
return 0;
|
||||
}
|
||||
else
|
||||
{
|
||||
return $self->_process_current_actions();
|
||||
}
|
||||
}
|
||||
|
||||
sub _set_obj
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
$self->item_obj( $self->_calc_current_item_obj() );
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _run_cb
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
$self->_set_obj();
|
||||
|
||||
$self->callback()->( $self->_curr_path() );
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _process_current_actions
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
while ( my $action = $self->_next_action() )
|
||||
{
|
||||
my $status = $self->$action();
|
||||
|
||||
if ( $status ne "SKIP" )
|
||||
{
|
||||
return $status;
|
||||
}
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub _recurse
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
$self->_check_subdir()
|
||||
or return "SKIP";
|
||||
|
||||
push @{ $self->_dir_stack() },
|
||||
$self->_current(
|
||||
File::Find::Object::DeepPath->new( $self, $self->_current() ) );
|
||||
|
||||
$self->{_st} = 1;
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub _filter_wrapper
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
return defined( $self->filter() )
|
||||
? $self->filter()->( $self->_curr_path() )
|
||||
: 1;
|
||||
}
|
||||
|
||||
sub _check_subdir
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
# If current is not a directory always return 0, because we may
|
||||
# be asked to traverse single-files.
|
||||
|
||||
if ( $self->_curr_not_a_dir() )
|
||||
{
|
||||
return 0;
|
||||
}
|
||||
else
|
||||
{
|
||||
return $self->_check_subdir_h()->($self);
|
||||
}
|
||||
}
|
||||
|
||||
sub _warn_about_loop
|
||||
{
|
||||
my $self = shift;
|
||||
my $component_idx = shift;
|
||||
|
||||
# Don't pass strings directly to the format.
|
||||
# Instead - use %s
|
||||
# This was a security problem.
|
||||
warn(
|
||||
sprintf(
|
||||
"Avoid loop %s => %s\n",
|
||||
File::Spec->catdir(
|
||||
@{ $self->_curr_comps() }[ 0 .. $component_idx ]
|
||||
),
|
||||
$self->_curr_path(),
|
||||
)
|
||||
);
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub _is_loop
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
my $key = join( ",", @{ $self->_top_stat() }[ 0, 1 ] );
|
||||
my $lookup = $self->_current->_inodes;
|
||||
|
||||
if ( exists( $lookup->{$key} ) )
|
||||
{
|
||||
$self->_warn_about_loop( $lookup->{$key} );
|
||||
return 1;
|
||||
}
|
||||
else
|
||||
{
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
# We eval "" the helper of check_subdir because the conditions that
|
||||
# affect the checks are instance-wide and constant and so we can
|
||||
# determine how the code should look like.
|
||||
|
||||
sub _gen_check_subdir_helper
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
my @clauses;
|
||||
|
||||
if ( !$self->followlink() )
|
||||
{
|
||||
push @clauses, '$s->_top_is_link()';
|
||||
}
|
||||
|
||||
if ( $self->nocrossfs() )
|
||||
{
|
||||
push @clauses, '($s->_top_stat->[0] != $s->_dev())';
|
||||
}
|
||||
|
||||
push @clauses, '$s->_is_loop()';
|
||||
|
||||
$self->_check_subdir_h(
|
||||
_context_less_eval(
|
||||
'sub { my $s = shift; '
|
||||
. 'return ((!exists($s->{_st})) || !('
|
||||
. join( "||", @clauses ) . '));' . '}'
|
||||
)
|
||||
);
|
||||
}
|
||||
|
||||
sub _context_less_eval
|
||||
{
|
||||
## no critic
|
||||
my $code = shift;
|
||||
return eval $code;
|
||||
## use critic
|
||||
}
|
||||
|
||||
sub _open_dir
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
return $self->_current()->_component_open_dir( $self->_curr_path() );
|
||||
}
|
||||
|
||||
sub set_traverse_to
|
||||
{
|
||||
my ( $self, $children ) = @_;
|
||||
|
||||
# Make sure we scan the current directory for sub-items first.
|
||||
$self->get_current_node_files_list();
|
||||
|
||||
$self->_current->_traverse_to( [@$children] );
|
||||
}
|
||||
|
||||
sub get_traverse_to
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
return $self->_current->_traverse_to_copy();
|
||||
}
|
||||
|
||||
sub get_current_node_files_list
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
# _open_dir can return undef if $self->_current is not a directory.
|
||||
if ( $self->_open_dir() )
|
||||
{
|
||||
return $self->_current->_files_copy();
|
||||
}
|
||||
else
|
||||
{
|
||||
return [];
|
||||
}
|
||||
}
|
||||
|
||||
sub prune
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
return $self->set_traverse_to( [] );
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::Find::Object - An object oriented File::Find replacement
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.3.5
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use File::Find::Object;
|
||||
my $tree = File::Find::Object->new({}, @targets);
|
||||
|
||||
while (my $r = $tree->next()) {
|
||||
print $r ."\n";
|
||||
}
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
File::Find::Object does the same job as File::Find but works like an object
|
||||
and with an iterator. As File::Find is not object oriented, one cannot perform
|
||||
multiple searches in the same application. The second problem of File::Find
|
||||
is its file processing: after starting its main loop, one cannot easily wait
|
||||
for another event and so get the next result.
|
||||
|
||||
With File::Find::Object you can get the next file by calling the next()
|
||||
function, but setting a callback is still possible.
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
=head2 new
|
||||
|
||||
my $ffo = File::Find::Object->new( { options }, @targets);
|
||||
|
||||
Create a new File::Find::Object object. C<@targets> is the list of
|
||||
directories or files which the object should explore.
|
||||
|
||||
=head3 options
|
||||
|
||||
=over 4
|
||||
|
||||
=item depth
|
||||
|
||||
Boolean - returns the directory content before the directory itself.
|
||||
|
||||
=item nocrossfs
|
||||
|
||||
Boolean - doesn't continue on filesystems different than the parent.
|
||||
|
||||
=item followlink
|
||||
|
||||
Boolean - follow symlinks when they point to a directory.
|
||||
|
||||
You can safely set this option to true as File::Find::Object does not follow
|
||||
the link if it detects a loop.
|
||||
|
||||
=item filter
|
||||
|
||||
Function reference - should point to a function returning TRUE or FALSE. This
|
||||
function is called with the filename to filter, if the function return FALSE,
|
||||
the file is skipped.
|
||||
|
||||
=item callback
|
||||
|
||||
Function reference - should point to a function, which would be called each
|
||||
time a new file is returned. The function is called with the current filename
|
||||
as an argument.
|
||||
|
||||
=back
|
||||
|
||||
=head2 next
|
||||
|
||||
Returns the next file found by the File::Find::Object. It returns undef once
|
||||
the scan is completed.
|
||||
|
||||
=head2 item
|
||||
|
||||
Returns the current filename found by the File::Find::Object object, i.e: the
|
||||
last value returned by next().
|
||||
|
||||
=head2 next_obj
|
||||
|
||||
Like next() only returns the result as a convenient
|
||||
L<File::Find::Object::Result> object. C<< $ff->next() >> is equivalent to
|
||||
C<< $ff->next_obj()->path() >>.
|
||||
|
||||
=head2 item_obj
|
||||
|
||||
Like item() only returns the result as a convenient
|
||||
L<File::Find::Object::Result> object. C<< $ff->item() >> is equivalent to
|
||||
C<< $ff->item_obj()->path() >>.
|
||||
|
||||
=head2 $ff->set_traverse_to([@children])
|
||||
|
||||
Sets the children to traverse to from the current node. Useful for pruning
|
||||
items to traverse.
|
||||
|
||||
Accepts a single array reference.
|
||||
|
||||
Example:
|
||||
|
||||
$ff->set_traverse_to([ grep { ! /\A\./ } @{ $ff->get_traverse_to }]);
|
||||
|
||||
=head2 $ff->prune()
|
||||
|
||||
Prunes the current directory. Equivalent to $ff->set_traverse_to([]).
|
||||
|
||||
=head2 [@children] = $ff->get_traverse_to()
|
||||
|
||||
Retrieves the children that will be traversed to. Returns a single array
|
||||
reference.
|
||||
|
||||
(Example under C<set_traverse_to>).
|
||||
|
||||
=head2 [@files] = $ff->get_current_node_files_list()
|
||||
|
||||
Gets all the files that appear in the current directory. This value remains
|
||||
constant for every node, even after traversal or calls to C<set_traverse_to()>
|
||||
and is useful to use as the basis of the argument for C<set_traverse_to()>.
|
||||
|
||||
Returns a single array reference.
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
No bugs are known, but it doesn't mean there aren't any.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
There's an article about this module in the Perl Advent Calendar of 2006:
|
||||
L<http://perladvent.pm.org/2006/2/>.
|
||||
|
||||
L<File::Find> is the core module for traversing files in perl, which has
|
||||
several limitations.
|
||||
|
||||
L<File::Next>, L<File::Find::Iterator>, L<File::Walker> and the unmaintained
|
||||
L<File::FTS> are alternatives to this module.
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
Copyright (C) 2005, 2006 by Olivier Thauvin
|
||||
|
||||
This package is free software; you can redistribute it and/or modify it under
|
||||
the following terms:
|
||||
|
||||
1. The GNU General Public License Version 2.0 -
|
||||
http://www.opensource.org/licenses/gpl-license.php
|
||||
|
||||
2. The Artistic License Version 2.0 -
|
||||
http://www.perlfoundation.org/legal/licenses/artistic-2_0.html
|
||||
|
||||
3. At your option - any later version of either or both of these licenses.
|
||||
|
||||
=for :stopwords cpan testmatrix url bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
=head2 Websites
|
||||
|
||||
The following websites have more information about this module, and may be of help to you. As always,
|
||||
in addition to those websites please use your favorite search engine to discover more resources.
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
MetaCPAN
|
||||
|
||||
A modern, open-source CPAN search engine, useful to view POD in HTML format.
|
||||
|
||||
L<https://metacpan.org/release/File-Find-Object>
|
||||
|
||||
=item *
|
||||
|
||||
Search CPAN
|
||||
|
||||
The default CPAN search engine, useful to view POD in HTML format.
|
||||
|
||||
L<http://search.cpan.org/dist/File-Find-Object>
|
||||
|
||||
=item *
|
||||
|
||||
RT: CPAN's Bug Tracker
|
||||
|
||||
The RT ( Request Tracker ) website is the default bug/issue tracking system for CPAN.
|
||||
|
||||
L<https://rt.cpan.org/Public/Dist/Display.html?Name=File-Find-Object>
|
||||
|
||||
=item *
|
||||
|
||||
CPAN Ratings
|
||||
|
||||
The CPAN Ratings is a website that allows community ratings and reviews of Perl modules.
|
||||
|
||||
L<http://cpanratings.perl.org/d/File-Find-Object>
|
||||
|
||||
=item *
|
||||
|
||||
CPANTS
|
||||
|
||||
The CPANTS is a website that analyzes the Kwalitee ( code metrics ) of a distribution.
|
||||
|
||||
L<http://cpants.cpanauthors.org/dist/File-Find-Object>
|
||||
|
||||
=item *
|
||||
|
||||
CPAN Testers
|
||||
|
||||
The CPAN Testers is a network of smoke testers who run automated tests on uploaded CPAN distributions.
|
||||
|
||||
L<http://www.cpantesters.org/distro/F/File-Find-Object>
|
||||
|
||||
=item *
|
||||
|
||||
CPAN Testers Matrix
|
||||
|
||||
The CPAN Testers Matrix is a website that provides a visual overview of the test results for a distribution on various Perls/platforms.
|
||||
|
||||
L<http://matrix.cpantesters.org/?dist=File-Find-Object>
|
||||
|
||||
=item *
|
||||
|
||||
CPAN Testers Dependencies
|
||||
|
||||
The CPAN Testers Dependencies is a website that shows a chart of the test results of all dependencies for a distribution.
|
||||
|
||||
L<http://deps.cpantesters.org/?module=File::Find::Object>
|
||||
|
||||
=back
|
||||
|
||||
=head2 Bugs / Feature Requests
|
||||
|
||||
Please report any bugs or feature requests by email to C<bug-file-find-object at rt.cpan.org>, or through
|
||||
the web interface at L<https://rt.cpan.org/Public/Bug/Report.html?Queue=File-Find-Object>. You will be automatically notified of any
|
||||
progress on the request by the system.
|
||||
|
||||
=head2 Source Code
|
||||
|
||||
The code is open to the world, and available for you to hack on. Please feel free to browse it and play
|
||||
with it, or whatever. If you want to contribute patches, please send me a diff or prod me to pull
|
||||
from your repository :)
|
||||
|
||||
L<https://github.com/shlomif/perl-file-find-object>
|
||||
|
||||
git clone git://github.com/shlomif/perl-file-find-object.git
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Shlomi Fish <shlomif@cpan.org>
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
Please report any bugs or feature requests on the bugtracker website
|
||||
L<https://github.com/shlomif/perl-file-find-object/issues>
|
||||
|
||||
When submitting a bug or request, please include a test-file or a
|
||||
patch to an existing test-file that illustrates the bug or desired
|
||||
feature.
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is Copyright (c) 2000 by Olivier Thauvin and others.
|
||||
|
||||
This is free software, licensed under:
|
||||
|
||||
The Artistic License 2.0 (GPL Compatible)
|
||||
|
||||
=cut
|
||||
205
database/perl/lib/File/Find/Object/Base.pm
Normal file
205
database/perl/lib/File/Find/Object/Base.pm
Normal file
@@ -0,0 +1,205 @@
|
||||
package File::Find::Object::Base;
|
||||
$File::Find::Object::Base::VERSION = '0.3.5';
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use integer;
|
||||
|
||||
# TODO :
|
||||
# _last_dir_scanned should be defined only for ::PathComp , but we should
|
||||
# add a regression test to test it.
|
||||
#
|
||||
|
||||
use Class::XSAccessor accessors => {
|
||||
(
|
||||
map { $_ => $_ } (
|
||||
qw(
|
||||
_last_dir_scanned
|
||||
)
|
||||
)
|
||||
)
|
||||
};
|
||||
|
||||
use File::Spec;
|
||||
|
||||
# Create a _copy method that does a flat copy of an array returned by
|
||||
# a method as a reference.
|
||||
|
||||
sub _make_copy_methods
|
||||
{
|
||||
my ( $pkg, $methods ) = @_;
|
||||
|
||||
## no critic
|
||||
no strict 'refs';
|
||||
foreach my $method (@$methods)
|
||||
{
|
||||
*{ $pkg . "::" . $method . "_copy" } = do
|
||||
{
|
||||
my $m = $method;
|
||||
sub {
|
||||
my $self = shift;
|
||||
return [ @{ $self->$m(@_) } ];
|
||||
};
|
||||
};
|
||||
}
|
||||
## use critic
|
||||
return;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::Find::Object::Base - base class for File::Find::Object
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.3.5
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is the base class for F::F::O classes. It only defines some accessors,
|
||||
and is for File::Find::Object's internal use.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<File::Find::Object>
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
Copyright (C) 2005, 2006 by Olivier Thauvin
|
||||
|
||||
This package is free software; you can redistribute it and/or modify it under
|
||||
the following terms:
|
||||
|
||||
1. The GNU General Public License Version 2.0 -
|
||||
http://www.opensource.org/licenses/gpl-license.php
|
||||
|
||||
2. The Artistic License Version 2.0 -
|
||||
http://www.perlfoundation.org/legal/licenses/artistic-2_0.html
|
||||
|
||||
3. At your option - any later version of either or both of these licenses.
|
||||
|
||||
=for :stopwords cpan testmatrix url bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
=head2 Websites
|
||||
|
||||
The following websites have more information about this module, and may be of help to you. As always,
|
||||
in addition to those websites please use your favorite search engine to discover more resources.
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
MetaCPAN
|
||||
|
||||
A modern, open-source CPAN search engine, useful to view POD in HTML format.
|
||||
|
||||
L<https://metacpan.org/release/File-Find-Object>
|
||||
|
||||
=item *
|
||||
|
||||
Search CPAN
|
||||
|
||||
The default CPAN search engine, useful to view POD in HTML format.
|
||||
|
||||
L<http://search.cpan.org/dist/File-Find-Object>
|
||||
|
||||
=item *
|
||||
|
||||
RT: CPAN's Bug Tracker
|
||||
|
||||
The RT ( Request Tracker ) website is the default bug/issue tracking system for CPAN.
|
||||
|
||||
L<https://rt.cpan.org/Public/Dist/Display.html?Name=File-Find-Object>
|
||||
|
||||
=item *
|
||||
|
||||
CPAN Ratings
|
||||
|
||||
The CPAN Ratings is a website that allows community ratings and reviews of Perl modules.
|
||||
|
||||
L<http://cpanratings.perl.org/d/File-Find-Object>
|
||||
|
||||
=item *
|
||||
|
||||
CPANTS
|
||||
|
||||
The CPANTS is a website that analyzes the Kwalitee ( code metrics ) of a distribution.
|
||||
|
||||
L<http://cpants.cpanauthors.org/dist/File-Find-Object>
|
||||
|
||||
=item *
|
||||
|
||||
CPAN Testers
|
||||
|
||||
The CPAN Testers is a network of smoke testers who run automated tests on uploaded CPAN distributions.
|
||||
|
||||
L<http://www.cpantesters.org/distro/F/File-Find-Object>
|
||||
|
||||
=item *
|
||||
|
||||
CPAN Testers Matrix
|
||||
|
||||
The CPAN Testers Matrix is a website that provides a visual overview of the test results for a distribution on various Perls/platforms.
|
||||
|
||||
L<http://matrix.cpantesters.org/?dist=File-Find-Object>
|
||||
|
||||
=item *
|
||||
|
||||
CPAN Testers Dependencies
|
||||
|
||||
The CPAN Testers Dependencies is a website that shows a chart of the test results of all dependencies for a distribution.
|
||||
|
||||
L<http://deps.cpantesters.org/?module=File::Find::Object>
|
||||
|
||||
=back
|
||||
|
||||
=head2 Bugs / Feature Requests
|
||||
|
||||
Please report any bugs or feature requests by email to C<bug-file-find-object at rt.cpan.org>, or through
|
||||
the web interface at L<https://rt.cpan.org/Public/Bug/Report.html?Queue=File-Find-Object>. You will be automatically notified of any
|
||||
progress on the request by the system.
|
||||
|
||||
=head2 Source Code
|
||||
|
||||
The code is open to the world, and available for you to hack on. Please feel free to browse it and play
|
||||
with it, or whatever. If you want to contribute patches, please send me a diff or prod me to pull
|
||||
from your repository :)
|
||||
|
||||
L<https://github.com/shlomif/perl-file-find-object>
|
||||
|
||||
git clone git://github.com/shlomif/perl-file-find-object.git
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Shlomi Fish <shlomif@cpan.org>
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
Please report any bugs or feature requests on the bugtracker website
|
||||
L<https://github.com/shlomif/perl-file-find-object/issues>
|
||||
|
||||
When submitting a bug or request, please include a test-file or a
|
||||
patch to an existing test-file that illustrates the bug or desired
|
||||
feature.
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is Copyright (c) 2000 by Olivier Thauvin and others.
|
||||
|
||||
This is free software, licensed under:
|
||||
|
||||
The Artistic License 2.0 (GPL Compatible)
|
||||
|
||||
=cut
|
||||
291
database/perl/lib/File/Find/Object/PathComp.pm
Normal file
291
database/perl/lib/File/Find/Object/PathComp.pm
Normal file
@@ -0,0 +1,291 @@
|
||||
package File::Find::Object::PathComp;
|
||||
$File::Find::Object::PathComp::VERSION = '0.3.5';
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use integer;
|
||||
|
||||
use parent 'File::Find::Object::Base';
|
||||
|
||||
use Class::XSAccessor accessors => {
|
||||
(
|
||||
map { $_ => $_ } (
|
||||
qw(
|
||||
_actions
|
||||
_curr_file
|
||||
_files
|
||||
_last_dir_scanned
|
||||
_open_dir_ret
|
||||
_stat_ret
|
||||
_traverse_to
|
||||
)
|
||||
)
|
||||
)
|
||||
},
|
||||
getters => { _inodes => '_inodes' },
|
||||
setters => { _set_inodes => '_inodes' },
|
||||
;
|
||||
|
||||
use File::Spec;
|
||||
|
||||
__PACKAGE__->_make_copy_methods(
|
||||
[
|
||||
qw(
|
||||
_files
|
||||
_traverse_to
|
||||
)
|
||||
]
|
||||
);
|
||||
|
||||
sub _dev
|
||||
{
|
||||
return shift->_stat_ret->[0];
|
||||
}
|
||||
|
||||
sub _inode
|
||||
{
|
||||
return shift->_stat_ret->[1];
|
||||
}
|
||||
|
||||
sub _is_same_inode
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
# $st is an array ref with the return of perldoc -f stat .
|
||||
my $st = shift;
|
||||
|
||||
# On MS-Windows, all inodes in stat are returned as 0, so we need to
|
||||
# check that both inodes are not zero. This is why there's the
|
||||
# $self->_inode() != 0 check at the end.
|
||||
return ( $self->_dev() == $st->[0]
|
||||
&& $self->_inode() == $st->[1]
|
||||
&& $self->_inode() != 0 );
|
||||
}
|
||||
|
||||
sub _should_scan_dir
|
||||
{
|
||||
my $self = shift;
|
||||
my $dir_str = shift;
|
||||
|
||||
if ( defined( $self->_last_dir_scanned() )
|
||||
&& ( $self->_last_dir_scanned() eq $dir_str ) )
|
||||
{
|
||||
return;
|
||||
}
|
||||
else
|
||||
{
|
||||
$self->_last_dir_scanned($dir_str);
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
|
||||
sub _set_up_dir
|
||||
{
|
||||
my $self = shift;
|
||||
my $dir_str = shift;
|
||||
|
||||
$self->_files( $self->_calc_dir_files($dir_str) );
|
||||
|
||||
$self->_traverse_to( $self->_files_copy() );
|
||||
|
||||
return $self->_open_dir_ret(1);
|
||||
}
|
||||
|
||||
sub _calc_dir_files
|
||||
{
|
||||
my $self = shift;
|
||||
my $dir_str = shift;
|
||||
|
||||
my $handle;
|
||||
my @files;
|
||||
if ( !opendir( $handle, $dir_str ) )
|
||||
{
|
||||
# Handle this error gracefully.
|
||||
}
|
||||
else
|
||||
{
|
||||
@files =
|
||||
( sort { $a cmp $b } File::Spec->no_upwards( readdir($handle) ) );
|
||||
closedir($handle);
|
||||
}
|
||||
|
||||
return \@files;
|
||||
}
|
||||
|
||||
sub _component_open_dir
|
||||
{
|
||||
my $self = shift;
|
||||
my $dir_str = shift;
|
||||
|
||||
if ( !$self->_should_scan_dir($dir_str) )
|
||||
{
|
||||
return $self->_open_dir_ret();
|
||||
}
|
||||
|
||||
return $self->_set_up_dir($dir_str);
|
||||
}
|
||||
|
||||
sub _next_traverse_to
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
return shift( @{ $self->_traverse_to() } );
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::Find::Object::PathComp - base class for File::Find::Object's Path Components
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.3.5
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is the base class for F::F::O's path components. It only defines some
|
||||
accessors, and is for File::Find::Object's internal use.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<File::Find::Object>
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
Copyright (C) 2005, 2006 by Olivier Thauvin
|
||||
|
||||
This package is free software; you can redistribute it and/or modify it under
|
||||
the following terms:
|
||||
|
||||
1. The GNU General Public License Version 2.0 -
|
||||
http://www.opensource.org/licenses/gpl-license.php
|
||||
|
||||
2. The Artistic License Version 2.0 -
|
||||
http://www.perlfoundation.org/legal/licenses/artistic-2_0.html
|
||||
|
||||
3. At your option - any later version of either or both of these licenses.
|
||||
|
||||
=for :stopwords cpan testmatrix url bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
=head2 Websites
|
||||
|
||||
The following websites have more information about this module, and may be of help to you. As always,
|
||||
in addition to those websites please use your favorite search engine to discover more resources.
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
MetaCPAN
|
||||
|
||||
A modern, open-source CPAN search engine, useful to view POD in HTML format.
|
||||
|
||||
L<https://metacpan.org/release/File-Find-Object>
|
||||
|
||||
=item *
|
||||
|
||||
Search CPAN
|
||||
|
||||
The default CPAN search engine, useful to view POD in HTML format.
|
||||
|
||||
L<http://search.cpan.org/dist/File-Find-Object>
|
||||
|
||||
=item *
|
||||
|
||||
RT: CPAN's Bug Tracker
|
||||
|
||||
The RT ( Request Tracker ) website is the default bug/issue tracking system for CPAN.
|
||||
|
||||
L<https://rt.cpan.org/Public/Dist/Display.html?Name=File-Find-Object>
|
||||
|
||||
=item *
|
||||
|
||||
CPAN Ratings
|
||||
|
||||
The CPAN Ratings is a website that allows community ratings and reviews of Perl modules.
|
||||
|
||||
L<http://cpanratings.perl.org/d/File-Find-Object>
|
||||
|
||||
=item *
|
||||
|
||||
CPANTS
|
||||
|
||||
The CPANTS is a website that analyzes the Kwalitee ( code metrics ) of a distribution.
|
||||
|
||||
L<http://cpants.cpanauthors.org/dist/File-Find-Object>
|
||||
|
||||
=item *
|
||||
|
||||
CPAN Testers
|
||||
|
||||
The CPAN Testers is a network of smoke testers who run automated tests on uploaded CPAN distributions.
|
||||
|
||||
L<http://www.cpantesters.org/distro/F/File-Find-Object>
|
||||
|
||||
=item *
|
||||
|
||||
CPAN Testers Matrix
|
||||
|
||||
The CPAN Testers Matrix is a website that provides a visual overview of the test results for a distribution on various Perls/platforms.
|
||||
|
||||
L<http://matrix.cpantesters.org/?dist=File-Find-Object>
|
||||
|
||||
=item *
|
||||
|
||||
CPAN Testers Dependencies
|
||||
|
||||
The CPAN Testers Dependencies is a website that shows a chart of the test results of all dependencies for a distribution.
|
||||
|
||||
L<http://deps.cpantesters.org/?module=File::Find::Object>
|
||||
|
||||
=back
|
||||
|
||||
=head2 Bugs / Feature Requests
|
||||
|
||||
Please report any bugs or feature requests by email to C<bug-file-find-object at rt.cpan.org>, or through
|
||||
the web interface at L<https://rt.cpan.org/Public/Bug/Report.html?Queue=File-Find-Object>. You will be automatically notified of any
|
||||
progress on the request by the system.
|
||||
|
||||
=head2 Source Code
|
||||
|
||||
The code is open to the world, and available for you to hack on. Please feel free to browse it and play
|
||||
with it, or whatever. If you want to contribute patches, please send me a diff or prod me to pull
|
||||
from your repository :)
|
||||
|
||||
L<https://github.com/shlomif/perl-file-find-object>
|
||||
|
||||
git clone git://github.com/shlomif/perl-file-find-object.git
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Shlomi Fish <shlomif@cpan.org>
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
Please report any bugs or feature requests on the bugtracker website
|
||||
L<https://github.com/shlomif/perl-file-find-object/issues>
|
||||
|
||||
When submitting a bug or request, please include a test-file or a
|
||||
patch to an existing test-file that illustrates the bug or desired
|
||||
feature.
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is Copyright (c) 2000 by Olivier Thauvin and others.
|
||||
|
||||
This is free software, licensed under:
|
||||
|
||||
The Artistic License 2.0 (GPL Compatible)
|
||||
|
||||
=cut
|
||||
251
database/perl/lib/File/Find/Object/Result.pm
Normal file
251
database/perl/lib/File/Find/Object/Result.pm
Normal file
@@ -0,0 +1,251 @@
|
||||
package File::Find::Object::Result;
|
||||
$File::Find::Object::Result::VERSION = '0.3.5';
|
||||
use strict;
|
||||
use warnings;
|
||||
use integer;
|
||||
|
||||
use Class::XSAccessor accessors => {
|
||||
(
|
||||
map { $_ => $_ } (
|
||||
qw(
|
||||
base
|
||||
basename
|
||||
is_dir
|
||||
is_file
|
||||
is_link
|
||||
path
|
||||
dir_components
|
||||
stat_ret
|
||||
)
|
||||
)
|
||||
)
|
||||
};
|
||||
|
||||
use Fcntl qw(:mode);
|
||||
|
||||
sub new
|
||||
{
|
||||
my $class = shift;
|
||||
my $self = shift;
|
||||
|
||||
bless $self, $class;
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub full_components
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
return [
|
||||
@{ $self->dir_components() },
|
||||
( $self->is_dir() ? () : $self->basename() ),
|
||||
];
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::Find::Object::Result - a result class for File::Find::Object
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.3.5
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is a class returning a single L<File::Find::Object> result as returned
|
||||
by its next_obj() method.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 File::Find::Object::Result->new({%args});
|
||||
|
||||
Initializes a new object from %args. For internal use.
|
||||
|
||||
=head2 $result->base()
|
||||
|
||||
Returns the base directory from which searching began.
|
||||
|
||||
=head2 $result->path()
|
||||
|
||||
Returns the full path of the result. As such C<< $ffo->next_obj()->path() >>
|
||||
is equivalent to C<< $ffo->next() >> .
|
||||
|
||||
=head2 $result->is_dir()
|
||||
|
||||
Returns true if the result refers to a directory.
|
||||
|
||||
=head2 $result->is_file()
|
||||
|
||||
Returns true if the result refers to a plain file (equivalent to the Perl
|
||||
C<-f> operator).
|
||||
|
||||
=head2 $result->is_link()
|
||||
|
||||
Returns true if the result is a symbolic link.
|
||||
|
||||
=head2 $result->dir_components()
|
||||
|
||||
The components of the directory part of the path starting from base()
|
||||
(also the full path if the result is a directory) as an array reference.
|
||||
|
||||
=head2 $result->basename()
|
||||
|
||||
Returns the basename of the file (if it is a file and not a directory.)
|
||||
Otherwise - undef().
|
||||
|
||||
=head2 $result->full_components()
|
||||
|
||||
Returns the full components of the result with the basename if it is
|
||||
a file.
|
||||
|
||||
Returns a single array reference.
|
||||
|
||||
=head2 $result->stat_ret()
|
||||
|
||||
The return value of L<perlfunc/stat> for the result, placed
|
||||
inside an array reference. This is calculated by L<File::Find::Object> and
|
||||
kept here for convenience and for internal use.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<File::Find::Object>
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
Copyright (C) 2005, 2006 by Olivier Thauvin
|
||||
|
||||
This package is free software; you can redistribute it and/or modify it under
|
||||
the following terms:
|
||||
|
||||
1. The GNU General Public License Version 2.0 -
|
||||
http://www.opensource.org/licenses/gpl-license.php
|
||||
|
||||
2. The Artistic License Version 2.0 -
|
||||
http://www.perlfoundation.org/legal/licenses/artistic-2_0.html
|
||||
|
||||
3. At your option - any later version of either or both of these licenses.
|
||||
|
||||
=for :stopwords cpan testmatrix url bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
=head2 Websites
|
||||
|
||||
The following websites have more information about this module, and may be of help to you. As always,
|
||||
in addition to those websites please use your favorite search engine to discover more resources.
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
MetaCPAN
|
||||
|
||||
A modern, open-source CPAN search engine, useful to view POD in HTML format.
|
||||
|
||||
L<https://metacpan.org/release/File-Find-Object>
|
||||
|
||||
=item *
|
||||
|
||||
Search CPAN
|
||||
|
||||
The default CPAN search engine, useful to view POD in HTML format.
|
||||
|
||||
L<http://search.cpan.org/dist/File-Find-Object>
|
||||
|
||||
=item *
|
||||
|
||||
RT: CPAN's Bug Tracker
|
||||
|
||||
The RT ( Request Tracker ) website is the default bug/issue tracking system for CPAN.
|
||||
|
||||
L<https://rt.cpan.org/Public/Dist/Display.html?Name=File-Find-Object>
|
||||
|
||||
=item *
|
||||
|
||||
CPAN Ratings
|
||||
|
||||
The CPAN Ratings is a website that allows community ratings and reviews of Perl modules.
|
||||
|
||||
L<http://cpanratings.perl.org/d/File-Find-Object>
|
||||
|
||||
=item *
|
||||
|
||||
CPANTS
|
||||
|
||||
The CPANTS is a website that analyzes the Kwalitee ( code metrics ) of a distribution.
|
||||
|
||||
L<http://cpants.cpanauthors.org/dist/File-Find-Object>
|
||||
|
||||
=item *
|
||||
|
||||
CPAN Testers
|
||||
|
||||
The CPAN Testers is a network of smoke testers who run automated tests on uploaded CPAN distributions.
|
||||
|
||||
L<http://www.cpantesters.org/distro/F/File-Find-Object>
|
||||
|
||||
=item *
|
||||
|
||||
CPAN Testers Matrix
|
||||
|
||||
The CPAN Testers Matrix is a website that provides a visual overview of the test results for a distribution on various Perls/platforms.
|
||||
|
||||
L<http://matrix.cpantesters.org/?dist=File-Find-Object>
|
||||
|
||||
=item *
|
||||
|
||||
CPAN Testers Dependencies
|
||||
|
||||
The CPAN Testers Dependencies is a website that shows a chart of the test results of all dependencies for a distribution.
|
||||
|
||||
L<http://deps.cpantesters.org/?module=File::Find::Object>
|
||||
|
||||
=back
|
||||
|
||||
=head2 Bugs / Feature Requests
|
||||
|
||||
Please report any bugs or feature requests by email to C<bug-file-find-object at rt.cpan.org>, or through
|
||||
the web interface at L<https://rt.cpan.org/Public/Bug/Report.html?Queue=File-Find-Object>. You will be automatically notified of any
|
||||
progress on the request by the system.
|
||||
|
||||
=head2 Source Code
|
||||
|
||||
The code is open to the world, and available for you to hack on. Please feel free to browse it and play
|
||||
with it, or whatever. If you want to contribute patches, please send me a diff or prod me to pull
|
||||
from your repository :)
|
||||
|
||||
L<https://github.com/shlomif/perl-file-find-object>
|
||||
|
||||
git clone git://github.com/shlomif/perl-file-find-object.git
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Shlomi Fish <shlomif@cpan.org>
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
Please report any bugs or feature requests on the bugtracker website
|
||||
L<https://github.com/shlomif/perl-file-find-object/issues>
|
||||
|
||||
When submitting a bug or request, please include a test-file or a
|
||||
patch to an existing test-file that illustrates the bug or desired
|
||||
feature.
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is Copyright (c) 2000 by Olivier Thauvin and others.
|
||||
|
||||
This is free software, licensed under:
|
||||
|
||||
The Artistic License 2.0 (GPL Compatible)
|
||||
|
||||
=cut
|
||||
407
database/perl/lib/File/Glob.pm
Normal file
407
database/perl/lib/File/Glob.pm
Normal file
@@ -0,0 +1,407 @@
|
||||
package File::Glob;
|
||||
|
||||
use strict;
|
||||
our($VERSION, @ISA, @EXPORT_OK, @EXPORT_FAIL, %EXPORT_TAGS, $DEFAULT_FLAGS);
|
||||
|
||||
require XSLoader;
|
||||
|
||||
@ISA = qw(Exporter);
|
||||
|
||||
# NOTE: The glob() export is only here for compatibility with 5.6.0.
|
||||
# csh_glob() should not be used directly, unless you know what you're doing.
|
||||
|
||||
%EXPORT_TAGS = (
|
||||
'glob' => [ qw(
|
||||
GLOB_ABEND
|
||||
GLOB_ALPHASORT
|
||||
GLOB_ALTDIRFUNC
|
||||
GLOB_BRACE
|
||||
GLOB_CSH
|
||||
GLOB_ERR
|
||||
GLOB_ERROR
|
||||
GLOB_LIMIT
|
||||
GLOB_MARK
|
||||
GLOB_NOCASE
|
||||
GLOB_NOCHECK
|
||||
GLOB_NOMAGIC
|
||||
GLOB_NOSORT
|
||||
GLOB_NOSPACE
|
||||
GLOB_QUOTE
|
||||
GLOB_TILDE
|
||||
bsd_glob
|
||||
) ],
|
||||
);
|
||||
$EXPORT_TAGS{bsd_glob} = [@{$EXPORT_TAGS{glob}}];
|
||||
|
||||
@EXPORT_OK = (@{$EXPORT_TAGS{'glob'}}, 'csh_glob');
|
||||
|
||||
$VERSION = '1.33';
|
||||
|
||||
sub import {
|
||||
require Exporter;
|
||||
local $Exporter::ExportLevel = $Exporter::ExportLevel + 1;
|
||||
Exporter::import(grep {
|
||||
my $passthrough;
|
||||
if ($_ eq ':case') {
|
||||
$DEFAULT_FLAGS &= ~GLOB_NOCASE()
|
||||
}
|
||||
elsif ($_ eq ':nocase') {
|
||||
$DEFAULT_FLAGS |= GLOB_NOCASE();
|
||||
}
|
||||
elsif ($_ eq ':globally') {
|
||||
no warnings 'redefine';
|
||||
*CORE::GLOBAL::glob = \&File::Glob::csh_glob;
|
||||
}
|
||||
elsif ($_ eq ':bsd_glob') {
|
||||
no strict; *{caller."::glob"} = \&bsd_glob_override;
|
||||
$passthrough = 1;
|
||||
}
|
||||
else {
|
||||
$passthrough = 1;
|
||||
}
|
||||
$passthrough;
|
||||
} @_);
|
||||
}
|
||||
|
||||
XSLoader::load();
|
||||
|
||||
$DEFAULT_FLAGS = GLOB_CSH();
|
||||
if ($^O =~ /^(?:MSWin32|VMS|os2|dos|riscos)$/) {
|
||||
$DEFAULT_FLAGS |= GLOB_NOCASE();
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::Glob - Perl extension for BSD glob routine
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use File::Glob ':bsd_glob';
|
||||
|
||||
@list = bsd_glob('*.[ch]');
|
||||
$homedir = bsd_glob('~gnat', GLOB_TILDE | GLOB_ERR);
|
||||
|
||||
if (GLOB_ERROR) {
|
||||
# an error occurred reading $homedir
|
||||
}
|
||||
|
||||
## override the core glob (CORE::glob() does this automatically
|
||||
## by default anyway, since v5.6.0)
|
||||
use File::Glob ':globally';
|
||||
my @sources = <*.{c,h,y}>;
|
||||
|
||||
## override the core glob, forcing case sensitivity
|
||||
use File::Glob qw(:globally :case);
|
||||
my @sources = <*.{c,h,y}>;
|
||||
|
||||
## override the core glob forcing case insensitivity
|
||||
use File::Glob qw(:globally :nocase);
|
||||
my @sources = <*.{c,h,y}>;
|
||||
|
||||
## glob on all files in home directory
|
||||
use File::Glob ':globally';
|
||||
my @sources = <~gnat/*>;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The glob angle-bracket operator C<< <> >> is a pathname generator that
|
||||
implements the rules for file name pattern matching used by Unix-like shells
|
||||
such as the Bourne shell or C shell.
|
||||
|
||||
File::Glob::bsd_glob() implements the FreeBSD glob(3) routine, which is
|
||||
a superset of the POSIX glob() (described in IEEE Std 1003.2 "POSIX.2").
|
||||
bsd_glob() takes a mandatory C<pattern> argument, and an optional
|
||||
C<flags> argument, and returns a list of filenames matching the
|
||||
pattern, with interpretation of the pattern modified by the C<flags>
|
||||
variable.
|
||||
|
||||
Since v5.6.0, Perl's CORE::glob() is implemented in terms of bsd_glob().
|
||||
Note that they don't share the same prototype--CORE::glob() only accepts
|
||||
a single argument. Due to historical reasons, CORE::glob() will also
|
||||
split its argument on whitespace, treating it as multiple patterns,
|
||||
whereas bsd_glob() considers them as one pattern. But see C<:bsd_glob>
|
||||
under L</EXPORTS>, below.
|
||||
|
||||
=head2 META CHARACTERS
|
||||
|
||||
\ Quote the next metacharacter
|
||||
[] Character class
|
||||
{} Multiple pattern
|
||||
* Match any string of characters
|
||||
? Match any single character
|
||||
~ User name home directory
|
||||
|
||||
The metanotation C<a{b,c,d}e> is a shorthand for C<abe ace ade>. Left to
|
||||
right order is preserved, with results of matches being sorted separately
|
||||
at a low level to preserve this order. As a special case C<{>, C<}>, and
|
||||
C<{}> are passed undisturbed.
|
||||
|
||||
=head2 EXPORTS
|
||||
|
||||
See also the L</POSIX FLAGS> below, which can be exported individually.
|
||||
|
||||
=head3 C<:bsd_glob>
|
||||
|
||||
The C<:bsd_glob> export tag exports bsd_glob() and the constants listed
|
||||
below. It also overrides glob() in the calling package with one that
|
||||
behaves like bsd_glob() with regard to spaces (the space is treated as part
|
||||
of a file name), but supports iteration in scalar context; i.e., it
|
||||
preserves the core function's feature of returning the next item each time
|
||||
it is called.
|
||||
|
||||
=head3 C<:glob>
|
||||
|
||||
The C<:glob> tag, now discouraged, is the old version of C<:bsd_glob>. It
|
||||
exports the same constants and functions, but its glob() override does not
|
||||
support iteration; it returns the last file name in scalar context. That
|
||||
means this will loop forever:
|
||||
|
||||
use File::Glob ':glob';
|
||||
while (my $file = <* copy.txt>) {
|
||||
...
|
||||
}
|
||||
|
||||
=head3 C<bsd_glob>
|
||||
|
||||
This function, which is included in the two export tags listed above,
|
||||
takes one or two arguments. The first is the glob pattern. The
|
||||
second, if given, is a set of flags ORed together. The available
|
||||
flags and the default set of flags are listed below under L</POSIX FLAGS>.
|
||||
|
||||
Remember that to use the named constants for flags you must import
|
||||
them, for example with C<:bsd_glob> described above. If not imported,
|
||||
and C<use strict> is not in effect, then the constants will be
|
||||
treated as bareword strings, which won't do what you what.
|
||||
|
||||
|
||||
=head3 C<:nocase> and C<:case>
|
||||
|
||||
These two export tags globally modify the default flags that bsd_glob()
|
||||
and, except on VMS, Perl's built-in C<glob> operator use. C<GLOB_NOCASE>
|
||||
is turned on or off, respectively.
|
||||
|
||||
=head3 C<csh_glob>
|
||||
|
||||
The csh_glob() function can also be exported, but you should not use it
|
||||
directly unless you really know what you are doing. It splits the pattern
|
||||
into words and feeds each one to bsd_glob(). Perl's own glob() function
|
||||
uses this internally.
|
||||
|
||||
=head2 POSIX FLAGS
|
||||
|
||||
If no flags argument is give then C<GLOB_CSH> is set, and on VMS and
|
||||
Windows systems, C<GLOB_NOCASE> too. Otherwise the flags to use are
|
||||
determined solely by the flags argument. The POSIX defined flags are:
|
||||
|
||||
=over 4
|
||||
|
||||
=item C<GLOB_ERR>
|
||||
|
||||
Force bsd_glob() to return an error when it encounters a directory it
|
||||
cannot open or read. Ordinarily bsd_glob() continues to find matches.
|
||||
|
||||
=item C<GLOB_LIMIT>
|
||||
|
||||
Make bsd_glob() return an error (GLOB_NOSPACE) when the pattern expands
|
||||
to a size bigger than the system constant C<ARG_MAX> (usually found in
|
||||
limits.h). If your system does not define this constant, bsd_glob() uses
|
||||
C<sysconf(_SC_ARG_MAX)> or C<_POSIX_ARG_MAX> where available (in that
|
||||
order). You can inspect these values using the standard C<POSIX>
|
||||
extension.
|
||||
|
||||
=item C<GLOB_MARK>
|
||||
|
||||
Each pathname that is a directory that matches the pattern has a slash
|
||||
appended.
|
||||
|
||||
=item C<GLOB_NOCASE>
|
||||
|
||||
By default, file names are assumed to be case sensitive; this flag
|
||||
makes bsd_glob() treat case differences as not significant.
|
||||
|
||||
=item C<GLOB_NOCHECK>
|
||||
|
||||
If the pattern does not match any pathname, then bsd_glob() returns a list
|
||||
consisting of only the pattern. If C<GLOB_QUOTE> is set, its effect
|
||||
is present in the pattern returned.
|
||||
|
||||
=item C<GLOB_NOSORT>
|
||||
|
||||
By default, the pathnames are sorted in ascending ASCII order; this
|
||||
flag prevents that sorting (speeding up bsd_glob()).
|
||||
|
||||
=back
|
||||
|
||||
The FreeBSD extensions to the POSIX standard are the following flags:
|
||||
|
||||
=over 4
|
||||
|
||||
=item C<GLOB_BRACE>
|
||||
|
||||
Pre-process the string to expand C<{pat,pat,...}> strings like csh(1).
|
||||
The pattern '{}' is left unexpanded for historical reasons (and csh(1)
|
||||
does the same thing to ease typing of find(1) patterns).
|
||||
|
||||
=item C<GLOB_NOMAGIC>
|
||||
|
||||
Same as C<GLOB_NOCHECK> but it only returns the pattern if it does not
|
||||
contain any of the special characters "*", "?" or "[". C<NOMAGIC> is
|
||||
provided to simplify implementing the historic csh(1) globbing
|
||||
behaviour and should probably not be used anywhere else.
|
||||
|
||||
=item C<GLOB_QUOTE>
|
||||
|
||||
Use the backslash ('\') character for quoting: every occurrence of a
|
||||
backslash followed by a character in the pattern is replaced by that
|
||||
character, avoiding any special interpretation of the character.
|
||||
(But see below for exceptions on DOSISH systems).
|
||||
|
||||
=item C<GLOB_TILDE>
|
||||
|
||||
Expand patterns that start with '~' to user name home directories.
|
||||
|
||||
=item C<GLOB_CSH>
|
||||
|
||||
For convenience, C<GLOB_CSH> is a synonym for
|
||||
C<GLOB_BRACE | GLOB_NOMAGIC | GLOB_QUOTE | GLOB_TILDE | GLOB_ALPHASORT>.
|
||||
|
||||
=back
|
||||
|
||||
The POSIX provided C<GLOB_APPEND>, C<GLOB_DOOFFS>, and the FreeBSD
|
||||
extensions C<GLOB_ALTDIRFUNC>, and C<GLOB_MAGCHAR> flags have not been
|
||||
implemented in the Perl version because they involve more complex
|
||||
interaction with the underlying C structures.
|
||||
|
||||
The following flag has been added in the Perl implementation for
|
||||
csh compatibility:
|
||||
|
||||
=over 4
|
||||
|
||||
=item C<GLOB_ALPHASORT>
|
||||
|
||||
If C<GLOB_NOSORT> is not in effect, sort filenames is alphabetical
|
||||
order (case does not matter) rather than in ASCII order.
|
||||
|
||||
=back
|
||||
|
||||
=head1 DIAGNOSTICS
|
||||
|
||||
bsd_glob() returns a list of matching paths, possibly zero length. If an
|
||||
error occurred, &File::Glob::GLOB_ERROR will be non-zero and C<$!> will be
|
||||
set. &File::Glob::GLOB_ERROR is guaranteed to be zero if no error occurred,
|
||||
or one of the following values otherwise:
|
||||
|
||||
=over 4
|
||||
|
||||
=item C<GLOB_NOSPACE>
|
||||
|
||||
An attempt to allocate memory failed.
|
||||
|
||||
=item C<GLOB_ABEND>
|
||||
|
||||
The glob was stopped because an error was encountered.
|
||||
|
||||
=back
|
||||
|
||||
In the case where bsd_glob() has found some matching paths, but is
|
||||
interrupted by an error, it will return a list of filenames B<and>
|
||||
set &File::Glob::ERROR.
|
||||
|
||||
Note that bsd_glob() deviates from POSIX and FreeBSD glob(3) behaviour
|
||||
by not considering C<ENOENT> and C<ENOTDIR> as errors - bsd_glob() will
|
||||
continue processing despite those errors, unless the C<GLOB_ERR> flag is
|
||||
set.
|
||||
|
||||
Be aware that all filenames returned from File::Glob are tainted.
|
||||
|
||||
=head1 NOTES
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
If you want to use multiple patterns, e.g. C<bsd_glob("a* b*")>, you should
|
||||
probably throw them in a set as in C<bsd_glob("{a*,b*}")>. This is because
|
||||
the argument to bsd_glob() isn't subjected to parsing by the C shell.
|
||||
Remember that you can use a backslash to escape things.
|
||||
|
||||
=item *
|
||||
|
||||
On DOSISH systems, backslash is a valid directory separator character.
|
||||
In this case, use of backslash as a quoting character (via GLOB_QUOTE)
|
||||
interferes with the use of backslash as a directory separator. The
|
||||
best (simplest, most portable) solution is to use forward slashes for
|
||||
directory separators, and backslashes for quoting. However, this does
|
||||
not match "normal practice" on these systems. As a concession to user
|
||||
expectation, therefore, backslashes (under GLOB_QUOTE) only quote the
|
||||
glob metacharacters '[', ']', '{', '}', '-', '~', and backslash itself.
|
||||
All other backslashes are passed through unchanged.
|
||||
|
||||
=item *
|
||||
|
||||
Win32 users should use the real slash. If you really want to use
|
||||
backslashes, consider using Sarathy's File::DosGlob, which comes with
|
||||
the standard Perl distribution.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<perlfunc/glob>, glob(3)
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
The Perl interface was written by Nathan Torkington E<lt>gnat@frii.comE<gt>,
|
||||
and is released under the artistic license. Further modifications were
|
||||
made by Greg Bacon E<lt>gbacon@cs.uah.eduE<gt>, Gurusamy Sarathy
|
||||
E<lt>gsar@activestate.comE<gt>, and Thomas Wegner
|
||||
E<lt>wegner_thomas@yahoo.comE<gt>. The C glob code has the
|
||||
following copyright:
|
||||
|
||||
Copyright (c) 1989, 1993 The Regents of the University of California.
|
||||
All rights reserved.
|
||||
|
||||
This code is derived from software contributed to Berkeley by
|
||||
Guido van Rossum.
|
||||
|
||||
Redistribution and use in source and binary forms, with or without
|
||||
modification, are permitted provided that the following conditions
|
||||
are met:
|
||||
|
||||
=over 4
|
||||
|
||||
=item 1.
|
||||
|
||||
Redistributions of source code must retain the above copyright
|
||||
notice, this list of conditions and the following disclaimer.
|
||||
|
||||
=item 2.
|
||||
|
||||
Redistributions in binary form must reproduce the above copyright
|
||||
notice, this list of conditions and the following disclaimer in the
|
||||
documentation and/or other materials provided with the distribution.
|
||||
|
||||
=item 3.
|
||||
|
||||
Neither the name of the University nor the names of its contributors
|
||||
may be used to endorse or promote products derived from this software
|
||||
without specific prior written permission.
|
||||
|
||||
=back
|
||||
|
||||
THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS "AS IS" AND
|
||||
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
||||
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
||||
ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
|
||||
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
||||
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
|
||||
OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
|
||||
HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
|
||||
LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
|
||||
OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
|
||||
SUCH DAMAGE.
|
||||
|
||||
=cut
|
||||
679
database/perl/lib/File/GlobMapper.pm
Normal file
679
database/perl/lib/File/GlobMapper.pm
Normal file
@@ -0,0 +1,679 @@
|
||||
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 = File::GlobMapper->new($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 = File::GlobMapper->new( $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.
|
||||
1287
database/perl/lib/File/Path.pm
Normal file
1287
database/perl/lib/File/Path.pm
Normal file
File diff suppressed because it is too large
Load Diff
341
database/perl/lib/File/Spec.pm
Normal file
341
database/perl/lib/File/Spec.pm
Normal file
@@ -0,0 +1,341 @@
|
||||
package File::Spec;
|
||||
|
||||
use strict;
|
||||
|
||||
our $VERSION = '3.78';
|
||||
$VERSION =~ tr/_//d;
|
||||
|
||||
my %module = (
|
||||
MSWin32 => 'Win32',
|
||||
os2 => 'OS2',
|
||||
VMS => 'VMS',
|
||||
NetWare => 'Win32', # Yes, File::Spec::Win32 works on NetWare.
|
||||
symbian => 'Win32', # Yes, File::Spec::Win32 works on symbian.
|
||||
dos => 'OS2', # Yes, File::Spec::OS2 works on DJGPP.
|
||||
cygwin => 'Cygwin',
|
||||
amigaos => 'AmigaOS');
|
||||
|
||||
|
||||
my $module = $module{$^O} || 'Unix';
|
||||
|
||||
require "File/Spec/$module.pm";
|
||||
our @ISA = ("File::Spec::$module");
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::Spec - portably perform operations on file names
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use File::Spec;
|
||||
|
||||
$x=File::Spec->catfile('a', 'b', 'c');
|
||||
|
||||
which returns 'a/b/c' under Unix. Or:
|
||||
|
||||
use File::Spec::Functions;
|
||||
|
||||
$x = catfile('a', 'b', 'c');
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module is designed to support operations commonly performed on file
|
||||
specifications (usually called "file names", but not to be confused with the
|
||||
contents of a file, or Perl's file handles), such as concatenating several
|
||||
directory and file names into a single path, or determining whether a path
|
||||
is rooted. It is based on code directly taken from MakeMaker 5.17, code
|
||||
written by Andreas KE<ouml>nig, Andy Dougherty, Charles Bailey, Ilya
|
||||
Zakharevich, Paul Schinder, and others.
|
||||
|
||||
Since these functions are different for most operating systems, each set of
|
||||
OS specific routines is available in a separate module, including:
|
||||
|
||||
File::Spec::Unix
|
||||
File::Spec::Mac
|
||||
File::Spec::OS2
|
||||
File::Spec::Win32
|
||||
File::Spec::VMS
|
||||
|
||||
The module appropriate for the current OS is automatically loaded by
|
||||
File::Spec. Since some modules (like VMS) make use of facilities available
|
||||
only under that OS, it may not be possible to load all modules under all
|
||||
operating systems.
|
||||
|
||||
Since File::Spec is object oriented, subroutines should not be called directly,
|
||||
as in:
|
||||
|
||||
File::Spec::catfile('a','b');
|
||||
|
||||
but rather as class methods:
|
||||
|
||||
File::Spec->catfile('a','b');
|
||||
|
||||
For simple uses, L<File::Spec::Functions> provides convenient functional
|
||||
forms of these methods.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over 2
|
||||
|
||||
=item canonpath
|
||||
X<canonpath>
|
||||
|
||||
No physical check on the filesystem, but a logical cleanup of a
|
||||
path.
|
||||
|
||||
$cpath = File::Spec->canonpath( $path ) ;
|
||||
|
||||
Note that this does *not* collapse F<x/../y> sections into F<y>. This
|
||||
is by design. If F</foo> on your system is a symlink to F</bar/baz>,
|
||||
then F</foo/../quux> is actually F</bar/quux>, not F</quux> as a naive
|
||||
F<../>-removal would give you. If you want to do this kind of
|
||||
processing, you probably want C<Cwd>'s C<realpath()> function to
|
||||
actually traverse the filesystem cleaning up paths like this.
|
||||
|
||||
=item catdir
|
||||
X<catdir>
|
||||
|
||||
Concatenate two or more directory names to form a complete path ending
|
||||
with a directory. But remove the trailing slash from the resulting
|
||||
string, because it doesn't look good, isn't necessary and confuses
|
||||
OS/2. Of course, if this is the root directory, don't cut off the
|
||||
trailing slash :-)
|
||||
|
||||
$path = File::Spec->catdir( @directories );
|
||||
|
||||
=item catfile
|
||||
X<catfile>
|
||||
|
||||
Concatenate one or more directory names and a filename to form a
|
||||
complete path ending with a filename
|
||||
|
||||
$path = File::Spec->catfile( @directories, $filename );
|
||||
|
||||
=item curdir
|
||||
X<curdir>
|
||||
|
||||
Returns a string representation of the current directory.
|
||||
|
||||
$curdir = File::Spec->curdir();
|
||||
|
||||
=item devnull
|
||||
X<devnull>
|
||||
|
||||
Returns a string representation of the null device.
|
||||
|
||||
$devnull = File::Spec->devnull();
|
||||
|
||||
=item rootdir
|
||||
X<rootdir>
|
||||
|
||||
Returns a string representation of the root directory.
|
||||
|
||||
$rootdir = File::Spec->rootdir();
|
||||
|
||||
=item tmpdir
|
||||
X<tmpdir>
|
||||
|
||||
Returns a string representation of the first writable directory from a
|
||||
list of possible temporary directories. Returns the current directory
|
||||
if no writable temporary directories are found. The list of directories
|
||||
checked depends on the platform; e.g. File::Spec::Unix checks C<$ENV{TMPDIR}>
|
||||
(unless taint is on) and F</tmp>.
|
||||
|
||||
$tmpdir = File::Spec->tmpdir();
|
||||
|
||||
=item updir
|
||||
X<updir>
|
||||
|
||||
Returns a string representation of the parent directory.
|
||||
|
||||
$updir = File::Spec->updir();
|
||||
|
||||
=item no_upwards
|
||||
|
||||
Given a list of files in a directory (such as from C<readdir()>),
|
||||
strip out C<'.'> and C<'..'>.
|
||||
|
||||
B<SECURITY NOTE:> This does NOT filter paths containing C<'..'>, like
|
||||
C<'../../../../etc/passwd'>, only literal matches to C<'.'> and C<'..'>.
|
||||
|
||||
@paths = File::Spec->no_upwards( readdir $dirhandle );
|
||||
|
||||
=item case_tolerant
|
||||
|
||||
Returns a true or false value indicating, respectively, that alphabetic
|
||||
case is not or is significant when comparing file specifications.
|
||||
Cygwin and Win32 accept an optional drive argument.
|
||||
|
||||
$is_case_tolerant = File::Spec->case_tolerant();
|
||||
|
||||
=item file_name_is_absolute
|
||||
|
||||
Takes as its argument a path, and returns true if it is an absolute path.
|
||||
|
||||
$is_absolute = File::Spec->file_name_is_absolute( $path );
|
||||
|
||||
This does not consult the local filesystem on Unix, Win32, OS/2, or
|
||||
Mac OS (Classic). It does consult the working environment for VMS
|
||||
(see L<File::Spec::VMS/file_name_is_absolute>).
|
||||
|
||||
=item path
|
||||
X<path>
|
||||
|
||||
Takes no argument. Returns the environment variable C<PATH> (or the local
|
||||
platform's equivalent) as a list.
|
||||
|
||||
@PATH = File::Spec->path();
|
||||
|
||||
=item join
|
||||
X<join, path>
|
||||
|
||||
join is the same as catfile.
|
||||
|
||||
=item splitpath
|
||||
X<splitpath> X<split, path>
|
||||
|
||||
Splits a path in to volume, directory, and filename portions. On systems
|
||||
with no concept of volume, returns '' for volume.
|
||||
|
||||
($volume,$directories,$file) =
|
||||
File::Spec->splitpath( $path );
|
||||
($volume,$directories,$file) =
|
||||
File::Spec->splitpath( $path, $no_file );
|
||||
|
||||
For systems with no syntax differentiating filenames from directories,
|
||||
assumes that the last file is a path unless C<$no_file> is true or a
|
||||
trailing separator or F</.> or F</..> is present. On Unix, this means that C<$no_file>
|
||||
true makes this return ( '', $path, '' ).
|
||||
|
||||
The directory portion may or may not be returned with a trailing '/'.
|
||||
|
||||
The results can be passed to L</catpath()> to get back a path equivalent to
|
||||
(usually identical to) the original path.
|
||||
|
||||
=item splitdir
|
||||
X<splitdir> X<split, dir>
|
||||
|
||||
The opposite of L</catdir>.
|
||||
|
||||
@dirs = File::Spec->splitdir( $directories );
|
||||
|
||||
C<$directories> must be only the directory portion of the path on systems
|
||||
that have the concept of a volume or that have path syntax that differentiates
|
||||
files from directories.
|
||||
|
||||
Unlike just splitting the directories on the separator, empty
|
||||
directory names (C<''>) can be returned, because these are significant
|
||||
on some OSes.
|
||||
|
||||
=item catpath()
|
||||
|
||||
Takes volume, directory and file portions and returns an entire path. Under
|
||||
Unix, C<$volume> is ignored, and directory and file are concatenated. A '/' is
|
||||
inserted if need be. On other OSes, C<$volume> is significant.
|
||||
|
||||
$full_path = File::Spec->catpath( $volume, $directory, $file );
|
||||
|
||||
=item abs2rel
|
||||
X<abs2rel> X<absolute, path> X<relative, path>
|
||||
|
||||
Takes a destination path and an optional base path returns a relative path
|
||||
from the base path to the destination path:
|
||||
|
||||
$rel_path = File::Spec->abs2rel( $path ) ;
|
||||
$rel_path = File::Spec->abs2rel( $path, $base ) ;
|
||||
|
||||
If C<$base> is not present or '', then L<Cwd::cwd()|Cwd> is used. If C<$base> is
|
||||
relative, then it is converted to absolute form using
|
||||
L</rel2abs()>. This means that it is taken to be relative to
|
||||
L<Cwd::cwd()|Cwd>.
|
||||
|
||||
On systems with the concept of volume, if C<$path> and C<$base> appear to be
|
||||
on two different volumes, we will not attempt to resolve the two
|
||||
paths, and we will instead simply return C<$path>. Note that previous
|
||||
versions of this module ignored the volume of C<$base>, which resulted in
|
||||
garbage results part of the time.
|
||||
|
||||
On systems that have a grammar that indicates filenames, this ignores the
|
||||
C<$base> filename as well. Otherwise all path components are assumed to be
|
||||
directories.
|
||||
|
||||
If C<$path> is relative, it is converted to absolute form using L</rel2abs()>.
|
||||
This means that it is taken to be relative to L<Cwd::cwd()|Cwd>.
|
||||
|
||||
No checks against the filesystem are made. On VMS, there is
|
||||
interaction with the working environment, as logicals and
|
||||
macros are expanded.
|
||||
|
||||
Based on code written by Shigio Yamaguchi.
|
||||
|
||||
=item rel2abs()
|
||||
X<rel2abs> X<absolute, path> X<relative, path>
|
||||
|
||||
Converts a relative path to an absolute path.
|
||||
|
||||
$abs_path = File::Spec->rel2abs( $path ) ;
|
||||
$abs_path = File::Spec->rel2abs( $path, $base ) ;
|
||||
|
||||
If C<$base> is not present or '', then L<Cwd::cwd()|Cwd> is used. If C<$base> is relative,
|
||||
then it is converted to absolute form using L</rel2abs()>. This means that it
|
||||
is taken to be relative to L<Cwd::cwd()|Cwd>.
|
||||
|
||||
On systems with the concept of volume, if C<$path> and C<$base> appear to be
|
||||
on two different volumes, we will not attempt to resolve the two
|
||||
paths, and we will instead simply return C<$path>. Note that previous
|
||||
versions of this module ignored the volume of C<$base>, which resulted in
|
||||
garbage results part of the time.
|
||||
|
||||
On systems that have a grammar that indicates filenames, this ignores the
|
||||
C<$base> filename as well. Otherwise all path components are assumed to be
|
||||
directories.
|
||||
|
||||
If C<$path> is absolute, it is cleaned up and returned using L</canonpath>.
|
||||
|
||||
No checks against the filesystem are made. On VMS, there is
|
||||
interaction with the working environment, as logicals and
|
||||
macros are expanded.
|
||||
|
||||
Based on code written by Shigio Yamaguchi.
|
||||
|
||||
=back
|
||||
|
||||
For further information, please see L<File::Spec::Unix>,
|
||||
L<File::Spec::Mac>, L<File::Spec::OS2>, L<File::Spec::Win32>, or
|
||||
L<File::Spec::VMS>.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<File::Spec::Unix>, L<File::Spec::Mac>, L<File::Spec::OS2>,
|
||||
L<File::Spec::Win32>, L<File::Spec::VMS>, L<File::Spec::Functions>,
|
||||
L<ExtUtils::MakeMaker>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Currently maintained by Ken Williams C<< <KWILLIAMS@cpan.org> >>.
|
||||
|
||||
The vast majority of the code was written by
|
||||
Kenneth Albanowski C<< <kjahds@kjahds.com> >>,
|
||||
Andy Dougherty C<< <doughera@lafayette.edu> >>,
|
||||
Andreas KE<ouml>nig C<< <A.Koenig@franz.ww.TU-Berlin.DE> >>,
|
||||
Tim Bunce C<< <Tim.Bunce@ig.co.uk> >>.
|
||||
VMS support by Charles Bailey C<< <bailey@newman.upenn.edu> >>.
|
||||
OS/2 support by Ilya Zakharevich C<< <ilya@math.ohio-state.edu> >>.
|
||||
Mac support by Paul Schinder C<< <schinder@pobox.com> >>, and
|
||||
Thomas Wegner C<< <wegner_thomas@yahoo.com> >>.
|
||||
abs2rel() and rel2abs() written by Shigio Yamaguchi C<< <shigio@tamacom.com> >>,
|
||||
modified by Barrie Slaymaker C<< <barries@slaysys.com> >>.
|
||||
splitpath(), splitdir(), catpath() and catdir() by Barrie Slaymaker.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004-2013 by the Perl 5 Porters. All rights reserved.
|
||||
|
||||
This program is free software; you can redistribute it and/or modify
|
||||
it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
61
database/perl/lib/File/Spec/AmigaOS.pm
Normal file
61
database/perl/lib/File/Spec/AmigaOS.pm
Normal file
@@ -0,0 +1,61 @@
|
||||
package File::Spec::AmigaOS;
|
||||
|
||||
use strict;
|
||||
require File::Spec::Unix;
|
||||
|
||||
our $VERSION = '3.78';
|
||||
$VERSION =~ tr/_//d;
|
||||
|
||||
our @ISA = qw(File::Spec::Unix);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::Spec::AmigaOS - File::Spec for AmigaOS
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
require File::Spec::AmigaOS; # Done automatically by File::Spec
|
||||
# if needed
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Methods for manipulating file specifications.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over 2
|
||||
|
||||
=item tmpdir
|
||||
|
||||
Returns $ENV{TMPDIR} or if that is unset, "/t".
|
||||
|
||||
=cut
|
||||
|
||||
my $tmpdir;
|
||||
sub tmpdir {
|
||||
return $tmpdir if defined $tmpdir;
|
||||
$tmpdir = $_[0]->_tmpdir( $ENV{TMPDIR}, "/t" );
|
||||
}
|
||||
|
||||
=item file_name_is_absolute
|
||||
|
||||
Returns true if there's a colon in the file name,
|
||||
or if it begins with a slash.
|
||||
|
||||
=cut
|
||||
|
||||
sub file_name_is_absolute {
|
||||
my ($self, $file) = @_;
|
||||
|
||||
# Not 100% robust as a "/" must not preceded a ":"
|
||||
# but this cannot happen in a well formed path.
|
||||
return $file =~ m{^/|:}s;
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
All the other methods are from L<File::Spec::Unix>.
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
163
database/perl/lib/File/Spec/Cygwin.pm
Normal file
163
database/perl/lib/File/Spec/Cygwin.pm
Normal file
@@ -0,0 +1,163 @@
|
||||
package File::Spec::Cygwin;
|
||||
|
||||
use strict;
|
||||
require File::Spec::Unix;
|
||||
|
||||
our $VERSION = '3.78';
|
||||
$VERSION =~ tr/_//d;
|
||||
|
||||
our @ISA = qw(File::Spec::Unix);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::Spec::Cygwin - methods for Cygwin file specs
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
require File::Spec::Cygwin; # Done internally by File::Spec if needed
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
|
||||
implementation of these methods, not the semantics.
|
||||
|
||||
This module is still in beta. Cygwin-knowledgeable folks are invited
|
||||
to offer patches and suggestions.
|
||||
|
||||
=cut
|
||||
|
||||
=pod
|
||||
|
||||
=over 4
|
||||
|
||||
=item canonpath
|
||||
|
||||
Any C<\> (backslashes) are converted to C</> (forward slashes),
|
||||
and then File::Spec::Unix canonpath() is called on the result.
|
||||
|
||||
=cut
|
||||
|
||||
sub canonpath {
|
||||
my($self,$path) = @_;
|
||||
return unless defined $path;
|
||||
|
||||
$path =~ s|\\|/|g;
|
||||
|
||||
# Handle network path names beginning with double slash
|
||||
my $node = '';
|
||||
if ( $path =~ s@^(//[^/]+)(?:/|\z)@/@s ) {
|
||||
$node = $1;
|
||||
}
|
||||
return $node . $self->SUPER::canonpath($path);
|
||||
}
|
||||
|
||||
sub catdir {
|
||||
my $self = shift;
|
||||
return unless @_;
|
||||
|
||||
# Don't create something that looks like a //network/path
|
||||
if ($_[0] and ($_[0] eq '/' or $_[0] eq '\\')) {
|
||||
shift;
|
||||
return $self->SUPER::catdir('', @_);
|
||||
}
|
||||
|
||||
$self->SUPER::catdir(@_);
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=item file_name_is_absolute
|
||||
|
||||
True is returned if the file name begins with C<drive_letter:>,
|
||||
and if not, File::Spec::Unix file_name_is_absolute() is called.
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
sub file_name_is_absolute {
|
||||
my ($self,$file) = @_;
|
||||
return 1 if $file =~ m{^([a-z]:)?[\\/]}is; # C:/test
|
||||
return $self->SUPER::file_name_is_absolute($file);
|
||||
}
|
||||
|
||||
=item tmpdir (override)
|
||||
|
||||
Returns a string representation of the first existing directory
|
||||
from the following list:
|
||||
|
||||
$ENV{TMPDIR}
|
||||
/tmp
|
||||
$ENV{'TMP'}
|
||||
$ENV{'TEMP'}
|
||||
C:/temp
|
||||
|
||||
If running under taint mode, and if the environment
|
||||
variables are tainted, they are not used.
|
||||
|
||||
=cut
|
||||
|
||||
sub tmpdir {
|
||||
my $cached = $_[0]->_cached_tmpdir(qw 'TMPDIR TMP TEMP');
|
||||
return $cached if defined $cached;
|
||||
$_[0]->_cache_tmpdir(
|
||||
$_[0]->_tmpdir(
|
||||
$ENV{TMPDIR}, "/tmp", $ENV{'TMP'}, $ENV{'TEMP'}, 'C:/temp'
|
||||
),
|
||||
qw 'TMPDIR TMP TEMP'
|
||||
);
|
||||
}
|
||||
|
||||
=item case_tolerant
|
||||
|
||||
Override Unix. Cygwin case-tolerance depends on managed mount settings and
|
||||
as with MsWin32 on GetVolumeInformation() $ouFsFlags == FS_CASE_SENSITIVE,
|
||||
indicating the case significance when comparing file specifications.
|
||||
Default: 1
|
||||
|
||||
=cut
|
||||
|
||||
sub case_tolerant {
|
||||
return 1 unless $^O eq 'cygwin'
|
||||
and defined &Cygwin::mount_flags;
|
||||
|
||||
my $drive = shift;
|
||||
if (! $drive) {
|
||||
my @flags = split(/,/, Cygwin::mount_flags('/cygwin'));
|
||||
my $prefix = pop(@flags);
|
||||
if (! $prefix || $prefix eq 'cygdrive') {
|
||||
$drive = '/cygdrive/c';
|
||||
} elsif ($prefix eq '/') {
|
||||
$drive = '/c';
|
||||
} else {
|
||||
$drive = "$prefix/c";
|
||||
}
|
||||
}
|
||||
my $mntopts = Cygwin::mount_flags($drive);
|
||||
if ($mntopts and ($mntopts =~ /,managed/)) {
|
||||
return 0;
|
||||
}
|
||||
eval {
|
||||
local @INC = @INC;
|
||||
pop @INC if $INC[-1] eq '.';
|
||||
require Win32API::File;
|
||||
} or return 1;
|
||||
my $osFsType = "\0"x256;
|
||||
my $osVolName = "\0"x256;
|
||||
my $ouFsFlags = 0;
|
||||
Win32API::File::GetVolumeInformation($drive, $osVolName, 256, [], [], $ouFsFlags, $osFsType, 256 );
|
||||
if ($ouFsFlags & Win32API::File::FS_CASE_SENSITIVE()) { return 0; }
|
||||
else { return 1; }
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004,2007 by the Perl 5 Porters. All rights reserved.
|
||||
|
||||
This program is free software; you can redistribute it and/or modify
|
||||
it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
78
database/perl/lib/File/Spec/Epoc.pm
Normal file
78
database/perl/lib/File/Spec/Epoc.pm
Normal file
@@ -0,0 +1,78 @@
|
||||
package File::Spec::Epoc;
|
||||
|
||||
use strict;
|
||||
|
||||
our $VERSION = '3.78';
|
||||
$VERSION =~ tr/_//d;
|
||||
|
||||
require File::Spec::Unix;
|
||||
our @ISA = qw(File::Spec::Unix);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::Spec::Epoc - methods for Epoc file specs
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
require File::Spec::Epoc; # Done internally by File::Spec if needed
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
See File::Spec::Unix for a documentation of the methods provided
|
||||
there. This package overrides the implementation of these methods, not
|
||||
the semantics.
|
||||
|
||||
This package is still a work in progress. ;-)
|
||||
|
||||
=cut
|
||||
|
||||
sub case_tolerant {
|
||||
return 1;
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=over 4
|
||||
|
||||
=item canonpath()
|
||||
|
||||
No physical check on the filesystem, but a logical cleanup of a
|
||||
path. On UNIX eliminated successive slashes and successive "/.".
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub canonpath {
|
||||
my ($self,$path) = @_;
|
||||
return unless defined $path;
|
||||
|
||||
$path =~ s|/+|/|g; # xx////xx -> xx/xx
|
||||
$path =~ s|(/\.)+/|/|g; # xx/././xx -> xx/xx
|
||||
$path =~ s|^(\./)+||s unless $path eq "./"; # ./xx -> xx
|
||||
$path =~ s|^/(\.\./)+|/|s; # /../../xx -> xx
|
||||
$path =~ s|/\Z(?!\n)|| unless $path eq "/"; # xx/ -> xx
|
||||
return $path;
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
o.flebbe@gmx.de
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
|
||||
|
||||
This program is free software; you can redistribute it and/or modify
|
||||
it under the same terms as Perl itself.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
|
||||
implementation of these methods, not the semantics.
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
128
database/perl/lib/File/Spec/Functions.pm
Normal file
128
database/perl/lib/File/Spec/Functions.pm
Normal file
@@ -0,0 +1,128 @@
|
||||
package File::Spec::Functions;
|
||||
|
||||
use File::Spec;
|
||||
use strict;
|
||||
|
||||
our $VERSION = '3.78';
|
||||
$VERSION =~ tr/_//d;
|
||||
|
||||
require Exporter;
|
||||
|
||||
our @ISA = qw(Exporter);
|
||||
|
||||
our @EXPORT = qw(
|
||||
canonpath
|
||||
catdir
|
||||
catfile
|
||||
curdir
|
||||
rootdir
|
||||
updir
|
||||
no_upwards
|
||||
file_name_is_absolute
|
||||
path
|
||||
);
|
||||
|
||||
our @EXPORT_OK = qw(
|
||||
devnull
|
||||
tmpdir
|
||||
splitpath
|
||||
splitdir
|
||||
catpath
|
||||
abs2rel
|
||||
rel2abs
|
||||
case_tolerant
|
||||
);
|
||||
|
||||
our %EXPORT_TAGS = ( ALL => [ @EXPORT_OK, @EXPORT ] );
|
||||
|
||||
require File::Spec::Unix;
|
||||
my %udeps = (
|
||||
canonpath => [],
|
||||
catdir => [qw(canonpath)],
|
||||
catfile => [qw(canonpath catdir)],
|
||||
case_tolerant => [],
|
||||
curdir => [],
|
||||
devnull => [],
|
||||
rootdir => [],
|
||||
updir => [],
|
||||
);
|
||||
|
||||
foreach my $meth (@EXPORT, @EXPORT_OK) {
|
||||
my $sub = File::Spec->can($meth);
|
||||
no strict 'refs';
|
||||
if (exists($udeps{$meth}) && $sub == File::Spec::Unix->can($meth) &&
|
||||
!(grep {
|
||||
File::Spec->can($_) != File::Spec::Unix->can($_)
|
||||
} @{$udeps{$meth}}) &&
|
||||
defined(&{"File::Spec::Unix::_fn_$meth"})) {
|
||||
*{$meth} = \&{"File::Spec::Unix::_fn_$meth"};
|
||||
} else {
|
||||
*{$meth} = sub {&$sub('File::Spec', @_)};
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::Spec::Functions - portably perform operations on file names
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use File::Spec::Functions;
|
||||
$x = catfile('a','b');
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module exports convenience functions for all of the class methods
|
||||
provided by File::Spec.
|
||||
|
||||
For a reference of available functions, please consult L<File::Spec::Unix>,
|
||||
which contains the entire set, and which is inherited by the modules for
|
||||
other platforms. For further information, please see L<File::Spec::Mac>,
|
||||
L<File::Spec::OS2>, L<File::Spec::Win32>, or L<File::Spec::VMS>.
|
||||
|
||||
=head2 Exports
|
||||
|
||||
The following functions are exported by default.
|
||||
|
||||
canonpath
|
||||
catdir
|
||||
catfile
|
||||
curdir
|
||||
rootdir
|
||||
updir
|
||||
no_upwards
|
||||
file_name_is_absolute
|
||||
path
|
||||
|
||||
|
||||
The following functions are exported only by request.
|
||||
|
||||
devnull
|
||||
tmpdir
|
||||
splitpath
|
||||
splitdir
|
||||
catpath
|
||||
abs2rel
|
||||
rel2abs
|
||||
case_tolerant
|
||||
|
||||
All the functions may be imported using the C<:ALL> tag.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
|
||||
|
||||
This program is free software; you can redistribute it and/or modify
|
||||
it under the same terms as Perl itself.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
File::Spec, File::Spec::Unix, File::Spec::Mac, File::Spec::OS2,
|
||||
File::Spec::Win32, File::Spec::VMS, ExtUtils::MakeMaker
|
||||
|
||||
=cut
|
||||
|
||||
765
database/perl/lib/File/Spec/Mac.pm
Normal file
765
database/perl/lib/File/Spec/Mac.pm
Normal file
@@ -0,0 +1,765 @@
|
||||
package File::Spec::Mac;
|
||||
|
||||
use strict;
|
||||
use Cwd ();
|
||||
require File::Spec::Unix;
|
||||
|
||||
our $VERSION = '3.78';
|
||||
$VERSION =~ tr/_//d;
|
||||
|
||||
our @ISA = qw(File::Spec::Unix);
|
||||
|
||||
sub case_tolerant { 1 }
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::Spec::Mac - File::Spec for Mac OS (Classic)
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
require File::Spec::Mac; # Done internally by File::Spec if needed
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Methods for manipulating file specifications.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over 2
|
||||
|
||||
=item canonpath
|
||||
|
||||
On Mac OS, there's nothing to be done. Returns what it's given.
|
||||
|
||||
=cut
|
||||
|
||||
sub canonpath {
|
||||
my ($self,$path) = @_;
|
||||
return $path;
|
||||
}
|
||||
|
||||
=item catdir()
|
||||
|
||||
Concatenate two or more directory names to form a path separated by colons
|
||||
(":") ending with a directory. Resulting paths are B<relative> by default,
|
||||
but can be forced to be absolute (but avoid this, see below). Automatically
|
||||
puts a trailing ":" on the end of the complete path, because that's what's
|
||||
done in MacPerl's environment and helps to distinguish a file path from a
|
||||
directory path.
|
||||
|
||||
B<IMPORTANT NOTE:> Beginning with version 1.3 of this module, the resulting
|
||||
path is relative by default and I<not> absolute. This decision was made due
|
||||
to portability reasons. Since C<File::Spec-E<gt>catdir()> returns relative paths
|
||||
on all other operating systems, it will now also follow this convention on Mac
|
||||
OS. Note that this may break some existing scripts.
|
||||
|
||||
The intended purpose of this routine is to concatenate I<directory names>.
|
||||
But because of the nature of Macintosh paths, some additional possibilities
|
||||
are allowed to make using this routine give reasonable results for some
|
||||
common situations. In other words, you are also allowed to concatenate
|
||||
I<paths> instead of directory names (strictly speaking, a string like ":a"
|
||||
is a path, but not a name, since it contains a punctuation character ":").
|
||||
|
||||
So, beside calls like
|
||||
|
||||
catdir("a") = ":a:"
|
||||
catdir("a","b") = ":a:b:"
|
||||
catdir() = "" (special case)
|
||||
|
||||
calls like the following
|
||||
|
||||
catdir(":a:") = ":a:"
|
||||
catdir(":a","b") = ":a:b:"
|
||||
catdir(":a:","b") = ":a:b:"
|
||||
catdir(":a:",":b:") = ":a:b:"
|
||||
catdir(":") = ":"
|
||||
|
||||
are allowed.
|
||||
|
||||
Here are the rules that are used in C<catdir()>; note that we try to be as
|
||||
compatible as possible to Unix:
|
||||
|
||||
=over 2
|
||||
|
||||
=item 1.
|
||||
|
||||
The resulting path is relative by default, i.e. the resulting path will have a
|
||||
leading colon.
|
||||
|
||||
=item 2.
|
||||
|
||||
A trailing colon is added automatically to the resulting path, to denote a
|
||||
directory.
|
||||
|
||||
=item 3.
|
||||
|
||||
Generally, each argument has one leading ":" and one trailing ":"
|
||||
removed (if any). They are then joined together by a ":". Special
|
||||
treatment applies for arguments denoting updir paths like "::lib:",
|
||||
see (4), or arguments consisting solely of colons ("colon paths"),
|
||||
see (5).
|
||||
|
||||
=item 4.
|
||||
|
||||
When an updir path like ":::lib::" is passed as argument, the number
|
||||
of directories to climb up is handled correctly, not removing leading
|
||||
or trailing colons when necessary. E.g.
|
||||
|
||||
catdir(":::a","::b","c") = ":::a::b:c:"
|
||||
catdir(":::a::","::b","c") = ":::a:::b:c:"
|
||||
|
||||
=item 5.
|
||||
|
||||
Adding a colon ":" or empty string "" to a path at I<any> position
|
||||
doesn't alter the path, i.e. these arguments are ignored. (When a ""
|
||||
is passed as the first argument, it has a special meaning, see
|
||||
(6)). This way, a colon ":" is handled like a "." (curdir) on Unix,
|
||||
while an empty string "" is generally ignored (see
|
||||
L<File::Spec::Unix/canonpath()> ). Likewise, a "::" is handled like a ".."
|
||||
(updir), and a ":::" is handled like a "../.." etc. E.g.
|
||||
|
||||
catdir("a",":",":","b") = ":a:b:"
|
||||
catdir("a",":","::",":b") = ":a::b:"
|
||||
|
||||
=item 6.
|
||||
|
||||
If the first argument is an empty string "" or is a volume name, i.e. matches
|
||||
the pattern /^[^:]+:/, the resulting path is B<absolute>.
|
||||
|
||||
=item 7.
|
||||
|
||||
Passing an empty string "" as the first argument to C<catdir()> is
|
||||
like passingC<File::Spec-E<gt>rootdir()> as the first argument, i.e.
|
||||
|
||||
catdir("","a","b") is the same as
|
||||
|
||||
catdir(rootdir(),"a","b").
|
||||
|
||||
This is true on Unix, where C<catdir("","a","b")> yields "/a/b" and
|
||||
C<rootdir()> is "/". Note that C<rootdir()> on Mac OS is the startup
|
||||
volume, which is the closest in concept to Unix' "/". This should help
|
||||
to run existing scripts originally written for Unix.
|
||||
|
||||
=item 8.
|
||||
|
||||
For absolute paths, some cleanup is done, to ensure that the volume
|
||||
name isn't immediately followed by updirs. This is invalid, because
|
||||
this would go beyond "root". Generally, these cases are handled like
|
||||
their Unix counterparts:
|
||||
|
||||
Unix:
|
||||
Unix->catdir("","") = "/"
|
||||
Unix->catdir("",".") = "/"
|
||||
Unix->catdir("","..") = "/" # can't go
|
||||
# beyond root
|
||||
Unix->catdir("",".","..","..","a") = "/a"
|
||||
Mac:
|
||||
Mac->catdir("","") = rootdir() # (e.g. "HD:")
|
||||
Mac->catdir("",":") = rootdir()
|
||||
Mac->catdir("","::") = rootdir() # can't go
|
||||
# beyond root
|
||||
Mac->catdir("",":","::","::","a") = rootdir() . "a:"
|
||||
# (e.g. "HD:a:")
|
||||
|
||||
However, this approach is limited to the first arguments following
|
||||
"root" (again, see L<File::Spec::Unix/canonpath()>. If there are more
|
||||
arguments that move up the directory tree, an invalid path going
|
||||
beyond root can be created.
|
||||
|
||||
=back
|
||||
|
||||
As you've seen, you can force C<catdir()> to create an absolute path
|
||||
by passing either an empty string or a path that begins with a volume
|
||||
name as the first argument. However, you are strongly encouraged not
|
||||
to do so, since this is done only for backward compatibility. Newer
|
||||
versions of File::Spec come with a method called C<catpath()> (see
|
||||
below), that is designed to offer a portable solution for the creation
|
||||
of absolute paths. It takes volume, directory and file portions and
|
||||
returns an entire path. While C<catdir()> is still suitable for the
|
||||
concatenation of I<directory names>, you are encouraged to use
|
||||
C<catpath()> to concatenate I<volume names> and I<directory
|
||||
paths>. E.g.
|
||||
|
||||
$dir = File::Spec->catdir("tmp","sources");
|
||||
$abs_path = File::Spec->catpath("MacintoshHD:", $dir,"");
|
||||
|
||||
yields
|
||||
|
||||
"MacintoshHD:tmp:sources:" .
|
||||
|
||||
=cut
|
||||
|
||||
sub catdir {
|
||||
my $self = shift;
|
||||
return '' unless @_;
|
||||
my @args = @_;
|
||||
my $first_arg;
|
||||
my $relative;
|
||||
|
||||
# take care of the first argument
|
||||
|
||||
if ($args[0] eq '') { # absolute path, rootdir
|
||||
shift @args;
|
||||
$relative = 0;
|
||||
$first_arg = $self->rootdir;
|
||||
|
||||
} elsif ($args[0] =~ /^[^:]+:/) { # absolute path, volume name
|
||||
$relative = 0;
|
||||
$first_arg = shift @args;
|
||||
# add a trailing ':' if need be (may be it's a path like HD:dir)
|
||||
$first_arg = "$first_arg:" unless ($first_arg =~ /:\Z(?!\n)/);
|
||||
|
||||
} else { # relative path
|
||||
$relative = 1;
|
||||
if ( $args[0] =~ /^::+\Z(?!\n)/ ) {
|
||||
# updir colon path ('::', ':::' etc.), don't shift
|
||||
$first_arg = ':';
|
||||
} elsif ($args[0] eq ':') {
|
||||
$first_arg = shift @args;
|
||||
} else {
|
||||
# add a trailing ':' if need be
|
||||
$first_arg = shift @args;
|
||||
$first_arg = "$first_arg:" unless ($first_arg =~ /:\Z(?!\n)/);
|
||||
}
|
||||
}
|
||||
|
||||
# For all other arguments,
|
||||
# (a) ignore arguments that equal ':' or '',
|
||||
# (b) handle updir paths specially:
|
||||
# '::' -> concatenate '::'
|
||||
# '::' . '::' -> concatenate ':::' etc.
|
||||
# (c) add a trailing ':' if need be
|
||||
|
||||
my $result = $first_arg;
|
||||
while (@args) {
|
||||
my $arg = shift @args;
|
||||
unless (($arg eq '') || ($arg eq ':')) {
|
||||
if ($arg =~ /^::+\Z(?!\n)/ ) { # updir colon path like ':::'
|
||||
my $updir_count = length($arg) - 1;
|
||||
while ((@args) && ($args[0] =~ /^::+\Z(?!\n)/) ) { # while updir colon path
|
||||
$arg = shift @args;
|
||||
$updir_count += (length($arg) - 1);
|
||||
}
|
||||
$arg = (':' x $updir_count);
|
||||
} else {
|
||||
$arg =~ s/^://s; # remove a leading ':' if any
|
||||
$arg = "$arg:" unless ($arg =~ /:\Z(?!\n)/); # ensure trailing ':'
|
||||
}
|
||||
$result .= $arg;
|
||||
}#unless
|
||||
}
|
||||
|
||||
if ( ($relative) && ($result !~ /^:/) ) {
|
||||
# add a leading colon if need be
|
||||
$result = ":$result";
|
||||
}
|
||||
|
||||
unless ($relative) {
|
||||
# remove updirs immediately following the volume name
|
||||
$result =~ s/([^:]+:)(:*)(.*)\Z(?!\n)/$1$3/;
|
||||
}
|
||||
|
||||
return $result;
|
||||
}
|
||||
|
||||
=item catfile
|
||||
|
||||
Concatenate one or more directory names and a filename to form a
|
||||
complete path ending with a filename. Resulting paths are B<relative>
|
||||
by default, but can be forced to be absolute (but avoid this).
|
||||
|
||||
B<IMPORTANT NOTE:> Beginning with version 1.3 of this module, the
|
||||
resulting path is relative by default and I<not> absolute. This
|
||||
decision was made due to portability reasons. Since
|
||||
C<File::Spec-E<gt>catfile()> returns relative paths on all other
|
||||
operating systems, it will now also follow this convention on Mac OS.
|
||||
Note that this may break some existing scripts.
|
||||
|
||||
The last argument is always considered to be the file portion. Since
|
||||
C<catfile()> uses C<catdir()> (see above) for the concatenation of the
|
||||
directory portions (if any), the following with regard to relative and
|
||||
absolute paths is true:
|
||||
|
||||
catfile("") = ""
|
||||
catfile("file") = "file"
|
||||
|
||||
but
|
||||
|
||||
catfile("","") = rootdir() # (e.g. "HD:")
|
||||
catfile("","file") = rootdir() . file # (e.g. "HD:file")
|
||||
catfile("HD:","file") = "HD:file"
|
||||
|
||||
This means that C<catdir()> is called only when there are two or more
|
||||
arguments, as one might expect.
|
||||
|
||||
Note that the leading ":" is removed from the filename, so that
|
||||
|
||||
catfile("a","b","file") = ":a:b:file" and
|
||||
|
||||
catfile("a","b",":file") = ":a:b:file"
|
||||
|
||||
give the same answer.
|
||||
|
||||
To concatenate I<volume names>, I<directory paths> and I<filenames>,
|
||||
you are encouraged to use C<catpath()> (see below).
|
||||
|
||||
=cut
|
||||
|
||||
sub catfile {
|
||||
my $self = shift;
|
||||
return '' unless @_;
|
||||
my $file = pop @_;
|
||||
return $file unless @_;
|
||||
my $dir = $self->catdir(@_);
|
||||
$file =~ s/^://s;
|
||||
return $dir.$file;
|
||||
}
|
||||
|
||||
=item curdir
|
||||
|
||||
Returns a string representing the current directory. On Mac OS, this is ":".
|
||||
|
||||
=cut
|
||||
|
||||
sub curdir {
|
||||
return ":";
|
||||
}
|
||||
|
||||
=item devnull
|
||||
|
||||
Returns a string representing the null device. On Mac OS, this is "Dev:Null".
|
||||
|
||||
=cut
|
||||
|
||||
sub devnull {
|
||||
return "Dev:Null";
|
||||
}
|
||||
|
||||
=item rootdir
|
||||
|
||||
Returns the empty string. Mac OS has no real root directory.
|
||||
|
||||
=cut
|
||||
|
||||
sub rootdir { '' }
|
||||
|
||||
=item tmpdir
|
||||
|
||||
Returns the contents of $ENV{TMPDIR}, if that directory exits or the
|
||||
current working directory otherwise. Under MacPerl, $ENV{TMPDIR} will
|
||||
contain a path like "MacintoshHD:Temporary Items:", which is a hidden
|
||||
directory on your startup volume.
|
||||
|
||||
=cut
|
||||
|
||||
sub tmpdir {
|
||||
my $cached = $_[0]->_cached_tmpdir('TMPDIR');
|
||||
return $cached if defined $cached;
|
||||
$_[0]->_cache_tmpdir($_[0]->_tmpdir( $ENV{TMPDIR} ), 'TMPDIR');
|
||||
}
|
||||
|
||||
=item updir
|
||||
|
||||
Returns a string representing the parent directory. On Mac OS, this is "::".
|
||||
|
||||
=cut
|
||||
|
||||
sub updir {
|
||||
return "::";
|
||||
}
|
||||
|
||||
=item file_name_is_absolute
|
||||
|
||||
Takes as argument a path and returns true, if it is an absolute path.
|
||||
If the path has a leading ":", it's a relative path. Otherwise, it's an
|
||||
absolute path, unless the path doesn't contain any colons, i.e. it's a name
|
||||
like "a". In this particular case, the path is considered to be relative
|
||||
(i.e. it is considered to be a filename). Use ":" in the appropriate place
|
||||
in the path if you want to distinguish unambiguously. As a special case,
|
||||
the filename '' is always considered to be absolute. Note that with version
|
||||
1.2 of File::Spec::Mac, this does no longer consult the local filesystem.
|
||||
|
||||
E.g.
|
||||
|
||||
File::Spec->file_name_is_absolute("a"); # false (relative)
|
||||
File::Spec->file_name_is_absolute(":a:b:"); # false (relative)
|
||||
File::Spec->file_name_is_absolute("MacintoshHD:");
|
||||
# true (absolute)
|
||||
File::Spec->file_name_is_absolute(""); # true (absolute)
|
||||
|
||||
|
||||
=cut
|
||||
|
||||
sub file_name_is_absolute {
|
||||
my ($self,$file) = @_;
|
||||
if ($file =~ /:/) {
|
||||
return (! ($file =~ m/^:/s) );
|
||||
} elsif ( $file eq '' ) {
|
||||
return 1 ;
|
||||
} else {
|
||||
return 0; # i.e. a file like "a"
|
||||
}
|
||||
}
|
||||
|
||||
=item path
|
||||
|
||||
Returns the null list for the MacPerl application, since the concept is
|
||||
usually meaningless under Mac OS. But if you're using the MacPerl tool under
|
||||
MPW, it gives back $ENV{Commands} suitably split, as is done in
|
||||
:lib:ExtUtils:MM_Mac.pm.
|
||||
|
||||
=cut
|
||||
|
||||
sub path {
|
||||
#
|
||||
# The concept is meaningless under the MacPerl application.
|
||||
# Under MPW, it has a meaning.
|
||||
#
|
||||
return unless exists $ENV{Commands};
|
||||
return split(/,/, $ENV{Commands});
|
||||
}
|
||||
|
||||
=item splitpath
|
||||
|
||||
($volume,$directories,$file) = File::Spec->splitpath( $path );
|
||||
($volume,$directories,$file) = File::Spec->splitpath( $path,
|
||||
$no_file );
|
||||
|
||||
Splits a path into volume, directory, and filename portions.
|
||||
|
||||
On Mac OS, assumes that the last part of the path is a filename unless
|
||||
$no_file is true or a trailing separator ":" is present.
|
||||
|
||||
The volume portion is always returned with a trailing ":". The directory portion
|
||||
is always returned with a leading (to denote a relative path) and a trailing ":"
|
||||
(to denote a directory). The file portion is always returned I<without> a leading ":".
|
||||
Empty portions are returned as empty string ''.
|
||||
|
||||
The results can be passed to C<catpath()> to get back a path equivalent to
|
||||
(usually identical to) the original path.
|
||||
|
||||
|
||||
=cut
|
||||
|
||||
sub splitpath {
|
||||
my ($self,$path, $nofile) = @_;
|
||||
my ($volume,$directory,$file);
|
||||
|
||||
if ( $nofile ) {
|
||||
( $volume, $directory ) = $path =~ m|^((?:[^:]+:)?)(.*)|s;
|
||||
}
|
||||
else {
|
||||
$path =~
|
||||
m|^( (?: [^:]+: )? )
|
||||
( (?: .*: )? )
|
||||
( .* )
|
||||
|xs;
|
||||
$volume = $1;
|
||||
$directory = $2;
|
||||
$file = $3;
|
||||
}
|
||||
|
||||
$volume = '' unless defined($volume);
|
||||
$directory = ":$directory" if ( $volume && $directory ); # take care of "HD::dir"
|
||||
if ($directory) {
|
||||
# Make sure non-empty directories begin and end in ':'
|
||||
$directory .= ':' unless (substr($directory,-1) eq ':');
|
||||
$directory = ":$directory" unless (substr($directory,0,1) eq ':');
|
||||
} else {
|
||||
$directory = '';
|
||||
}
|
||||
$file = '' unless defined($file);
|
||||
|
||||
return ($volume,$directory,$file);
|
||||
}
|
||||
|
||||
|
||||
=item splitdir
|
||||
|
||||
The opposite of C<catdir()>.
|
||||
|
||||
@dirs = File::Spec->splitdir( $directories );
|
||||
|
||||
$directories should be only the directory portion of the path on systems
|
||||
that have the concept of a volume or that have path syntax that differentiates
|
||||
files from directories. Consider using C<splitpath()> otherwise.
|
||||
|
||||
Unlike just splitting the directories on the separator, empty directory names
|
||||
(C<"">) can be returned. Since C<catdir()> on Mac OS always appends a trailing
|
||||
colon to distinguish a directory path from a file path, a single trailing colon
|
||||
will be ignored, i.e. there's no empty directory name after it.
|
||||
|
||||
Hence, on Mac OS, both
|
||||
|
||||
File::Spec->splitdir( ":a:b::c:" ); and
|
||||
File::Spec->splitdir( ":a:b::c" );
|
||||
|
||||
yield:
|
||||
|
||||
( "a", "b", "::", "c")
|
||||
|
||||
while
|
||||
|
||||
File::Spec->splitdir( ":a:b::c::" );
|
||||
|
||||
yields:
|
||||
|
||||
( "a", "b", "::", "c", "::")
|
||||
|
||||
|
||||
=cut
|
||||
|
||||
sub splitdir {
|
||||
my ($self, $path) = @_;
|
||||
my @result = ();
|
||||
my ($head, $sep, $tail, $volume, $directories);
|
||||
|
||||
return @result if ( (!defined($path)) || ($path eq '') );
|
||||
return (':') if ($path eq ':');
|
||||
|
||||
( $volume, $sep, $directories ) = $path =~ m|^((?:[^:]+:)?)(:*)(.*)|s;
|
||||
|
||||
# deprecated, but handle it correctly
|
||||
if ($volume) {
|
||||
push (@result, $volume);
|
||||
$sep .= ':';
|
||||
}
|
||||
|
||||
while ($sep || $directories) {
|
||||
if (length($sep) > 1) {
|
||||
my $updir_count = length($sep) - 1;
|
||||
for (my $i=0; $i<$updir_count; $i++) {
|
||||
# push '::' updir_count times;
|
||||
# simulate Unix '..' updirs
|
||||
push (@result, '::');
|
||||
}
|
||||
}
|
||||
$sep = '';
|
||||
if ($directories) {
|
||||
( $head, $sep, $tail ) = $directories =~ m|^((?:[^:]+)?)(:*)(.*)|s;
|
||||
push (@result, $head);
|
||||
$directories = $tail;
|
||||
}
|
||||
}
|
||||
return @result;
|
||||
}
|
||||
|
||||
|
||||
=item catpath
|
||||
|
||||
$path = File::Spec->catpath($volume,$directory,$file);
|
||||
|
||||
Takes volume, directory and file portions and returns an entire path. On Mac OS,
|
||||
$volume, $directory and $file are concatenated. A ':' is inserted if need be. You
|
||||
may pass an empty string for each portion. If all portions are empty, the empty
|
||||
string is returned. If $volume is empty, the result will be a relative path,
|
||||
beginning with a ':'. If $volume and $directory are empty, a leading ":" (if any)
|
||||
is removed form $file and the remainder is returned. If $file is empty, the
|
||||
resulting path will have a trailing ':'.
|
||||
|
||||
|
||||
=cut
|
||||
|
||||
sub catpath {
|
||||
my ($self,$volume,$directory,$file) = @_;
|
||||
|
||||
if ( (! $volume) && (! $directory) ) {
|
||||
$file =~ s/^:// if $file;
|
||||
return $file ;
|
||||
}
|
||||
|
||||
# We look for a volume in $volume, then in $directory, but not both
|
||||
|
||||
my ($dir_volume, $dir_dirs) = $self->splitpath($directory, 1);
|
||||
|
||||
$volume = $dir_volume unless length $volume;
|
||||
my $path = $volume; # may be ''
|
||||
$path .= ':' unless (substr($path, -1) eq ':'); # ensure trailing ':'
|
||||
|
||||
if ($directory) {
|
||||
$directory = $dir_dirs if $volume;
|
||||
$directory =~ s/^://; # remove leading ':' if any
|
||||
$path .= $directory;
|
||||
$path .= ':' unless (substr($path, -1) eq ':'); # ensure trailing ':'
|
||||
}
|
||||
|
||||
if ($file) {
|
||||
$file =~ s/^://; # remove leading ':' if any
|
||||
$path .= $file;
|
||||
}
|
||||
|
||||
return $path;
|
||||
}
|
||||
|
||||
=item abs2rel
|
||||
|
||||
Takes a destination path and an optional base path and returns a relative path
|
||||
from the base path to the destination path:
|
||||
|
||||
$rel_path = File::Spec->abs2rel( $path ) ;
|
||||
$rel_path = File::Spec->abs2rel( $path, $base ) ;
|
||||
|
||||
Note that both paths are assumed to have a notation that distinguishes a
|
||||
directory path (with trailing ':') from a file path (without trailing ':').
|
||||
|
||||
If $base is not present or '', then the current working directory is used.
|
||||
If $base is relative, then it is converted to absolute form using C<rel2abs()>.
|
||||
This means that it is taken to be relative to the current working directory.
|
||||
|
||||
If $path and $base appear to be on two different volumes, we will not
|
||||
attempt to resolve the two paths, and we will instead simply return
|
||||
$path. Note that previous versions of this module ignored the volume
|
||||
of $base, which resulted in garbage results part of the time.
|
||||
|
||||
If $base doesn't have a trailing colon, the last element of $base is
|
||||
assumed to be a filename. This filename is ignored. Otherwise all path
|
||||
components are assumed to be directories.
|
||||
|
||||
If $path is relative, it is converted to absolute form using C<rel2abs()>.
|
||||
This means that it is taken to be relative to the current working directory.
|
||||
|
||||
Based on code written by Shigio Yamaguchi.
|
||||
|
||||
|
||||
=cut
|
||||
|
||||
# maybe this should be done in canonpath() ?
|
||||
sub _resolve_updirs {
|
||||
my $path = shift @_;
|
||||
my $proceed;
|
||||
|
||||
# resolve any updirs, e.g. "HD:tmp::file" -> "HD:file"
|
||||
do {
|
||||
$proceed = ($path =~ s/^(.*):[^:]+::(.*?)\z/$1:$2/);
|
||||
} while ($proceed);
|
||||
|
||||
return $path;
|
||||
}
|
||||
|
||||
|
||||
sub abs2rel {
|
||||
my($self,$path,$base) = @_;
|
||||
|
||||
# Clean up $path
|
||||
if ( ! $self->file_name_is_absolute( $path ) ) {
|
||||
$path = $self->rel2abs( $path ) ;
|
||||
}
|
||||
|
||||
# Figure out the effective $base and clean it up.
|
||||
if ( !defined( $base ) || $base eq '' ) {
|
||||
$base = Cwd::getcwd();
|
||||
}
|
||||
elsif ( ! $self->file_name_is_absolute( $base ) ) {
|
||||
$base = $self->rel2abs( $base ) ;
|
||||
$base = _resolve_updirs( $base ); # resolve updirs in $base
|
||||
}
|
||||
else {
|
||||
$base = _resolve_updirs( $base );
|
||||
}
|
||||
|
||||
# Split up paths - ignore $base's file
|
||||
my ( $path_vol, $path_dirs, $path_file ) = $self->splitpath( $path );
|
||||
my ( $base_vol, $base_dirs ) = $self->splitpath( $base );
|
||||
|
||||
return $path unless lc( $path_vol ) eq lc( $base_vol );
|
||||
|
||||
# Now, remove all leading components that are the same
|
||||
my @pathchunks = $self->splitdir( $path_dirs );
|
||||
my @basechunks = $self->splitdir( $base_dirs );
|
||||
|
||||
while ( @pathchunks &&
|
||||
@basechunks &&
|
||||
lc( $pathchunks[0] ) eq lc( $basechunks[0] ) ) {
|
||||
shift @pathchunks ;
|
||||
shift @basechunks ;
|
||||
}
|
||||
|
||||
# @pathchunks now has the directories to descend in to.
|
||||
# ensure relative path, even if @pathchunks is empty
|
||||
$path_dirs = $self->catdir( ':', @pathchunks );
|
||||
|
||||
# @basechunks now contains the number of directories to climb out of.
|
||||
$base_dirs = (':' x @basechunks) . ':' ;
|
||||
|
||||
return $self->catpath( '', $self->catdir( $base_dirs, $path_dirs ), $path_file ) ;
|
||||
}
|
||||
|
||||
=item rel2abs
|
||||
|
||||
Converts a relative path to an absolute path:
|
||||
|
||||
$abs_path = File::Spec->rel2abs( $path ) ;
|
||||
$abs_path = File::Spec->rel2abs( $path, $base ) ;
|
||||
|
||||
Note that both paths are assumed to have a notation that distinguishes a
|
||||
directory path (with trailing ':') from a file path (without trailing ':').
|
||||
|
||||
If $base is not present or '', then $base is set to the current working
|
||||
directory. If $base is relative, then it is converted to absolute form
|
||||
using C<rel2abs()>. This means that it is taken to be relative to the
|
||||
current working directory.
|
||||
|
||||
If $base doesn't have a trailing colon, the last element of $base is
|
||||
assumed to be a filename. This filename is ignored. Otherwise all path
|
||||
components are assumed to be directories.
|
||||
|
||||
If $path is already absolute, it is returned and $base is ignored.
|
||||
|
||||
Based on code written by Shigio Yamaguchi.
|
||||
|
||||
=cut
|
||||
|
||||
sub rel2abs {
|
||||
my ($self,$path,$base) = @_;
|
||||
|
||||
if ( ! $self->file_name_is_absolute($path) ) {
|
||||
# Figure out the effective $base and clean it up.
|
||||
if ( !defined( $base ) || $base eq '' ) {
|
||||
$base = Cwd::getcwd();
|
||||
}
|
||||
elsif ( ! $self->file_name_is_absolute($base) ) {
|
||||
$base = $self->rel2abs($base) ;
|
||||
}
|
||||
|
||||
# Split up paths
|
||||
|
||||
# ignore $path's volume
|
||||
my ( $path_dirs, $path_file ) = ($self->splitpath($path))[1,2] ;
|
||||
|
||||
# ignore $base's file part
|
||||
my ( $base_vol, $base_dirs ) = $self->splitpath($base) ;
|
||||
|
||||
# Glom them together
|
||||
$path_dirs = ':' if ($path_dirs eq '');
|
||||
$base_dirs =~ s/:$//; # remove trailing ':', if any
|
||||
$base_dirs = $base_dirs . $path_dirs;
|
||||
|
||||
$path = $self->catpath( $base_vol, $base_dirs, $path_file );
|
||||
}
|
||||
return $path;
|
||||
}
|
||||
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
See the authors list in I<File::Spec>. Mac OS support by Paul Schinder
|
||||
<schinder@pobox.com> and Thomas Wegner <wegner_thomas@yahoo.com>.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
|
||||
|
||||
This program is free software; you can redistribute it and/or modify
|
||||
it under the same terms as Perl itself.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
|
||||
implementation of these methods, not the semantics.
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
271
database/perl/lib/File/Spec/OS2.pm
Normal file
271
database/perl/lib/File/Spec/OS2.pm
Normal file
@@ -0,0 +1,271 @@
|
||||
package File::Spec::OS2;
|
||||
|
||||
use strict;
|
||||
use Cwd ();
|
||||
require File::Spec::Unix;
|
||||
|
||||
our $VERSION = '3.78';
|
||||
$VERSION =~ tr/_//d;
|
||||
|
||||
our @ISA = qw(File::Spec::Unix);
|
||||
|
||||
sub devnull {
|
||||
return "/dev/nul";
|
||||
}
|
||||
|
||||
sub case_tolerant {
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub file_name_is_absolute {
|
||||
my ($self,$file) = @_;
|
||||
return scalar($file =~ m{^([a-z]:)?[\\/]}is);
|
||||
}
|
||||
|
||||
sub path {
|
||||
my $path = $ENV{PATH};
|
||||
$path =~ s:\\:/:g;
|
||||
my @path = split(';',$path);
|
||||
foreach (@path) { $_ = '.' if $_ eq '' }
|
||||
return @path;
|
||||
}
|
||||
|
||||
sub tmpdir {
|
||||
my $cached = $_[0]->_cached_tmpdir(qw 'TMPDIR TEMP TMP');
|
||||
return $cached if defined $cached;
|
||||
my @d = @ENV{qw(TMPDIR TEMP TMP)}; # function call could autovivivy
|
||||
$_[0]->_cache_tmpdir(
|
||||
$_[0]->_tmpdir( @d, '/tmp', '/' ), qw 'TMPDIR TEMP TMP'
|
||||
);
|
||||
}
|
||||
|
||||
sub catdir {
|
||||
my $self = shift;
|
||||
my @args = @_;
|
||||
foreach (@args) {
|
||||
tr[\\][/];
|
||||
# append a backslash to each argument unless it has one there
|
||||
$_ .= "/" unless m{/$};
|
||||
}
|
||||
return $self->canonpath(join('', @args));
|
||||
}
|
||||
|
||||
sub canonpath {
|
||||
my ($self,$path) = @_;
|
||||
return unless defined $path;
|
||||
|
||||
$path =~ s/^([a-z]:)/\l$1/s;
|
||||
$path =~ s|\\|/|g;
|
||||
$path =~ s|([^/])/+|$1/|g; # xx////xx -> xx/xx
|
||||
$path =~ s|(/\.)+/|/|g; # xx/././xx -> xx/xx
|
||||
$path =~ s|^(\./)+(?=[^/])||s; # ./xx -> xx
|
||||
$path =~ s|/\Z(?!\n)||
|
||||
unless $path =~ m#^([a-z]:)?/\Z(?!\n)#si;# xx/ -> xx
|
||||
$path =~ s{^/\.\.$}{/}; # /.. -> /
|
||||
1 while $path =~ s{^/\.\.}{}; # /../xx -> /xx
|
||||
return $path;
|
||||
}
|
||||
|
||||
|
||||
sub splitpath {
|
||||
my ($self,$path, $nofile) = @_;
|
||||
my ($volume,$directory,$file) = ('','','');
|
||||
if ( $nofile ) {
|
||||
$path =~
|
||||
m{^( (?:[a-zA-Z]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? )
|
||||
(.*)
|
||||
}xs;
|
||||
$volume = $1;
|
||||
$directory = $2;
|
||||
}
|
||||
else {
|
||||
$path =~
|
||||
m{^ ( (?: [a-zA-Z]: |
|
||||
(?:\\\\|//)[^\\/]+[\\/][^\\/]+
|
||||
)?
|
||||
)
|
||||
( (?:.*[\\\\/](?:\.\.?\Z(?!\n))?)? )
|
||||
(.*)
|
||||
}xs;
|
||||
$volume = $1;
|
||||
$directory = $2;
|
||||
$file = $3;
|
||||
}
|
||||
|
||||
return ($volume,$directory,$file);
|
||||
}
|
||||
|
||||
|
||||
sub splitdir {
|
||||
my ($self,$directories) = @_ ;
|
||||
split m|[\\/]|, $directories, -1;
|
||||
}
|
||||
|
||||
|
||||
sub catpath {
|
||||
my ($self,$volume,$directory,$file) = @_;
|
||||
|
||||
# If it's UNC, make sure the glue separator is there, reusing
|
||||
# whatever separator is first in the $volume
|
||||
$volume .= $1
|
||||
if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s &&
|
||||
$directory =~ m@^[^\\/]@s
|
||||
) ;
|
||||
|
||||
$volume .= $directory ;
|
||||
|
||||
# If the volume is not just A:, make sure the glue separator is
|
||||
# there, reusing whatever separator is first in the $volume if possible.
|
||||
if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
|
||||
$volume =~ m@[^\\/]\Z(?!\n)@ &&
|
||||
$file =~ m@[^\\/]@
|
||||
) {
|
||||
$volume =~ m@([\\/])@ ;
|
||||
my $sep = $1 ? $1 : '/' ;
|
||||
$volume .= $sep ;
|
||||
}
|
||||
|
||||
$volume .= $file ;
|
||||
|
||||
return $volume ;
|
||||
}
|
||||
|
||||
|
||||
sub abs2rel {
|
||||
my($self,$path,$base) = @_;
|
||||
|
||||
# Clean up $path
|
||||
if ( ! $self->file_name_is_absolute( $path ) ) {
|
||||
$path = $self->rel2abs( $path ) ;
|
||||
} else {
|
||||
$path = $self->canonpath( $path ) ;
|
||||
}
|
||||
|
||||
# Figure out the effective $base and clean it up.
|
||||
if ( !defined( $base ) || $base eq '' ) {
|
||||
$base = Cwd::getcwd();
|
||||
} elsif ( ! $self->file_name_is_absolute( $base ) ) {
|
||||
$base = $self->rel2abs( $base ) ;
|
||||
} else {
|
||||
$base = $self->canonpath( $base ) ;
|
||||
}
|
||||
|
||||
# Split up paths
|
||||
my ( $path_volume, $path_directories, $path_file ) = $self->splitpath( $path, 1 ) ;
|
||||
my ( $base_volume, $base_directories ) = $self->splitpath( $base, 1 ) ;
|
||||
return $path unless $path_volume eq $base_volume;
|
||||
|
||||
# Now, remove all leading components that are the same
|
||||
my @pathchunks = $self->splitdir( $path_directories );
|
||||
my @basechunks = $self->splitdir( $base_directories );
|
||||
|
||||
while ( @pathchunks &&
|
||||
@basechunks &&
|
||||
lc( $pathchunks[0] ) eq lc( $basechunks[0] )
|
||||
) {
|
||||
shift @pathchunks ;
|
||||
shift @basechunks ;
|
||||
}
|
||||
|
||||
# No need to catdir, we know these are well formed.
|
||||
$path_directories = CORE::join( '/', @pathchunks );
|
||||
$base_directories = CORE::join( '/', @basechunks );
|
||||
|
||||
# $base_directories now contains the directories the resulting relative
|
||||
# path must ascend out of before it can descend to $path_directory. So,
|
||||
# replace all names with $parentDir
|
||||
|
||||
#FA Need to replace between backslashes...
|
||||
$base_directories =~ s|[^\\/]+|..|g ;
|
||||
|
||||
# Glue the two together, using a separator if necessary, and preventing an
|
||||
# empty result.
|
||||
|
||||
#FA Must check that new directories are not empty.
|
||||
if ( $path_directories ne '' && $base_directories ne '' ) {
|
||||
$path_directories = "$base_directories/$path_directories" ;
|
||||
} else {
|
||||
$path_directories = "$base_directories$path_directories" ;
|
||||
}
|
||||
|
||||
return $self->canonpath(
|
||||
$self->catpath( "", $path_directories, $path_file )
|
||||
) ;
|
||||
}
|
||||
|
||||
|
||||
sub rel2abs {
|
||||
my ($self,$path,$base ) = @_;
|
||||
|
||||
if ( ! $self->file_name_is_absolute( $path ) ) {
|
||||
|
||||
if ( !defined( $base ) || $base eq '' ) {
|
||||
$base = Cwd::getcwd();
|
||||
}
|
||||
elsif ( ! $self->file_name_is_absolute( $base ) ) {
|
||||
$base = $self->rel2abs( $base ) ;
|
||||
}
|
||||
else {
|
||||
$base = $self->canonpath( $base ) ;
|
||||
}
|
||||
|
||||
my ( $path_directories, $path_file ) =
|
||||
($self->splitpath( $path, 1 ))[1,2] ;
|
||||
|
||||
my ( $base_volume, $base_directories ) =
|
||||
$self->splitpath( $base, 1 ) ;
|
||||
|
||||
$path = $self->catpath(
|
||||
$base_volume,
|
||||
$self->catdir( $base_directories, $path_directories ),
|
||||
$path_file
|
||||
) ;
|
||||
}
|
||||
|
||||
return $self->canonpath( $path ) ;
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::Spec::OS2 - methods for OS/2 file specs
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
require File::Spec::OS2; # Done internally by File::Spec if needed
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
|
||||
implementation of these methods, not the semantics.
|
||||
|
||||
Amongst the changes made for OS/2 are...
|
||||
|
||||
=over 4
|
||||
|
||||
=item tmpdir
|
||||
|
||||
Modifies the list of places temp directory information is looked for.
|
||||
|
||||
$ENV{TMPDIR}
|
||||
$ENV{TEMP}
|
||||
$ENV{TMP}
|
||||
/tmp
|
||||
/
|
||||
|
||||
=item splitpath
|
||||
|
||||
Volumes can be drive letters or UNC sharenames (\\server\share).
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
|
||||
|
||||
This program is free software; you can redistribute it and/or modify
|
||||
it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
575
database/perl/lib/File/Spec/Unix.pm
Normal file
575
database/perl/lib/File/Spec/Unix.pm
Normal file
@@ -0,0 +1,575 @@
|
||||
package File::Spec::Unix;
|
||||
|
||||
use strict;
|
||||
use Cwd ();
|
||||
|
||||
our $VERSION = '3.78';
|
||||
$VERSION =~ tr/_//d;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::Spec::Unix - File::Spec for Unix, base for other File::Spec modules
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
require File::Spec::Unix; # Done automatically by File::Spec
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Methods for manipulating file specifications. Other File::Spec
|
||||
modules, such as File::Spec::Mac, inherit from File::Spec::Unix and
|
||||
override specific methods.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over 2
|
||||
|
||||
=item canonpath()
|
||||
|
||||
No physical check on the filesystem, but a logical cleanup of a
|
||||
path. On UNIX eliminates successive slashes and successive "/.".
|
||||
|
||||
$cpath = File::Spec->canonpath( $path ) ;
|
||||
|
||||
Note that this does *not* collapse F<x/../y> sections into F<y>. This
|
||||
is by design. If F</foo> on your system is a symlink to F</bar/baz>,
|
||||
then F</foo/../quux> is actually F</bar/quux>, not F</quux> as a naive
|
||||
F<../>-removal would give you. If you want to do this kind of
|
||||
processing, you probably want C<Cwd>'s C<realpath()> function to
|
||||
actually traverse the filesystem cleaning up paths like this.
|
||||
|
||||
=cut
|
||||
|
||||
sub _pp_canonpath {
|
||||
my ($self,$path) = @_;
|
||||
return unless defined $path;
|
||||
|
||||
# Handle POSIX-style node names beginning with double slash (qnx, nto)
|
||||
# (POSIX says: "a pathname that begins with two successive slashes
|
||||
# may be interpreted in an implementation-defined manner, although
|
||||
# more than two leading slashes shall be treated as a single slash.")
|
||||
my $node = '';
|
||||
my $double_slashes_special = $^O eq 'qnx' || $^O eq 'nto';
|
||||
|
||||
|
||||
if ( $double_slashes_special
|
||||
&& ( $path =~ s{^(//[^/]+)/?\z}{}s || $path =~ s{^(//[^/]+)/}{/}s ) ) {
|
||||
$node = $1;
|
||||
}
|
||||
# This used to be
|
||||
# $path =~ s|/+|/|g unless ($^O eq 'cygwin');
|
||||
# but that made tests 29, 30, 35, 46, and 213 (as of #13272) to fail
|
||||
# (Mainly because trailing "" directories didn't get stripped).
|
||||
# Why would cygwin avoid collapsing multiple slashes into one? --jhi
|
||||
$path =~ s|/{2,}|/|g; # xx////xx -> xx/xx
|
||||
$path =~ s{(?:/\.)+(?:/|\z)}{/}g; # xx/././xx -> xx/xx
|
||||
$path =~ s|^(?:\./)+||s unless $path eq "./"; # ./xx -> xx
|
||||
$path =~ s|^/(?:\.\./)+|/|; # /../../xx -> xx
|
||||
$path =~ s|^/\.\.$|/|; # /.. -> /
|
||||
$path =~ s|/\z|| unless $path eq "/"; # xx/ -> xx
|
||||
return "$node$path";
|
||||
}
|
||||
*canonpath = \&_pp_canonpath unless defined &canonpath;
|
||||
|
||||
=item catdir()
|
||||
|
||||
Concatenate two or more directory names to form a complete path ending
|
||||
with a directory. But remove the trailing slash from the resulting
|
||||
string, because it doesn't look good, isn't necessary and confuses
|
||||
OS2. Of course, if this is the root directory, don't cut off the
|
||||
trailing slash :-)
|
||||
|
||||
=cut
|
||||
|
||||
sub _pp_catdir {
|
||||
my $self = shift;
|
||||
|
||||
$self->canonpath(join('/', @_, '')); # '' because need a trailing '/'
|
||||
}
|
||||
*catdir = \&_pp_catdir unless defined &catdir;
|
||||
|
||||
=item catfile
|
||||
|
||||
Concatenate one or more directory names and a filename to form a
|
||||
complete path ending with a filename
|
||||
|
||||
=cut
|
||||
|
||||
sub _pp_catfile {
|
||||
my $self = shift;
|
||||
my $file = $self->canonpath(pop @_);
|
||||
return $file unless @_;
|
||||
my $dir = $self->catdir(@_);
|
||||
$dir .= "/" unless substr($dir,-1) eq "/";
|
||||
return $dir.$file;
|
||||
}
|
||||
*catfile = \&_pp_catfile unless defined &catfile;
|
||||
|
||||
=item curdir
|
||||
|
||||
Returns a string representation of the current directory. "." on UNIX.
|
||||
|
||||
=cut
|
||||
|
||||
sub curdir { '.' }
|
||||
use constant _fn_curdir => ".";
|
||||
|
||||
=item devnull
|
||||
|
||||
Returns a string representation of the null device. "/dev/null" on UNIX.
|
||||
|
||||
=cut
|
||||
|
||||
sub devnull { '/dev/null' }
|
||||
use constant _fn_devnull => "/dev/null";
|
||||
|
||||
=item rootdir
|
||||
|
||||
Returns a string representation of the root directory. "/" on UNIX.
|
||||
|
||||
=cut
|
||||
|
||||
sub rootdir { '/' }
|
||||
use constant _fn_rootdir => "/";
|
||||
|
||||
=item tmpdir
|
||||
|
||||
Returns a string representation of the first writable directory from
|
||||
the following list or the current directory if none from the list are
|
||||
writable:
|
||||
|
||||
$ENV{TMPDIR}
|
||||
/tmp
|
||||
|
||||
If running under taint mode, and if $ENV{TMPDIR}
|
||||
is tainted, it is not used.
|
||||
|
||||
=cut
|
||||
|
||||
my ($tmpdir, %tmpenv);
|
||||
# Cache and return the calculated tmpdir, recording which env vars
|
||||
# determined it.
|
||||
sub _cache_tmpdir {
|
||||
@tmpenv{@_[2..$#_]} = @ENV{@_[2..$#_]};
|
||||
return $tmpdir = $_[1];
|
||||
}
|
||||
# Retrieve the cached tmpdir, checking first whether relevant env vars have
|
||||
# changed and invalidated the cache.
|
||||
sub _cached_tmpdir {
|
||||
shift;
|
||||
local $^W;
|
||||
return if grep $ENV{$_} ne $tmpenv{$_}, @_;
|
||||
return $tmpdir;
|
||||
}
|
||||
sub _tmpdir {
|
||||
my $self = shift;
|
||||
my @dirlist = @_;
|
||||
my $taint = do { no strict 'refs'; ${"\cTAINT"} };
|
||||
if ($taint) { # Check for taint mode on perl >= 5.8.0
|
||||
require Scalar::Util;
|
||||
@dirlist = grep { ! Scalar::Util::tainted($_) } @dirlist;
|
||||
}
|
||||
elsif ($] < 5.007) { # No ${^TAINT} before 5.8
|
||||
@dirlist = grep { !defined($_) || eval { eval('1'.substr $_,0,0) } }
|
||||
@dirlist;
|
||||
}
|
||||
|
||||
foreach (@dirlist) {
|
||||
next unless defined && -d && -w _;
|
||||
$tmpdir = $_;
|
||||
last;
|
||||
}
|
||||
$tmpdir = $self->curdir unless defined $tmpdir;
|
||||
$tmpdir = defined $tmpdir && $self->canonpath($tmpdir);
|
||||
if ( !$self->file_name_is_absolute($tmpdir) ) {
|
||||
# See [perl #120593] for the full details
|
||||
# If possible, return a full path, rather than '.' or 'lib', but
|
||||
# jump through some hoops to avoid returning a tainted value.
|
||||
($tmpdir) = grep {
|
||||
$taint ? ! Scalar::Util::tainted($_) :
|
||||
$] < 5.007 ? eval { eval('1'.substr $_,0,0) } : 1
|
||||
} $self->rel2abs($tmpdir), $tmpdir;
|
||||
}
|
||||
return $tmpdir;
|
||||
}
|
||||
|
||||
sub tmpdir {
|
||||
my $cached = $_[0]->_cached_tmpdir('TMPDIR');
|
||||
return $cached if defined $cached;
|
||||
$_[0]->_cache_tmpdir($_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp" ), 'TMPDIR');
|
||||
}
|
||||
|
||||
=item updir
|
||||
|
||||
Returns a string representation of the parent directory. ".." on UNIX.
|
||||
|
||||
=cut
|
||||
|
||||
sub updir { '..' }
|
||||
use constant _fn_updir => "..";
|
||||
|
||||
=item no_upwards
|
||||
|
||||
Given a list of file names, strip out those that refer to a parent
|
||||
directory. (Does not strip symlinks, only '.', '..', and equivalents.)
|
||||
|
||||
=cut
|
||||
|
||||
sub no_upwards {
|
||||
my $self = shift;
|
||||
return grep(!/^\.{1,2}\z/s, @_);
|
||||
}
|
||||
|
||||
=item case_tolerant
|
||||
|
||||
Returns a true or false value indicating, respectively, that alphabetic
|
||||
is not or is significant when comparing file specifications.
|
||||
|
||||
=cut
|
||||
|
||||
sub case_tolerant { 0 }
|
||||
use constant _fn_case_tolerant => 0;
|
||||
|
||||
=item file_name_is_absolute
|
||||
|
||||
Takes as argument a path and returns true if it is an absolute path.
|
||||
|
||||
This does not consult the local filesystem on Unix, Win32, OS/2 or Mac
|
||||
OS (Classic). It does consult the working environment for VMS (see
|
||||
L<File::Spec::VMS/file_name_is_absolute>).
|
||||
|
||||
=cut
|
||||
|
||||
sub file_name_is_absolute {
|
||||
my ($self,$file) = @_;
|
||||
return scalar($file =~ m:^/:s);
|
||||
}
|
||||
|
||||
=item path
|
||||
|
||||
Takes no argument, returns the environment variable PATH as an array.
|
||||
|
||||
=cut
|
||||
|
||||
sub path {
|
||||
return () unless exists $ENV{PATH};
|
||||
my @path = split(':', $ENV{PATH});
|
||||
foreach (@path) { $_ = '.' if $_ eq '' }
|
||||
return @path;
|
||||
}
|
||||
|
||||
=item join
|
||||
|
||||
join is the same as catfile.
|
||||
|
||||
=cut
|
||||
|
||||
sub join {
|
||||
my $self = shift;
|
||||
return $self->catfile(@_);
|
||||
}
|
||||
|
||||
=item splitpath
|
||||
|
||||
($volume,$directories,$file) = File::Spec->splitpath( $path );
|
||||
($volume,$directories,$file) = File::Spec->splitpath( $path,
|
||||
$no_file );
|
||||
|
||||
Splits a path into volume, directory, and filename portions. On systems
|
||||
with no concept of volume, returns '' for volume.
|
||||
|
||||
For systems with no syntax differentiating filenames from directories,
|
||||
assumes that the last file is a path unless $no_file is true or a
|
||||
trailing separator or /. or /.. is present. On Unix this means that $no_file
|
||||
true makes this return ( '', $path, '' ).
|
||||
|
||||
The directory portion may or may not be returned with a trailing '/'.
|
||||
|
||||
The results can be passed to L</catpath()> to get back a path equivalent to
|
||||
(usually identical to) the original path.
|
||||
|
||||
=cut
|
||||
|
||||
sub splitpath {
|
||||
my ($self,$path, $nofile) = @_;
|
||||
|
||||
my ($volume,$directory,$file) = ('','','');
|
||||
|
||||
if ( $nofile ) {
|
||||
$directory = $path;
|
||||
}
|
||||
else {
|
||||
$path =~ m|^ ( (?: .* / (?: \.\.?\z )? )? ) ([^/]*) |xs;
|
||||
$directory = $1;
|
||||
$file = $2;
|
||||
}
|
||||
|
||||
return ($volume,$directory,$file);
|
||||
}
|
||||
|
||||
|
||||
=item splitdir
|
||||
|
||||
The opposite of L</catdir()>.
|
||||
|
||||
@dirs = File::Spec->splitdir( $directories );
|
||||
|
||||
$directories must be only the directory portion of the path on systems
|
||||
that have the concept of a volume or that have path syntax that differentiates
|
||||
files from directories.
|
||||
|
||||
Unlike just splitting the directories on the separator, empty
|
||||
directory names (C<''>) can be returned, because these are significant
|
||||
on some OSs.
|
||||
|
||||
On Unix,
|
||||
|
||||
File::Spec->splitdir( "/a/b//c/" );
|
||||
|
||||
Yields:
|
||||
|
||||
( '', 'a', 'b', '', 'c', '' )
|
||||
|
||||
=cut
|
||||
|
||||
sub splitdir {
|
||||
return split m|/|, $_[1], -1; # Preserve trailing fields
|
||||
}
|
||||
|
||||
|
||||
=item catpath()
|
||||
|
||||
Takes volume, directory and file portions and returns an entire path. Under
|
||||
Unix, $volume is ignored, and directory and file are concatenated. A '/' is
|
||||
inserted if needed (though if the directory portion doesn't start with
|
||||
'/' it is not added). On other OSs, $volume is significant.
|
||||
|
||||
=cut
|
||||
|
||||
sub catpath {
|
||||
my ($self,$volume,$directory,$file) = @_;
|
||||
|
||||
if ( $directory ne '' &&
|
||||
$file ne '' &&
|
||||
substr( $directory, -1 ) ne '/' &&
|
||||
substr( $file, 0, 1 ) ne '/'
|
||||
) {
|
||||
$directory .= "/$file" ;
|
||||
}
|
||||
else {
|
||||
$directory .= $file ;
|
||||
}
|
||||
|
||||
return $directory ;
|
||||
}
|
||||
|
||||
=item abs2rel
|
||||
|
||||
Takes a destination path and an optional base path returns a relative path
|
||||
from the base path to the destination path:
|
||||
|
||||
$rel_path = File::Spec->abs2rel( $path ) ;
|
||||
$rel_path = File::Spec->abs2rel( $path, $base ) ;
|
||||
|
||||
If $base is not present or '', then L<cwd()|Cwd> is used. If $base is
|
||||
relative, then it is converted to absolute form using
|
||||
L</rel2abs()>. This means that it is taken to be relative to
|
||||
L<cwd()|Cwd>.
|
||||
|
||||
On systems that have a grammar that indicates filenames, this ignores the
|
||||
$base filename. Otherwise all path components are assumed to be
|
||||
directories.
|
||||
|
||||
If $path is relative, it is converted to absolute form using L</rel2abs()>.
|
||||
This means that it is taken to be relative to L<cwd()|Cwd>.
|
||||
|
||||
No checks against the filesystem are made, so the result may not be correct if
|
||||
C<$base> contains symbolic links. (Apply
|
||||
L<Cwd::abs_path()|Cwd/abs_path> beforehand if that
|
||||
is a concern.) On VMS, there is interaction with the working environment, as
|
||||
logicals and macros are expanded.
|
||||
|
||||
Based on code written by Shigio Yamaguchi.
|
||||
|
||||
=cut
|
||||
|
||||
sub abs2rel {
|
||||
my($self,$path,$base) = @_;
|
||||
$base = Cwd::getcwd() unless defined $base and length $base;
|
||||
|
||||
($path, $base) = map $self->canonpath($_), $path, $base;
|
||||
|
||||
my $path_directories;
|
||||
my $base_directories;
|
||||
|
||||
if (grep $self->file_name_is_absolute($_), $path, $base) {
|
||||
($path, $base) = map $self->rel2abs($_), $path, $base;
|
||||
|
||||
my ($path_volume) = $self->splitpath($path, 1);
|
||||
my ($base_volume) = $self->splitpath($base, 1);
|
||||
|
||||
# Can't relativize across volumes
|
||||
return $path unless $path_volume eq $base_volume;
|
||||
|
||||
$path_directories = ($self->splitpath($path, 1))[1];
|
||||
$base_directories = ($self->splitpath($base, 1))[1];
|
||||
|
||||
# For UNC paths, the user might give a volume like //foo/bar that
|
||||
# strictly speaking has no directory portion. Treat it as if it
|
||||
# had the root directory for that volume.
|
||||
if (!length($base_directories) and $self->file_name_is_absolute($base)) {
|
||||
$base_directories = $self->rootdir;
|
||||
}
|
||||
}
|
||||
else {
|
||||
my $wd= ($self->splitpath(Cwd::getcwd(), 1))[1];
|
||||
$path_directories = $self->catdir($wd, $path);
|
||||
$base_directories = $self->catdir($wd, $base);
|
||||
}
|
||||
|
||||
# Now, remove all leading components that are the same
|
||||
my @pathchunks = $self->splitdir( $path_directories );
|
||||
my @basechunks = $self->splitdir( $base_directories );
|
||||
|
||||
if ($base_directories eq $self->rootdir) {
|
||||
return $self->curdir if $path_directories eq $self->rootdir;
|
||||
shift @pathchunks;
|
||||
return $self->canonpath( $self->catpath('', $self->catdir( @pathchunks ), '') );
|
||||
}
|
||||
|
||||
my @common;
|
||||
while (@pathchunks && @basechunks && $self->_same($pathchunks[0], $basechunks[0])) {
|
||||
push @common, shift @pathchunks ;
|
||||
shift @basechunks ;
|
||||
}
|
||||
return $self->curdir unless @pathchunks || @basechunks;
|
||||
|
||||
# @basechunks now contains the directories the resulting relative path
|
||||
# must ascend out of before it can descend to $path_directory. If there
|
||||
# are updir components, we must descend into the corresponding directories
|
||||
# (this only works if they are no symlinks).
|
||||
my @reverse_base;
|
||||
while( defined(my $dir= shift @basechunks) ) {
|
||||
if( $dir ne $self->updir ) {
|
||||
unshift @reverse_base, $self->updir;
|
||||
push @common, $dir;
|
||||
}
|
||||
elsif( @common ) {
|
||||
if( @reverse_base && $reverse_base[0] eq $self->updir ) {
|
||||
shift @reverse_base;
|
||||
pop @common;
|
||||
}
|
||||
else {
|
||||
unshift @reverse_base, pop @common;
|
||||
}
|
||||
}
|
||||
}
|
||||
my $result_dirs = $self->catdir( @reverse_base, @pathchunks );
|
||||
return $self->canonpath( $self->catpath('', $result_dirs, '') );
|
||||
}
|
||||
|
||||
sub _same {
|
||||
$_[1] eq $_[2];
|
||||
}
|
||||
|
||||
=item rel2abs()
|
||||
|
||||
Converts a relative path to an absolute path.
|
||||
|
||||
$abs_path = File::Spec->rel2abs( $path ) ;
|
||||
$abs_path = File::Spec->rel2abs( $path, $base ) ;
|
||||
|
||||
If $base is not present or '', then L<cwd()|Cwd> is used. If $base is
|
||||
relative, then it is converted to absolute form using
|
||||
L</rel2abs()>. This means that it is taken to be relative to
|
||||
L<cwd()|Cwd>.
|
||||
|
||||
On systems that have a grammar that indicates filenames, this ignores
|
||||
the $base filename. Otherwise all path components are assumed to be
|
||||
directories.
|
||||
|
||||
If $path is absolute, it is cleaned up and returned using L</canonpath()>.
|
||||
|
||||
No checks against the filesystem are made. On VMS, there is
|
||||
interaction with the working environment, as logicals and
|
||||
macros are expanded.
|
||||
|
||||
Based on code written by Shigio Yamaguchi.
|
||||
|
||||
=cut
|
||||
|
||||
sub rel2abs {
|
||||
my ($self,$path,$base ) = @_;
|
||||
|
||||
# Clean up $path
|
||||
if ( ! $self->file_name_is_absolute( $path ) ) {
|
||||
# Figure out the effective $base and clean it up.
|
||||
if ( !defined( $base ) || $base eq '' ) {
|
||||
$base = Cwd::getcwd();
|
||||
}
|
||||
elsif ( ! $self->file_name_is_absolute( $base ) ) {
|
||||
$base = $self->rel2abs( $base ) ;
|
||||
}
|
||||
else {
|
||||
$base = $self->canonpath( $base ) ;
|
||||
}
|
||||
|
||||
# Glom them together
|
||||
$path = $self->catdir( $base, $path ) ;
|
||||
}
|
||||
|
||||
return $self->canonpath( $path ) ;
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
|
||||
|
||||
This program is free software; you can redistribute it and/or modify
|
||||
it under the same terms as Perl itself.
|
||||
|
||||
Please submit bug reports and patches to perlbug@perl.org.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<File::Spec>
|
||||
|
||||
=cut
|
||||
|
||||
# Internal method to reduce xx\..\yy -> yy
|
||||
sub _collapse {
|
||||
my($fs, $path) = @_;
|
||||
|
||||
my $updir = $fs->updir;
|
||||
my $curdir = $fs->curdir;
|
||||
|
||||
my($vol, $dirs, $file) = $fs->splitpath($path);
|
||||
my @dirs = $fs->splitdir($dirs);
|
||||
pop @dirs if @dirs && $dirs[-1] eq '';
|
||||
|
||||
my @collapsed;
|
||||
foreach my $dir (@dirs) {
|
||||
if( $dir eq $updir and # if we have an updir
|
||||
@collapsed and # and something to collapse
|
||||
length $collapsed[-1] and # and its not the rootdir
|
||||
$collapsed[-1] ne $updir and # nor another updir
|
||||
$collapsed[-1] ne $curdir # nor the curdir
|
||||
)
|
||||
{ # then
|
||||
pop @collapsed; # collapse
|
||||
}
|
||||
else { # else
|
||||
push @collapsed, $dir; # just hang onto it
|
||||
}
|
||||
}
|
||||
|
||||
return $fs->catpath($vol,
|
||||
$fs->catdir(@collapsed),
|
||||
$file
|
||||
);
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
569
database/perl/lib/File/Spec/VMS.pm
Normal file
569
database/perl/lib/File/Spec/VMS.pm
Normal file
@@ -0,0 +1,569 @@
|
||||
package File::Spec::VMS;
|
||||
|
||||
use strict;
|
||||
use Cwd ();
|
||||
require File::Spec::Unix;
|
||||
|
||||
our $VERSION = '3.78';
|
||||
$VERSION =~ tr/_//d;
|
||||
|
||||
our @ISA = qw(File::Spec::Unix);
|
||||
|
||||
use File::Basename;
|
||||
use VMS::Filespec;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::Spec::VMS - methods for VMS file specs
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
require File::Spec::VMS; # Done internally by File::Spec if needed
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
See File::Spec::Unix for a documentation of the methods provided
|
||||
there. This package overrides the implementation of these methods, not
|
||||
the semantics.
|
||||
|
||||
The default behavior is to allow either VMS or Unix syntax on input and to
|
||||
return VMS syntax on output unless Unix syntax has been explicitly requested
|
||||
via the C<DECC$FILENAME_UNIX_REPORT> CRTL feature.
|
||||
|
||||
=over 4
|
||||
|
||||
=cut
|
||||
|
||||
# Need to look up the feature settings. The preferred way is to use the
|
||||
# VMS::Feature module, but that may not be available to dual life modules.
|
||||
|
||||
my $use_feature;
|
||||
BEGIN {
|
||||
if (eval { local $SIG{__DIE__};
|
||||
local @INC = @INC;
|
||||
pop @INC if $INC[-1] eq '.';
|
||||
require VMS::Feature; }) {
|
||||
$use_feature = 1;
|
||||
}
|
||||
}
|
||||
|
||||
# Need to look up the UNIX report mode. This may become a dynamic mode
|
||||
# in the future.
|
||||
sub _unix_rpt {
|
||||
my $unix_rpt;
|
||||
if ($use_feature) {
|
||||
$unix_rpt = VMS::Feature::current("filename_unix_report");
|
||||
} else {
|
||||
my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
|
||||
$unix_rpt = $env_unix_rpt =~ /^[ET1]/i;
|
||||
}
|
||||
return $unix_rpt;
|
||||
}
|
||||
|
||||
=item canonpath (override)
|
||||
|
||||
Removes redundant portions of file specifications and returns results
|
||||
in native syntax unless Unix filename reporting has been enabled.
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
sub canonpath {
|
||||
my($self,$path) = @_;
|
||||
|
||||
return undef unless defined $path;
|
||||
|
||||
my $unix_rpt = $self->_unix_rpt;
|
||||
|
||||
if ($path =~ m|/|) {
|
||||
my $pathify = $path =~ m|/\Z(?!\n)|;
|
||||
$path = $self->SUPER::canonpath($path);
|
||||
|
||||
return $path if $unix_rpt;
|
||||
$path = $pathify ? vmspath($path) : vmsify($path);
|
||||
}
|
||||
|
||||
$path =~ s/(?<!\^)</[/; # < and > ==> [ and ]
|
||||
$path =~ s/(?<!\^)>/]/;
|
||||
$path =~ s/(?<!\^)\]\[\./\.\]\[/g; # ][. ==> .][
|
||||
$path =~ s/(?<!\^)\[000000\.\]\[/\[/g; # [000000.][ ==> [
|
||||
$path =~ s/(?<!\^)\[000000\./\[/g; # [000000. ==> [
|
||||
$path =~ s/(?<!\^)\.\]\[000000\]/\]/g; # .][000000] ==> ]
|
||||
$path =~ s/(?<!\^)\.\]\[/\./g; # foo.][bar ==> foo.bar
|
||||
1 while ($path =~ s/(?<!\^)([\[\.])(-+)\.(-+)([\.\]])/$1$2$3$4/);
|
||||
# That loop does the following
|
||||
# with any amount of dashes:
|
||||
# .-.-. ==> .--.
|
||||
# [-.-. ==> [--.
|
||||
# .-.-] ==> .--]
|
||||
# [-.-] ==> [--]
|
||||
1 while ($path =~ s/(?<!\^)([\[\.])(?:\^.|[^\]\.])+\.-(-+)([\]\.])/$1$2$3/);
|
||||
# That loop does the following
|
||||
# with any amount (minimum 2)
|
||||
# of dashes:
|
||||
# .foo.--. ==> .-.
|
||||
# .foo.--] ==> .-]
|
||||
# [foo.--. ==> [-.
|
||||
# [foo.--] ==> [-]
|
||||
#
|
||||
# And then, the remaining cases
|
||||
$path =~ s/(?<!\^)\[\.-/[-/; # [.- ==> [-
|
||||
$path =~ s/(?<!\^)\.(?:\^.|[^\]\.])+\.-\./\./g; # .foo.-. ==> .
|
||||
$path =~ s/(?<!\^)\[(?:\^.|[^\]\.])+\.-\./\[/g; # [foo.-. ==> [
|
||||
$path =~ s/(?<!\^)\.(?:\^.|[^\]\.])+\.-\]/\]/g; # .foo.-] ==> ]
|
||||
# [foo.-] ==> [000000]
|
||||
$path =~ s/(?<!\^)\[(?:\^.|[^\]\.])+\.-\]/\[000000\]/g;
|
||||
# [] ==>
|
||||
$path =~ s/(?<!\^)\[\]// unless $path eq '[]';
|
||||
return $unix_rpt ? unixify($path) : $path;
|
||||
}
|
||||
|
||||
=item catdir (override)
|
||||
|
||||
Concatenates a list of file specifications, and returns the result as a
|
||||
native directory specification unless the Unix filename reporting feature
|
||||
has been enabled. No check is made for "impossible" cases (e.g. elements
|
||||
other than the first being absolute filespecs).
|
||||
|
||||
=cut
|
||||
|
||||
sub catdir {
|
||||
my $self = shift;
|
||||
my $dir = pop;
|
||||
|
||||
my $unix_rpt = $self->_unix_rpt;
|
||||
|
||||
my @dirs = grep {defined() && length()} @_;
|
||||
|
||||
my $rslt;
|
||||
if (@dirs) {
|
||||
my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
|
||||
my ($spath,$sdir) = ($path,$dir);
|
||||
$spath =~ s/\.dir\Z(?!\n)//i; $sdir =~ s/\.dir\Z(?!\n)//i;
|
||||
|
||||
if ($unix_rpt) {
|
||||
$spath = unixify($spath) unless $spath =~ m#/#;
|
||||
$sdir= unixify($sdir) unless $sdir =~ m#/#;
|
||||
return $self->SUPER::catdir($spath, $sdir)
|
||||
}
|
||||
|
||||
$rslt = vmspath( unixify($spath) . '/' . unixify($sdir));
|
||||
|
||||
# Special case for VMS absolute directory specs: these will have
|
||||
# had device prepended during trip through Unix syntax in
|
||||
# eliminate_macros(), since Unix syntax has no way to express
|
||||
# "absolute from the top of this device's directory tree".
|
||||
if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; }
|
||||
|
||||
} else {
|
||||
# Single directory. Return an empty string on null input; otherwise
|
||||
# just return a canonical path.
|
||||
|
||||
if (not defined $dir or not length $dir) {
|
||||
$rslt = '';
|
||||
} else {
|
||||
$rslt = $unix_rpt ? $dir : vmspath($dir);
|
||||
}
|
||||
}
|
||||
return $self->canonpath($rslt);
|
||||
}
|
||||
|
||||
=item catfile (override)
|
||||
|
||||
Concatenates a list of directory specifications with a filename specification
|
||||
to build a path.
|
||||
|
||||
=cut
|
||||
|
||||
sub catfile {
|
||||
my $self = shift;
|
||||
my $tfile = pop();
|
||||
my $file = $self->canonpath($tfile);
|
||||
my @files = grep {defined() && length()} @_;
|
||||
|
||||
my $unix_rpt = $self->_unix_rpt;
|
||||
|
||||
my $rslt;
|
||||
if (@files) {
|
||||
my $path = (@files == 1 ? $files[0] : $self->catdir(@files));
|
||||
my $spath = $path;
|
||||
|
||||
# Something building a VMS path in pieces may try to pass a
|
||||
# directory name in filename format, so normalize it.
|
||||
$spath =~ s/\.dir\Z(?!\n)//i;
|
||||
|
||||
# If the spath ends with a directory delimiter and the file is bare,
|
||||
# then just concatenate them.
|
||||
if ($spath =~ /^(?<!\^)[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) {
|
||||
$rslt = "$spath$file";
|
||||
} else {
|
||||
$rslt = unixify($spath);
|
||||
$rslt .= (defined($rslt) && length($rslt) ? '/' : '') . unixify($file);
|
||||
$rslt = vmsify($rslt) unless $unix_rpt;
|
||||
}
|
||||
}
|
||||
else {
|
||||
# Only passed a single file?
|
||||
my $xfile = (defined($file) && length($file)) ? $file : '';
|
||||
|
||||
$rslt = $unix_rpt ? $xfile : vmsify($xfile);
|
||||
}
|
||||
return $self->canonpath($rslt) unless $unix_rpt;
|
||||
|
||||
# In Unix report mode, do not strip off redundant path information.
|
||||
return $rslt;
|
||||
}
|
||||
|
||||
|
||||
=item curdir (override)
|
||||
|
||||
Returns a string representation of the current directory: '[]' or '.'
|
||||
|
||||
=cut
|
||||
|
||||
sub curdir {
|
||||
my $self = shift @_;
|
||||
return '.' if ($self->_unix_rpt);
|
||||
return '[]';
|
||||
}
|
||||
|
||||
=item devnull (override)
|
||||
|
||||
Returns a string representation of the null device: '_NLA0:' or '/dev/null'
|
||||
|
||||
=cut
|
||||
|
||||
sub devnull {
|
||||
my $self = shift @_;
|
||||
return '/dev/null' if ($self->_unix_rpt);
|
||||
return "_NLA0:";
|
||||
}
|
||||
|
||||
=item rootdir (override)
|
||||
|
||||
Returns a string representation of the root directory: 'SYS$DISK:[000000]'
|
||||
or '/'
|
||||
|
||||
=cut
|
||||
|
||||
sub rootdir {
|
||||
my $self = shift @_;
|
||||
if ($self->_unix_rpt) {
|
||||
# Root may exist, try it first.
|
||||
my $try = '/';
|
||||
my ($dev1, $ino1) = stat('/');
|
||||
my ($dev2, $ino2) = stat('.');
|
||||
|
||||
# Perl falls back to '.' if it can not determine '/'
|
||||
if (($dev1 != $dev2) || ($ino1 != $ino2)) {
|
||||
return $try;
|
||||
}
|
||||
# Fall back to UNIX format sys$disk.
|
||||
return '/sys$disk/';
|
||||
}
|
||||
return 'SYS$DISK:[000000]';
|
||||
}
|
||||
|
||||
=item tmpdir (override)
|
||||
|
||||
Returns a string representation of the first writable directory
|
||||
from the following list or '' if none are writable:
|
||||
|
||||
/tmp if C<DECC$FILENAME_UNIX_REPORT> is enabled.
|
||||
sys$scratch:
|
||||
$ENV{TMPDIR}
|
||||
|
||||
If running under taint mode, and if $ENV{TMPDIR}
|
||||
is tainted, it is not used.
|
||||
|
||||
=cut
|
||||
|
||||
sub tmpdir {
|
||||
my $self = shift @_;
|
||||
my $tmpdir = $self->_cached_tmpdir('TMPDIR');
|
||||
return $tmpdir if defined $tmpdir;
|
||||
if ($self->_unix_rpt) {
|
||||
$tmpdir = $self->_tmpdir('/tmp', '/sys$scratch', $ENV{TMPDIR});
|
||||
}
|
||||
else {
|
||||
$tmpdir = $self->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} );
|
||||
}
|
||||
$self->_cache_tmpdir($tmpdir, 'TMPDIR');
|
||||
}
|
||||
|
||||
=item updir (override)
|
||||
|
||||
Returns a string representation of the parent directory: '[-]' or '..'
|
||||
|
||||
=cut
|
||||
|
||||
sub updir {
|
||||
my $self = shift @_;
|
||||
return '..' if ($self->_unix_rpt);
|
||||
return '[-]';
|
||||
}
|
||||
|
||||
=item case_tolerant (override)
|
||||
|
||||
VMS file specification syntax is case-tolerant.
|
||||
|
||||
=cut
|
||||
|
||||
sub case_tolerant {
|
||||
return 1;
|
||||
}
|
||||
|
||||
=item path (override)
|
||||
|
||||
Translate logical name DCL$PATH as a searchlist, rather than trying
|
||||
to C<split> string value of C<$ENV{'PATH'}>.
|
||||
|
||||
=cut
|
||||
|
||||
sub path {
|
||||
my (@dirs,$dir,$i);
|
||||
while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }
|
||||
return @dirs;
|
||||
}
|
||||
|
||||
=item file_name_is_absolute (override)
|
||||
|
||||
Checks for VMS directory spec as well as Unix separators.
|
||||
|
||||
=cut
|
||||
|
||||
sub file_name_is_absolute {
|
||||
my ($self,$file) = @_;
|
||||
# If it's a logical name, expand it.
|
||||
$file = $ENV{$file} while $file =~ /^[\w\$\-]+\Z(?!\n)/s && $ENV{$file};
|
||||
return scalar($file =~ m!^/!s ||
|
||||
$file =~ m![<\[][^.\-\]>]! ||
|
||||
$file =~ /^[A-Za-z0-9_\$\-\~]+(?<!\^):/);
|
||||
}
|
||||
|
||||
=item splitpath (override)
|
||||
|
||||
($volume,$directories,$file) = File::Spec->splitpath( $path );
|
||||
($volume,$directories,$file) = File::Spec->splitpath( $path,
|
||||
$no_file );
|
||||
|
||||
Passing a true value for C<$no_file> indicates that the path being
|
||||
split only contains directory components, even on systems where you
|
||||
can usually (when not supporting a foreign syntax) tell the difference
|
||||
between directories and files at a glance.
|
||||
|
||||
=cut
|
||||
|
||||
sub splitpath {
|
||||
my($self,$path, $nofile) = @_;
|
||||
my($dev,$dir,$file) = ('','','');
|
||||
my $vmsify_path = vmsify($path);
|
||||
|
||||
if ( $nofile ) {
|
||||
#vmsify('d1/d2/d3') returns '[.d1.d2]d3'
|
||||
#vmsify('/d1/d2/d3') returns 'd1:[d2]d3'
|
||||
if( $vmsify_path =~ /(.*)\](.+)/ ){
|
||||
$vmsify_path = $1.'.'.$2.']';
|
||||
}
|
||||
$vmsify_path =~ /(.+:)?(.*)/s;
|
||||
$dir = defined $2 ? $2 : ''; # dir can be '0'
|
||||
return ($1 || '',$dir,$file);
|
||||
}
|
||||
else {
|
||||
$vmsify_path =~ /(.+:)?([\[<].*[\]>])?(.*)/s;
|
||||
return ($1 || '',$2 || '',$3);
|
||||
}
|
||||
}
|
||||
|
||||
=item splitdir (override)
|
||||
|
||||
Split a directory specification into the components.
|
||||
|
||||
=cut
|
||||
|
||||
sub splitdir {
|
||||
my($self,$dirspec) = @_;
|
||||
my @dirs = ();
|
||||
return @dirs if ( (!defined $dirspec) || ('' eq $dirspec) );
|
||||
|
||||
$dirspec =~ s/(?<!\^)</[/; # < and > ==> [ and ]
|
||||
$dirspec =~ s/(?<!\^)>/]/;
|
||||
$dirspec =~ s/(?<!\^)\]\[\./\.\]\[/g; # ][. ==> .][
|
||||
$dirspec =~ s/(?<!\^)\[000000\.\]\[/\[/g; # [000000.][ ==> [
|
||||
$dirspec =~ s/(?<!\^)\[000000\./\[/g; # [000000. ==> [
|
||||
$dirspec =~ s/(?<!\^)\.\]\[000000\]/\]/g; # .][000000] ==> ]
|
||||
$dirspec =~ s/(?<!\^)\.\]\[/\./g; # foo.][bar ==> foo.bar
|
||||
while ($dirspec =~ s/(^|[\[\<\.])\-(\-+)($|[\]\>\.])/$1-.$2$3/g) {}
|
||||
# That loop does the following
|
||||
# with any amount of dashes:
|
||||
# .--. ==> .-.-.
|
||||
# [--. ==> [-.-.
|
||||
# .--] ==> .-.-]
|
||||
# [--] ==> [-.-]
|
||||
$dirspec = "[$dirspec]" unless $dirspec =~ /(?<!\^)[\[<]/; # make legal
|
||||
$dirspec =~ s/^(\[|<)\./$1/;
|
||||
@dirs = split /(?<!\^)\./, vmspath($dirspec);
|
||||
$dirs[0] =~ s/^[\[<]//s; $dirs[-1] =~ s/[\]>]\Z(?!\n)//s;
|
||||
@dirs;
|
||||
}
|
||||
|
||||
|
||||
=item catpath (override)
|
||||
|
||||
Construct a complete filespec.
|
||||
|
||||
=cut
|
||||
|
||||
sub catpath {
|
||||
my($self,$dev,$dir,$file) = @_;
|
||||
|
||||
# We look for a volume in $dev, then in $dir, but not both
|
||||
my ($dir_volume, $dir_dir, $dir_file) = $self->splitpath($dir);
|
||||
$dev = $dir_volume unless length $dev;
|
||||
$dir = length $dir_file ? $self->catfile($dir_dir, $dir_file) : $dir_dir;
|
||||
|
||||
if ($dev =~ m|^(?<!\^)/+([^/]+)|) { $dev = "$1:"; }
|
||||
else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; }
|
||||
if (length($dev) or length($dir)) {
|
||||
$dir = "[$dir]" unless $dir =~ /(?<!\^)[\[<\/]/;
|
||||
$dir = vmspath($dir);
|
||||
}
|
||||
$dir = '' if length($dev) && ($dir eq '[]' || $dir eq '<>');
|
||||
"$dev$dir$file";
|
||||
}
|
||||
|
||||
=item abs2rel (override)
|
||||
|
||||
Attempt to convert an absolute file specification to a relative specification.
|
||||
|
||||
=cut
|
||||
|
||||
sub abs2rel {
|
||||
my $self = shift;
|
||||
my($path,$base) = @_;
|
||||
|
||||
$base = Cwd::getcwd() unless defined $base and length $base;
|
||||
|
||||
# If there is no device or directory syntax on $base, make sure it
|
||||
# is treated as a directory.
|
||||
$base = vmspath($base) unless $base =~ m{(?<!\^)[\[<:]};
|
||||
|
||||
for ($path, $base) { $_ = $self->rel2abs($_) }
|
||||
|
||||
# Are we even starting $path on the same (node::)device as $base? Note that
|
||||
# logical paths or nodename differences may be on the "same device"
|
||||
# but the comparison that ignores device differences so as to concatenate
|
||||
# [---] up directory specs is not even a good idea in cases where there is
|
||||
# a logical path difference between $path and $base nodename and/or device.
|
||||
# Hence we fall back to returning the absolute $path spec
|
||||
# if there is a case blind device (or node) difference of any sort
|
||||
# and we do not even try to call $parse() or consult %ENV for $trnlnm()
|
||||
# (this module needs to run on non VMS platforms after all).
|
||||
|
||||
my ($path_volume, $path_directories, $path_file) = $self->splitpath($path);
|
||||
my ($base_volume, $base_directories, $base_file) = $self->splitpath($base);
|
||||
return $self->canonpath( $path ) unless lc($path_volume) eq lc($base_volume);
|
||||
|
||||
# Now, remove all leading components that are the same
|
||||
my @pathchunks = $self->splitdir( $path_directories );
|
||||
my $pathchunks = @pathchunks;
|
||||
unshift(@pathchunks,'000000') unless $pathchunks[0] eq '000000';
|
||||
my @basechunks = $self->splitdir( $base_directories );
|
||||
my $basechunks = @basechunks;
|
||||
unshift(@basechunks,'000000') unless $basechunks[0] eq '000000';
|
||||
|
||||
while ( @pathchunks &&
|
||||
@basechunks &&
|
||||
lc( $pathchunks[0] ) eq lc( $basechunks[0] )
|
||||
) {
|
||||
shift @pathchunks ;
|
||||
shift @basechunks ;
|
||||
}
|
||||
|
||||
# @basechunks now contains the directories to climb out of,
|
||||
# @pathchunks now has the directories to descend in to.
|
||||
if ((@basechunks > 0) || ($basechunks != $pathchunks)) {
|
||||
$path_directories = join '.', ('-' x @basechunks, @pathchunks) ;
|
||||
}
|
||||
else {
|
||||
$path_directories = join '.', @pathchunks;
|
||||
}
|
||||
$path_directories = '['.$path_directories.']';
|
||||
return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ;
|
||||
}
|
||||
|
||||
|
||||
=item rel2abs (override)
|
||||
|
||||
Return an absolute file specification from a relative one.
|
||||
|
||||
=cut
|
||||
|
||||
sub rel2abs {
|
||||
my $self = shift ;
|
||||
my ($path,$base ) = @_;
|
||||
return undef unless defined $path;
|
||||
if ($path =~ m/\//) {
|
||||
$path = ( -d $path || $path =~ m/\/\z/ # educated guessing about
|
||||
? vmspath($path) # whether it's a directory
|
||||
: vmsify($path) );
|
||||
}
|
||||
$base = vmspath($base) if defined $base && $base =~ m/\//;
|
||||
|
||||
# Clean up and split up $path
|
||||
if ( ! $self->file_name_is_absolute( $path ) ) {
|
||||
# Figure out the effective $base and clean it up.
|
||||
if ( !defined( $base ) || $base eq '' ) {
|
||||
$base = Cwd::getcwd();
|
||||
}
|
||||
elsif ( ! $self->file_name_is_absolute( $base ) ) {
|
||||
$base = $self->rel2abs( $base ) ;
|
||||
}
|
||||
else {
|
||||
$base = $self->canonpath( $base ) ;
|
||||
}
|
||||
|
||||
# Split up paths
|
||||
my ( $path_directories, $path_file ) =
|
||||
($self->splitpath( $path ))[1,2] ;
|
||||
|
||||
my ( $base_volume, $base_directories ) =
|
||||
$self->splitpath( $base ) ;
|
||||
|
||||
$path_directories = '' if $path_directories eq '[]' ||
|
||||
$path_directories eq '<>';
|
||||
my $sep = '' ;
|
||||
$sep = '.'
|
||||
if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} &&
|
||||
$path_directories =~ m{^[^.\[<]}s
|
||||
) ;
|
||||
$base_directories = "$base_directories$sep$path_directories";
|
||||
$base_directories =~ s{\.?[\]>][\[<]\.?}{.};
|
||||
|
||||
$path = $self->catpath( $base_volume, $base_directories, $path_file );
|
||||
}
|
||||
|
||||
return $self->canonpath( $path ) ;
|
||||
}
|
||||
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004-14 by the Perl 5 Porters. All rights reserved.
|
||||
|
||||
This program is free software; you can redistribute it and/or modify
|
||||
it under the same terms as Perl itself.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
|
||||
implementation of these methods, not the semantics.
|
||||
|
||||
An explanation of VMS file specs can be found at
|
||||
L<http://h71000.www7.hp.com/doc/731FINAL/4506/4506pro_014.html#apps_locating_naming_files>.
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
439
database/perl/lib/File/Spec/Win32.pm
Normal file
439
database/perl/lib/File/Spec/Win32.pm
Normal file
@@ -0,0 +1,439 @@
|
||||
package File::Spec::Win32;
|
||||
|
||||
use strict;
|
||||
|
||||
use Cwd ();
|
||||
require File::Spec::Unix;
|
||||
|
||||
our $VERSION = '3.79';
|
||||
$VERSION =~ tr/_//d;
|
||||
|
||||
our @ISA = qw(File::Spec::Unix);
|
||||
|
||||
# Some regexes we use for path splitting
|
||||
my $DRIVE_RX = '[a-zA-Z]:';
|
||||
my $UNC_RX = '(?:\\\\\\\\|//)[^\\\\/]+[\\\\/][^\\\\/]+';
|
||||
my $VOL_RX = "(?:$DRIVE_RX|$UNC_RX)";
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::Spec::Win32 - methods for Win32 file specs
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
require File::Spec::Win32; # Done internally by File::Spec if needed
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
See File::Spec::Unix for a documentation of the methods provided
|
||||
there. This package overrides the implementation of these methods, not
|
||||
the semantics.
|
||||
|
||||
=over 4
|
||||
|
||||
=item devnull
|
||||
|
||||
Returns a string representation of the null device.
|
||||
|
||||
=cut
|
||||
|
||||
sub devnull {
|
||||
return "nul";
|
||||
}
|
||||
|
||||
sub rootdir { '\\' }
|
||||
|
||||
|
||||
=item tmpdir
|
||||
|
||||
Returns a string representation of the first existing directory
|
||||
from the following list:
|
||||
|
||||
$ENV{TMPDIR}
|
||||
$ENV{TEMP}
|
||||
$ENV{TMP}
|
||||
SYS:/temp
|
||||
C:\system\temp
|
||||
C:/temp
|
||||
/tmp
|
||||
/
|
||||
|
||||
The SYS:/temp is preferred in Novell NetWare and the C:\system\temp
|
||||
for Symbian (the File::Spec::Win32 is used also for those platforms).
|
||||
|
||||
If running under taint mode, and if the environment
|
||||
variables are tainted, they are not used.
|
||||
|
||||
=cut
|
||||
|
||||
sub tmpdir {
|
||||
my $tmpdir = $_[0]->_cached_tmpdir(qw(TMPDIR TEMP TMP));
|
||||
return $tmpdir if defined $tmpdir;
|
||||
$tmpdir = $_[0]->_tmpdir( map( $ENV{$_}, qw(TMPDIR TEMP TMP) ),
|
||||
'SYS:/temp',
|
||||
'C:\system\temp',
|
||||
'C:/temp',
|
||||
'/tmp',
|
||||
'/' );
|
||||
$_[0]->_cache_tmpdir($tmpdir, qw(TMPDIR TEMP TMP));
|
||||
}
|
||||
|
||||
=item case_tolerant
|
||||
|
||||
MSWin32 case-tolerance depends on GetVolumeInformation() $ouFsFlags == FS_CASE_SENSITIVE,
|
||||
indicating the case significance when comparing file specifications.
|
||||
Since XP FS_CASE_SENSITIVE is effectively disabled for the NT subsubsystem.
|
||||
See L<http://cygwin.com/ml/cygwin/2007-07/msg00891.html>
|
||||
Default: 1
|
||||
|
||||
=cut
|
||||
|
||||
sub case_tolerant {
|
||||
eval {
|
||||
local @INC = @INC;
|
||||
pop @INC if $INC[-1] eq '.';
|
||||
require Win32API::File;
|
||||
} or return 1;
|
||||
my $drive = shift || "C:";
|
||||
my $osFsType = "\0"x256;
|
||||
my $osVolName = "\0"x256;
|
||||
my $ouFsFlags = 0;
|
||||
Win32API::File::GetVolumeInformation($drive, $osVolName, 256, [], [], $ouFsFlags, $osFsType, 256 );
|
||||
if ($ouFsFlags & Win32API::File::FS_CASE_SENSITIVE()) { return 0; }
|
||||
else { return 1; }
|
||||
}
|
||||
|
||||
=item file_name_is_absolute
|
||||
|
||||
As of right now, this returns 2 if the path is absolute with a
|
||||
volume, 1 if it's absolute with no volume, 0 otherwise.
|
||||
|
||||
=cut
|
||||
|
||||
sub file_name_is_absolute {
|
||||
|
||||
my ($self,$file) = @_;
|
||||
|
||||
if ($file =~ m{^($VOL_RX)}o) {
|
||||
my $vol = $1;
|
||||
return ($vol =~ m{^$UNC_RX}o ? 2
|
||||
: $file =~ m{^$DRIVE_RX[\\/]}o ? 2
|
||||
: 0);
|
||||
}
|
||||
return $file =~ m{^[\\/]} ? 1 : 0;
|
||||
}
|
||||
|
||||
=item catfile
|
||||
|
||||
Concatenate one or more directory names and a filename to form a
|
||||
complete path ending with a filename
|
||||
|
||||
=cut
|
||||
|
||||
sub catfile {
|
||||
shift;
|
||||
|
||||
# Legacy / compatibility support
|
||||
#
|
||||
shift, return _canon_cat( "/", @_ )
|
||||
if !@_ || $_[0] eq "";
|
||||
|
||||
# Compatibility with File::Spec <= 3.26:
|
||||
# catfile('A:', 'foo') should return 'A:\foo'.
|
||||
return _canon_cat( ($_[0].'\\'), @_[1..$#_] )
|
||||
if $_[0] =~ m{^$DRIVE_RX\z}o;
|
||||
|
||||
return _canon_cat( @_ );
|
||||
}
|
||||
|
||||
sub catdir {
|
||||
shift;
|
||||
|
||||
# Legacy / compatibility support
|
||||
#
|
||||
return ""
|
||||
unless @_;
|
||||
shift, return _canon_cat( "/", @_ )
|
||||
if $_[0] eq "";
|
||||
|
||||
# Compatibility with File::Spec <= 3.26:
|
||||
# catdir('A:', 'foo') should return 'A:\foo'.
|
||||
return _canon_cat( ($_[0].'\\'), @_[1..$#_] )
|
||||
if $_[0] =~ m{^$DRIVE_RX\z}o;
|
||||
|
||||
return _canon_cat( @_ );
|
||||
}
|
||||
|
||||
sub path {
|
||||
my @path = split(';', $ENV{PATH});
|
||||
s/"//g for @path;
|
||||
@path = grep length, @path;
|
||||
unshift(@path, ".");
|
||||
return @path;
|
||||
}
|
||||
|
||||
=item canonpath
|
||||
|
||||
No physical check on the filesystem, but a logical cleanup of a
|
||||
path. On UNIX eliminated successive slashes and successive "/.".
|
||||
On Win32 makes
|
||||
|
||||
dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even
|
||||
dir1\dir2\dir3\...\dir4 -> \dir\dir4
|
||||
|
||||
=cut
|
||||
|
||||
sub canonpath {
|
||||
# Legacy / compatibility support
|
||||
#
|
||||
return $_[1] if !defined($_[1]) or $_[1] eq '';
|
||||
return _canon_cat( $_[1] );
|
||||
}
|
||||
|
||||
=item splitpath
|
||||
|
||||
($volume,$directories,$file) = File::Spec->splitpath( $path );
|
||||
($volume,$directories,$file) = File::Spec->splitpath( $path,
|
||||
$no_file );
|
||||
|
||||
Splits a path into volume, directory, and filename portions. Assumes that
|
||||
the last file is a path unless the path ends in '\\', '\\.', '\\..'
|
||||
or $no_file is true. On Win32 this means that $no_file true makes this return
|
||||
( $volume, $path, '' ).
|
||||
|
||||
Separators accepted are \ and /.
|
||||
|
||||
Volumes can be drive letters or UNC sharenames (\\server\share).
|
||||
|
||||
The results can be passed to L</catpath> to get back a path equivalent to
|
||||
(usually identical to) the original path.
|
||||
|
||||
=cut
|
||||
|
||||
sub splitpath {
|
||||
my ($self,$path, $nofile) = @_;
|
||||
my ($volume,$directory,$file) = ('','','');
|
||||
if ( $nofile ) {
|
||||
$path =~
|
||||
m{^ ( $VOL_RX ? ) (.*) }sox;
|
||||
$volume = $1;
|
||||
$directory = $2;
|
||||
}
|
||||
else {
|
||||
$path =~
|
||||
m{^ ( $VOL_RX ? )
|
||||
( (?:.*[\\/](?:\.\.?\Z(?!\n))?)? )
|
||||
(.*)
|
||||
}sox;
|
||||
$volume = $1;
|
||||
$directory = $2;
|
||||
$file = $3;
|
||||
}
|
||||
|
||||
return ($volume,$directory,$file);
|
||||
}
|
||||
|
||||
|
||||
=item splitdir
|
||||
|
||||
The opposite of L<catdir()|File::Spec/catdir>.
|
||||
|
||||
@dirs = File::Spec->splitdir( $directories );
|
||||
|
||||
$directories must be only the directory portion of the path on systems
|
||||
that have the concept of a volume or that have path syntax that differentiates
|
||||
files from directories.
|
||||
|
||||
Unlike just splitting the directories on the separator, leading empty and
|
||||
trailing directory entries can be returned, because these are significant
|
||||
on some OSs. So,
|
||||
|
||||
File::Spec->splitdir( "/a/b/c" );
|
||||
|
||||
Yields:
|
||||
|
||||
( '', 'a', 'b', '', 'c', '' )
|
||||
|
||||
=cut
|
||||
|
||||
sub splitdir {
|
||||
my ($self,$directories) = @_ ;
|
||||
#
|
||||
# split() likes to forget about trailing null fields, so here we
|
||||
# check to be sure that there will not be any before handling the
|
||||
# simple case.
|
||||
#
|
||||
if ( $directories !~ m|[\\/]\Z(?!\n)| ) {
|
||||
return split( m|[\\/]|, $directories );
|
||||
}
|
||||
else {
|
||||
#
|
||||
# since there was a trailing separator, add a file name to the end,
|
||||
# then do the split, then replace it with ''.
|
||||
#
|
||||
my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ;
|
||||
$directories[ $#directories ]= '' ;
|
||||
return @directories ;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
=item catpath
|
||||
|
||||
Takes volume, directory and file portions and returns an entire path. Under
|
||||
Unix, $volume is ignored, and this is just like catfile(). On other OSs,
|
||||
the $volume become significant.
|
||||
|
||||
=cut
|
||||
|
||||
sub catpath {
|
||||
my ($self,$volume,$directory,$file) = @_;
|
||||
|
||||
# If it's UNC, make sure the glue separator is there, reusing
|
||||
# whatever separator is first in the $volume
|
||||
my $v;
|
||||
$volume .= $v
|
||||
if ( (($v) = $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s) &&
|
||||
$directory =~ m@^[^\\/]@s
|
||||
) ;
|
||||
|
||||
$volume .= $directory ;
|
||||
|
||||
# If the volume is not just A:, make sure the glue separator is
|
||||
# there, reusing whatever separator is first in the $volume if possible.
|
||||
if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
|
||||
$volume =~ m@[^\\/]\Z(?!\n)@ &&
|
||||
$file =~ m@[^\\/]@
|
||||
) {
|
||||
$volume =~ m@([\\/])@ ;
|
||||
my $sep = $1 ? $1 : '\\' ;
|
||||
$volume .= $sep ;
|
||||
}
|
||||
|
||||
$volume .= $file ;
|
||||
|
||||
return $volume ;
|
||||
}
|
||||
|
||||
sub _same {
|
||||
lc($_[1]) eq lc($_[2]);
|
||||
}
|
||||
|
||||
sub rel2abs {
|
||||
my ($self,$path,$base ) = @_;
|
||||
|
||||
my $is_abs = $self->file_name_is_absolute($path);
|
||||
|
||||
# Check for volume (should probably document the '2' thing...)
|
||||
return $self->canonpath( $path ) if $is_abs == 2;
|
||||
|
||||
if ($is_abs) {
|
||||
# It's missing a volume, add one
|
||||
my $vol = ($self->splitpath( Cwd::getcwd() ))[0];
|
||||
return $self->canonpath( $vol . $path );
|
||||
}
|
||||
|
||||
if ( !defined( $base ) || $base eq '' ) {
|
||||
$base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ;
|
||||
$base = Cwd::getcwd() unless defined $base ;
|
||||
}
|
||||
elsif ( ! $self->file_name_is_absolute( $base ) ) {
|
||||
$base = $self->rel2abs( $base ) ;
|
||||
}
|
||||
else {
|
||||
$base = $self->canonpath( $base ) ;
|
||||
}
|
||||
|
||||
my ( $path_directories, $path_file ) =
|
||||
($self->splitpath( $path, 1 ))[1,2] ;
|
||||
|
||||
my ( $base_volume, $base_directories ) =
|
||||
$self->splitpath( $base, 1 ) ;
|
||||
|
||||
$path = $self->catpath(
|
||||
$base_volume,
|
||||
$self->catdir( $base_directories, $path_directories ),
|
||||
$path_file
|
||||
) ;
|
||||
|
||||
return $self->canonpath( $path ) ;
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=head2 Note For File::Spec::Win32 Maintainers
|
||||
|
||||
Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004,2007 by the Perl 5 Porters. All rights reserved.
|
||||
|
||||
This program is free software; you can redistribute it and/or modify
|
||||
it under the same terms as Perl itself.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
|
||||
implementation of these methods, not the semantics.
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
sub _canon_cat # @path -> path
|
||||
{
|
||||
my ($first, @rest) = @_;
|
||||
|
||||
my $volume = $first =~ s{ \A ([A-Za-z]:) ([\\/]?) }{}x # drive letter
|
||||
? ucfirst( $1 ).( $2 ? "\\" : "" )
|
||||
: $first =~ s{ \A (?:\\\\|//) ([^\\/]+)
|
||||
(?: [\\/] ([^\\/]+) )?
|
||||
[\\/]? }{}xs # UNC volume
|
||||
? "\\\\$1".( defined $2 ? "\\$2" : "" )."\\"
|
||||
: $first =~ s{ \A [\\/] }{}x # root dir
|
||||
? "\\"
|
||||
: "";
|
||||
my $path = join "\\", $first, @rest;
|
||||
|
||||
$path =~ tr#\\/#\\\\#s; # xx/yy --> xx\yy & xx\\yy --> xx\yy
|
||||
|
||||
# xx/././yy --> xx/yy
|
||||
$path =~ s{(?:
|
||||
(?:\A|\\) # at begin or after a slash
|
||||
\.
|
||||
(?:\\\.)* # and more
|
||||
(?:\\|\z) # at end or followed by slash
|
||||
)+ # performance boost -- I do not know why
|
||||
}{\\}gx;
|
||||
|
||||
# xx\yy\..\zz --> xx\zz
|
||||
while ( $path =~ s{(?:
|
||||
(?:\A|\\) # at begin or after a slash
|
||||
[^\\]+ # rip this 'yy' off
|
||||
\\\.\.
|
||||
(?<!\A\.\.\\\.\.) # do *not* replace ^..\..
|
||||
(?<!\\\.\.\\\.\.) # do *not* replace \..\..
|
||||
(?:\\|\z) # at end or followed by slash
|
||||
)+ # performance boost -- I do not know why
|
||||
}{\\}sx ) {}
|
||||
|
||||
$path =~ s#\A\\##; # \xx --> xx NOTE: this is *not* root
|
||||
$path =~ s#\\\z##; # xx\ --> xx
|
||||
|
||||
if ( $volume =~ m#\\\z# )
|
||||
{ # <vol>\.. --> <vol>\
|
||||
$path =~ s{ \A # at begin
|
||||
\.\.
|
||||
(?:\\\.\.)* # and more
|
||||
(?:\\|\z) # at end or followed by slash
|
||||
}{}x;
|
||||
|
||||
return $1 # \\HOST\SHARE\ --> \\HOST\SHARE
|
||||
if $path eq ""
|
||||
and $volume =~ m#\A(\\\\.*)\\\z#s;
|
||||
}
|
||||
return $path ne "" || $volume ? $volume.$path : ".";
|
||||
}
|
||||
|
||||
1;
|
||||
3721
database/perl/lib/File/Temp.pm
Normal file
3721
database/perl/lib/File/Temp.pm
Normal file
File diff suppressed because it is too large
Load Diff
338
database/perl/lib/File/pushd.pm
Normal file
338
database/perl/lib/File/pushd.pm
Normal file
@@ -0,0 +1,338 @@
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
package File::pushd;
|
||||
# ABSTRACT: change directory temporarily for a limited scope
|
||||
|
||||
our $VERSION = '1.016';
|
||||
|
||||
our @EXPORT = qw( pushd tempd );
|
||||
our @ISA = qw( Exporter );
|
||||
|
||||
use Exporter;
|
||||
use Carp;
|
||||
use Cwd qw( getcwd abs_path );
|
||||
use File::Path qw( rmtree );
|
||||
use File::Temp qw();
|
||||
use File::Spec;
|
||||
|
||||
use overload
|
||||
q{""} => sub { File::Spec->canonpath( $_[0]->{_pushd} ) },
|
||||
fallback => 1;
|
||||
|
||||
#--------------------------------------------------------------------------#
|
||||
# pushd()
|
||||
#--------------------------------------------------------------------------#
|
||||
|
||||
sub pushd {
|
||||
# Called in void context?
|
||||
unless (defined wantarray) {
|
||||
warnings::warnif(void => 'Useless use of File::pushd::pushd in void context');
|
||||
return
|
||||
}
|
||||
|
||||
my ( $target_dir, $options ) = @_;
|
||||
$options->{untaint_pattern} ||= qr{^([-+@\w./]+)$};
|
||||
|
||||
$target_dir = "." unless defined $target_dir;
|
||||
croak "Can't locate directory $target_dir" unless -d $target_dir;
|
||||
|
||||
my $tainted_orig = getcwd;
|
||||
my $orig;
|
||||
if ( $tainted_orig =~ $options->{untaint_pattern} ) {
|
||||
$orig = $1;
|
||||
}
|
||||
else {
|
||||
$orig = $tainted_orig;
|
||||
}
|
||||
|
||||
my $tainted_dest;
|
||||
eval { $tainted_dest = $target_dir ? abs_path($target_dir) : $orig };
|
||||
croak "Can't locate absolute path for $target_dir: $@" if $@;
|
||||
|
||||
my $dest;
|
||||
if ( $tainted_dest =~ $options->{untaint_pattern} ) {
|
||||
$dest = $1;
|
||||
}
|
||||
else {
|
||||
$dest = $tainted_dest;
|
||||
}
|
||||
|
||||
if ( $dest ne $orig ) {
|
||||
chdir $dest or croak "Can't chdir to $dest\: $!";
|
||||
}
|
||||
|
||||
my $self = bless {
|
||||
_pushd => $dest,
|
||||
_original => $orig
|
||||
},
|
||||
__PACKAGE__;
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
#--------------------------------------------------------------------------#
|
||||
# tempd()
|
||||
#--------------------------------------------------------------------------#
|
||||
|
||||
sub tempd {
|
||||
# Called in void context?
|
||||
unless (defined wantarray) {
|
||||
warnings::warnif(void => 'Useless use of File::pushd::tempd in void context');
|
||||
return
|
||||
}
|
||||
|
||||
my ($options) = @_;
|
||||
my $dir;
|
||||
eval { $dir = pushd( File::Temp::tempdir( CLEANUP => 0 ), $options ) };
|
||||
croak $@ if $@;
|
||||
$dir->{_tempd} = 1;
|
||||
$dir->{_owner} = $$;
|
||||
return $dir;
|
||||
}
|
||||
|
||||
#--------------------------------------------------------------------------#
|
||||
# preserve()
|
||||
#--------------------------------------------------------------------------#
|
||||
|
||||
sub preserve {
|
||||
my $self = shift;
|
||||
return 1 if !$self->{"_tempd"};
|
||||
if ( @_ == 0 ) {
|
||||
return $self->{_preserve} = 1;
|
||||
}
|
||||
else {
|
||||
return $self->{_preserve} = $_[0] ? 1 : 0;
|
||||
}
|
||||
}
|
||||
|
||||
#--------------------------------------------------------------------------#
|
||||
# DESTROY()
|
||||
# Revert to original directory as object is destroyed and cleanup
|
||||
# if necessary
|
||||
#--------------------------------------------------------------------------#
|
||||
|
||||
sub DESTROY {
|
||||
my ($self) = @_;
|
||||
my $orig = $self->{_original};
|
||||
chdir $orig if $orig; # should always be so, but just in case...
|
||||
if ( $self->{_tempd}
|
||||
&& $self->{_owner} == $$
|
||||
&& !$self->{_preserve} )
|
||||
{
|
||||
# don't destroy existing $@ if there is no error.
|
||||
my $err = do {
|
||||
local $@;
|
||||
eval { rmtree( $self->{_pushd} ) };
|
||||
$@;
|
||||
};
|
||||
carp $err if $err;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::pushd - change directory temporarily for a limited scope
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 1.016
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use File::pushd;
|
||||
|
||||
chdir $ENV{HOME};
|
||||
|
||||
# change directory again for a limited scope
|
||||
{
|
||||
my $dir = pushd( '/tmp' );
|
||||
# working directory changed to /tmp
|
||||
}
|
||||
# working directory has reverted to $ENV{HOME}
|
||||
|
||||
# tempd() is equivalent to pushd( File::Temp::tempdir )
|
||||
{
|
||||
my $dir = tempd();
|
||||
}
|
||||
|
||||
# object stringifies naturally as an absolute path
|
||||
{
|
||||
my $dir = pushd( '/tmp' );
|
||||
my $filename = File::Spec->catfile( $dir, "somefile.txt" );
|
||||
# gives /tmp/somefile.txt
|
||||
}
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
File::pushd does a temporary C<chdir> that is easily and automatically
|
||||
reverted, similar to C<pushd> in some Unix command shells. It works by
|
||||
creating an object that caches the original working directory. When the object
|
||||
is destroyed, the destructor calls C<chdir> to revert to the original working
|
||||
directory. By storing the object in a lexical variable with a limited scope,
|
||||
this happens automatically at the end of the scope.
|
||||
|
||||
This is very handy when working with temporary directories for tasks like
|
||||
testing; a function is provided to streamline getting a temporary
|
||||
directory from L<File::Temp>.
|
||||
|
||||
For convenience, the object stringifies as the canonical form of the absolute
|
||||
pathname of the directory entered.
|
||||
|
||||
B<Warning>: if you create multiple C<pushd> objects in the same lexical scope,
|
||||
their destruction order is not guaranteed and you might not wind up in the
|
||||
directory you expect.
|
||||
|
||||
=head1 USAGE
|
||||
|
||||
use File::pushd;
|
||||
|
||||
Using File::pushd automatically imports the C<pushd> and C<tempd> functions.
|
||||
|
||||
=head2 pushd
|
||||
|
||||
{
|
||||
my $dir = pushd( $target_directory );
|
||||
}
|
||||
|
||||
Caches the current working directory, calls C<chdir> to change to the target
|
||||
directory, and returns a File::pushd object. When the object is
|
||||
destroyed, the working directory reverts to the original directory.
|
||||
|
||||
The provided target directory can be a relative or absolute path. If
|
||||
called with no arguments, it uses the current directory as its target and
|
||||
returns to the current directory when the object is destroyed.
|
||||
|
||||
If the target directory does not exist or if the directory change fails
|
||||
for some reason, C<pushd> will die with an error message.
|
||||
|
||||
Can be given a hashref as an optional second argument. The only supported
|
||||
option is C<untaint_pattern>, which is used to untaint file paths involved.
|
||||
It defaults to {qr{^(L<-+@\w./>+)$}}, which is reasonably restrictive (e.g.
|
||||
it does not even allow spaces in the path). Change this to suit your
|
||||
circumstances and security needs if running under taint mode. *Note*: you
|
||||
must include the parentheses in the pattern to capture the untainted
|
||||
portion of the path.
|
||||
|
||||
=head2 tempd
|
||||
|
||||
{
|
||||
my $dir = tempd();
|
||||
}
|
||||
|
||||
This function is like C<pushd> but automatically creates and calls C<chdir> to
|
||||
a temporary directory created by L<File::Temp>. Unlike normal L<File::Temp>
|
||||
cleanup which happens at the end of the program, this temporary directory is
|
||||
removed when the object is destroyed. (But also see C<preserve>.) A warning
|
||||
will be issued if the directory cannot be removed.
|
||||
|
||||
As with C<pushd>, C<tempd> will die if C<chdir> fails.
|
||||
|
||||
It may be given a single options hash that will be passed internally
|
||||
to C<pushd>.
|
||||
|
||||
=head2 preserve
|
||||
|
||||
{
|
||||
my $dir = tempd();
|
||||
$dir->preserve; # mark to preserve at end of scope
|
||||
$dir->preserve(0); # mark to delete at end of scope
|
||||
}
|
||||
|
||||
Controls whether a temporary directory will be cleaned up when the object is
|
||||
destroyed. With no arguments, C<preserve> sets the directory to be preserved.
|
||||
With an argument, the directory will be preserved if the argument is true, or
|
||||
marked for cleanup if the argument is false. Only C<tempd> objects may be
|
||||
marked for cleanup. (Target directories to C<pushd> are always preserved.)
|
||||
C<preserve> returns true if the directory will be preserved, and false
|
||||
otherwise.
|
||||
|
||||
=head1 DIAGNOSTICS
|
||||
|
||||
C<pushd> and C<tempd> warn with message
|
||||
C<"Useless use of File::pushd::I<%s> in void context"> if called in
|
||||
void context and the warnings category C<void> is enabled.
|
||||
|
||||
{
|
||||
use warnings 'void';
|
||||
|
||||
pushd();
|
||||
}
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
L<File::chdir>
|
||||
|
||||
=back
|
||||
|
||||
=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
=head2 Bugs / Feature Requests
|
||||
|
||||
Please report any bugs or feature requests through the issue tracker
|
||||
at L<https://github.com/dagolden/File-pushd/issues>.
|
||||
You will be notified automatically of any progress on your issue.
|
||||
|
||||
=head2 Source Code
|
||||
|
||||
This is open source software. The code repository is available for
|
||||
public review and contribution under the terms of the license.
|
||||
|
||||
L<https://github.com/dagolden/File-pushd>
|
||||
|
||||
git clone https://github.com/dagolden/File-pushd.git
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
David Golden <dagolden@cpan.org>
|
||||
|
||||
=head1 CONTRIBUTORS
|
||||
|
||||
=for stopwords Diab Jerius Graham Ollis Olivier Mengué Shoichi Kaji
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
Diab Jerius <djerius@cfa.harvard.edu>
|
||||
|
||||
=item *
|
||||
|
||||
Graham Ollis <plicease@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
Olivier Mengué <dolmen@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
Shoichi Kaji <skaji@cpan.org>
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is Copyright (c) 2018 by David A Golden.
|
||||
|
||||
This is free software, licensed under:
|
||||
|
||||
The Apache License, Version 2.0, January 2004
|
||||
|
||||
=cut
|
||||
|
||||
__END__
|
||||
|
||||
|
||||
# vim: ts=4 sts=4 sw=4 et:
|
||||
363
database/perl/lib/File/stat.pm
Normal file
363
database/perl/lib/File/stat.pm
Normal file
@@ -0,0 +1,363 @@
|
||||
package File::stat;
|
||||
use 5.006;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use warnings::register;
|
||||
use Carp;
|
||||
use constant _IS_CYGWIN => $^O eq "cygwin";
|
||||
|
||||
BEGIN { *warnif = \&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 => [ @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 { &{"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 (_IS_CYGWIN ? _ingroup(544, $eff) : ($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
|
||||
Reference in New Issue
Block a user