From: Rafael Garcia-Suarez Date: Thu, 24 Jun 2004 12:58:35 +0000 (+0000) Subject: Upgrade to Cwd 2.17_03 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=09122b95120d497042cb9df9ebb06ebcfca423aa;p=p5sagit%2Fp5-mst-13.2.git Upgrade to Cwd 2.17_03 p4raw-id: //depot/perl@22988 --- diff --git a/ext/Cwd/Changes b/ext/Cwd/Changes index ca9684e..12e14e7 100644 --- a/ext/Cwd/Changes +++ b/ext/Cwd/Changes @@ -1,5 +1,30 @@ Revision history for Perl extension Cwd. +2.18 (pending, still in beta release) + + - Fixed a problem in which abs_path($arg) on some platforms could + only be called on directories, and died when called on files. This + was a problem in the pure-perl implementation _perl_abs_path(). + + - Fixed fast_abs_path($arg) in the same way as abs_path($arg) above. + + - On Win32, a function getdcwd($vol) has been added, which gets the + current working directory of the specified drive/volume. + [Steve Hay] + + - Fixed a problem on perl 5.6.2 when built with the MULTIPLICITY + compile-time flags. [Yitzchak Scott-Thoennes] + + - When looking for a `pwd` system command, we no longer assume the + path separator is ':'. + + - On platforms where cwd() is implemented internally (like Win32), + don't look for a `pwd` command externally. This can greatly speed + up load time. [Stefan Scherer] + + - The pure-perl version of abs_path() now has the same prototype as + the XS version (;$). + 2.17 Wed Mar 10 07:55:36 CST 2004 - The change in 2.16 created a testing failure when tested from diff --git a/ext/Cwd/Cwd.xs b/ext/Cwd/Cwd.xs index 04ab25e..fae3ef9 100644 --- a/ext/Cwd/Cwd.xs +++ b/ext/Cwd/Cwd.xs @@ -212,7 +212,8 @@ err2: #ifndef getcwd_sv /* Taken from perl 5.8's util.c */ -int getcwd_sv(pTHX_ register SV *sv) +#define getcwd_sv(a) Perl_getcwd_sv(aTHX_ a) +int Perl_getcwd_sv(pTHX_ register SV *sv) { #ifndef PERL_MICRO @@ -402,3 +403,40 @@ PPCODE: SvTAINTED_on(TARG); #endif } + +#ifdef WIN32 + +void +getdcwd(...) +PPCODE: +{ + dXSTARG; + int drive; + char *dir; + + /* Drive 0 is the current drive, 1 is A:, 2 is B:, 3 is C: and so on. */ + if ( items == 0 || + (items == 1 && (!SvOK(ST(0)) || (SvPOK(ST(0)) && !SvCUR(ST(0)))))) + drive = 0; + else if (items == 1 && SvPOK(ST(0)) && SvCUR(ST(0)) && + isALPHA(SvPVX(ST(0))[0])) + drive = toUPPER(SvPVX(ST(0))[0]) - 'A' + 1; + else + croak("Usage: getdcwd(DRIVE)"); + + /* Pass a NULL pointer as the second argument to have space allocated. */ + if (dir = _getdcwd(drive, NULL, MAXPATHLEN)) { + sv_setpvn(TARG, dir, strlen(dir)); + free(dir); + SvPOK_only(TARG); + } + else + sv_setsv(TARG, &PL_sv_undef); + + XSprePUSH; PUSHTARG; +#ifndef INCOMPLETE_TAINTS + SvTAINTED_on(TARG); +#endif +} + +#endif diff --git a/lib/Cwd.pm b/lib/Cwd.pm index 4d5c71e..e7d12e3 100644 --- a/lib/Cwd.pm +++ b/lib/Cwd.pm @@ -1,5 +1,5 @@ package Cwd; -$VERSION = $VERSION = '2.17'; +$VERSION = $VERSION = '2.17_03'; =head1 NAME @@ -20,7 +20,7 @@ current working directory. It is recommended that getcwd (or another *cwd() function) be used in I code to ensure portability. By default, it exports the functions cwd(), getcwd(), fastcwd(), and -fastgetcwd() into the caller's namespace. +fastgetcwd() (and, on Win32, getdcwd()) into the caller's namespace. =head2 getcwd and friends @@ -67,6 +67,18 @@ unexpectedly". That should never happen. The fastgetcwd() function is provided as a synonym for cwd(). +=item getdcwd + + my $cwd = getdcwd(); + my $cwd = getdcwd('C:'); + +The getdcwd() function is also provided on Win32 to get the current working +directory on the specified drive, since Windows maintains a separate current +working directory for each drive. If no drive is specified then the current +drive is assumed. + +This function simply calls the Microsoft C library _getdcwd() function. + =back @@ -148,6 +160,7 @@ use vars qw(@ISA @EXPORT @EXPORT_OK); @ISA = qw/ Exporter /; @EXPORT = qw(cwd getcwd fastcwd fastgetcwd); +push @EXPORT, qw(getdcwd) if $^O eq 'MSWin32'; @EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath); # sys_cwd may keep the builtin command @@ -178,6 +191,79 @@ eval { XSLoader::load('Cwd'); }; +# Big nasty table of function aliases +my %METHOD_MAP = + ( + VMS => + { + cwd => '_vms_cwd', + getcwd => '_vms_cwd', + fastcwd => '_vms_cwd', + fastgetcwd => '_vms_cwd', + abs_path => '_vms_abs_path', + fast_abs_path => '_vms_abs_path', + }, + + MSWin32 => + { + # We assume that &_NT_cwd is defined as an XSUB or in the core. + cwd => '_NT_cwd', + getcwd => '_NT_cwd', + fastcwd => '_NT_cwd', + fastgetcwd => '_NT_cwd', + abs_path => 'fast_abs_path', + realpath => 'fast_abs_path', + }, + + dos => + { + cwd => '_dos_cwd', + getcwd => '_dos_cwd', + fastgetcwd => '_dos_cwd', + fastcwd => '_dos_cwd', + abs_path => 'fast_abs_path', + }, + + qnx => + { + cwd => '_qnx_cwd', + getcwd => '_qnx_cwd', + fastgetcwd => '_qnx_cwd', + fastcwd => '_qnx_cwd', + abs_path => '_qnx_abs_path', + fast_abs_path => '_qnx_abs_path', + }, + + cygwin => + { + getcwd => 'cwd', + fastgetcwd => 'cwd', + fastcwd => 'cwd', + abs_path => 'fast_abs_path', + realpath => 'fast_abs_path', + }, + + epoc => + { + cwd => '_epoc_cwd', + getcwd => '_epoc_cwd', + fastgetcwd => '_epoc_cwd', + fastcwd => '_epoc_cwd', + abs_path => 'fast_abs_path', + }, + + MacOS => + { + getcwd => 'cwd', + fastgetcwd => 'cwd', + fastcwd => 'cwd', + abs_path => 'fast_abs_path', + }, + ); + +$METHOD_MAP{NT} = $METHOD_MAP{MSWin32}; +$METHOD_MAP{nto} = $METHOD_MAP{qnx}; + # Find the pwd command in the expected locations. We assume these # are safe. This prevents _backtick_pwd() consulting $ENV{PATH} @@ -218,10 +304,11 @@ sub _backtick_pwd { # Since some ports may predefine cwd internally (e.g., NT) # we take care not to override an existing definition for cwd(). -unless(defined &cwd) { +unless ($METHOD_MAP{$^O}{cwd} or defined &cwd) { # The pwd command is not available in some chroot(2)'ed environments - if( $^O eq 'MacOS' || (defined $ENV{PATH} && - grep { -x "$_/pwd" } split(':', $ENV{PATH})) ) + my $sep = $Config::Config{path_sep} || ':'; + if( $^O eq 'MacOS' || (defined $ENV{PATH} && + grep { -x "$_/pwd" } split($sep, $ENV{PATH})) ) { *cwd = \&_backtick_pwd; } @@ -364,7 +451,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); @@ -374,6 +461,28 @@ sub _perl_abs_path _carp("stat($start): $!"); return ''; } + + unless (-d _) { + # Make sure we can be invoked on plain files, not just directories. + # NOTE that this routine assumes that '/' is the only directory separator. + + my ($dir, $file) = $start =~ m{^(.*)/(.+)$} + or return cwd() . '/' . $start; + + if (-l _) { + my $link_target = readlink($start); + die "Can't resolve link $start: $!" unless defined $link_target; + + require File::Spec; + $link_target = $dir . '/' . $link_target + unless File::Spec->file_name_is_absolute($link_target); + + return abs_path($link_target); + } + + return abs_path($dir) . '/' . $file; + } + $cwd = ''; $dotdots = $start; do @@ -434,6 +543,29 @@ sub fast_abs_path { ($path) = $path =~ /(.*)/; ($cwd) = $cwd =~ /(.*)/; + unless (-e $path) { + _croak("$path: No such file or directory"); + } + + unless (-d _) { + # Make sure we can be invoked on plain files, not just directories. + + my ($vol, $dir, $file) = File::Spec->splitpath($path); + return File::Spec->catfile($cwd, $path) unless length $dir; + + if (-l $path) { + my $link_target = readlink($path); + die "Can't resolve link $path: $!" unless defined $link_target; + + $link_target = File::Spec->catpath($vol, $dir, $link_target) + unless File::Spec->file_name_is_absolute($link_target); + + return fast_abs_path($link_target); + } + + return fast_abs_path(File::Spec->catpath($vol, $dir, '')) . '/' . $file; + } + if (!CORE::chdir($path)) { _croak("Cannot chdir to $path: $!"); } @@ -531,61 +663,17 @@ sub _epoc_cwd { return $ENV{'PWD'}; } -{ - no warnings; # assignments trigger 'subroutine redefined' warning - if ($^O eq 'VMS') { - *cwd = \&_vms_cwd; - *getcwd = \&_vms_cwd; - *fastcwd = \&_vms_cwd; - *fastgetcwd = \&_vms_cwd; - *abs_path = \&_vms_abs_path; - *fast_abs_path = \&_vms_abs_path; - } - elsif ($^O eq 'NT' or $^O eq 'MSWin32') { - # We assume that &_NT_cwd is defined as an XSUB or in the core. - *cwd = \&_NT_cwd; - *getcwd = \&_NT_cwd; - *fastcwd = \&_NT_cwd; - *fastgetcwd = \&_NT_cwd; - *abs_path = \&fast_abs_path; - *realpath = \&fast_abs_path; - } - elsif ($^O eq 'dos') { - *cwd = \&_dos_cwd; - *getcwd = \&_dos_cwd; - *fastgetcwd = \&_dos_cwd; - *fastcwd = \&_dos_cwd; - *abs_path = \&fast_abs_path; - } - elsif ($^O =~ m/^(?:qnx|nto)$/ ) { - *cwd = \&_qnx_cwd; - *getcwd = \&_qnx_cwd; - *fastgetcwd = \&_qnx_cwd; - *fastcwd = \&_qnx_cwd; - *abs_path = \&_qnx_abs_path; - *fast_abs_path = \&_qnx_abs_path; - } - elsif ($^O eq 'cygwin') { - *getcwd = \&cwd; - *fastgetcwd = \&cwd; - *fastcwd = \&cwd; - *abs_path = \&fast_abs_path; - *realpath = \&abs_path; - } - elsif ($^O eq 'epoc') { - *cwd = \&_epoc_cwd; - *getcwd = \&_epoc_cwd; - *fastgetcwd = \&_epoc_cwd; - *fastcwd = \&_epoc_cwd; - *abs_path = \&fast_abs_path; - } - elsif ($^O eq 'MacOS') { - *getcwd = \&cwd; - *fastgetcwd = \&cwd; - *fastcwd = \&cwd; - *abs_path = \&fast_abs_path; - } +# Now that all the base-level functions are set up, alias the +# user-level functions to the right places + +if (exists $METHOD_MAP{$^O}) { + my $map = $METHOD_MAP{$^O}; + foreach my $name (keys %$map) { + no warnings; # assignments trigger 'subroutine redefined' warning + no strict 'refs'; + *{$name} = \&{$map->{$name}}; + } }