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
use Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
-$VERSION = '3.04_01';
+$VERSION = '3.30';
+my $xs_version = $VERSION;
+$VERSION = eval $VERSION;
@ISA = qw/ Exporter /;
@EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
return 1;
}
-eval {
-if ( $] >= 5.006 ) {
- require XSLoader;
- XSLoader::load( __PACKAGE__, $VERSION );
-} else {
- require DynaLoader;
- push @ISA, 'DynaLoader';
- __PACKAGE__->bootstrap( $VERSION );
+# Need to look up the feature settings on VMS. The preferred way is to use the
+# VMS::Feature module, but that may not be available to dual life modules.
+
+my $use_vms_feature;
+BEGIN {
+ if ($^O eq 'VMS') {
+ if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
+ $use_vms_feature = 1;
+ }
+ }
+}
+
+# Need to look up the UNIX report mode. This may become a dynamic mode
+# in the future.
+sub _vms_unix_rpt {
+ my $unix_rpt;
+ if ($use_vms_feature) {
+ $unix_rpt = VMS::Feature::current("filename_unix_report");
+ } else {
+ my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
+ $unix_rpt = $env_unix_rpt =~ /^[ET1]/i;
+ }
+ return $unix_rpt;
+}
+
+# Need to look up the EFS character set mode. This may become a dynamic
+# mode in the future.
+sub _vms_efs {
+ my $efs;
+ if ($use_vms_feature) {
+ $efs = VMS::Feature::current("efs_charset");
+ } else {
+ my $env_efs = $ENV{'DECC$EFS_CHARSET'} || '';
+ $efs = $env_efs =~ /^[ET1]/i;
+ }
+ return $efs;
}
+
+
+# If loading the XS stuff doesn't work, we can fall back to pure perl
+eval {
+ if ( $] >= 5.006 ) {
+ require XSLoader;
+ XSLoader::load( __PACKAGE__, $xs_version);
+ } else {
+ require DynaLoader;
+ push @ISA, 'DynaLoader';
+ __PACKAGE__->bootstrap( $xs_version );
+ }
};
# Must be after the DynaLoader stuff:
abs_path => 'fast_abs_path',
},
+ # QNX4. QNX6 has a $os of 'nto'.
qnx =>
{
cwd => '_qnx_cwd',
);
$METHOD_MAP{NT} = $METHOD_MAP{MSWin32};
-$METHOD_MAP{nto} = $METHOD_MAP{qnx};
# Find the pwd command in the expected locations. We assume these
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?
# 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";
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} &&
- $^O ne 'MSWin32' && # no pwd on Windows
- 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;
}
}
}
+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;
-# By Brandon S. Allbery
-#
-# Usage: $cwd = getcwd();
-
-sub getcwd
+# A non-XS version of getcwd() - also used to bootstrap the perl build
+# process, when miniperl is running and no XS loading happens.
+sub _perl_getcwd
{
abs_path('.');
}
-
# By John Bazik
#
# Usage: $cwd = &fastcwd;
return 1;
}
- if ($newdir =~ m#^/#s) {
+ if (ref $newdir eq 'GLOB') { # in case a file/dir handle is passed in
+ $ENV{'PWD'} = cwd();
+ } elsif ($newdir =~ m#^/#s) {
$ENV{'PWD'} = $newdir;
} else {
my @curdir = split(m#/#,$ENV{'PWD'});
local *PARENT;
unless (opendir(PARENT, $dotdots))
{
- _carp("opendir($dotdots): $!");
- return '';
+ # probably a permissions issue. Try the native command.
+ return File::Spec->rel2abs( $start, _backtick_pwd() );
}
unless (@cst = stat($dotdots))
{
return fast_abs_path($link_target);
}
- my $tdir = $dir;
- $tdir =~ s!\\!/!g if $^O eq 'MSWin32';
- return $tdir eq File::Spec->rootdir
+ return $dir eq File::Spec->rootdir
? File::Spec->catpath($vol, $dir, $file)
: fast_abs_path(File::Spec->catpath($vol, $dir, '')) . '/' . $file;
}
sub _vms_abs_path {
return $ENV{'DEFAULT'} unless @_;
+ my $path = shift;
+
+ my $efs = _vms_efs;
+ my $unix_rpt = _vms_unix_rpt;
+
+ if (defined &VMS::Filespec::vmsrealpath) {
+ my $path_unix = 0;
+ my $path_vms = 0;
+
+ $path_unix = 1 if ($path =~ m#(?<=\^)/#);
+ $path_unix = 1 if ($path =~ /^\.\.?$/);
+ $path_vms = 1 if ($path =~ m#[\[<\]]#);
+ $path_vms = 1 if ($path =~ /^--?$/);
+
+ my $unix_mode = $path_unix;
+ if ($efs) {
+ # In case of a tie, the Unix report mode decides.
+ if ($path_vms == $path_unix) {
+ $unix_mode = $unix_rpt;
+ } else {
+ $unix_mode = 0 if $path_vms;
+ }
+ }
+
+ if ($unix_mode) {
+ # Unix format
+ return VMS::Filespec::unixrealpath($path);
+ }
+
+ # VMS format
+
+ my $new_path = VMS::Filespec::vmsrealpath($path);
+
+ # Perl expects directories to be in directory format
+ $new_path = VMS::Filespec::pathify($new_path) if -d $path;
+ return $new_path;
+ }
- # may need to turn foo.dir into [.foo]
- my $path = VMS::Filespec::pathify($_[0]);
- $path = $_[0] unless defined $path;
+ # Fallback to older algorithm if correct ones are not
+ # available.
+
+ if (-l $path) {
+ my $link_target = readlink($path);
+ die "Can't resolve link $path: $!" unless defined $link_target;
+
+ return _vms_abs_path($link_target);
+ }
+ # may need to turn foo.dir into [.foo]
+ my $pathified = VMS::Filespec::pathify($path);
+ $path = $pathified if defined $pathified;
+
return VMS::Filespec::rmsexpand($path);
}
}
sub _win32_cwd {
- $ENV{'PWD'} = Win32::GetCwd();
+ if (defined &DynaLoader::boot_DynaLoader) {
+ $ENV{'PWD'} = Win32::GetCwd();
+ }
+ else { # miniperl
+ chomp($ENV{'PWD'} = `cd`);
+ }
$ENV{'PWD'} =~ s:\\:/:g ;
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) {
# 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