package Cwd;
-use 5.006;
=head1 NAME
*cwd() function) be used in I<all> code to ensure portability.
By default, it exports the functions cwd(), getcwd(), fastcwd(), and
-fastgetcwd() into the caller's namespace.
+fastgetcwd() (and, on Win32, getdcwd()) into the caller's namespace.
=head2 getcwd and friends
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
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
=back
+=head1 AUTHOR
+
+Originally by the perl5-porters.
+
+Maintained by Ken Williams <KWILLIAMS@cpan.org>
+
+=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<Cwd.xs> for the
+details.
+
=head1 SEE ALSO
L<File::chdir>
=cut
use strict;
+use Exporter;
+use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
-use Carp;
-
-our $VERSION = '2.08';
+$VERSION = '3.19';
-use base qw/ Exporter /;
-our @EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
-our @EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath);
+@ISA = qw/ Exporter /;
+@EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
+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
# 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) {
+if ($^O eq 'os2') {
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;
+
+ *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;
}
+# 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 =
+ (
+ 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 (qw(/bin/pwd /usr/bin/pwd)) {
+foreach my $try ('/bin/pwd',
+ '/usr/bin/pwd',
+ '/QOpenSys/bin/pwd', # OS/400 PASE.
+ ) {
+
if( -x $try ) {
$pwd_cmd = $try;
last;
}
}
+my $found_pwd_cmd = defined($pwd_cmd);
unless ($pwd_cmd) {
- if (-x '/QOpenSys/bin/pwd') { # OS/400 PASE.
- $pwd_cmd = '/QOpenSys/bin/pwd' ;
- } else {
- # 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';
- }
+ # 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)};
+ # 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";
# Since some ports may predefine cwd internally (e.g., NT)
# we take care not to override an existing definition for cwd().
-unless(defined &cwd) {
+unless ($METHOD_MAP{$^O}{cwd} or defined &cwd) {
# The pwd command is not available in some chroot(2)'ed environments
- if( $^O eq 'MacOS' || (defined $ENV{PATH} &&
- grep { -x "$_/pwd" } split(':', $ENV{PATH})) )
+ my $sep = $Config::Config{path_sep} || ':';
+ 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;
# 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);
if $cdev != $orig_cdev || $cino != $orig_cino;
$path;
}
+if (not defined &fastcwd) { *fastcwd = \&fastcwd_ }
# Keeps track of current working directory in PWD environment var
}
-# In case the XS version doesn't load.
-*abs_path = \&_perl_abs_path unless defined &abs_path;
sub _perl_abs_path
{
my $start = @_ ? shift : '.';
unless (@cst = stat( $start ))
{
- carp "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 $dir ? abs_path($dir) . "/$file" : "/$file";
+ }
+
$cwd = '';
$dotdots = $start;
do
local *PARENT;
unless (opendir(PARENT, $dotdots))
{
- carp "opendir($dotdots): $!";
+ _carp("opendir($dotdots): $!");
return '';
}
unless (@cst = stat($dotdots))
{
- carp "stat($dotdots): $!";
+ _carp("stat($dotdots): $!");
closedir(PARENT);
return '';
}
{
unless (defined ($dir = readdir(PARENT)))
{
- carp "readdir($dotdots): $!";
+ _carp("readdir($dotdots): $!");
closedir(PARENT);
return '';
}
}
-# 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);
($path) = $path =~ /(.*)/;
($cwd) = $cwd =~ /(.*)/;
- CORE::chdir($path) || croak "Cannot chdir to $path: $!";
+ 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 $dir eq File::Spec->rootdir
+ ? File::Spec->catpath($vol, $dir, $file)
+ : fast_abs_path(File::Spec->catpath($vol, $dir, '')) . '/' . $file;
+ }
+
+ if (!CORE::chdir($path)) {
+ _croak("Cannot chdir to $path: $!");
+ }
my $realpath = getcwd();
- -d $cwd && CORE::chdir($cwd) ||
- croak "Cannot chdir back to $cwd: $!";
+ if (! ((-d $cwd) && (CORE::chdir($cwd)))) {
+ _croak("Cannot chdir back to $cwd: $!");
+ }
$realpath;
}
sub _vms_abs_path {
return $ENV{'DEFAULT'} unless @_;
+
+ # may need to turn foo.dir into [.foo]
my $path = VMS::Filespec::pathify($_[0]);
- croak("Invalid path name $_[0]") unless defined $path;
+ $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'};
}
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) {
$ENV{'PWD'} = `command /c cd`;
- chop $ENV{'PWD'};
+ chomp $ENV{'PWD'};
$ENV{'PWD'} =~ s:\\:/:g ;
} else {
$ENV{'PWD'} = Dos::GetCwd();
local $ENV{CDPATH} = '';
local $ENV{ENV} = '';
$ENV{'PWD'} = `/usr/bin/fullpath -t`;
- chop $ENV{'PWD'};
+ chomp $ENV{'PWD'};
return $ENV{'PWD'};
}
local $ENV{CDPATH} = '';
local $ENV{ENV} = '';
my $path = @_ ? shift : '.';
- my $realpath=`/usr/bin/fullpath -t $path`;
- chop $realpath;
+ local *REALPATH;
+
+ defined( open(REALPATH, '-|') || exec '/usr/bin/fullpath', '-t', $path ) or
+ die "Can't open /usr/bin/fullpath: $!";
+ my $realpath = <REALPATH>;
+ close REALPATH;
+ chomp $realpath;
return $realpath;
}
return $ENV{'PWD'};
}
-{
- no warnings; # assignments trigger 'subroutine redefined' warning
- if ($^O eq 'VMS') {
- *cwd = \&_vms_cwd;
- *getcwd = \&_vms_cwd;
- *fastcwd = \&_vms_cwd;
- *fastgetcwd = \&_vms_cwd;
- *abs_path = \&_vms_abs_path;
- *fast_abs_path = \&_vms_abs_path;
- }
- 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_abs_path;
- *realpath = \&fast_abs_path;
- }
- elsif ($^O eq 'os2') {
- # sys_cwd may keep the builtin command
- *cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
- *getcwd = \&cwd;
- *fastgetcwd = \&cwd;
- *fastcwd = \&cwd;
- *abs_path = \&fast_abs_path;
- }
- elsif ($^O eq 'dos') {
- *cwd = \&_dos_cwd;
- *getcwd = \&_dos_cwd;
- *fastgetcwd = \&_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;
- }
+# 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) {
+ 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;
https://perl5.git.perl.org / perl5.git / blobdiff