package Cwd;
require 5.000;
-require Exporter;
=head1 NAME
=cut
+## use strict;
+
+use Carp;
+
+$VERSION = '2.00';
+
+require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
-@EXPORT_OK = qw(chdir);
+@EXPORT_OK = qw(chdir abs_path fast_abs_path);
+
-# use strict;
+# The 'natural and safe form' for UNIX (pwd may be setuid root)
-sub _backtick_pwd { # The 'natural and safe form' for UNIX (pwd may be setuid root)
+sub _backtick_pwd {
my $cwd;
chop($cwd = `pwd`);
$cwd;
-}
+}
# Since some ports may predefine cwd internally (e.g., NT)
# we take care not to override an existing definition for cwd().
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;
+}
+
+sub fast_abs_path {
+ my $cwd = getcwd();
+ my $path = shift || '.';
+ chdir($path) || croak "Cannot chdir to $path:$!";
+ my $realpath = getcwd();
+ chdir($cwd) || croak "Cannot chdir back to $cwd:$!";
+ $realpath;
+}
+
# --- PORTING SECTION ---
# VMS: $ENV{'DEFAULT'} points to default directory at all times
# 06-Mar-1996 Charles Bailey bailey@genetics.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
+# 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.
sub _vms_cwd {
- return $ENV{'DEFAULT'}
+ return $ENV{'DEFAULT'};
+}
+
+sub _vms_abs_path {
+ return $ENV{'DEFAULT'} unless @_;
+ my $path = VMS::Filespec::pathify($_[0]);
+ croak("Invalid path name $_[0]") unless defined $path;
+ return VMS::Filespec::rmsexpand($path);
}
sub _os2_cwd {
return $ENV{'PWD'};
}
+sub _win32_cwd {
+ $ENV{'PWD'} = Win32::GetCurrentDirectory();
+ $ENV{'PWD'} =~ s:\\:/:g ;
+ return $ENV{'PWD'};
+}
+
+*_NT_cwd = \&_win32_cwd if (!defined &_NT_cwd &&
+ defined &Win32::GetCurrentDirectory);
+
*_NT_cwd = \&_os2_cwd unless defined &_NT_cwd;
sub _msdos_cwd {
local $^W = 0; # assignments trigger 'subroutine redefined' warning
if ($^O eq 'VMS') {
- *cwd = \&_vms_cwd;
- *getcwd = \&_vms_cwd;
- *fastcwd = \&_vms_cwd;
- *fastgetcwd = \&_vms_cwd;
+ *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;
+ *cwd = \&_NT_cwd;
+ *getcwd = \&_NT_cwd;
+ *fastcwd = \&_NT_cwd;
+ *fastgetcwd = \&_NT_cwd;
+ *abs_path = \&fast_abs_path;
}
elsif ($^O eq 'os2') {
# sys_cwd may keep the builtin command
- *cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
- *getcwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
- *fastgetcwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
- *fastcwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
+ *cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
+ *getcwd = \&cwd;
+ *fastgetcwd = \&cwd;
+ *fastcwd = \&cwd;
+ *abs_path = \&fast_abs_path;
}
elsif ($^O eq 'msdos') {
- *cwd = \&_msdos_cwd;
- *getcwd = \&_msdos_cwd;
- *fastgetcwd = \&_msdos_cwd;
- *fastcwd = \&_msdos_cwd;
+ *cwd = \&_msdos_cwd;
+ *getcwd = \&_msdos_cwd;
+ *fastgetcwd = \&_msdos_cwd;
+ *fastcwd = \&_msdos_cwd;
+ *abs_path = \&fast_abs_path;
}
}