X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCwd.pm;h=3c5c50a35cebfb6d76f79ad8d96f16ecb9ae2176;hb=67597c89125e7e144f9ba60f5b1fe23b951286d8;hp=048842b4ac4cedffa892db532fb1e4f8a492ad41;hpb=2d7a92375815264badaef23c612657cbd4799f31;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/Cwd.pm b/lib/Cwd.pm index 048842b..3c5c50a 100644 --- a/lib/Cwd.pm +++ b/lib/Cwd.pm @@ -1,9 +1,9 @@ package Cwd; -require 5.000; +require 5.6.0; =head1 NAME -getcwd - get pathname of current working directory +Cwd - get pathname of current working directory =head1 SYNOPSIS @@ -14,14 +14,35 @@ getcwd - get pathname of current working directory $dir = getcwd; use Cwd; + $dir = fastcwd; + + use Cwd; $dir = fastgetcwd; use Cwd 'chdir'; chdir "/tmp"; print $ENV{'PWD'}; + use Cwd 'abs_path'; # aka realpath() + print abs_path($ENV{'PWD'}); + + use Cwd 'fast_abs_path'; + print fast_abs_path($ENV{'PWD'}); + =head1 DESCRIPTION +This module provides functions for determining the pathname of the +current working directory. By default, it exports the functions +cwd(), getcwd(), fastcwd(), and fastgetcwd() into the caller's +namespace. Each of these functions are called without arguments and +return the absolute path of the current working directory. It is +recommended that cwd (or another *cwd() function) be used in I +code to ensure portability. + +The cwd() is the most natural and safe form for the current +architecture. For most systems it is identical to `pwd` (but without +the trailing line terminator). + The getcwd() function re-implements the getcwd(3) (or getwd(3)) functions in Perl. @@ -35,46 +56,106 @@ 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. -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). +The fastgetcwd() function is provided as a synonym for cwd(). -It is recommended that cwd (or another *cwd() function) is used in -I code to ensure portability. +The abs_path() function takes a single argument and returns the +absolute pathname for that argument. It uses the same algorithm as +getcwd(). (Actually, getcwd() is abs_path(".")) Symbolic links and +relative-path components ("." and "..") are resolved to return the +canonical pathname, just like realpath(3). This function is also +callable as realpath(). + +The fast_abs_path() function looks the same as abs_path() but runs +faster and, like fastcwd(), is more dangerous. 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 if all packages which use chdir import it from Cwd. +=head1 NOTES + +=over 4 + +=item * + +On Mac OS (Classic), the path separator is ':', not '/', and the +current directory is denoted as ':', not '.'. To move up the directory +tree, you will use '::' to move up one level, but ':::' and so on to +move up the tree two or more levels (i.e. the equivalent to '../../..' +is '::::'). Generally, you should be careful about specifying relative pathnames. +While a full path always begins with a volume name, a relative pathname +should always begin with a ':'. If specifying a volume name only, a +trailing ':' is required. + +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. + +=back + =cut -## use strict; +use strict; use Carp; -$VERSION = '2.00'; - -require Exporter; -@ISA = qw(Exporter); -@EXPORT = qw(cwd getcwd fastcwd fastgetcwd); -@EXPORT_OK = qw(chdir abs_path fast_abs_path); +our $VERSION = '2.05'; + +use base qw/ Exporter /; +our @EXPORT = qw(cwd getcwd fastcwd fastgetcwd); +our @EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath); + +# sys_cwd may keep the builtin command + +# 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? + +if ($^O eq 'os2' && defined &sys_cwd && defined &sys_abspath) { + local $^W = 0; + *cwd = \&sys_cwd; + *getcwd = \&cwd; + *fastgetcwd = \&cwd; + *fastcwd = \&cwd; + *abs_path = \&sys_abspath; + *fast_abs_path = \&abs_path; + *realpath = \&abs_path; + *fast_realpath = \&abs_path; + return 1; +} +eval { + require XSLoader; + XSLoader::load('Cwd'); +}; # The 'natural and safe form' for UNIX (pwd may be setuid root) sub _backtick_pwd { - my $cwd; - chop($cwd = `pwd`); + my $cwd = `pwd`; + # `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(defined &cwd) { + # The pwd command is not available in some chroot(2)'ed environments + if($^O eq 'MacOS' || grep { -x "$_/pwd" } split(':', $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 # @@ -82,115 +163,9 @@ sub _backtick_pwd { 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 = undef; - } - 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 = (defined $dir ? "$dir" : "" ) . "/$cwd" ; - closedir(PARENT); - } while (defined $dir); - chop($cwd) unless $cwd eq '/'; # drop the trailing / - $cwd; -} - - - -# 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. - -# List of metachars taken from do_exec() in doio.c -my $quoted_shell_meta = quotemeta('$&*(){}[]";\\|?<>~`'."'\n"); - -sub fastcwd { - my($odev, $oino, $cdev, $cino, $tdev, $tino); - my(@path, $path); - local(*DIR); - - my($orig_cdev, $orig_cino) = stat('.'); - ($cdev, $cino) = ($orig_cdev, $orig_cino); - for (;;) { - my $direntry; - ($odev, $oino) = ($cdev, $cino); - chdir('..') || return undef; - ($cdev, $cino) = stat('.'); - last if $odev == $cdev && $oino == $cino; - opendir(DIR, '.') || return undef; - for (;;) { - $direntry = readdir(DIR); - last unless defined $direntry; - next if $direntry eq '.'; - next if $direntry eq '..'; - - ($tdev, $tino) = lstat($direntry); - last unless $tdev != $odev || $tino != $oino; - } - closedir(DIR); - return undef unless defined $direntry; # should never happen - unshift(@path, $direntry); - } - $path = '/' . join('/', @path); - # At this point $path may be tainted (if tainting) and chdir would fail. - # To be more useful we untaint it then check that we landed where we started. - $path = $1 if $path =~ /^(.*)$/; # untaint - chdir($path) || return undef; - ($cdev, $cino) = stat('.'); - die "Unstable directory path, current directory changed unexpectedly" - if $cdev != $orig_cdev || $cino != $orig_cino; - $path; + abs_path('.'); } - # Keeps track of current working directory in PWD environment var # Usage: # use Cwd 'chdir'; @@ -199,7 +174,7 @@ sub fastcwd { my $chdir_init = 0; sub chdir_init { - if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos') { + 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) { @@ -207,10 +182,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) { @@ -221,13 +198,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 ($^O 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'}); @@ -243,77 +236,29 @@ 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; -} +# added function alias for those of us more +# used to the libc function. --tchrist 27-Jan-00 +*realpath = \&abs_path; sub fast_abs_path { my $cwd = getcwd(); - my $path = shift || '.'; - chdir($path) || croak "Cannot chdir to $path:$!"; + require File::Spec; + my $path = @_ ? shift : File::Spec->curdir; + CORE::chdir($path) || croak "Cannot chdir to $path:$!"; my $realpath = getcwd(); - chdir($cwd) || croak "Cannot chdir back to $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 -# 06-Mar-1996 Charles Bailey bailey@genetics.upenn.edu +# 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 @@ -360,8 +305,26 @@ sub _dos_cwd { return $ENV{'PWD'}; } +sub _qnx_cwd { + $ENV{'PWD'} = `/usr/bin/fullpath -t`; + chop $ENV{'PWD'}; + return $ENV{'PWD'}; +} + +sub _qnx_abs_path { + my $path = @_ ? shift : '.'; + my $realpath=`/usr/bin/fullpath -t $path`; + chop $realpath; + return $realpath; +} + +sub _epoc_cwd { + $ENV{'PWD'} = EPOC::getcwd(); + return $ENV{'PWD'}; +} + { - local $^W = 0; # assignments trigger 'subroutine redefined' warning + no warnings; # assignments trigger 'subroutine redefined' warning if ($^O eq 'VMS') { *cwd = \&_vms_cwd; @@ -394,6 +357,33 @@ sub _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; + } + 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; + } } # package main; eval join('',) || die $@; # quick test