Revision history for Perl distribution PathTools.
+3.14_01 Fri Dec 9 22:45:49 CST 2005
+
+ - The Cwd::getcwd() function on *nix is now a direct pass-through to
+ the underlying getcwd() C library function when possible. This is
+ safer and faster than the previous implementation, which just did
+ abs_path('.'). [Suggested by Nick Ing-Simmons]
+
+ - When Cwd searches for a 'pwd' executable in the $PATH, we now stop
+ after we find the first one rather than continuing the search. We
+ also avoid the $PATH search altogether when a 'pwd' was already
+ found in a well-known and well-trusted location like /bin or
+ /usr/bin. [Suggested by Nick Ing-Simmons]
+
+ - On Win32 abs2rel($path, $base) was failing whenever $base is the
+ root of a volume (such as C:\ or \\share\dir). This has been
+ fixed. [Reported by Bryan Daimler]
+
+ - In abs2rel() on VMS, we've fixed handling of directory trees so
+ that the test $file = File::Spec::VMS->abs2rel('[t1.t2.t3]file',
+ '[t1.t2.t3]') returns 'file' instead of an empty string. [John
+ E. Malmberg]
+
+ - In canonpath() on VMS, '[]' was totally optimized away instead of
+ just returning '[]'. Now it's fixed. [John E. Malmberg]
+
3.14 Thu Nov 17 18:08:44 CST 2005
- canonpath() has some logic in it that avoids collapsing a
}
void
+getcwd()
+PROTOTYPE: DISABLE
+PPCODE:
+{
+ dXSTARG;
+ getcwd_sv(TARG);
+ XSprePUSH; PUSHTARG;
+#ifndef INCOMPLETE_TAINTS
+ SvTAINTED_on(TARG);
+#endif
+}
+
+void
abs_path(pathsv=Nullsv)
SV *pathsv
PROTOTYPE: DISABLE
Returns the current working directory.
-Re-implements the getcwd(3) (or getwd(3)) functions in Perl.
+Exposes the POSIX function getcwd(3) or re-implements it if it's not
+available.
=item cwd
use Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
-$VERSION = '3.14';
+$VERSION = '3.14_01';
@ISA = qw/ Exporter /;
@EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
last;
}
}
+my $found_pwd_cmd = defined($pwd_cmd);
unless ($pwd_cmd) {
# Isn't this wrong? _backtick_pwd() will fail if somenone has
# pwd in their path but it is not /bin/pwd or /usr/bin/pwd?
# The pwd command is not available in some chroot(2)'ed environments
my $sep = $Config::Config{path_sep} || ':';
my $os = $^O; # Protect $^O from tainting
- if( $os eq 'MacOS' || (defined $ENV{PATH} &&
- $os ne 'MSWin32' && # no pwd on Windows
- grep { -x "$_/pwd" } split($sep, $ENV{PATH})) )
+
+
+ # Try again to find a pwd, this time searching the whole PATH.
+ if (defined $ENV{PATH} and $os ne 'MSWin32') { # no pwd on Windows
+ my @candidates = split($sep, $ENV{PATH});
+ while (!$found_pwd_cmd and @candidates) {
+ my $candidate = shift @candidates;
+ $found_pwd_cmd = 1 if -x "$candidate/pwd";
+ }
+ }
+
+ # MacOS has some special magic to make `pwd` work.
+ if( $os eq 'MacOS' || $found_pwd_cmd )
{
*cwd = \&_backtick_pwd;
}
# isn't redefined later (20001212 rspier)
*fastgetcwd = \&cwd;
-# By Brandon S. Allbery
-#
-# Usage: $cwd = getcwd();
-
-sub getcwd
-{
- abs_path('.');
-}
-
-
# By John Bazik
#
# Usage: $cwd = &fastcwd;
use strict;
use vars qw(@ISA $VERSION);
-$VERSION = '3.14';
+$VERSION = '3.14_01';
$VERSION = eval $VERSION;
my %module = (MacOS => 'Mac',
my $path_directories = ($self->splitpath($path, 1))[1];
my $base_directories = ($self->splitpath($base, 1))[1];
+ # For UNC paths, the user might give a volume like //foo/bar that
+ # strictly speaking has no directory portion. Treat it as if it
+ # had the root directory for that volume.
+ if (!length($base_directories) and $self->file_name_is_absolute($base)) {
+ $base_directories = $self->rootdir;
+ }
+
# Now, remove all leading components that are the same
my @pathchunks = $self->splitdir( $path_directories );
my @basechunks = $self->splitdir( $base_directories );
+ if ($base_directories eq $self->rootdir) {
+ shift @pathchunks;
+ return $self->canonpath( $self->catpath('', $self->catdir( @pathchunks ), '') );
+ }
+
while (@pathchunks && @basechunks && $self->_same($pathchunks[0], $basechunks[0])) {
shift @pathchunks ;
shift @basechunks ;
$path =~ s/\[[^\]\.]+\.-\./\[/g; # [foo.-. ==> [
$path =~ s/\.[^\]\.]+\.-\]/\]/g; # .foo.-] ==> ]
$path =~ s/\[[^\]\.]+\.-\]/\[000000\]/g;# [foo.-] ==> [000000]
- $path =~ s/\[\]//; # [] ==>
+ $path =~ s/\[\]// unless $path eq '[]'; # [] ==>
return $path;
}
}
# Now, remove all leading components that are the same
my @pathchunks = $self->splitdir( $path_directories );
+ my $pathchunks = @pathchunks;
unshift(@pathchunks,'000000') unless $pathchunks[0] eq '000000';
my @basechunks = $self->splitdir( $base_directories );
+ my $basechunks = @basechunks;
unshift(@basechunks,'000000') unless $basechunks[0] eq '000000';
while ( @pathchunks &&
shift @basechunks ;
}
- return $self->curdir unless @pathchunks || @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) ;
+ if ((@basechunks > 0) || ($basechunks != $pathchunks)) {
+ $path_directories = join '.', ('-' x @basechunks, @pathchunks) ;
+ }
+ else {
+ $path_directories = join '.', @pathchunks;
+ }
+ $path_directories = '['.$path_directories.']';
return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ;
}
[ "FakeWin32->abs2rel('A:/t1/t2/t3/t4','B:/t1/t2/t3')", 'A:\\t1\\t2\\t3\\t4' ],
[ "FakeWin32->abs2rel('E:/foo/bar/baz')", 'E:\\foo\\bar\\baz' ],
[ "FakeWin32->abs2rel('C:/one/two/three')", 'three' ],
+[ "FakeWin32->abs2rel('C:\\Windows\\System32', 'C:\\')", 'Windows\System32' ],
+[ "FakeWin32->abs2rel('\\\\computer2\\share3\\foo.txt', '\\\\computer2\\share3')", 'foo.txt' ],
[ "FakeWin32->rel2abs('temp','C:/')", 'C:\\temp' ],
[ "FakeWin32->rel2abs('temp','C:/a')", 'C:\\a\\temp' ],
projects / p5sagit/p5-mst-13.2.git / commitdiff