*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
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>
use strict;
use Exporter;
-use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
+use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
-$VERSION = '2.13';
+$VERSION = '3.04_01';
@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
}
eval {
- require XSLoader;
- local $^W = 0;
- XSLoader::load('Cwd');
+if ( $] >= 5.006 ) {
+ require XSLoader;
+ 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}
# 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} || ':';
+ if( $^O eq 'MacOS' || (defined $ENV{PATH} &&
+ $^O ne 'MSWin32' && # no pwd on Windows
+ grep { -x "$_/pwd" } split($sep, $ENV{PATH})) )
{
*cwd = \&_backtick_pwd;
}
# 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 : '.';
_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
}
-# 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 =~ /(.*)/;
+ 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);
+ }
+
+ my $tdir = $dir;
+ $tdir =~ s!\\!/!g if $^O eq 'MSWin32';
+ return $tdir 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: $!");
}
sub _vms_abs_path {
return $ENV{'DEFAULT'} unless @_;
+
+ # may need to turn foo.dir into [.foo]
my $path = VMS::Filespec::pathify($_[0]);
- if (! defined $path)
- {
- _croak("Invalid path name $_[0]")
- }
+ $path = $_[0] unless defined $path;
+
return VMS::Filespec::rmsexpand($path);
}
my $path = @_ ? shift : '.';
local *REALPATH;
- open(REALPATH, '-|', '/usr/bin/fullpath', '-t', $path) or
+ defined( open(REALPATH, '-|') || exec '/usr/bin/fullpath', '-t', $path ) or
die "Can't open /usr/bin/fullpath: $!";
my $realpath = <REALPATH>;
close 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 '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;
- *realpath = \&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;
+
+# 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