Add a regression test for bug #32193, and make the

[perl5.git] / lib / Cwd.pm

diff --git a/lib/Cwd.pm b/lib/Cwd.pm
index af0c47f..c389c38 100644 (file)
--- a/lib/Cwd.pm
+++ b/lib/Cwd.pm
@@ -1,5 +1,4 @@
 package Cwd;
-$VERSION = $VERSION = '2.18';
 
 =head1 NAME
 
@@ -148,6 +147,19 @@ Originally by the perl5-porters.
 
 Maintained by Ken Williams <KWILLIAMS@cpan.org>
 
+=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.
+
+Portions of the C code in this library are copyright (c) 1994 by the
+Regents of the University of California.  All rights reserved.  The
+license on this code is compatible with the licensing of the rest of
+the distribution - please see the source code in F<Cwd.xs> for the
+details.
+
 =head1 SEE ALSO
 
 L<File::chdir>
@@ -156,7 +168,9 @@ L<File::chdir>
 
 use strict;
 use Exporter;
-use vars qw(@ISA @EXPORT @EXPORT_OK);
+use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
+
+$VERSION = '3.04_01';
 
 @ISA = qw/ Exporter /;
 @EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
@@ -186,11 +200,19 @@ if ($^O eq 'os2') {
 }
 
 eval {
-    require XSLoader;
-    local $^W = 0;
-    XSLoader::load('Cwd');
+if ( $] >= 5.006 ) {
+  require XSLoader;
+  XSLoader::load( __PACKAGE__, $VERSION );
+} else {
+  require DynaLoader;
+  push @ISA, 'DynaLoader';
+  __PACKAGE__->bootstrap( $VERSION );
+}
 };
 
+# Must be after the DynaLoader stuff:
+$VERSION = eval $VERSION;
+
 # Big nasty table of function aliases
 my %METHOD_MAP =
   (
@@ -308,6 +330,7 @@ unless ($METHOD_MAP{$^O}{cwd} or defined &cwd) {
     # The pwd command is not available in some chroot(2)'ed environments
     my $sep = $Config::Config{path_sep} || ':';
     if( $^O eq 'MacOS' || (defined $ENV{PATH} &&
+                          $^O ne 'MSWin32' &&  # no pwd on Windows
                           grep { -x "$_/pwd" } split($sep, $ENV{PATH})) )
     {
        *cwd = \&_backtick_pwd;
@@ -338,7 +361,7 @@ sub getcwd
 # This is a faster version of getcwd.  It's also more dangerous because
 # you might chdir out of a directory that you can't chdir back into.
     
-sub fastcwd {
+sub fastcwd_ {
     my($odev, $oino, $cdev, $cino, $tdev, $tino);
     my(@path, $path);
     local(*DIR);
@@ -376,6 +399,7 @@ sub fastcwd {
        if $cdev != $orig_cdev || $cino != $orig_cino;
     $path;
 }
+if (not defined &fastcwd) { *fastcwd = \&fastcwd_ }
 
 
 # Keeps track of current working directory in PWD environment var
@@ -449,9 +473,7 @@ sub chdir {
 }
 
 
-# In case the XS version doesn't load.
-*abs_path = \&_perl_abs_path unless defined &abs_path;
-sub _perl_abs_path(;$)
+sub _perl_abs_path
 {
     my $start = @_ ? shift : '.';
     my($dotdots, $cwd, @pst, @cst, $dir, @tst);
@@ -469,7 +491,8 @@ sub _perl_abs_path(;$)
         my ($dir, $file) = $start =~ m{^(.*)/(.+)$}
            or return cwd() . '/' . $start;
        
-       if (-l _) {
+       # Can't use "-l _" here, because the previous stat was a stat(), not an lstat().
+       if (-l $start) {
            my $link_target = readlink($start);
            die "Can't resolve link $start: $!" unless defined $link_target;
            
@@ -480,7 +503,7 @@ sub _perl_abs_path(;$)
            return abs_path($link_target);
        }
        
-       return abs_path($dir) . '/' . $file;
+       return $dir ? abs_path($dir) . "/$file" : "/$file";
     }
 
     $cwd = '';
@@ -528,12 +551,9 @@ sub _perl_abs_path(;$)
 }
 
 
-# added function alias for those of us more
-# used to the libc function.  --tchrist 27-Jan-00
-*realpath = \&abs_path;
-
 my $Curdir;
 sub fast_abs_path {
+    local $ENV{PWD} = $ENV{PWD} || ''; # Guard against clobberage
     my $cwd = getcwd();
     require File::Spec;
     my $path = @_ ? shift : ($Curdir ||= File::Spec->curdir);
@@ -563,7 +583,11 @@ sub fast_abs_path {
            return fast_abs_path($link_target);
        }
        
-       return fast_abs_path(File::Spec->catpath($vol, $dir, '')) . '/' . $file;
+       my $tdir = $dir;
+       $tdir =~ s!\\!/!g if $^O eq 'MSWin32';
+       return $tdir eq File::Spec->rootdir
+         ? File::Spec->catpath($vol, $dir, $file)
+         : fast_abs_path(File::Spec->catpath($vol, $dir, '')) . '/' . $file;
     }
 
     if (!CORE::chdir($path)) {
@@ -597,11 +621,11 @@ sub _vms_cwd {
 
 sub _vms_abs_path {
     return $ENV{'DEFAULT'} unless @_;
+
+    # may need to turn foo.dir into [.foo]
     my $path = VMS::Filespec::pathify($_[0]);
-    if (! defined $path)
-       {
-       _croak("Invalid path name $_[0]")
-       }
+    $path = $_[0] unless defined $path;
+
     return VMS::Filespec::rmsexpand($path);
 }
 
@@ -650,7 +674,7 @@ sub _qnx_abs_path {
     my $path = @_ ? shift : '.';
     local *REALPATH;
 
-    open(REALPATH, '-|', '/usr/bin/fullpath', '-t', $path) or
+    defined( open(REALPATH, '-|') || exec '/usr/bin/fullpath', '-t', $path ) or
       die "Can't open /usr/bin/fullpath: $!";
     my $realpath = <REALPATH>;
     close REALPATH;
@@ -670,11 +694,17 @@ sub _epoc_cwd {
 if (exists $METHOD_MAP{$^O}) {
   my $map = $METHOD_MAP{$^O};
   foreach my $name (keys %$map) {
-    no warnings;       # assignments trigger 'subroutine redefined' warning
+    local $^W = 0;  # assignments trigger 'subroutine redefined' warning
     no strict 'refs';
     *{$name} = \&{$map->{$name}};
   }
 }
 
+# In case the XS version doesn't load.
+*abs_path = \&_perl_abs_path unless defined &abs_path;
+
+# added function alias for those of us more
+# used to the libc function.  --tchrist 27-Jan-00
+*realpath = \&abs_path;
 
 1;