X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCwd.pm;h=e25ff4b223110c99c40727658fb8de03c82a7422;hb=6877a1cf6ff3f0f711772ea75e579e2e7219cc46;hp=6b845108c252c170410b339d860b977feadef694;hpb=4633a7c4bad06b471d9310620b7fe8ddd158cccd;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/Cwd.pm b/lib/Cwd.pm index 6b84510..e25ff4b 100644 --- a/lib/Cwd.pm +++ b/lib/Cwd.pm @@ -1,11 +1,7 @@ package Cwd; require 5.000; require Exporter; -require Config; - -# Use osname for portability switches (doubled to cheaply avoid -w warning) -my $osname = $Config::Config{'osname'} || $Config::Config{'osname'}; - +use Carp; =head1 NAME @@ -31,7 +27,7 @@ getcwd - get pathname of current working directory The getcwd() function re-implements the getcwd(3) (or getwd(3)) functions in Perl. -The fastgetcwd() function looks the same as getcwd(), but runs faster. +The fastcwd() function looks the same as getcwd(), but runs faster. It's also more dangerous because you might conceivably chdir() out of a directory that you can't chdir() back into. @@ -43,22 +39,23 @@ the trailing line terminator). It is recommended that cwd (or another If you ask to override your chdir() built-in function, then your PWD environment variable will be kept up to date. (See -L.) Note that it will only be -kept up to date it all packages which use chdir import it from Cwd. +L.) Note that it will only be +kept up to date if all packages which use chdir import it from Cwd. =cut @ISA = qw(Exporter); -@EXPORT = qw(cwd getcwd fastcwd); -@EXPORT_OK = qw(chdir); +@EXPORT = qw(cwd getcwd fastcwd fastgetcwd); +@EXPORT_OK = qw(chdir abs_path fast_abspath); # use strict; -sub _backtick_pwd { # The 'natural and safe form' for UNIX (pwd may be setuid root) +# The 'natural and safe form' for UNIX (pwd may be setuid root) +sub _backtick_pwd { my $cwd; chop($cwd = `pwd`); $cwd; -} +} # Since some ports may predefine cwd internally (e.g., NT) # we take care not to override an existing definition for cwd(). @@ -113,9 +110,11 @@ sub getcwd } unless (@tst = lstat("$dotdots/$dir")) { - warn "lstat($dotdots/$dir): $!"; - closedir(PARENT); - return ''; + # warn "lstat($dotdots/$dir): $!"; + # Just because you can't lstat this directory + # doesn't mean you'll never find the right one. + # closedir(PARENT); + # return ''; } } while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] || @@ -124,7 +123,7 @@ sub getcwd $cwd = "$dir/$cwd"; closedir(PARENT); } while ($dir); - chop($cwd); # drop the trailing / + chop($cwd) unless $cwd eq '/'; # drop the trailing / $cwd; } @@ -175,7 +174,7 @@ sub fastcwd { my $chdir_init = 0; sub chdir_init { - if ($ENV{'PWD'} and $osname ne 'os2') { + if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'msdos') { my($dd,$di) = stat('.'); my($pd,$pi) = stat($ENV{'PWD'}); if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) { @@ -201,7 +200,7 @@ sub chdir { $newdir =~ s|///*|/|g; chdir_init() unless $chdir_init; return 0 unless CORE::chdir $newdir; - if ($osname eq 'VMS') { return $ENV{'PWD'} = $ENV{'DEFAULT'} } + if ($^O eq 'VMS') { return $ENV{'PWD'} = $ENV{'DEFAULT'} } if ($newdir =~ m#^/#) { $ENV{'PWD'} = $newdir; @@ -219,25 +218,88 @@ sub chdir { 1; } +# Taken from Cwd.pm It is really getcwd with an optional +# parameter instead of '.' +# + +sub abs_path +{ + my $start = shift || '.'; + my($dotdots, $cwd, @pst, @cst, $dir, @tst); + + unless (@cst = stat( $start )) + { + carp "stat($start): $!"; + return ''; + } + $cwd = ''; + $dotdots = $start; + do + { + $dotdots .= '/..'; + @pst = @cst; + unless (opendir(PARENT, $dotdots)) + { + carp "opendir($dotdots): $!"; + return ''; + } + unless (@cst = stat($dotdots)) + { + carp "stat($dotdots): $!"; + closedir(PARENT); + return ''; + } + if ($pst[0] == $cst[0] && $pst[1] == $cst[1]) + { + $dir = ''; + } + else + { + do + { + unless (defined ($dir = readdir(PARENT))) + { + carp "readdir($dotdots): $!"; + closedir(PARENT); + return ''; + } + $tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir")) + } + while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] || + $tst[1] != $pst[1]); + } + $cwd = "$dir/$cwd"; + closedir(PARENT); + } while ($dir); + chop($cwd); # drop the trailing / + $cwd; +} + +sub fast_abspath +{ + my $cwd = getcwd(); + my $path = shift || '.'; + chdir($path) || croak "Cannot chdir to $path:$!"; + my $realpath = getcwd(); + chdir($cwd) || croak "Cannot chdir back to $cwd:$!"; + $realpath; +} + # --- PORTING SECTION --- # VMS: $ENV{'DEFAULT'} points to default directory at all times -# 08-Dec-1994 Charles Bailey bailey@genetics.upenn.edu -# Note: Use of Cwd::getcwd() or Cwd::chdir() (but not Cwd::fastcwd()) -# causes the logical name PWD to be defined in the process -# logical name table as the default device and directory -# seen by Perl. This may not be the same as the default device +# 06-Mar-1996 Charles Bailey bailey@genetics.upenn.edu +# Note: Use of Cwd::chdir() causes the logical name PWD to be defined +# in the process logical name table as the default device and directory +# seen by Perl. This may not be the same as the default device # and directory seen by DCL after Perl exits, since the effects # the CRTL chdir() function persist only until Perl exits. -# This does not apply to other systems (where only chdir() sets PWD). sub _vms_cwd { return $ENV{'DEFAULT'} } -sub _vms_pwd { - return $ENV{'PWD'} = $ENV{'DEFAULT'} -} + sub _os2_cwd { $ENV{'PWD'} = `cmd /c cd`; chop $ENV{'PWD'}; @@ -245,22 +307,48 @@ sub _os2_cwd { return $ENV{'PWD'}; } -if ($osname eq 'VMS') { +*_NT_cwd = \&_os2_cwd unless defined &_NT_cwd; - *cwd = \&_vms_pwd; - *getcwd = \&_vms_pwd; - *fastgetcwd = \&_vms_cwd; +sub _msdos_cwd { + $ENV{'PWD'} = `command /c cd`; + chop $ENV{'PWD'}; + $ENV{'PWD'} =~ s:\\:/:g ; + return $ENV{'PWD'}; } -elsif ($osname eq 'NT') { - *getcwd = \&cwd; - *fastgetcwd = \&cwd; -} -elsif ($osname eq 'os2') { - *cwd = \&_os2_cwd; - *getcwd = \&_os2_cwd; - *fastgetcwd = \&_os2_cwd; - *fastcwd = \&_os2_cwd; +{ + local $^W = 0; # assignments trigger 'subroutine redefined' warning + + if ($^O eq 'VMS') { + *cwd = \&_vms_cwd; + *getcwd = \&_vms_cwd; + *fastcwd = \&_vms_cwd; + *fastgetcwd = \&_vms_cwd; + *abs_path = \&fast_abspath; + } + 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_abspath; + } + elsif ($^O eq 'os2') { + # sys_cwd may keep the builtin command + *cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd; + *getcwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd; + *fastgetcwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd; + *fastcwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd; + *abs_path = \&fast_abspath; + } + elsif ($^O eq 'msdos') { + *cwd = \&_msdos_cwd; + *getcwd = \&_msdos_cwd; + *fastgetcwd = \&_msdos_cwd; + *fastcwd = \&_msdos_cwd; + *abs_path = \&fast_abspath; + } } # package main; eval join('',) || die $@; # quick test