X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCwd.pm;h=febd296bd30c1605fc3f2e0f0c21c8fa1ebd7126;hb=2ddb7828e223e2d2bbe82a4f9efaac6997a16d6c;hp=bc206db4d4dce55763ee86ba1ce2551e3f1026bb;hpb=e7ae011613ab9e1683332421cf9ea7b4c5e94c94;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/Cwd.pm b/lib/Cwd.pm index bc206db..febd296 100644 --- a/lib/Cwd.pm +++ b/lib/Cwd.pm @@ -1,70 +1,325 @@ 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'}; - +$VERSION = $VERSION = '3.01'; =head1 NAME -getcwd - get pathname of current working directory +Cwd - get pathname of current working directory =head1 SYNOPSIS use Cwd; - $dir = cwd; + my $dir = getcwd; - use Cwd; - $dir = getcwd; + use Cwd 'abs_path'; + my $abs_path = abs_path($file); - use Cwd; - $dir = fastgetcwd; +=head1 DESCRIPTION - use Cwd 'chdir'; - chdir "/tmp"; - print $ENV{'PWD'}; +This module provides functions for determining the pathname of the +current working directory. It is recommended that getcwd (or another +*cwd() function) be used in I code to ensure portability. -=head1 DESCRIPTION +By default, it exports the functions cwd(), getcwd(), fastcwd(), and +fastgetcwd() (and, on Win32, getdcwd()) into the caller's namespace. + + +=head2 getcwd and friends + +Each of these functions are called without arguments and return the +absolute path of the current working directory. + +=over 4 + +=item getcwd + + my $cwd = getcwd(); + +Returns the current working directory. + +Re-implements the getcwd(3) (or getwd(3)) functions in Perl. + +=item cwd + + my $cwd = cwd(); + +The cwd() is the most natural form for the current architecture. For +most systems it is identical to `pwd` (but without the trailing line +terminator). + +=item fastcwd + + my $cwd = fastcwd(); + +A more dangerous version of getcwd(), but potentially faster. + +It might conceivably chdir() you out of a directory that it can't +chdir() you back into. If fastcwd encounters a problem it will return +undef but will probably leave you in a different directory. For a +measure of extra security, if everything appears to have worked, the +fastcwd() function will check that it leaves you in the same directory +that it started in. If it has changed it will C with the message +"Unstable directory path, current directory changed +unexpectedly". That should never happen. + +=item fastgetcwd + + my $cwd = fastgetcwd(); + +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 + + +=head2 abs_path and friends + +These functions are exported only on request. They each take a single +argument and return the absolute pathname for it. If no argument is +given they'll use the current working directory. + +=over 4 + +=item abs_path + + my $abs_path = abs_path($file); + +Uses the same algorithm as getcwd(). Symbolic links and relative-path +components ("." and "..") are resolved to return the canonical +pathname, just like realpath(3). + +=item realpath + + my $abs_path = realpath($file); + +A synonym for abs_path(). + +=item fast_abs_path + + my $abs_path = fast_abs_path($file); + +A more dangerous, but potentially faster version of abs_path. + +=back + +=head2 $ENV{PWD} + +If you ask to override your chdir() built-in function, + + use Cwd qw(chdir); + +then your PWD environment variable will be kept up to date. Note that +it will only be kept up to date if all packages which use chdir import +it from Cwd. + + +=head1 NOTES + +=over 4 + +=item * -The getcwd() function re-implements the getcwd(3) (or getwd(3)) functions -in Perl. +Since the path seperators are different on some operating systems ('/' +on Unix, ':' on MacPerl, etc...) we recommend you use the File::Spec +modules wherever portability is a concern. -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. +=item * -The cwd() function looks the same as getcwd and fastgetcwd but is -implemented using the most natural and safe form for the current -architecture. For most systems it is identical to `pwd` (but without -the trailing line terminator). It is recommended that cwd (or another -*cwd() function) is used in I code to ensure portability. +Actually, on Mac OS, the C, C and C +functions are all aliases for the C function, which, on Mac OS, +calls `pwd`. Likewise, the C function is an alias for +C. -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. +=back + +=head1 AUTHOR + +Originally by the perl5-porters. + +Maintained by Ken Williams + +=head1 SEE ALSO + +L =cut -@ISA = qw(Exporter); +use strict; +use Exporter; +use vars qw(@ISA @EXPORT @EXPORT_OK); + +@ISA = qw/ Exporter /; @EXPORT = qw(cwd getcwd fastcwd fastgetcwd); -@EXPORT_OK = qw(chdir); +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 -# use strict; +# All the functionality of this module may provided by builtins, +# there is no sense to process the rest of the file. +# The best choice may be to have this in BEGIN, but how to return from BEGIN? -sub _backtick_pwd { # The 'natural and safe form' for UNIX (pwd may be setuid root) - my $cwd; - chop($cwd = `pwd`); +if ($^O eq 'os2') { + local $^W = 0; + + *cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd; + *getcwd = \&cwd; + *fastgetcwd = \&cwd; + *fastcwd = \&cwd; + + *fast_abs_path = \&sys_abspath if defined &sys_abspath; + *abs_path = \&fast_abs_path; + *realpath = \&fast_abs_path; + *fast_realpath = \&fast_abs_path; + + return 1; +} + +eval { + require XSLoader; + local $^W = 0; + 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} +# so everything works under taint mode. +my $pwd_cmd; +foreach my $try ('/bin/pwd', + '/usr/bin/pwd', + '/QOpenSys/bin/pwd', # OS/400 PASE. + ) { + + if( -x $try ) { + $pwd_cmd = $try; + last; + } +} +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? + # See [perl #16774]. --jhi + $pwd_cmd = 'pwd'; +} + +# Lazy-load Carp +sub _carp { require Carp; Carp::carp(@_) } +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)}; + my $cwd = `$pwd_cmd`; + # Belt-and-suspenders in case someone said "undef $/". + local $/ = "\n"; + # `pwd` may fail e.g. if the disk is full + chomp($cwd) if defined $cwd; $cwd; -} +} # Since some ports may predefine cwd internally (e.g., NT) # we take care not to override an existing definition for cwd(). -*cwd = \&_backtick_pwd unless defined &cwd; +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})) ) + { + *cwd = \&_backtick_pwd; + } + else { + *cwd = \&getcwd; + } +} +# set a reasonable (and very safe) default for fastgetcwd, in case it +# isn't redefined later (20001212 rspier) +*fastgetcwd = \&cwd; # By Brandon S. Allbery # @@ -72,99 +327,53 @@ sub _backtick_pwd { # The 'natural and safe form' for UNIX (pwd may be setuid r sub getcwd { - my($dotdots, $cwd, @pst, @cst, $dir, @tst); - - unless (@cst = stat('.')) - { - warn "stat(.): $!"; - return ''; - } - $cwd = ''; - $dotdots = ''; - do - { - $dotdots .= '/' if $dotdots; - $dotdots .= '..'; - @pst = @cst; - unless (opendir(PARENT, $dotdots)) - { - warn "opendir($dotdots): $!"; - return ''; - } - unless (@cst = stat($dotdots)) - { - warn "stat($dotdots): $!"; - closedir(PARENT); - return ''; - } - if ($pst[0] == $cst[0] && $pst[1] == $cst[1]) - { - $dir = ''; - } - else - { - do - { - unless (defined ($dir = readdir(PARENT))) - { - warn "readdir($dotdots): $!"; - closedir(PARENT); - return ''; - } - unless (@tst = lstat("$dotdots/$dir")) - { - 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] || - $tst[1] != $pst[1]); - } - $cwd = "$dir/$cwd"; - closedir(PARENT); - } while ($dir); - chop($cwd); # drop the trailing / - $cwd; + abs_path('.'); } - # By John Bazik # # Usage: $cwd = &fastcwd; # # 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 { my($odev, $oino, $cdev, $cino, $tdev, $tino); my(@path, $path); local(*DIR); - ($cdev, $cino) = stat('.'); + my($orig_cdev, $orig_cino) = stat('.'); + ($cdev, $cino) = ($orig_cdev, $orig_cino); for (;;) { my $direntry; ($odev, $oino) = ($cdev, $cino); - chdir('..'); + CORE::chdir('..') || return undef; ($cdev, $cino) = stat('.'); last if $odev == $cdev && $oino == $cino; - opendir(DIR, '.'); + opendir(DIR, '.') || return undef; for (;;) { $direntry = readdir(DIR); + last unless defined $direntry; next if $direntry eq '.'; next if $direntry eq '..'; - last unless defined $direntry; ($tdev, $tino) = lstat($direntry); last unless $tdev != $odev || $tino != $oino; } closedir(DIR); + return undef unless defined $direntry; # should never happen unshift(@path, $direntry); } - chdir($path = '/' . join('/', @path)); + $path = '/' . join('/', @path); + if ($^O eq 'apollo') { $path = "/".$path; } + # At this point $path may be tainted (if tainting) and chdir would fail. + # Untaint it then check that we landed where we started. + $path =~ /^(.*)\z/s # untaint + && CORE::chdir($1) or return undef; + ($cdev, $cino) = stat('.'); + die "Unstable directory path, current directory changed unexpectedly" + if $cdev != $orig_cdev || $cino != $orig_cino; $path; } @@ -177,7 +386,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 'dos' and $^O ne 'MSWin32') { my($dd,$di) = stat('.'); my($pd,$pi) = stat($ENV{'PWD'}); if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) { @@ -185,10 +394,12 @@ sub chdir_init { } } else { - $ENV{'PWD'} = cwd(); + my $wd = cwd(); + $wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32'; + $ENV{'PWD'} = $wd; } # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar) - if ($ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|) { + if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) { my($pd,$pi) = stat($2); my($dd,$di) = stat($1); if (defined $pd and defined $dd and $di == $pi and $dd == $pd) { @@ -199,13 +410,29 @@ sub chdir_init { } sub chdir { - my $newdir = shift || ''; # allow for no arg (chdir to HOME dir) - $newdir =~ s|///*|/|g; + my $newdir = @_ ? shift : ''; # allow for no arg (chdir to HOME dir) + $newdir =~ s|///*|/|g unless $^O eq 'MSWin32'; chdir_init() unless $chdir_init; + my $newpwd; + if ($^O eq 'MSWin32') { + # get the full path name *before* the chdir() + $newpwd = Win32::GetFullPathName($newdir); + } + return 0 unless CORE::chdir $newdir; - if ($osname eq 'VMS') { return $ENV{'PWD'} = $ENV{'DEFAULT'} } - if ($newdir =~ m#^/#) { + if ($^O eq 'VMS') { + return $ENV{'PWD'} = $ENV{'DEFAULT'} + } + elsif ($^O eq 'MacOS') { + return $ENV{'PWD'} = cwd(); + } + elsif ($^O eq 'MSWin32') { + $ENV{'PWD'} = $newpwd; + return 1; + } + + if ($newdir =~ m#^/#s) { $ENV{'PWD'} = $newdir; } else { my @curdir = split(m#/#,$ENV{'PWD'}); @@ -222,57 +449,233 @@ sub chdir { } +# In case the XS version doesn't load. +*abs_path = \&_perl_abs_path unless defined &abs_path; +sub _perl_abs_path(;$) +{ + my $start = @_ ? shift : '.'; + my($dotdots, $cwd, @pst, @cst, $dir, @tst); + + unless (@cst = stat( $start )) + { + _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; + + # 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; + + 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 + { + $dotdots .= '/..'; + @pst = @cst; + local *PARENT; + 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 = undef; + } + 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 = (defined $dir ? "$dir" : "" ) . "/$cwd" ; + closedir(PARENT); + } while (defined $dir); + chop($cwd) unless $cwd eq '/'; # drop the trailing / + $cwd; +} + + +# 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 { + my $cwd = getcwd(); + require File::Spec; + my $path = @_ ? shift : ($Curdir ||= File::Spec->curdir); + + # Detaint else we'll explode in taint mode. This is safe because + # we're not doing anything dangerous with it. + ($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: $!"); + } + my $realpath = getcwd(); + if (! ((-d $cwd) && (CORE::chdir($cwd)))) { + _croak("Cannot chdir back to $cwd: $!"); + } + $realpath; +} + +# added function alias to follow principle of least surprise +# based on previous aliasing. --tchrist 27-Jan-00 +*fast_realpath = \&fast_abs_path; + + # --- 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@newman.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'} + return $ENV{'DEFAULT'}; } -sub _vms_pwd { - return $ENV{'PWD'} = $ENV{'DEFAULT'} + +sub _vms_abs_path { + return $ENV{'DEFAULT'} unless @_; + + # may need to turn foo.dir into [.foo] + my $path = VMS::Filespec::pathify($_[0]); + $path = $_[0] unless defined $path; + + return VMS::Filespec::rmsexpand($path); } + sub _os2_cwd { $ENV{'PWD'} = `cmd /c cd`; - chop $ENV{'PWD'}; + chomp $ENV{'PWD'}; $ENV{'PWD'} =~ s:\\:/:g ; return $ENV{'PWD'}; } -if ($osname eq 'VMS') { +sub _win32_cwd { + $ENV{'PWD'} = Win32::GetCwd(); + $ENV{'PWD'} =~ s:\\:/:g ; + return $ENV{'PWD'}; +} - *cwd = \&_vms_pwd; - *getcwd = \&_vms_pwd; - *fastcwd = \&_vms_cwd; - *fastgetcwd = \&_vms_cwd; +*_NT_cwd = \&_win32_cwd if (!defined &_NT_cwd && + defined &Win32::GetCwd); + +*_NT_cwd = \&_os2_cwd unless defined &_NT_cwd; + +sub _dos_cwd { + if (!defined &Dos::GetCwd) { + $ENV{'PWD'} = `command /c cd`; + chomp $ENV{'PWD'}; + $ENV{'PWD'} =~ s:\\:/:g ; + } else { + $ENV{'PWD'} = Dos::GetCwd(); + } + return $ENV{'PWD'}; +} + +sub _qnx_cwd { + local $ENV{PATH} = ''; + local $ENV{CDPATH} = ''; + local $ENV{ENV} = ''; + $ENV{'PWD'} = `/usr/bin/fullpath -t`; + chomp $ENV{'PWD'}; + return $ENV{'PWD'}; +} + +sub _qnx_abs_path { + local $ENV{PATH} = ''; + local $ENV{CDPATH} = ''; + local $ENV{ENV} = ''; + my $path = @_ ? shift : '.'; + local *REALPATH; + + open(REALPATH, '-|', '/usr/bin/fullpath', '-t', $path) or + die "Can't open /usr/bin/fullpath: $!"; + my $realpath = ; + close REALPATH; + chomp $realpath; + return $realpath; } -elsif ($osname eq 'NT') { - *getcwd = \&cwd; - *fastgetcwd = \&cwd; +sub _epoc_cwd { + $ENV{'PWD'} = EPOC::getcwd(); + return $ENV{'PWD'}; } -elsif ($osname eq 'os2') { - *cwd = \&_os2_cwd; - *getcwd = \&_os2_cwd; - *fastgetcwd = \&_os2_cwd; - *fastcwd = \&_os2_cwd; + + +# 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}}; + } } -# package main; eval join('',) || die $@; # quick test 1; - -__END__ -BEGIN { import Cwd qw(:DEFAULT chdir); } -print join("\n", cwd, getcwd, fastcwd, ""); -chdir('..'); -print join("\n", cwd, getcwd, fastcwd, ""); -print "$ENV{PWD}\n";