diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | ext/Cwd/Changes | 13 | ||||
| -rw-r--r-- | ext/Cwd/Cwd.xs | 6 | ||||
| -rw-r--r-- | ext/Cwd/t/cwd.t | 14 | ||||
| -rw-r--r-- | ext/Cwd/t/win32.t | 29 | ||||
| -rw-r--r-- | lib/Cwd.pm | 5 |
6 files changed, 61 insertions, 7 deletions
@@ -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 f6974b8161..0b7dd1fbbb 100644 --- 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 fae3ef97e3..273ab2d121 100644 --- 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 52427e648c..2c7d6c5598 100644 --- 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 index 0000000000..f5fa20e102 --- /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 b0dad20e6a..dc52b72014 100644 --- 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; |