X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCwd.pm;h=755c7a77959220706f2f028fd773f9c31e48f425;hb=250d67eb8e42c118b44bb5437965a1f4a8a0d828;hp=37fdcfad5b8c340029465b156fc2011413db6385;hpb=9d7d97294754b044f4b4bee93dbdfb1d82ffe0d7;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/Cwd.pm b/lib/Cwd.pm index 37fdcfa..755c7a7 100644 --- a/lib/Cwd.pm +++ b/lib/Cwd.pm @@ -1,5 +1,4 @@ package Cwd; -$VERSION = $VERSION = '2.18'; =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 @@ -148,6 +148,19 @@ Originally by the perl5-porters. 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 L @@ -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.18'; @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; } @@ -317,6 +357,15 @@ unless ($METHOD_MAP{$^O}{cwd} or defined &cwd) { } } +if ($^O eq 'cygwin') { + # We need to make sure cwd() is called with no args, because it's + # got an arg-less prototype and will die if args are present. + local $^W = 0; + my $orig_cwd = \&cwd; + *cwd = sub { &$orig_cwd() } +} + + # set a reasonable (and very safe) default for fastgetcwd, in case it # isn't redefined later (20001212 rspier) *fastgetcwd = \&cwd; @@ -325,12 +374,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 +386,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 +424,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 +498,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 +516,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 +528,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 +576,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 +608,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)) { @@ -618,10 +665,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 +694,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 +714,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;