X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCwd.pm;h=b6f0a2ad2e83f1954317a509855ab2b77e9093e1;hb=71fbae4b4b3f337a0c2643cc859be9d389fd2e98;hp=e7d12e3ae79a42c17eabcd0c89ce775e20e4ab87;hpb=09122b95120d497042cb9df9ebb06ebcfca423aa;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/Cwd.pm b/lib/Cwd.pm index e7d12e3..b6f0a2a 100644 --- a/lib/Cwd.pm +++ b/lib/Cwd.pm @@ -1,5 +1,4 @@ package Cwd; -$VERSION = $VERSION = '2.17_03'; =head1 NAME @@ -36,7 +35,8 @@ absolute path of the current working directory. 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 @@ -146,7 +146,20 @@ C. Originally by the perl5-porters. -Now maintained by Ken Williams +Maintained by Ken Williams + +=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 for the +details. =head1 SEE ALSO @@ -156,7 +169,9 @@ L use strict; use Exporter; -use vars qw(@ISA @EXPORT @EXPORT_OK); +use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION); + +$VERSION = '3.15'; @ISA = qw/ Exporter /; @EXPORT = qw(cwd getcwd fastcwd fastgetcwd); @@ -185,12 +200,21 @@ if ($^O eq 'os2') { return 1; } +# If loading the XS stuff doesn't work, we can fall back to pure perl eval { + if ( $] >= 5.006 ) { require XSLoader; - local $^W = 0; - XSLoader::load('Cwd'); + 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 = ( @@ -279,6 +303,7 @@ foreach my $try ('/bin/pwd', 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? @@ -292,7 +317,10 @@ sub _croak { require Carp; Carp::croak(@_) } # The 'natural and safe form' for UNIX (pwd may be setuid root) sub _backtick_pwd { - local @ENV{qw(PATH IFS CDPATH ENV BASH_ENV)}; + # Localize %ENV entries in a way that won't create new hash keys + my @localize = grep exists $ENV{$_}, qw(PATH IFS CDPATH ENV BASH_ENV); + local @ENV{@localize}; + my $cwd = `$pwd_cmd`; # Belt-and-suspenders in case someone said "undef $/". local $/ = "\n"; @@ -307,8 +335,20 @@ sub _backtick_pwd { 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} && - grep { -x "$_/pwd" } split($sep, $ENV{PATH})) ) + my $os = $^O; # Protect $^O from tainting + + + # 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; } @@ -325,12 +365,11 @@ unless ($METHOD_MAP{$^O}{cwd} or defined &cwd) { # # Usage: $cwd = getcwd(); -sub getcwd +sub _perl_getcwd { abs_path('.'); } - # By John Bazik # # Usage: $cwd = &fastcwd; @@ -338,7 +377,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 +415,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 +489,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 +507,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 +519,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 +567,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 +599,9 @@ sub fast_abs_path { return fast_abs_path($link_target); } - return fast_abs_path(File::Spec->catpath($vol, $dir, '')) . '/' . $file; + return $dir 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 +635,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); } @@ -618,10 +656,7 @@ sub _win32_cwd { return $ENV{'PWD'}; } -*_NT_cwd = \&_win32_cwd if (!defined &_NT_cwd && - defined &Win32::GetCwd); - -*_NT_cwd = \&_os2_cwd unless defined &_NT_cwd; +*_NT_cwd = defined &Win32::GetCwd ? \&_win32_cwd : \&_os2_cwd; sub _dos_cwd { if (!defined &Dos::GetCwd) { @@ -650,7 +685,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 = ; close REALPATH; @@ -670,11 +705,18 @@ 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; +*getcwd = \&_perl_getcwd unless defined &getcwd; + +# added function alias for those of us more +# used to the libc function. --tchrist 27-Jan-00 +*realpath = \&abs_path; 1;