diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/File/Spec')
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/Spec/Cygwin.pm | 93 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/Spec/Epoc.pm | 77 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/Spec/Functions.pm | 109 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/Spec/Mac.pm | 780 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/Spec/OS2.pm | 272 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/Spec/Unix.pm | 510 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/Spec/VMS.pm | 521 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/Spec/Win32.pm | 369 |
8 files changed, 0 insertions, 2731 deletions
diff --git a/Master/tlpkg/tlperl/lib/File/Spec/Cygwin.pm b/Master/tlpkg/tlperl/lib/File/Spec/Cygwin.pm deleted file mode 100644 index 19a2937c6b9..00000000000 --- a/Master/tlpkg/tlperl/lib/File/Spec/Cygwin.pm +++ /dev/null @@ -1,93 +0,0 @@ -package File::Spec::Cygwin; - -use strict; -use vars qw(@ISA $VERSION); -require File::Spec::Unix; - -$VERSION = '1.1'; - -@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) = @_; - $path =~ s|\\|/|g; - return $self->SUPER::canonpath($path); -} - -=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 - C:/temp - -Since Perl 5.8.0, if running under taint mode, and if the environment -variables are tainted, they are not used. - -=cut - -my $tmpdir; -sub tmpdir { - return $tmpdir if defined $tmpdir; - $tmpdir = $_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp", 'C:/temp' ); -} - -=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 - -1; diff --git a/Master/tlpkg/tlperl/lib/File/Spec/Epoc.pm b/Master/tlpkg/tlperl/lib/File/Spec/Epoc.pm deleted file mode 100644 index a7168f9e494..00000000000 --- a/Master/tlpkg/tlperl/lib/File/Spec/Epoc.pm +++ /dev/null @@ -1,77 +0,0 @@ -package File::Spec::Epoc; - -use strict; -use vars qw($VERSION @ISA); - -$VERSION = '1.1'; - -require File::Spec::Unix; -@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 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) = @_; - - $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; diff --git a/Master/tlpkg/tlperl/lib/File/Spec/Functions.pm b/Master/tlpkg/tlperl/lib/File/Spec/Functions.pm deleted file mode 100644 index 38c898c5d8f..00000000000 --- a/Master/tlpkg/tlperl/lib/File/Spec/Functions.pm +++ /dev/null @@ -1,109 +0,0 @@ -package File::Spec::Functions; - -use File::Spec; -use strict; - -use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); - -$VERSION = '1.3'; - -require Exporter; - -@ISA = qw(Exporter); - -@EXPORT = qw( - canonpath - catdir - catfile - curdir - rootdir - updir - no_upwards - file_name_is_absolute - path -); - -@EXPORT_OK = qw( - devnull - tmpdir - splitpath - splitdir - catpath - abs2rel - rel2abs - case_tolerant -); - -%EXPORT_TAGS = ( ALL => [ @EXPORT_OK, @EXPORT ] ); - -foreach my $meth (@EXPORT, @EXPORT_OK) { - my $sub = File::Spec->can($meth); - no strict 'refs'; - *{$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 - diff --git a/Master/tlpkg/tlperl/lib/File/Spec/Mac.pm b/Master/tlpkg/tlperl/lib/File/Spec/Mac.pm deleted file mode 100644 index 8b51bd6c249..00000000000 --- a/Master/tlpkg/tlperl/lib/File/Spec/Mac.pm +++ /dev/null @@ -1,780 +0,0 @@ -package File::Spec::Mac; - -use strict; -use vars qw(@ISA $VERSION); -require File::Spec::Unix; - -$VERSION = '1.4'; - -@ISA = qw(File::Spec::Unix); - -my $macfiles; -if ($^O eq 'MacOS') { - $macfiles = eval { require Mac::Files }; -} - -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 -C<Unix-E<gt>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 C<Unix-E<gt>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 a string representing the root directory. Under MacPerl, -returns the name of the startup volume, since that's the closest in -concept, although other volumes aren't rooted there. The name has a -trailing ":", because that's the correct specification for a volume -name on Mac OS. - -If Mac::Files could not be loaded, the empty string is returned. - -=cut - -sub rootdir { -# -# There's no real root directory on Mac OS. The name of the startup -# volume is returned, since that's the closest in concept. -# - return '' unless $macfiles; - my $system = Mac::Files::FindFolder(&Mac::Files::kOnSystemDisk, - &Mac::Files::kSystemFolderType); - $system =~ s/:.*\Z(?!\n)/:/s; - return $system; -} - -=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 - -my $tmpdir; -sub tmpdir { - return $tmpdir if defined $tmpdir; - $tmpdir = $_[0]->_tmpdir( $ENV{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 ('') 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 = $self->_cwd(); - } - 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 = $self->_cwd(); - } - elsif ( ! $self->file_name_is_absolute($base) ) { - $base = $self->rel2abs($base) ; - } - - # Split up paths - - # igonore $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; diff --git a/Master/tlpkg/tlperl/lib/File/Spec/OS2.pm b/Master/tlpkg/tlperl/lib/File/Spec/OS2.pm deleted file mode 100644 index ec308f3b6f3..00000000000 --- a/Master/tlpkg/tlperl/lib/File/Spec/OS2.pm +++ /dev/null @@ -1,272 +0,0 @@ -package File::Spec::OS2; - -use strict; -use vars qw(@ISA $VERSION); -require File::Spec::Unix; - -$VERSION = '1.2'; - -@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 _cwd { - # In OS/2 the "require Cwd" is unnecessary bloat. - return Cwd::sys_cwd(); -} - -my $tmpdir; -sub tmpdir { - return $tmpdir if defined $tmpdir; - $tmpdir = $_[0]->_tmpdir( @ENV{qw(TMPDIR TEMP TMP)}, - '/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) = @_; - $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 = $self->_cwd(); - } 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 = $self->_cwd(); - } - 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 diff --git a/Master/tlpkg/tlperl/lib/File/Spec/Unix.pm b/Master/tlpkg/tlperl/lib/File/Spec/Unix.pm deleted file mode 100644 index 4a25fe632f2..00000000000 --- a/Master/tlpkg/tlperl/lib/File/Spec/Unix.pm +++ /dev/null @@ -1,510 +0,0 @@ -package File::Spec::Unix; - -use strict; -use vars qw($VERSION); - -$VERSION = '1.5'; - -=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 canonpath { - my ($self,$path) = @_; - - # Handle POSIX-style node names beginning with double slash (qnx, nto) - # Handle network path names beginning with double slash (cygwin) - # (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 = ''; - if ( $^O =~ m/^(?:qnx|nto|cygwin)$/ && $path =~ s:^(//[^/]+)(/|\z):/: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|/+|/|g; # xx////xx -> xx/xx - $path =~ s@(/\.)+(/|\Z(?!\n))@/@g; # xx/././xx -> xx/xx - $path =~ s|^(\./)+||s unless $path eq "./"; # ./xx -> xx - $path =~ s|^/(\.\./)+|/|; # /../../xx -> xx - $path =~ s|^/\.\.$|/|; # /.. -> / - $path =~ s|/\Z(?!\n)|| unless $path eq "/"; # xx/ -> xx - return "$node$path"; -} - -=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 catdir { - my $self = shift; - - $self->canonpath(join('/', @_, '')); # '' because need a trailing '/' -} - -=item catfile - -Concatenate one or more directory names and a filename to form a -complete path ending with a filename - -=cut - -sub 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; -} - -=item curdir - -Returns a string representation of the current directory. "." on UNIX. - -=cut - -sub curdir () { '.' } - -=item devnull - -Returns a string representation of the null device. "/dev/null" on UNIX. - -=cut - -sub devnull () { '/dev/null' } - -=item rootdir - -Returns a string representation of the root directory. "/" on UNIX. - -=cut - -sub 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 - -Since perl 5.8.0, if running under taint mode, and if $ENV{TMPDIR} -is tainted, it is not used. - -=cut - -my $tmpdir; -sub _tmpdir { - return $tmpdir if defined $tmpdir; - my $self = shift; - my @dirlist = @_; - { - no strict 'refs'; - if (${"\cTAINT"}) { # Check for taint mode on perl >= 5.8.0 - require Scalar::Util; - @dirlist = grep { ! Scalar::Util::tainted($_) } @dirlist; - } - } - foreach (@dirlist) { - next unless defined && -d && -w _; - $tmpdir = $_; - last; - } - $tmpdir = $self->curdir unless defined $tmpdir; - $tmpdir = defined $tmpdir && $self->canonpath($tmpdir); - return $tmpdir; -} - -sub tmpdir { - return $tmpdir if defined $tmpdir; - $tmpdir = $_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp" ); -} - -=item updir - -Returns a string representation of the parent directory. ".." on UNIX. - -=cut - -sub 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(?!\n)/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 } - -=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(?!\n) )? )? ) ([^/]*) |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. 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) = @_; - - # 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 = $self->_cwd(); - } - elsif ( ! $self->file_name_is_absolute( $base ) ) { - $base = $self->rel2abs( $base ) ; - } - else { - $base = $self->canonpath( $base ) ; - } - - # Now, remove all leading components that are the same - my @pathchunks = $self->splitdir( $path); - my @basechunks = $self->splitdir( $base); - - while (@pathchunks && @basechunks && $pathchunks[0] eq $basechunks[0]) { - shift @pathchunks ; - shift @basechunks ; - } - - $path = CORE::join( '/', @pathchunks ); - $base = CORE::join( '/', @basechunks ); - - # $base 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 - $base =~ s|[^/]+|..|g ; - - # Glue the two together, using a separator if necessary, and preventing an - # empty result. - if ( $path ne '' && $base ne '' ) { - $path = "$base/$path" ; - } else { - $path = "$base$path" ; - } - - return $self->canonpath( $path ) ; -} - -=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 = $self->_cwd(); - } - 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. - -=head1 SEE ALSO - -L<File::Spec> - -=cut - -# Internal routine to File::Spec, no point in making this public since -# it is the standard Cwd interface. Most of the platform-specific -# File::Spec subclasses use this. -sub _cwd { - require Cwd; - Cwd::cwd(); -} - - -# 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); - - 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; diff --git a/Master/tlpkg/tlperl/lib/File/Spec/VMS.pm b/Master/tlpkg/tlperl/lib/File/Spec/VMS.pm deleted file mode 100644 index f8923f25fb2..00000000000 --- a/Master/tlpkg/tlperl/lib/File/Spec/VMS.pm +++ /dev/null @@ -1,521 +0,0 @@ -package File::Spec::VMS; - -use strict; -use vars qw(@ISA $VERSION); -require File::Spec::Unix; - -$VERSION = '1.4'; - -@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. - -=over 4 - -=item canonpath (override) - -Removes redundant portions of file specifications according to VMS syntax. - -=cut - -sub canonpath { - my($self,$path) = @_; - - if ($path =~ m|/|) { # Fake Unix - my $pathify = $path =~ m|/\Z(?!\n)|; - $path = $self->SUPER::canonpath($path); - if ($pathify) { return vmspath($path); } - else { return vmsify($path); } - } - else { - $path =~ tr/<>/[]/; # < and > ==> [ and ] - $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.-] ==> ] - $path =~ s/\[[^\]\.]+\.-\]/\[000000\]/g;# [foo.-] ==> [000000] - $path =~ s/\[\]//; # [] ==> - return $path; - } -} - -=item catdir (override) - -Concatenates a list of file specifications, and returns the result as a -VMS-syntax directory specification. No check is made for "impossible" -cases (e.g. elements other than the first being absolute filespecs). - -=cut - -sub catdir { - my ($self,@dirs) = @_; - my $dir = pop @dirs; - @dirs = grep($_,@dirs); - my $rslt; - if (@dirs) { - my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs)); - my ($spath,$sdir) = ($path,$dir); - $spath =~ s/\.dir\Z(?!\n)//; $sdir =~ s/\.dir\Z(?!\n)//; - $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+\Z(?!\n)/s; - $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1); - - # 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 { - if (not defined $dir or not length $dir) { $rslt = ''; } - elsif ($dir =~ /^\$\([^\)]+\)\Z(?!\n)/s) { $rslt = $dir; } - else { $rslt = vmspath($dir); } - } - return $self->canonpath($rslt); -} - -=item catfile (override) - -Concatenates a list of file specifications, and returns the result as a -VMS-syntax file specification. - -=cut - -sub catfile { - my ($self,@files) = @_; - my $file = $self->canonpath(pop @files); - @files = grep($_,@files); - my $rslt; - if (@files) { - my $path = (@files == 1 ? $files[0] : $self->catdir(@files)); - my $spath = $path; - $spath =~ s/\.dir\Z(?!\n)//; - if ($spath =~ /^[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) { - $rslt = "$spath$file"; - } - else { - $rslt = $self->eliminate_macros($spath); - $rslt = vmsify($rslt.($rslt ? '/' : '').unixify($file)); - } - } - else { $rslt = (defined($file) && length($file)) ? vmsify($file) : ''; } - return $self->canonpath($rslt); -} - - -=item curdir (override) - -Returns a string representation of the current directory: '[]' - -=cut - -sub curdir { - return '[]'; -} - -=item devnull (override) - -Returns a string representation of the null device: '_NLA0:' - -=cut - -sub devnull { - return "_NLA0:"; -} - -=item rootdir (override) - -Returns a string representation of the root directory: 'SYS$DISK:[000000]' - -=cut - -sub rootdir { - 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: - - sys$scratch: - $ENV{TMPDIR} - -Since perl 5.8.0, if running under taint mode, and if $ENV{TMPDIR} -is tainted, it is not used. - -=cut - -my $tmpdir; -sub tmpdir { - return $tmpdir if defined $tmpdir; - $tmpdir = $_[0]->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} ); -} - -=item updir (override) - -Returns a string representation of the parent directory: '[-]' - -=cut - -sub updir { - 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 =~ /:[^<\[]/); -} - -=item splitpath (override) - -Splits using VMS syntax. - -=cut - -sub splitpath { - my($self,$path) = @_; - my($dev,$dir,$file) = ('','',''); - - vmsify($path) =~ /(.+:)?([\[<].*[\]>])?(.*)/s; - return ($1 || '',$2 || '',$3); -} - -=item splitdir (override) - -Split dirspec using VMS syntax. - -=cut - -sub splitdir { - my($self,$dirspec) = @_; - $dirspec =~ tr/<>/[]/; # < and > ==> [ and ] - $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 - my(@dirs) = split('\.', vmspath($dirspec)); - $dirs[0] =~ s/^[\[<]//s; $dirs[-1] =~ s/[\]>]\Z(?!\n)//s; - @dirs; -} - - -=item catpath (override) - -Construct a complete filespec using VMS syntax - -=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); - } - "$dev$dir$file"; -} - -=item abs2rel (override) - -Use VMS syntax when converting filespecs. - -=cut - -sub abs2rel { - my $self = shift; - return vmspath(File::Spec::Unix::abs2rel( $self, @_ )) - if grep m{/}, @_; - - my($path,$base) = @_; - $base = $self->_cwd() unless defined $base and length $base; - - for ($path, $base) { $_ = $self->canonpath($_) } - - # 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 $path unless lc($path_volume) eq lc($base_volume); - - for ($path, $base) { $_ = $self->rel2abs($_) } - - # Now, remove all leading components that are the same - my @pathchunks = $self->splitdir( $path_directories ); - unshift(@pathchunks,'000000') unless $pathchunks[0] eq '000000'; - my @basechunks = $self->splitdir( $base_directories ); - 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. - $path_directories = join '.', ('-' x @basechunks, @pathchunks) ; - return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ; -} - - -=item rel2abs (override) - -Use VMS syntax when converting filespecs. - -=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 = $self->_cwd; - } - 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 ) ; -} - - -# eliminate_macros() and fixpath() are MakeMaker-specific methods -# which are used inside catfile() and catdir(). MakeMaker has its own -# copies as of 6.06_03 which are the canonical ones. We leave these -# here, in peace, so that File::Spec continues to work with MakeMakers -# prior to 6.06_03. -# -# Please consider these two methods deprecated. Do not patch them, -# patch the ones in ExtUtils::MM_VMS instead. -sub eliminate_macros { - my($self,$path) = @_; - return '' unless $path; - $self = {} unless ref $self; - - if ($path =~ /\s/) { - return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path; - } - - my($npath) = unixify($path); - my($complex) = 0; - my($head,$macro,$tail); - - # perform m##g in scalar context so it acts as an iterator - while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) { - if ($self->{$2}) { - ($head,$macro,$tail) = ($1,$2,$3); - if (ref $self->{$macro}) { - if (ref $self->{$macro} eq 'ARRAY') { - $macro = join ' ', @{$self->{$macro}}; - } - else { - print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}), - "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n"; - $macro = "\cB$macro\cB"; - $complex = 1; - } - } - else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; } - $npath = "$head$macro$tail"; - } - } - if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; } - $npath; -} - -# Deprecated. See the note above for eliminate_macros(). -sub fixpath { - my($self,$path,$force_path) = @_; - return '' unless $path; - $self = bless {} unless ref $self; - my($fixedpath,$prefix,$name); - - if ($path =~ /\s/) { - return join ' ', - map { $self->fixpath($_,$force_path) } - split /\s+/, $path; - } - - if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) { - if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) { - $fixedpath = vmspath($self->eliminate_macros($path)); - } - else { - $fixedpath = vmsify($self->eliminate_macros($path)); - } - } - elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) { - my($vmspre) = $self->eliminate_macros("\$($prefix)"); - # is it a dir or just a name? - $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : ''; - $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name; - $fixedpath = vmspath($fixedpath) if $force_path; - } - else { - $fixedpath = $path; - $fixedpath = vmspath($fixedpath) if $force_path; - } - # No hints, so we try to guess - if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) { - $fixedpath = vmspath($fixedpath) if -d $fixedpath; - } - - # Trim off root dirname if it's had other dirs inserted in front of it. - $fixedpath =~ s/\.000000([\]>])/$1/; - # 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 ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; } - $fixedpath; -} - - -=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. - -=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; diff --git a/Master/tlpkg/tlperl/lib/File/Spec/Win32.pm b/Master/tlpkg/tlperl/lib/File/Spec/Win32.pm deleted file mode 100644 index a324306a74b..00000000000 --- a/Master/tlpkg/tlperl/lib/File/Spec/Win32.pm +++ /dev/null @@ -1,369 +0,0 @@ -package File::Spec::Win32; - -use strict; - -use vars qw(@ISA $VERSION); -require File::Spec::Unix; - -$VERSION = '1.6'; - -@ISA = qw(File::Spec::Unix); - -=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). - -Since Perl 5.8.0, if running under taint mode, and if the environment -variables are tainted, they are not used. - -=cut - -my $tmpdir; -sub tmpdir { - return $tmpdir if defined $tmpdir; - $tmpdir = $_[0]->_tmpdir( @ENV{qw(TMPDIR TEMP TMP)}, - 'SYS:/temp', - 'C:\system\temp', - 'C:/temp', - '/tmp', - '/' ); -} - -sub case_tolerant { - return 1; -} - -sub file_name_is_absolute { - my ($self,$file) = @_; - return scalar($file =~ m{^([a-z]:)?[\\/]}is); -} - -=item catfile - -Concatenate one or more directory names and a filename to form a -complete path ending with a filename - -=cut - -sub 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; -} - -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 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 { - my ($self,$path) = @_; - - $path =~ s/^([a-z]:)/\u$1/s; - $path =~ s|/|\\|g; - $path =~ s|([^\\])\\+|$1\\|g; # xx\\\\xx -> xx\xx - $path =~ s|(\\\.)+\\|\\|g; # xx\.\.\xx -> xx\xx - $path =~ s|^(\.\\)+||s unless $path eq ".\\"; # .\xx -> xx - $path =~ s|\\\Z(?!\n)|| - unless $path =~ m{^([A-Z]:)?\\\Z(?!\n)}s; # xx\ -> xx - # xx1/xx2/xx3/../../xx -> xx1/xx - $path =~ s|\\\.\.\.\\|\\\.\.\\\.\.\\|g; # \...\ is 2 levels up - $path =~ s|^\.\.\.\\|\.\.\\\.\.\\|g; # ...\ is 2 levels up - return $path if $path =~ m|^\.\.|; # skip relative paths - return $path unless $path =~ /\.\./; # too few .'s to cleanup - return $path if $path =~ /\.\.\.\./; # too many .'s to cleanup - $path =~ s{^\\\.\.$}{\\}; # \.. -> \ - 1 while $path =~ s{^\\\.\.}{}; # \..\xx -> \xx - - return $self->_collapse($path); -} - -=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{^( (?:[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); -} - - -=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 abs2rel { - my($self,$path,$base) = @_; - $base = $self->_cwd() unless defined $base and length $base; - - for ($path, $base) { $_ = $self->canonpath($_) } - - 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; - - for ($path, $base) { $_ = $self->rel2abs($_) } - - my $path_directories = ($self->splitpath($path, 1))[1]; - my $base_directories = ($self->splitpath($base, 1))[1]; - - # 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 ; - } - - my $result_dirs = $self->catdir( ($self->updir) x @basechunks, @pathchunks ); - - return $self->canonpath( $self->catpath('', $result_dirs, '') ); -} - - -sub rel2abs { - my ($self,$path,$base ) = @_; - - if ( ! $self->file_name_is_absolute( $path ) ) { - - if ( !defined( $base ) || $base eq '' ) { - require Cwd ; - $base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ; - $base = $self->_cwd() 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 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; |