diff options
Diffstat (limited to 'contrib/perl5/lib/File/Spec')
| -rw-r--r-- | contrib/perl5/lib/File/Spec/Functions.pm | 95 | ||||
| -rw-r--r-- | contrib/perl5/lib/File/Spec/Mac.pm | 285 | ||||
| -rw-r--r-- | contrib/perl5/lib/File/Spec/OS2.pm | 50 | ||||
| -rw-r--r-- | contrib/perl5/lib/File/Spec/Unix.pm | 363 | ||||
| -rw-r--r-- | contrib/perl5/lib/File/Spec/VMS.pm | 450 | ||||
| -rw-r--r-- | contrib/perl5/lib/File/Spec/Win32.pm | 385 |
6 files changed, 1394 insertions, 234 deletions
diff --git a/contrib/perl5/lib/File/Spec/Functions.pm b/contrib/perl5/lib/File/Spec/Functions.pm new file mode 100644 index 0000000..140738f --- /dev/null +++ b/contrib/perl5/lib/File/Spec/Functions.pm @@ -0,0 +1,95 @@ +package File::Spec::Functions; + +use File::Spec; +use strict; + +use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); + +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 +); + +%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 + +All the functions may be imported using the C<:ALL> tag. + +=head1 SEE ALSO + +File::Spec, File::Spec::Unix, File::Spec::Mac, File::Spec::OS2, +File::Spec::Win32, File::Spec::VMS, ExtUtils::MakeMaker diff --git a/contrib/perl5/lib/File/Spec/Mac.pm b/contrib/perl5/lib/File/Spec/Mac.pm index 63a9e12..959e33d 100644 --- a/contrib/perl5/lib/File/Spec/Mac.pm +++ b/contrib/perl5/lib/File/Spec/Mac.pm @@ -1,18 +1,9 @@ package File::Spec::Mac; -use Exporter (); -use Config; use strict; -use File::Spec; -use vars qw(@ISA $VERSION $Is_Mac); - -$VERSION = '1.0'; - +use vars qw(@ISA); +require File::Spec::Unix; @ISA = qw(File::Spec::Unix); -$Is_Mac = $^O eq 'MacOS'; - -Exporter::import('File::Spec', '$Verbose'); - =head1 NAME @@ -20,7 +11,7 @@ File::Spec::Mac - File::Spec for MacOS =head1 SYNOPSIS -C<require File::Spec::Mac;> + require File::Spec::Mac; # Done internally by File::Spec if needed =head1 DESCRIPTION @@ -37,8 +28,8 @@ On MacOS, there's nothing to be done. Returns what it's given. =cut sub canonpath { - my($self,$path) = @_; - $path; + my ($self,$path) = @_; + return $path; } =item catdir @@ -84,20 +75,17 @@ aren't done here. This routine will treat this as absolute. =cut -# '; - sub catdir { shift; my @args = @_; - $args[0] =~ s/:$//; - my $result = shift @args; - for (@args) { - s/:$//; - s/^://; - $result .= ":$_"; + my $result = shift @args; + $result =~ s/:\z//; + foreach (@args) { + s/:\z//; + s/^://s; + $result .= ":$_"; } - $result .= ":"; - $result; + return "$result:"; } =item catfile @@ -118,50 +106,69 @@ give the same answer, as one might expect. =cut sub catfile { - my $self = shift @_; + my $self = shift; my $file = pop @_; return $file unless @_; my $dir = $self->catdir(@_); - $file =~ s/^://; + $file =~ s/^://s; return $dir.$file; } =item curdir -Returns a string representing of the current directory. +Returns a string representing the current directory. =cut sub curdir { - return ":" ; + return ":"; +} + +=item devnull + +Returns a string representing the null device. + +=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. On any other -platform returns '', since there's no common way to indicate "root -directory" across all Macs. +concept, although other volumes aren't rooted there. =cut sub rootdir { # -# There's no real root directory on MacOS. If you're using MacPerl, -# the name of the startup volume is returned, since that's the closest in -# concept. On other platforms, simply return '', because nothing better -# can be done. +# There's no real root directory on MacOS. The name of the startup +# volume is returned, since that's the closest in concept. # - if($Is_Mac) { - require Mac::Files; - my $system = Mac::Files::FindFolder(&Mac::Files::kOnSystemDisk, - &Mac::Files::kSystemFolderType); - $system =~ s/:.*$/:/; - return $system; - } else { - return ''; - } + require Mac::Files; + my $system = Mac::Files::FindFolder(&Mac::Files::kOnSystemDisk, + &Mac::Files::kSystemFolderType); + $system =~ s/:.*\z/:/s; + return $system; +} + +=item tmpdir + +Returns a string representation of the first existing directory +from the following list or '' if none exist: + + $ENV{TMPDIR} + +=cut + +my $tmpdir; +sub tmpdir { + return $tmpdir if defined $tmpdir; + $tmpdir = $ENV{TMPDIR} if -d $ENV{TMPDIR}; + $tmpdir = '' unless defined $tmpdir; + return $tmpdir; } =item updir @@ -185,11 +192,11 @@ distinguish unambiguously. =cut sub file_name_is_absolute { - my($self,$file) = @_; - if ($file =~ /:/) { - return ($file !~ m/^:/); - } else { - return (! -e ":$file"); + my ($self,$file) = @_; + if ($file =~ /:/) { + return ($file !~ m/^:/s); + } else { + return (! -e ":$file"); } } @@ -207,16 +214,178 @@ sub path { # The concept is meaningless under the MacPerl application. # Under MPW, it has a meaning. # - my($self) = @_; - my @path; - if(exists $ENV{Commands}) { - @path = split /,/,$ENV{Commands}; - } else { - @path = (); - } - @path; + return unless exists $ENV{Commands}; + return split(/,/, $ENV{Commands}); +} + +=item splitpath + +=cut + +sub splitpath { + my ($self,$path, $nofile) = @_; + + my ($volume,$directory,$file) = ('','',''); + + if ( $nofile ) { + ( $volume, $directory ) = $path =~ m@((?:[^:]+(?::|\z))?)(.*)@s; + } + else { + $path =~ + m@^( (?: [^:]+: )? ) + ( (?: .*: )? ) + ( .* ) + @xs; + $volume = $1; + $directory = $2; + $file = $3; + } + + # Make sure non-empty volumes and directories end in ':' + $volume .= ':' if $volume =~ m@[^:]\z@ ; + $directory .= ':' if $directory =~ m@[^:]\z@ ; + return ($volume,$directory,$file); +} + + +=item splitdir + +=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@ ) { + 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 + +=cut + +sub catpath { + my $self = shift ; + + my $result = shift ; + $result =~ s@^([^/])@/$1@s ; + + my $segment ; + for $segment ( @_ ) { + if ( $result =~ m@[^/]\z@ && $segment =~ m@^[^/]@s ) { + $result .= "/$segment" ; + } + elsif ( $result =~ m@/\z@ && $segment =~ m@^/@s ) { + $result =~ s@/+\z@/@; + $segment =~ s@^/+@@s; + $result .= "$segment" ; + } + else { + $result .= $segment ; + } + } + + return $result ; } +=item abs2rel + +=cut + +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() ; + } + elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $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 = join( ':', @pathchunks ); + + # @basechunks now contains the number of directories to climb out of. + $base = ':' x @basechunks ; + + return "$base:$path" ; +} + +=item rel2abs + +Converts a relative path to an absolute path. + + $abs_path = File::Spec->rel2abs( $destination ) ; + $abs_path = File::Spec->rel2abs( $destination, $base ) ; + +If $base is not present or '', then L<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()>. + +On systems with the concept of a volume, this assumes that both paths +are on the $base volume, and ignores the $destination volume. + +On systems that have a grammar that indicates filenames, this ignores the +$base filename as well. Otherwise all path components are assumed to be +directories. + +If $path is absolute, it is cleaned up and returned using L</canonpath()>. + +Based on code written by Shigio Yamaguchi. + +No checks against the filesystem are made. + +=cut + +sub rel2abs($;$;) { + my ($self,$path,$base ) = @_; + + if ( ! $self->file_name_is_absolute( $path ) ) { + if ( !defined( $base ) || $base eq '' ) { + $base = cwd() ; + } + elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } + else { + $base = $self->canonpath( $base ) ; + } + + $path = $self->canonpath("$base$path") ; + } + + return $path ; +} + + =back =head1 SEE ALSO @@ -226,5 +395,3 @@ L<File::Spec> =cut 1; -__END__ - diff --git a/contrib/perl5/lib/File/Spec/OS2.pm b/contrib/perl5/lib/File/Spec/OS2.pm index d602617..33370f0 100644 --- a/contrib/perl5/lib/File/Spec/OS2.pm +++ b/contrib/perl5/lib/File/Spec/OS2.pm @@ -1,34 +1,44 @@ package File::Spec::OS2; -#use Config; -#use Cwd; -#use File::Basename; use strict; -require Exporter; - -use File::Spec; use vars qw(@ISA); - -Exporter::import('File::Spec', - qw( $Verbose)); - +require File::Spec::Unix; @ISA = qw(File::Spec::Unix); -$ENV{EMXSHELL} = 'sh'; # to run `commands` +sub devnull { + return "/dev/nul"; +} + +sub case_tolerant { + return 1; +} sub file_name_is_absolute { - my($self,$file) = @_; - $file =~ m{^([a-z]:)?[\\/]}i ; + my ($self,$file) = @_; + return scalar($file =~ m{^([a-z]:)?[\\/]}is); } sub path { - my($self) = @_; - my $path_sep = ";"; my $path = $ENV{PATH}; $path =~ s:\\:/:g; - my @path = split $path_sep, $path; - foreach(@path) { $_ = '.' if $_ eq '' } - @path; + my @path = split(';',$path); + foreach (@path) { $_ = '.' if $_ eq '' } + return @path; +} + +my $tmpdir; +sub tmpdir { + return $tmpdir if defined $tmpdir; + my $self = shift; + foreach (@ENV{qw(TMPDIR TEMP TMP)}, qw(/tmp /)) { + next unless defined && -d; + $tmpdir = $_; + last; + } + $tmpdir = '' unless defined $tmpdir; + $tmpdir =~ s:\\:/:g; + $tmpdir = $self->canonpath($tmpdir); + return $tmpdir; } 1; @@ -40,12 +50,10 @@ File::Spec::OS2 - methods for OS/2 file specs =head1 SYNOPSIS - use File::Spec::OS2; # Done internally by File::Spec if needed + require File::Spec::OS2; # 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. - -=cut diff --git a/contrib/perl5/lib/File/Spec/Unix.pm b/contrib/perl5/lib/File/Spec/Unix.pm index 77de73a..2305b75 100644 --- a/contrib/perl5/lib/File/Spec/Unix.pm +++ b/contrib/perl5/lib/File/Spec/Unix.pm @@ -1,23 +1,8 @@ package File::Spec::Unix; -use Exporter (); -use Config; -use File::Basename qw(basename dirname fileparse); -use DirHandle; use strict; -use vars qw(@ISA $Is_Mac $Is_OS2 $Is_VMS $Is_Win32); -use File::Spec; -Exporter::import('File::Spec', '$Verbose'); - -$Is_OS2 = $^O eq 'os2'; -$Is_Mac = $^O eq 'MacOS'; -$Is_Win32 = $^O eq 'MSWin32'; - -if ($Is_VMS = $^O eq 'VMS') { - require VMS::Filespec; - import VMS::Filespec qw( &vmsify ); -} +use Cwd; =head1 NAME @@ -25,7 +10,7 @@ File::Spec::Unix - methods used by File::Spec =head1 SYNOPSIS -C<require File::Spec::Unix;> + require File::Spec::Unix; # Done automatically by File::Spec =head1 DESCRIPTION @@ -40,15 +25,18 @@ Methods for manipulating file specifications. No physical check on the filesystem, but a logical cleanup of a path. On UNIX eliminated successive slashes and successive "/.". + $cpath = File::Spec->canonpath( $path ) ; + =cut sub canonpath { - my($self,$path) = @_; - $path =~ s|/+|/|g ; # xx////xx -> xx/xx - $path =~ s|(/\.)+/|/|g ; # xx/././xx -> xx/xx - $path =~ s|^(\./)+|| unless $path eq "./"; # ./xx -> xx - $path =~ s|/$|| unless $path eq "/"; # xx/ -> xx - $path; + my ($self,$path) = @_; + $path =~ s|/+|/|g unless($^O eq 'cygwin'); # 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|| unless $path eq "/"; # xx/ -> xx + return $path; } =item catdir @@ -61,20 +49,14 @@ trailing slash :-) =cut -# '; - sub catdir { - shift; + my $self = shift; my @args = @_; - for (@args) { + foreach (@args) { # append a slash to each argument unless it has one there - $_ .= "/" if $_ eq '' or substr($_,-1) ne "/"; + $_ .= "/" if $_ eq '' || substr($_,-1) ne "/"; } - my $result = join('', @args); - # remove a trailing slash unless we are root - substr($result,-1) = "" - if length($result) > 1 && substr($result,-1) eq "/"; - $result; + return $self->canonpath(join('', @args)); } =item catfile @@ -85,29 +67,37 @@ complete path ending with a filename =cut sub catfile { - my $self = shift @_; + my $self = shift; my $file = pop @_; return $file unless @_; my $dir = $self->catdir(@_); - for ($dir) { - $_ .= "/" unless substr($_,length($_)-1,1) eq "/"; - } + $dir .= "/" unless substr($dir,-1) eq "/"; return $dir.$file; } =item curdir -Returns a string representing of the current directory. "." on UNIX. +Returns a string representation of the current directory. "." on UNIX. =cut sub curdir { - return "." ; + return "."; +} + +=item devnull + +Returns a string representation of the null device. "/dev/null" on UNIX. + +=cut + +sub devnull { + return "/dev/null"; } =item rootdir -Returns a string representing of the root directory. "/" on UNIX. +Returns a string representation of the root directory. "/" on UNIX. =cut @@ -115,9 +105,31 @@ sub rootdir { return "/"; } +=item tmpdir + +Returns a string representation of the first writable directory +from the following list or "" if none are writable: + + $ENV{TMPDIR} + /tmp + +=cut + +my $tmpdir; +sub tmpdir { + return $tmpdir if defined $tmpdir; + foreach ($ENV{TMPDIR}, "/tmp") { + next unless defined && -d && -w _; + $tmpdir = $_; + last; + } + $tmpdir = '' unless defined $tmpdir; + return $tmpdir; +} + =item updir -Returns a string representing of the parent directory. ".." on UNIX. +Returns a string representation of the parent directory. ".." on UNIX. =cut @@ -133,8 +145,19 @@ directory. (Does not strip symlinks, only '.', '..', and equivalents.) =cut sub no_upwards { - my($self) = shift; - return grep(!/^\.{1,2}$/, @_); + 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 { + return 0; } =item file_name_is_absolute @@ -144,8 +167,8 @@ Takes as argument a path and returns true, if it is an absolute path. =cut sub file_name_is_absolute { - my($self,$file) = @_; - $file =~ m:^/: ; + my ($self,$file) = @_; + return scalar($file =~ m:^/:s); } =item path @@ -155,12 +178,9 @@ Takes no argument, returns the environment variable PATH as an array. =cut sub path { - my($self) = @_; - my $path_sep = ":"; - my $path = $ENV{PATH}; - my @path = split $path_sep, $path; - foreach(@path) { $_ = '.' if $_ eq '' } - @path; + my @path = split(':', $ENV{PATH}); + foreach (@path) { $_ = '.' if $_ eq '' } + return @path; } =item join @@ -170,21 +190,247 @@ join is the same as catfile. =cut sub join { - my($self) = shift @_; - $self->catfile(@_); + 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 in to volume, directory, and filename portions. On systems +with no concept of volume, returns undef 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 (e.g. MacOS). + +On Unix, + + 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| ) { + 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 nativename -TBW. +=item catpath + +Takes volume, directory and file portions and returns an entire path. Under +Unix, $volume is ignored, and directory and file are catenated. A '/' is +inserted if need be. On other OSs, $volume is significant. =cut -sub nativename { - my($self,$name) = shift @_; - $name; +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( $destination ) ; + $rel_path = File::Spec->abs2rel( $destination, $base ) ; + +If $base is not present or '', then L<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()>. + +On systems with the concept of a volume, this assumes that both paths +are on the $destination volume, and ignores the $base volume. + +On systems that have a grammar that indicates filenames, this ignores the +$base filename as well. 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()>. + +Based on code written by Shigio Yamaguchi. + +No checks against the filesystem are made. + +=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 = 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( $destination ) ; + $abs_path = File::Spec->rel2abs( $destination, $base ) ; + +If $base is not present or '', then L<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()>. + +On systems with the concept of a volume, this assumes that both paths +are on the $base volume, and ignores the $destination volume. + +On systems that have a grammar that indicates filenames, this ignores the +$base filename as well. Otherwise all path components are assumed to be +directories. + +If $path is absolute, it is cleaned up and returned using L</canonpath()>. + +Based on code written by Shigio Yamaguchi. + +No checks against the filesystem are made. + +=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() ; + } + 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 SEE ALSO @@ -194,4 +440,3 @@ L<File::Spec> =cut 1; -__END__ diff --git a/contrib/perl5/lib/File/Spec/VMS.pm b/contrib/perl5/lib/File/Spec/VMS.pm index c5269fd..a2ac8ca 100644 --- a/contrib/perl5/lib/File/Spec/VMS.pm +++ b/contrib/perl5/lib/File/Spec/VMS.pm @@ -1,19 +1,13 @@ - package File::Spec::VMS; -use Carp qw( &carp ); -use Config; -require Exporter; -use VMS::Filespec; -use File::Basename; - -use File::Spec; -use vars qw($Revision); -$Revision = '5.3901 (6-Mar-1997)'; - +use strict; +use vars qw(@ISA); +require File::Spec::Unix; @ISA = qw(File::Spec::Unix); -Exporter::import('File::Spec', '$Verbose'); +use Cwd; +use File::Basename; +use VMS::Filespec; =head1 NAME @@ -21,7 +15,7 @@ File::Spec::VMS - methods for VMS file specs =head1 SYNOPSIS - use File::Spec::VMS; # Done internally by File::Spec if needed + require File::Spec::VMS; # Done internally by File::Spec if needed =head1 DESCRIPTION @@ -29,67 +23,202 @@ See File::Spec::Unix for a documentation of the methods provided there. This package overrides the implementation of these methods, not the semantics. +=over + +=item eliminate_macros + +Expands MM[KS]/Make macros in a text string, using the contents of +identically named elements of C<%$self>, and returns the result +as a file specification in Unix syntax. + +=cut + +sub eliminate_macros { + my($self,$path) = @_; + return '' unless $path; + $self = {} unless ref $self; + 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##; } + $npath = "$head$macro$tail"; + } + } + if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; } + $npath; +} + +=item fixpath + +Catchall routine to clean up problem MM[SK]/Make macros. Expands macros +in any directory specification, in order to avoid juxtaposing two +VMS-syntax directories when MM[SK] is run. Also expands expressions which +are all macro, so that we can tell how long the expansion is, and avoid +overrunning DCL's command buffer when MM[KS] is running. + +If optional second argument has a TRUE value, then the return string is +a VMS-syntax directory specification, if it is FALSE, the return string +is a VMS-syntax file specification, and if it is not specified, fixpath() +checks to see whether it matches the name of a directory in the current +default directory, and returns a directory or file specification accordingly. + +=cut + +sub fixpath { + my($self,$path,$force_path) = @_; + return '' unless $path; + $self = bless {} unless ref $self; + my($fixedpath,$prefix,$name); + + if ($path =~ m#^\$\([^\)]+\)\z#s || $path =~ m#[/:>\]]#) { + if ($force_path or $path =~ /(?:DIR\)|\])\z/) { + $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/) ? 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 + =head2 Methods always loaded =over +=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|; + $path = $self->SUPER::canonpath($path); + if ($pathify) { return vmspath($path); } + else { return vmsify($path); } + } + else { + $path =~ s-\]\[--g; $path =~ s/><//g; # foo.][bar ==> foo.bar + $path =~ s/([\[<])000000\./$1/; # [000000.foo ==> foo + 1 while $path =~ s{([\[<-])\.-}{$1-}; # [.-.- ==> [-- + $path =~ s/\.[^\[<\.]+\.-([\]\>])/$1/; # bar.foo.-] ==> bar] + $path =~ s/([\[<])(-+)/$1 . "\cx" x length($2)/e; # encode leading '-'s + $path =~ s/([\[<\.])([^\[<\.\cx]+)\.-\.?/$1/g; # bar.-.foo ==> foo + $path =~ s/([\[<])(\cx+)/$1 . '-' x length($2)/e; # then decode + return $path; + } +} + =item catdir Concatenates a list of file specifications, and returns the result as a -VMS-syntax directory specification. +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; + my ($self,@dirs) = @_; + my $dir = pop @dirs; @dirs = grep($_,@dirs); - my($rslt); + my $rslt; if (@dirs) { - my($path) = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs)); - my($spath,$sdir) = ($path,$dir); - $spath =~ s/.dir$//; $sdir =~ s/.dir$//; - $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+$/; - $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1); + my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs)); + my ($spath,$sdir) = ($path,$dir); + $spath =~ s/\.dir\z//; $sdir =~ s/\.dir\z//; + $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+\z/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 ($dir =~ /^\$\([^\)]+\)$/) { $rslt = $dir; } - else { $rslt = vmspath($dir); } + else { + if (not defined $dir or not length $dir) { $rslt = ''; } + elsif ($dir =~ /^\$\([^\)]+\)\z/s) { $rslt = $dir; } + else { $rslt = vmspath($dir); } } - print "catdir(",join(',',@_[1..$#_]),") = |$rslt|\n" if $Verbose >= 3; - $rslt; + return $self->canonpath($rslt); } =item catfile Concatenates a list of file specifications, and returns the result as a -VMS-syntax directory specification. +VMS-syntax file specification. =cut sub catfile { - my($self,@files) = @_; - my($file) = pop @files; + my ($self,@files) = @_; + my $file = pop @files; @files = grep($_,@files); - my($rslt); + my $rslt; if (@files) { - my($path) = (@files == 1 ? $files[0] : $self->catdir(@files)); - my($spath) = $path; - $spath =~ s/.dir$//; - if ( $spath =~ /^[^\)\]\/:>]+\)$/ && basename($file) eq $file) { $rslt = "$spath$file"; } - else { - $rslt = $self->eliminate_macros($spath); - $rslt = vmsify($rslt.($rslt ? '/' : '').unixify($file)); - } + my $path = (@files == 1 ? $files[0] : $self->catdir(@files)); + my $spath = $path; + $spath =~ s/\.dir\z//; + if ($spath =~ /^[^\)\]\/:>]+\)\z/s && basename($file) eq $file) { + $rslt = "$spath$file"; + } + else { + $rslt = $self->eliminate_macros($spath); + $rslt = vmsify($rslt.($rslt ? '/' : '').unixify($file)); + } } - else { $rslt = vmsify($file); } - print "catfile(",join(',',@_[1..$#_]),") = |$rslt|\n" if $Verbose >= 3; - $rslt; + else { $rslt = (defined($file) && length($file)) ? vmsify($file) : ''; } + return $self->canonpath($rslt); } + =item curdir (override) -Returns a string representing of the current directory. +Returns a string representation of the current directory: '[]' =cut @@ -97,19 +226,51 @@ 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 representing of the root directory. +Returns a string representation of the root directory: 'SYS$DISK:[000000]' =cut sub rootdir { - return ''; + 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} + +=cut + +my $tmpdir; +sub tmpdir { + return $tmpdir if defined $tmpdir; + foreach ('sys$scratch', $ENV{TMPDIR}) { + next unless defined && -d && -w _; + $tmpdir = $_; + last; + } + $tmpdir = '' unless defined $tmpdir; + return $tmpdir; } =item updir (override) -Returns a string representing of the parent directory. +Returns a string representation of the parent directory: '[-]' =cut @@ -117,6 +278,16 @@ 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 @@ -125,9 +296,9 @@ to C<split> string value of C<$ENV{'PATH'}>. =cut sub path { - my(@dirs,$dir,$i); + my (@dirs,$dir,$i); while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); } - @dirs; + return @dirs; } =item file_name_is_absolute (override) @@ -137,12 +308,185 @@ Checks for VMS directory spec as well as Unix separators. =cut sub file_name_is_absolute { - my($self,$file) = @_; + my ($self,$file) = @_; # If it's a logical name, expand it. - $file = $ENV{$file} while $file =~ /^[\w\$\-]+$/ and $ENV{$file}; - $file =~ m!^/! or $file =~ m![<\[][^.\-\]>]! or $file =~ /:[^<\[]/; + $file = $ENV{$file} while $file =~ /^[\w\$\-]+\z/s && $ENV{$file}; + return scalar($file =~ m!^/!s || + $file =~ m![<\[][^.\-\]>]! || + $file =~ /:[^<\[]/); } -1; -__END__ +=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 =~ s/\]\[//g; $dirspec =~ s/\-\-/-.-/g; + $dirspec = "[$dirspec]" unless $dirspec =~ /[\[<]/; # make legal + my(@dirs) = split('\.', vmspath($dirspec)); + $dirs[0] =~ s/^[\[<]//s; $dirs[-1] =~ s/[\]>]\z//s; + @dirs; +} + + +=item catpath (override) + +Construct a complete filespec using VMS syntax + +=cut + +sub catpath { + my($self,$dev,$dir,$file) = @_; + if ($dev =~ m|^/+([^/]+)|) { $dev = "$1:"; } + else { $dev .= ':' unless $dev eq '' or $dev =~ /:\z/; } + 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 ( join( '', @_ ) =~ m{/} ) ; + + my($path,$base) = @_; + + # Note: we use '/' to glue things together here, then let canonpath() + # clean them up at the end. + # 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() ; + } + elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } + else { + $base = $self->canonpath( $base ) ; + } + + # Split up paths + my ( undef, $path_directories, $path_file ) = + $self->splitpath( $path, 1 ) ; + + $path_directories = $1 + if $path_directories =~ /^\[(.*)\]\z/s ; + + my ( undef, $base_directories, undef ) = + $self->splitpath( $base, 1 ) ; + + $base_directories = $1 + if $base_directories =~ /^\[(.*)\]\z/s ; + + # 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 ; + } + + # @basechunks now contains the directories to climb out of, + # @pathchunks now has the directories to descend in to. + $path_directories = '-.' x @basechunks . join( '.', @pathchunks ) ; + $path_directories =~ s{\.\z}{} ; + return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ; +} + + +=item rel2abs (override) + +Use VMS syntax when converting filespecs. + +=cut + +sub rel2abs($;$;) { + my $self = shift ; + return vmspath(File::Spec::Unix::rel2abs( $self, @_ )) + if ( join( '', @_ ) =~ m{/} ) ; + + my ($path,$base ) = @_; + # 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() ; + } + elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } + else { + $base = $self->canonpath( $base ) ; + } + + # Split up paths + my ( undef, $path_directories, $path_file ) = + $self->splitpath( $path ) ; + + my ( $base_volume, $base_directories, undef ) = + $self->splitpath( $base ) ; + + $path_directories = '' if $path_directories eq '[]' || + $path_directories eq '<>'; + my $sep = '' ; + $sep = '.' + if ( $base_directories =~ m{[^.\]>]\z} && + $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 SEE ALSO + +L<File::Spec> + +=cut + +1; diff --git a/contrib/perl5/lib/File/Spec/Win32.pm b/contrib/perl5/lib/File/Spec/Win32.pm index 034a0cb..aa95fbd 100644 --- a/contrib/perl5/lib/File/Spec/Win32.pm +++ b/contrib/perl5/lib/File/Spec/Win32.pm @@ -1,12 +1,18 @@ package File::Spec::Win32; +use strict; +use Cwd; +use vars qw(@ISA); +require File::Spec::Unix; +@ISA = qw(File::Spec::Unix); + =head1 NAME File::Spec::Win32 - methods for Win32 file specs =head1 SYNOPSIS - use File::Spec::Win32; # Done internally by File::Spec if needed + require File::Spec::Win32; # Done internally by File::Spec if needed =head1 DESCRIPTION @@ -16,37 +22,50 @@ the semantics. =over -=cut +=item devnull -#use Config; -#use Cwd; -use File::Basename; -require Exporter; -use strict; +Returns a string representation of the null device. -use vars qw(@ISA); +=cut -use File::Spec; -Exporter::import('File::Spec', qw( $Verbose)); +sub devnull { + return "nul"; +} -@ISA = qw(File::Spec::Unix); +=item tmpdir -$ENV{EMXSHELL} = 'sh'; # to run `commands` +Returns a string representation of the first existing directory +from the following list: -sub file_name_is_absolute { - my($self,$file) = @_; - $file =~ m{^([a-z]:)?[\\/]}i ; -} + $ENV{TMPDIR} + $ENV{TEMP} + $ENV{TMP} + /tmp + / -sub catdir { +=cut + +my $tmpdir; +sub tmpdir { + return $tmpdir if defined $tmpdir; my $self = shift; - my @args = @_; - for (@args) { - # append a slash to each argument unless it has one there - $_ .= "\\" if $_ eq '' or substr($_,-1) ne "\\"; + foreach (@ENV{qw(TMPDIR TEMP TMP)}, qw(/tmp /)) { + next unless defined && -d; + $tmpdir = $_; + last; } - my $result = $self->canonpath(join('', @args)); - $result; + $tmpdir = '' unless defined $tmpdir; + $tmpdir = $self->canonpath($tmpdir); + return $tmpdir; +} + +sub case_tolerant { + return 1; +} + +sub file_name_is_absolute { + my ($self,$file) = @_; + return scalar($file =~ m{^([a-z]:)?[\\/]}is); } =item catfile @@ -57,22 +76,19 @@ complete path ending with a filename =cut sub catfile { - my $self = shift @_; + my $self = shift; my $file = pop @_; return $file unless @_; my $dir = $self->catdir(@_); - $dir =~ s/(\\\.)$//; - $dir .= "\\" unless substr($dir,length($dir)-1,1) eq "\\"; + $dir .= "\\" unless substr($dir,-1) eq "\\"; return $dir.$file; } sub path { - local $^W = 1; - my($self) = @_; my $path = $ENV{'PATH'} || $ENV{'Path'} || $ENV{'path'}; my @path = split(';',$path); - foreach(@path) { $_ = '.' if $_ eq '' } - @path; + foreach (@path) { $_ = '.' if $_ eq '' } + return @path; } =item canonpath @@ -83,22 +99,307 @@ path. On UNIX eliminated successive slashes and successive "/.". =cut sub canonpath { - my($self,$path) = @_; - $path =~ s/^([a-z]:)/\u$1/; + my ($self,$path) = @_; + $path =~ s/^([a-z]:)/\u$1/s; $path =~ s|/|\\|g; - $path =~ s|\\+|\\|g ; # xx////xx -> xx/xx - $path =~ s|(\\\.)+\\|\\|g ; # xx/././xx -> xx/xx - $path =~ s|^(\.\\)+|| unless $path eq ".\\"; # ./xx -> xx - $path =~ s|\\$|| - unless $path =~ m#^([a-z]:)?\\#; # xx/ -> xx - $path .= '.' if $path =~ m#\\$#; - $path; + $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|| + unless $path =~ m#^([A-Z]:)?\\\z#s; # xx/ -> xx + return $path; } -1; -__END__ +=item splitpath + + ($volume,$directories,$file) = File::Spec->splitpath( $path ); + ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file ); + +Splits a path in to 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, undef ). + +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)?)? ) + (.*) + }xs; + $volume = $1; + $directory = $2; + $file = $3; + } + + 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, 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| ) { + 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 + $volume .= $1 + if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\z@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@s && + $volume =~ m@[^\\/]\z@ && + $file =~ m@[^\\/]@ + ) { + $volume =~ m@([\\/])@ ; + my $sep = $1 ? $1 : '\\' ; + $volume .= $sep ; + } + + $volume .= $file ; + + return $volume ; +} + + +=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( $destination ) ; + $rel_path = File::Spec->abs2rel( $destination, $base ) ; + +If $base is not present or '', then L</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()>. + +On systems with the concept of a volume, this assumes that both paths +are on the $destination volume, and ignores the $base volume. + +On systems that have a grammar that indicates filenames, this ignores the +$base filename as well. 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()>. + +Based on code written by Shigio Yamaguchi. + +No checks against the filesystem are made. + +=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 ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } + elsif ( !defined( $base ) || $base eq '' ) { + $base = cwd() ; + } + else { + $base = $self->canonpath( $base ) ; + } + + # Split up paths + my ( $path_volume, $path_directories, $path_file ) = + $self->splitpath( $path, 1 ) ; + + my ( undef, $base_directories, undef ) = + $self->splitpath( $base, 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 ; + } + + # 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" ; + } + + # It makes no sense to add a relative path to a UNC volume + $path_volume = '' unless $path_volume =~ m{^[A-Z]:}is ; + + return $self->canonpath( + $self->catpath($path_volume, $path_directories, $path_file ) + ) ; +} + +=item rel2abs + +Converts a relative path to an absolute path. + + $abs_path = File::Spec->rel2abs( $destination ) ; + $abs_path = File::Spec->rel2abs( $destination, $base ) ; + +If $base is not present or '', then L<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()>. + +Assumes that both paths are on the $base volume, and ignores the +$destination volume. + +On systems that have a grammar that indicates filenames, this ignores the +$base filename as well. Otherwise all path components are assumed to be +directories. + +If $path is absolute, it is cleaned up and returned using L</canonpath()>. + +Based on code written by Shigio Yamaguchi. + +No checks against the filesystem are made. + +=cut + +sub rel2abs($;$;) { + my ($self,$path,$base ) = @_; + + if ( ! $self->file_name_is_absolute( $path ) ) { + + if ( !defined( $base ) || $base eq '' ) { + $base = cwd() ; + } + elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } + else { + $base = $self->canonpath( $base ) ; + } + + my ( undef, $path_directories, $path_file ) = + $self->splitpath( $path, 1 ) ; + + my ( $base_volume, $base_directories, undef ) = + $self->splitpath( $base, 1 ) ; + + $path = $self->catpath( + $base_volume, + $self->catdir( $base_directories, $path_directories ), + $path_file + ) ; + } + + return $self->canonpath( $path ) ; +} =back -=cut +=head1 SEE ALSO + +L<File::Spec> +=cut + +1; |
