Upgrade to Cwd 2.20

p4raw-id: //depot/perl@23152

diff --git a/MANIFEST b/MANIFEST
index 6947f88..2860f40 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -146,6 +146,7 @@ ext/Cwd/Cwd.xs                      Cwd extension external subroutines
 ext/Cwd/Makefile.PL            Cwd extension makefile maker
 ext/Cwd/t/cwd.t                        See if Cwd works
 ext/Cwd/t/taint.t              See if Cwd works with taint
+ext/Cwd/t/win32.t              See if Cwd works on Win32
 ext/Data/Dumper/Changes                Data pretty printer, changelog
 ext/Data/Dumper/Dumper.pm      Data pretty printer, module
 ext/Data/Dumper/Dumper.xs      Data pretty printer, externals

diff --git a/ext/Cwd/Changes b/ext/Cwd/Changes
index f6974b8..0b7dd1f 100644 (file)
--- a/ext/Cwd/Changes
+++ b/ext/Cwd/Changes
@@ -1,5 +1,18 @@
 Revision history for Perl extension Cwd.
 
+2.20  Thu Jul 22 08:23:53 CDT 2004
+
+ - On some implementations of perl on Win32, a memory leak (or worse?)
+   occurred when calling getdcwd().  This has been fixed. [PodMaster]
+
+ - Added tests for getdcwd() on Win32.
+
+ - Fixed a problem in the pure-perl implementation _perl_abs_path()
+   that caused a fatal error when run on plain files. [Nicholas Clark]
+   To exercise the appropriate test code on platforms that wouldn't
+   otherwise use _perl_abs_path(), run the tests with $ENV{PERL_CORE}
+   or $ENV{TEST_PERL_CWD_CODE} set.
+
 2.19  Thu Jul 15 08:32:18 CDT 2004
 
  - The abs_path($arg) fix from 2.18 didn't work for VMS, now it's

diff --git a/ext/Cwd/Cwd.xs b/ext/Cwd/Cwd.xs
index fae3ef9..273ab2d 100644 (file)
--- a/ext/Cwd/Cwd.xs
+++ b/ext/Cwd/Cwd.xs
@@ -424,10 +424,10 @@ PPCODE:
     else
         croak("Usage: getdcwd(DRIVE)");
 
-    /* Pass a NULL pointer as the second argument to have space allocated. */
-    if (dir = _getdcwd(drive, NULL, MAXPATHLEN)) {
+    New(0,dir,MAXPATHLEN,char);
+    if (_getdcwd(drive, dir, MAXPATHLEN)) {
         sv_setpvn(TARG, dir, strlen(dir));
-        free(dir);
+        Safefree(dir);
         SvPOK_only(TARG);
     }
     else

diff --git a/ext/Cwd/t/cwd.t b/ext/Cwd/t/cwd.t
index 52427e6..2c7d6c5 100644 (file)
--- a/ext/Cwd/t/cwd.t
+++ b/ext/Cwd/t/cwd.t
@@ -14,7 +14,12 @@ use warnings;
 use File::Spec;
 use File::Path;
 
-use Test::More tests => 24;
+use Test::More;
+
+my $tests = 24;
+my $EXTRA_ABSPATH_TESTS = $ENV{PERL_CORE} || $ENV{TEST_PERL_CWD_CODE};
+$tests += 3 if $EXTRA_ABSPATH_TESTS;
+plan tests => $tests;
 
 my $IsVMS = $^O eq 'VMS';
 my $IsMacOS = $^O eq 'MacOS';
@@ -129,7 +134,7 @@ rmtree($test_dirs[0], 0, 0);
 }
 
 SKIP: {
-    skip "no symlinks on this platform", 2 unless $Config{d_symlink};
+    skip "no symlinks on this platform", 2+$EXTRA_ABSPATH_TESTS unless $Config{d_symlink};
 
     mkpath([$Test_Dir], 0, 0777);
     symlink $Test_Dir, "linktest";
@@ -140,6 +145,7 @@ SKIP: {
 
     like($abs_path,      qr|$want$|);
     like($fast_abs_path, qr|$want$|);
+    like(Cwd::_perl_abs_path("linktest"), qr|$want$|) if $EXTRA_ABSPATH_TESTS;
 
     rmtree($test_dirs[0], 0, 0);
     unlink "linktest";
@@ -154,10 +160,14 @@ if ($ENV{PERL_CORE}) {
 my $path = 'cwd.t';
 path_ends_with(Cwd::abs_path($path), 'cwd.t', 'abs_path() can be invoked on a file');
 path_ends_with(Cwd::fast_abs_path($path), 'cwd.t', 'fast_abs_path() can be invoked on a file');
+path_ends_with(Cwd::_perl_abs_path($path), 'cwd.t', '_perl_abs_path() can be invoked on a file')
+  if $EXTRA_ABSPATH_TESTS;
 
 $path = File::Spec->catfile(File::Spec->updir, 't', $path);
 path_ends_with(Cwd::abs_path($path), 'cwd.t', 'abs_path() can be invoked on a file');
 path_ends_with(Cwd::fast_abs_path($path), 'cwd.t', 'fast_abs_path() can be invoked on a file');
+path_ends_with(Cwd::_perl_abs_path($path), 'cwd.t', '_perl_abs_path() can be invoked on a file')
+  if $EXTRA_ABSPATH_TESTS;
 
 
 #############################################

diff --git a/ext/Cwd/t/win32.t b/ext/Cwd/t/win32.t
new file mode 100644 (file)
index 0000000..f5fa20e
--- /dev/null
+++ b/ext/Cwd/t/win32.t
@@ -0,0 +1,29 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    if ($ENV{PERL_CORE}) {
+        @INC = '../lib';
+    }
+}
+
+use Test::More;
+if( $^O eq 'MSWin32' ) {
+  plan tests => 3;
+} else {
+  plan skip_all => 'this is not win32';
+}
+
+use Cwd;
+ok 1;
+
+my $cdir = getdcwd('C:');
+like $cdir, qr{^C:};
+
+my $ddir = getdcwd('D:');
+if (defined $ddir) {
+  like $ddir, qr{^D:};
+} else {
+  # May not have a D: drive mounted
+  ok 1;
+}

diff --git a/lib/Cwd.pm b/lib/Cwd.pm
index b0dad20..dc52b72 100644 (file)
--- a/lib/Cwd.pm
+++ b/lib/Cwd.pm
@@ -1,5 +1,5 @@
 package Cwd;
-$VERSION = $VERSION = '2.19';
+$VERSION = $VERSION = '2.20';
 
 =head1 NAME
 
@@ -469,7 +469,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;