Initial Commit
This commit is contained in:
Riley Schneider
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;
|
||||
Reference in New Issue
Block a user