diff options
Diffstat (limited to 'contrib/perl5/lib/File/Spec/Unix.pm')
| -rw-r--r-- | contrib/perl5/lib/File/Spec/Unix.pm | 363 |
1 files changed, 304 insertions, 59 deletions
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__ |
