[p5sagit/p5-mst-13.2.git] / lib / Cwd.pm

package Cwd;
$VERSION = $VERSION = '3.01';

=head1 NAME

Cwd - get pathname of current working directory

=head1 SYNOPSIS

    use Cwd;
    my $dir = getcwd;

    use Cwd 'abs_path';
    my $abs_path = abs_path($file);

=head1 DESCRIPTION

This module provides functions for determining the pathname of the
current working directory.  It is recommended that getcwd (or another
*cwd() function) be used in I<all> code to ensure portability.

By default, it exports the functions cwd(), getcwd(), fastcwd(), and
fastgetcwd() (and, on Win32, getdcwd()) into the caller's namespace.  


=head2 getcwd and friends

Each of these functions are called without arguments and return the
absolute path of the current working directory.

=over 4

=item getcwd

    my $cwd = getcwd();

Returns the current working directory.

Re-implements the getcwd(3) (or getwd(3)) functions in Perl.

=item cwd

    my $cwd = cwd();

The cwd() is the most natural form for the current architecture. For
most systems it is identical to `pwd` (but without the trailing line
terminator).

=item fastcwd

    my $cwd = fastcwd();

A more dangerous version of getcwd(), but potentially faster.

It might conceivably chdir() you out of a directory that it can't
chdir() you back into.  If fastcwd encounters a problem it will return
undef but will probably leave you in a different directory.  For a
measure of extra security, if everything appears to have worked, the
fastcwd() function will check that it leaves you in the same directory
that it started in. If it has changed it will C<die> with the message
"Unstable directory path, current directory changed
unexpectedly". That should never happen.

=item fastgetcwd

  my $cwd = fastgetcwd();

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


=head2 abs_path and friends

These functions are exported only on request.  They each take a single
argument and return the absolute pathname for it.  If no argument is
given they'll use the current working directory.

=over 4

=item abs_path

  my $abs_path = abs_path($file);

Uses the same algorithm as getcwd().  Symbolic links and relative-path
components ("." and "..") are resolved to return the canonical
pathname, just like realpath(3).

=item realpath

  my $abs_path = realpath($file);

A synonym for abs_path().

=item fast_abs_path

  my $abs_path = fast_abs_path($file);

A more dangerous, but potentially faster version of abs_path.

=back

=head2 $ENV{PWD}

If you ask to override your chdir() built-in function, 

  use Cwd qw(chdir);

then your PWD environment variable will be kept up to date.  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 *

Since the path seperators are different on some operating systems ('/'
on Unix, ':' on MacPerl, etc...) we recommend you use the File::Spec
modules wherever portability is a concern.

=item *

Actually, on Mac OS, the C<getcwd()>, C<fastgetcwd()> and C<fastcwd()>
functions  are all aliases for the C<cwd()> function, which, on Mac OS,
calls `pwd`. Likewise, the C<abs_path()> function is an alias for
C<fast_abs_path()>.

=back

=head1 AUTHOR

Originally by the perl5-porters.

Maintained by Ken Williams <KWILLIAMS@cpan.org>

=head1 SEE ALSO

L<File::chdir>

=cut

use strict;
use Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK);

@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

# 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') {
    local $^W = 0;

    *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;
}

eval {
    require XSLoader;
    local $^W = 0;
    XSLoader::load('Cwd');
};

# 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 ('/bin/pwd',
		 '/usr/bin/pwd',
		 '/QOpenSys/bin/pwd', # OS/400 PASE.
		) {

    if( -x $try ) {
        $pwd_cmd = $try;
        last;
    }
}
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?
    # 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)};
    my $cwd = `$pwd_cmd`;
    # Belt-and-suspenders in case someone said "undef $/".
    local $/ = "\n";
    # `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().

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} &&
			   grep { -x "$_/pwd" } split($sep, $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
#
# Usage: $cwd = getcwd();

sub 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 {
    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);
	CORE::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);
    if ($^O eq 'apollo') { $path = "/".$path; }
    # At this point $path may be tainted (if tainting) and chdir would fail.
    # Untaint it then check that we landed where we started.
    $path =~ /^(.*)\z/s		# untaint
	&& CORE::chdir($1) or return undef;
    ($cdev, $cino) = stat('.');
    die "Unstable directory path, current directory changed unexpectedly"
	if $cdev != $orig_cdev || $cino != $orig_cino;
    $path;
}


# Keeps track of current working directory in PWD environment var
# Usage:
#	use Cwd 'chdir';
#	chdir $newdir;

my $chdir_init = 0;

sub chdir_init {
    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) {
	    $ENV{'PWD'} = cwd();
	}
    }
    else {
	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 ($^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) {
	    $ENV{'PWD'}="$2$3";
	}
    }
    $chdir_init = 1;
}

sub chdir {
    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'}
    }
    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'});
	@curdir = ('') unless @curdir;
	my $component;
	foreach $component (split(m#/#, $newdir)) {
	    next if $component eq '.';
	    pop(@curdir),next if $component eq '..';
	    push(@curdir,$component);
	}
	$ENV{'PWD'} = join('/',@curdir) || '/';
    }
    1;
}


# In case the XS version doesn't load.
*abs_path = \&_perl_abs_path unless defined &abs_path;
sub _perl_abs_path(;$)
{
    my $start = @_ ? shift : '.';
    my($dotdots, $cwd, @pst, @cst, $dir, @tst);

    unless (@cst = 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 abs_path($dir) . '/' . $file;
    }

    $cwd = '';
    $dotdots = $start;
    do
    {
	$dotdots .= '/..';
	@pst = @cst;
	local *PARENT;
	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 = undef;
	}
	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 = (defined $dir ? "$dir" : "" ) . "/$cwd" ;
	closedir(PARENT);
    } while (defined $dir);
    chop($cwd) unless $cwd eq '/'; # drop the trailing /
    $cwd;
}


# 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 {
    my $cwd = getcwd();
    require File::Spec;
    my $path = @_ ? shift : ($Curdir ||= File::Spec->curdir);

    # Detaint else we'll explode in taint mode.  This is safe because
    # we're not doing anything dangerous with it.
    ($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);
	}
	
	return fast_abs_path(File::Spec->catpath($vol, $dir, '')) . '/' . $file;
    }

    if (!CORE::chdir($path)) {
 	_croak("Cannot chdir to $path: $!");
    }
    my $realpath = getcwd();
    if (! ((-d $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@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
#   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'};
}

sub _vms_abs_path {
    return $ENV{'DEFAULT'} unless @_;

    # may need to turn foo.dir into [.foo]
    my $path = VMS::Filespec::pathify($_[0]);
    $path = $_[0] unless defined $path;

    return VMS::Filespec::rmsexpand($path);
}

sub _os2_cwd {
    $ENV{'PWD'} = `cmd /c cd`;
    chomp $ENV{'PWD'};
    $ENV{'PWD'} =~ s:\\:/:g ;
    return $ENV{'PWD'};
}

sub _win32_cwd {
    $ENV{'PWD'} = Win32::GetCwd();
    $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;

sub _dos_cwd {
    if (!defined &Dos::GetCwd) {
        $ENV{'PWD'} = `command /c cd`;
        chomp $ENV{'PWD'};
        $ENV{'PWD'} =~ s:\\:/:g ;
    } else {
        $ENV{'PWD'} = Dos::GetCwd();
    }
    return $ENV{'PWD'};
}

sub _qnx_cwd {
	local $ENV{PATH} = '';
	local $ENV{CDPATH} = '';
	local $ENV{ENV} = '';
    $ENV{'PWD'} = `/usr/bin/fullpath -t`;
    chomp $ENV{'PWD'};
    return $ENV{'PWD'};
}

sub _qnx_abs_path {
	local $ENV{PATH} = '';
	local $ENV{CDPATH} = '';
	local $ENV{ENV} = '';
    my $path = @_ ? shift : '.';
    local *REALPATH;

    open(REALPATH, '-|', '/usr/bin/fullpath', '-t', $path) or
      die "Can't open /usr/bin/fullpath: $!";
    my $realpath = <REALPATH>;
    close REALPATH;
    chomp $realpath;
    return $realpath;
}

sub _epoc_cwd {
    $ENV{'PWD'} = EPOC::getcwd();
    return $ENV{'PWD'};
}


# 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) {
    no warnings;	# assignments trigger 'subroutine redefined' warning
    no strict 'refs';
    *{$name} = \&{$map->{$name}};
  }
}


1;
Commit	Line	Data
a0d0e21e	1	package Cwd;
21f4e7e5	2	$VERSION = $VERSION = '3.01';
a0d0e21e	3
f06db76b	4	=head1 NAME
f06db76b	5
902bacac	6	Cwd - get pathname of current working directory
f06db76b	7
	8	=head1 SYNOPSIS
	9
4633a7c4	10	use Cwd;
04929354	11	my $dir = getcwd;
4633a7c4	12
04929354	13	use Cwd 'abs_path';
04929354	14	my $abs_path = abs_path($file);
f06db76b	15
04929354	16	=head1 DESCRIPTION
902bacac	17
04929354	18	This module provides functions for determining the pathname of the
	19	current working directory. It is recommended that getcwd (or another
	20	*cwd() function) be used in I<all> code to ensure portability.
f06db76b	21
04929354	22	By default, it exports the functions cwd(), getcwd(), fastcwd(), and
09122b95	23	fastgetcwd() (and, on Win32, getdcwd()) into the caller's namespace.
f06db76b	24
20408e3c	25
04929354	26	=head2 getcwd and friends
20408e3c	27
04929354	28	Each of these functions are called without arguments and return the
04929354	29	absolute path of the current working directory.
f06db76b	30
04929354	31	=over 4
	32
	33	=item getcwd
	34
	35	my $cwd = getcwd();
	36
	37	Returns the current working directory.
	38
	39	Re-implements the getcwd(3) (or getwd(3)) functions in Perl.
	40
	41	=item cwd
	42
	43	my $cwd = cwd();
	44
	45	The cwd() is the most natural form for the current architecture. For
	46	most systems it is identical to `pwd` (but without the trailing line
	47	terminator).
	48
04929354	49	=item fastcwd
	50
	51	my $cwd = fastcwd();
	52
	53	A more dangerous version of getcwd(), but potentially faster.
	54
	55	It might conceivably chdir() you out of a directory that it can't
	56	chdir() you back into. If fastcwd encounters a problem it will return
	57	undef but will probably leave you in a different directory. For a
	58	measure of extra security, if everything appears to have worked, the
	59	fastcwd() function will check that it leaves you in the same directory
	60	that it started in. If it has changed it will C<die> with the message
	61	"Unstable directory path, current directory changed
	62	unexpectedly". That should never happen.
	63
	64	=item fastgetcwd
	65
	66	my $cwd = fastgetcwd();
f06db76b	67
902bacac	68	The fastgetcwd() function is provided as a synonym for cwd().
fb73857a	69
09122b95	70	=item getdcwd
	71
	72	my $cwd = getdcwd();
	73	my $cwd = getdcwd('C:');
	74
	75	The getdcwd() function is also provided on Win32 to get the current working
	76	directory on the specified drive, since Windows maintains a separate current
	77	working directory for each drive. If no drive is specified then the current
	78	drive is assumed.
	79
	80	This function simply calls the Microsoft C library _getdcwd() function.
	81
04929354	82	=back
04929354	83
902bacac	84
04929354	85	=head2 abs_path and friends
	86
	87	These functions are exported only on request. They each take a single
3ee63918	88	argument and return the absolute pathname for it. If no argument is
3ee63918	89	given they'll use the current working directory.
04929354	90
	91	=over 4
	92
	93	=item abs_path
	94
	95	my $abs_path = abs_path($file);
	96
	97	Uses the same algorithm as getcwd(). Symbolic links and relative-path
	98	components ("." and "..") are resolved to return the canonical
	99	pathname, just like realpath(3).
	100
	101	=item realpath
	102
	103	my $abs_path = realpath($file);
	104
	105	A synonym for abs_path().
	106
	107	=item fast_abs_path
	108
510179aa	109	my $abs_path = fast_abs_path($file);
04929354	110
	111	A more dangerous, but potentially faster version of abs_path.
	112
	113	=back
	114
	115	=head2 $ENV{PWD}
	116
	117	If you ask to override your chdir() built-in function,
	118
	119	use Cwd qw(chdir);
	120
	121	then your PWD environment variable will be kept up to date. Note that
	122	it will only be kept up to date if all packages which use chdir import
	123	it from Cwd.
4633a7c4	124
4633a7c4	125
4d6b4052	126	=head1 NOTES
	127
	128	=over 4
	129
	130	=item *
	131
04929354	132	Since the path seperators are different on some operating systems ('/'
	133	on Unix, ':' on MacPerl, etc...) we recommend you use the File::Spec
	134	modules wherever portability is a concern.
	135
04929354	136	=item *
4d6b4052	137
	138	Actually, on Mac OS, the C<getcwd()>, C<fastgetcwd()> and C<fastcwd()>
	139	functions are all aliases for the C<cwd()> function, which, on Mac OS,
	140	calls `pwd`. Likewise, the C<abs_path()> function is an alias for
	141	C<fast_abs_path()>.
	142
	143	=back
	144
02cc4877	145	=head1 AUTHOR
	146
	147	Originally by the perl5-porters.
	148
78321866	149	Maintained by Ken Williams <KWILLIAMS@cpan.org>
02cc4877	150
04929354	151	=head1 SEE ALSO
	152
	153	L<File::chdir>
	154
f06db76b	155	=cut
f06db76b	156
b060a406	157	use strict;
a9939470	158	use Exporter;
ad78113d	159	use vars qw(@ISA @EXPORT @EXPORT_OK);
96e4d5b1	160
a9939470	161	@ISA = qw/ Exporter /;
a9939470	162	@EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
09122b95	163	push @EXPORT, qw(getdcwd) if $^O eq 'MSWin32';
a9939470	164	@EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath);
a0d0e21e	165
f5f423e4	166	# sys_cwd may keep the builtin command
	167
	168	# All the functionality of this module may provided by builtins,
	169	# there is no sense to process the rest of the file.
	170	# The best choice may be to have this in BEGIN, but how to return from BEGIN?
	171
a9939470	172	if ($^O eq 'os2') {
f5f423e4	173	local $^W = 0;
a9939470	174
	175	*cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
	176	*getcwd = \&cwd;
	177	*fastgetcwd = \&cwd;
	178	*fastcwd = \&cwd;
	179
	180	*fast_abs_path = \&sys_abspath if defined &sys_abspath;
	181	*abs_path = \&fast_abs_path;
	182	*realpath = \&fast_abs_path;
	183	*fast_realpath = \&fast_abs_path;
	184
f5f423e4	185	return 1;
	186	}
	187
f22d8e4b	188	eval {
f22d8e4b	189	require XSLoader;
46ba3155	190	local $^W = 0;
f22d8e4b	191	XSLoader::load('Cwd');
f22d8e4b	192	};
4633a7c4	193
09122b95	194	# Big nasty table of function aliases
	195	my %METHOD_MAP =
	196	(
	197	VMS =>
	198	{
	199	cwd => '_vms_cwd',
	200	getcwd => '_vms_cwd',
	201	fastcwd => '_vms_cwd',
	202	fastgetcwd => '_vms_cwd',
	203	abs_path => '_vms_abs_path',
	204	fast_abs_path => '_vms_abs_path',
	205	},
	206
	207	MSWin32 =>
	208	{
	209	# We assume that &_NT_cwd is defined as an XSUB or in the core.
	210	cwd => '_NT_cwd',
	211	getcwd => '_NT_cwd',
	212	fastcwd => '_NT_cwd',
	213	fastgetcwd => '_NT_cwd',
	214	abs_path => 'fast_abs_path',
	215	realpath => 'fast_abs_path',
	216	},
	217
	218	dos =>
	219	{
	220	cwd => '_dos_cwd',
	221	getcwd => '_dos_cwd',
	222	fastgetcwd => '_dos_cwd',
	223	fastcwd => '_dos_cwd',
	224	abs_path => 'fast_abs_path',
	225	},
	226
	227	qnx =>
	228	{
	229	cwd => '_qnx_cwd',
	230	getcwd => '_qnx_cwd',
	231	fastgetcwd => '_qnx_cwd',
	232	fastcwd => '_qnx_cwd',
	233	abs_path => '_qnx_abs_path',
	234	fast_abs_path => '_qnx_abs_path',
	235	},
	236
	237	cygwin =>
	238	{
	239	getcwd => 'cwd',
	240	fastgetcwd => 'cwd',
	241	fastcwd => 'cwd',
	242	abs_path => 'fast_abs_path',
	243	realpath => 'fast_abs_path',
	244	},
	245
	246	epoc =>
	247	{
	248	cwd => '_epoc_cwd',
	249	getcwd => '_epoc_cwd',
	250	fastgetcwd => '_epoc_cwd',
	251	fastcwd => '_epoc_cwd',
	252	abs_path => 'fast_abs_path',
	253	},
	254
	255	MacOS =>
	256	{
	257	getcwd => 'cwd',
258	fastgetcwd => 'cwd',
259	fastcwd => 'cwd',
260	abs_path => 'fast_abs_path',
261	},
262	);
263
264	$METHOD_MAP{NT} = $METHOD_MAP{MSWin32};
265	$METHOD_MAP{nto} = $METHOD_MAP{qnx};
266
96e4d5b1	267
3547aa9a	268	# Find the pwd command in the expected locations. We assume these
	269	# are safe. This prevents _backtick_pwd() consulting $ENV{PATH}
	270	# so everything works under taint mode.
	271	my $pwd_cmd;
889f7a4f	272	foreach my $try ('/bin/pwd',
	273	'/usr/bin/pwd',
	274	'/QOpenSys/bin/pwd', # OS/400 PASE.
	275	) {
	276
3547aa9a	277	if( -x $try ) {
	278	$pwd_cmd = $try;
	279	last;
	280	}
	281	}
522b859a	282	unless ($pwd_cmd) {
889f7a4f	283	# Isn't this wrong? _backtick_pwd() will fail if somenone has
	284	# pwd in their path but it is not /bin/pwd or /usr/bin/pwd?
	285	# See [perl #16774]. --jhi
	286	$pwd_cmd = 'pwd';
522b859a	287	}
3547aa9a	288
a9939470	289	# Lazy-load Carp
	290	sub _carp { require Carp; Carp::carp(@_) }
	291	sub _croak { require Carp; Carp::croak(@_) }
	292
3547aa9a	293	# The 'natural and safe form' for UNIX (pwd may be setuid root)
8b88ae92	294	sub _backtick_pwd {
db281859	295	local @ENV{qw(PATH IFS CDPATH ENV BASH_ENV)};
3547aa9a	296	my $cwd = `$pwd_cmd`;
ac3b20cb	297	# Belt-and-suspenders in case someone said "undef $/".
5cf6da5f	298	local $/ = "\n";
ac3b20cb	299	# `pwd` may fail e.g. if the disk is full
7e03f963	300	chomp($cwd) if defined $cwd;
4633a7c4	301	$cwd;
8b88ae92	302	}
4633a7c4	303
	304	# Since some ports may predefine cwd internally (e.g., NT)
	305	# we take care not to override an existing definition for cwd().
	306
09122b95	307	unless ($METHOD_MAP{$^O}{cwd} or defined &cwd) {
ea54c8bd	308	# The pwd command is not available in some chroot(2)'ed environments
09122b95	309	my $sep = $Config::Config{path_sep} \|\| ':';
	310	if( $^O eq 'MacOS' \|\| (defined $ENV{PATH} &&
	311	grep { -x "$_/pwd" } split($sep, $ENV{PATH})) )
73b801a6	312	{
ea54c8bd	313	*cwd = \&_backtick_pwd;
	314	}
	315	else {
	316	*cwd = \&getcwd;
	317	}
	318	}
a0d0e21e	319
1f4f94f5	320	# set a reasonable (and very safe) default for fastgetcwd, in case it
	321	# isn't redefined later (20001212 rspier)
	322	*fastgetcwd = \&cwd;
748a9306	323
a0d0e21e	324	# By Brandon S. Allbery
	325	#
	326	# Usage: $cwd = getcwd();
	327
	328	sub getcwd
	329	{
07569ed3	330	abs_path('.');
a0d0e21e	331	}
a0d0e21e	332
a0c9c202	333
	334	# By John Bazik
	335	#
	336	# Usage: $cwd = &fastcwd;
	337	#
	338	# This is a faster version of getcwd. It's also more dangerous because
	339	# you might chdir out of a directory that you can't chdir back into.
	340
	341	sub fastcwd {
	342	my($odev, $oino, $cdev, $cino, $tdev, $tino);
	343	my(@path, $path);
	344	local(*DIR);
	345
	346	my($orig_cdev, $orig_cino) = stat('.');
	347	($cdev, $cino) = ($orig_cdev, $orig_cino);
	348	for (;;) {
	349	my $direntry;
	350	($odev, $oino) = ($cdev, $cino);
	351	CORE::chdir('..') \|\| return undef;
	352	($cdev, $cino) = stat('.');
	353	last if $odev == $cdev && $oino == $cino;
	354	opendir(DIR, '.') \|\| return undef;
	355	for (;;) {
	356	$direntry = readdir(DIR);
	357	last unless defined $direntry;
	358	next if $direntry eq '.';
	359	next if $direntry eq '..';
	360
	361	($tdev, $tino) = lstat($direntry);
	362	last unless $tdev != $odev \|\| $tino != $oino;
	363	}
	364	closedir(DIR);
	365	return undef unless defined $direntry; # should never happen
	366	unshift(@path, $direntry);
	367	}
	368	$path = '/' . join('/', @path);
	369	if ($^O eq 'apollo') { $path = "/".$path; }
	370	# At this point $path may be tainted (if tainting) and chdir would fail.
248785eb	371	# Untaint it then check that we landed where we started.
	372	$path =~ /^(.*)\z/s # untaint
	373	&& CORE::chdir($1) or return undef;
a0c9c202	374	($cdev, $cino) = stat('.');
	375	die "Unstable directory path, current directory changed unexpectedly"
	376	if $cdev != $orig_cdev \|\| $cino != $orig_cino;
	377	$path;
	378	}
	379
	380
4633a7c4	381	# Keeps track of current working directory in PWD environment var
a0d0e21e	382	# Usage:
	383	# use Cwd 'chdir';
	384	# chdir $newdir;
	385
4633a7c4	386	my $chdir_init = 0;
a0d0e21e	387
4633a7c4	388	sub chdir_init {
3b8e3443	389	if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos' and $^O ne 'MSWin32') {
a0d0e21e	390	my($dd,$di) = stat('.');
	391	my($pd,$pi) = stat($ENV{'PWD'});
	392	if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
4633a7c4	393	$ENV{'PWD'} = cwd();
a0d0e21e	394	}
	395	}
	396	else {
3b8e3443	397	my $wd = cwd();
	398	$wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32';
	399	$ENV{'PWD'} = $wd;
a0d0e21e	400	}
4633a7c4	401	# Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar)
3b8e3443	402	if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m\|(/[^/]+(/[^/]+/[^/]+))(.*)\|s) {
a0d0e21e	403	my($pd,$pi) = stat($2);
	404	my($dd,$di) = stat($1);
	405	if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
	406	$ENV{'PWD'}="$2$3";
	407	}
	408	}
	409	$chdir_init = 1;
	410	}
	411
	412	sub chdir {
22978713	413	my $newdir = @_ ? shift : ''; # allow for no arg (chdir to HOME dir)
3b8e3443	414	$newdir =~ s\|///*\|/\|g unless $^O eq 'MSWin32';
a0d0e21e	415	chdir_init() unless $chdir_init;
4ffa1610	416	my $newpwd;
	417	if ($^O eq 'MSWin32') {
	418	# get the full path name before the chdir()
	419	$newpwd = Win32::GetFullPathName($newdir);
	420	}
	421
4633a7c4	422	return 0 unless CORE::chdir $newdir;
4ffa1610	423
3b8e3443	424	if ($^O eq 'VMS') {
	425	return $ENV{'PWD'} = $ENV{'DEFAULT'}
	426	}
4aecb5b5	427	elsif ($^O eq 'MacOS') {
	428	return $ENV{'PWD'} = cwd();
	429	}
3b8e3443	430	elsif ($^O eq 'MSWin32') {
4ffa1610	431	$ENV{'PWD'} = $newpwd;
3b8e3443	432	return 1;
3b8e3443	433	}
748a9306	434
392d8ab8	435	if ($newdir =~ m#^/#s) {
a0d0e21e	436	$ENV{'PWD'} = $newdir;
4633a7c4	437	} else {
	438	my @curdir = split(m#/#,$ENV{'PWD'});
	439	@curdir = ('') unless @curdir;
	440	my $component;
a0d0e21e	441	foreach $component (split(m#/#, $newdir)) {
	442	next if $component eq '.';
	443	pop(@curdir),next if $component eq '..';
	444	push(@curdir,$component);
	445	}
	446	$ENV{'PWD'} = join('/',@curdir) \|\| '/';
	447	}
4633a7c4	448	1;
a0d0e21e	449	}
a0d0e21e	450
a0c9c202	451
	452	# In case the XS version doesn't load.
	453	*abs_path = \&_perl_abs_path unless defined &abs_path;
09122b95	454	sub _perl_abs_path(;$)
a0c9c202	455	{
	456	my $start = @_ ? shift : '.';
	457	my($dotdots, $cwd, @pst, @cst, $dir, @tst);
	458
	459	unless (@cst = stat( $start ))
	460	{
a9939470	461	_carp("stat($start): $!");
a0c9c202	462	return '';
a0c9c202	463	}
09122b95	464
	465	unless (-d _) {
	466	# Make sure we can be invoked on plain files, not just directories.
	467	# NOTE that this routine assumes that '/' is the only directory separator.
	468
	469	my ($dir, $file) = $start =~ m{^(.*)/(.+)$}
	470	or return cwd() . '/' . $start;
	471
275e8705	472	# Can't use "-l _" here, because the previous stat was a stat(), not an lstat().
275e8705	473	if (-l $start) {
09122b95	474	my $link_target = readlink($start);
	475	die "Can't resolve link $start: $!" unless defined $link_target;
	476
	477	require File::Spec;
	478	$link_target = $dir . '/' . $link_target
	479	unless File::Spec->file_name_is_absolute($link_target);
	480
	481	return abs_path($link_target);
	482	}
	483
	484	return abs_path($dir) . '/' . $file;
	485	}
	486
a0c9c202	487	$cwd = '';
	488	$dotdots = $start;
	489	do
	490	{
	491	$dotdots .= '/..';
	492	@pst = @cst;
a25ef67d	493	local *PARENT;
a0c9c202	494	unless (opendir(PARENT, $dotdots))
a0c9c202	495	{
a9939470	496	_carp("opendir($dotdots): $!");
a0c9c202	497	return '';
	498	}
	499	unless (@cst = stat($dotdots))
	500	{
a9939470	501	_carp("stat($dotdots): $!");
a0c9c202	502	closedir(PARENT);
	503	return '';
	504	}
	505	if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
	506	{
	507	$dir = undef;
	508	}
	509	else
	510	{
	511	do
	512	{
	513	unless (defined ($dir = readdir(PARENT)))
	514	{
a9939470	515	_carp("readdir($dotdots): $!");
a0c9c202	516	closedir(PARENT);
	517	return '';
	518	}
	519	$tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir"))
	520	}
	521	while ($dir eq '.' \|\| $dir eq '..' \|\| $tst[0] != $pst[0] \|\|
	522	$tst[1] != $pst[1]);
	523	}
	524	$cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ;
	525	closedir(PARENT);
	526	} while (defined $dir);
	527	chop($cwd) unless $cwd eq '/'; # drop the trailing /
	528	$cwd;
	529	}
	530
	531
e4c51978	532	# added function alias for those of us more
	533	# used to the libc function. --tchrist 27-Jan-00
	534	*realpath = \&abs_path;
	535
3ee63918	536	my $Curdir;
96e4d5b1	537	sub fast_abs_path {
96e4d5b1	538	my $cwd = getcwd();
4d6b4052	539	require File::Spec;
3ee63918	540	my $path = @_ ? shift : ($Curdir \|\|= File::Spec->curdir);
	541
	542	# Detaint else we'll explode in taint mode. This is safe because
	543	# we're not doing anything dangerous with it.
	544	($path) = $path =~ /(.*)/;
	545	($cwd) = $cwd =~ /(.*)/;
	546
09122b95	547	unless (-e $path) {
	548	_croak("$path: No such file or directory");
	549	}
	550
	551	unless (-d _) {
	552	# Make sure we can be invoked on plain files, not just directories.
	553
	554	my ($vol, $dir, $file) = File::Spec->splitpath($path);
	555	return File::Spec->catfile($cwd, $path) unless length $dir;
	556
	557	if (-l $path) {
	558	my $link_target = readlink($path);
	559	die "Can't resolve link $path: $!" unless defined $link_target;
	560
	561	$link_target = File::Spec->catpath($vol, $dir, $link_target)
	562	unless File::Spec->file_name_is_absolute($link_target);
	563
	564	return fast_abs_path($link_target);
	565	}
	566
	567	return fast_abs_path(File::Spec->catpath($vol, $dir, '')) . '/' . $file;
	568	}
	569
e2ba406b	570	if (!CORE::chdir($path)) {
a9939470	571	_croak("Cannot chdir to $path: $!");
e2ba406b	572	}
96e4d5b1	573	my $realpath = getcwd();
e2ba406b	574	if (! ((-d $cwd) && (CORE::chdir($cwd)))) {
a9939470	575	_croak("Cannot chdir back to $cwd: $!");
e2ba406b	576	}
96e4d5b1	577	$realpath;
8b88ae92	578	}
8b88ae92	579
e4c51978	580	# added function alias to follow principle of least surprise
	581	# based on previous aliasing. --tchrist 27-Jan-00
	582	*fast_realpath = \&fast_abs_path;
	583
4633a7c4	584
	585	# --- PORTING SECTION ---
	586
	587	# VMS: $ENV{'DEFAULT'} points to default directory at all times
bd3fa61c	588	# 06-Mar-1996 Charles Bailey bailey@newman.upenn.edu
c6538b72	589	# Note: Use of Cwd::chdir() causes the logical name PWD to be defined
8b88ae92	590	# in the process logical name table as the default device and directory
8b88ae92	591	# seen by Perl. This may not be the same as the default device
4633a7c4	592	# and directory seen by DCL after Perl exits, since the effects
4633a7c4	593	# the CRTL chdir() function persist only until Perl exits.
4633a7c4	594
4633a7c4	595	sub _vms_cwd {
96e4d5b1	596	return $ENV{'DEFAULT'};
	597	}
	598
	599	sub _vms_abs_path {
	600	return $ENV{'DEFAULT'} unless @_;
9d7d9729	601
9d7d9729	602	# may need to turn foo.dir into [.foo]
96e4d5b1	603	my $path = VMS::Filespec::pathify($_[0]);
9d7d9729	604	$path = $_[0] unless defined $path;
9d7d9729	605
96e4d5b1	606	return VMS::Filespec::rmsexpand($path);
4633a7c4	607	}
68dc0745	608
4633a7c4	609	sub _os2_cwd {
4633a7c4	610	$ENV{'PWD'} = `cmd /c cd`;
39741d73	611	chomp $ENV{'PWD'};
aa6b7957	612	$ENV{'PWD'} =~ s:\\:/:g ;
4633a7c4	613	return $ENV{'PWD'};
	614	}
	615
96e4d5b1	616	sub _win32_cwd {
2d7a9237	617	$ENV{'PWD'} = Win32::GetCwd();
aa6b7957	618	$ENV{'PWD'} =~ s:\\:/:g ;
96e4d5b1	619	return $ENV{'PWD'};
	620	}
	621
	622	*_NT_cwd = \&_win32_cwd if (!defined &_NT_cwd &&
2d7a9237	623	defined &Win32::GetCwd);
96e4d5b1	624
96e4d5b1	625	*_NT_cwd = \&_os2_cwd unless defined &_NT_cwd;
68dc0745	626
39e571d4	627	sub _dos_cwd {
	628	if (!defined &Dos::GetCwd) {
	629	$ENV{'PWD'} = `command /c cd`;
39741d73	630	chomp $ENV{'PWD'};
aa6b7957	631	$ENV{'PWD'} =~ s:\\:/:g ;
39e571d4	632	} else {
	633	$ENV{'PWD'} = Dos::GetCwd();
	634	}
55497cff	635	return $ENV{'PWD'};
	636	}
	637
7fbf1995	638	sub _qnx_cwd {
35b807ef	639	local $ENV{PATH} = '';
	640	local $ENV{CDPATH} = '';
	641	local $ENV{ENV} = '';
7fbf1995	642	$ENV{'PWD'} = `/usr/bin/fullpath -t`;
39741d73	643	chomp $ENV{'PWD'};
7fbf1995	644	return $ENV{'PWD'};
	645	}
	646
	647	sub _qnx_abs_path {
35b807ef	648	local $ENV{PATH} = '';
	649	local $ENV{CDPATH} = '';
	650	local $ENV{ENV} = '';
fa921dc6	651	my $path = @_ ? shift : '.';
39741d73	652	local *REALPATH;
	653
	654	open(REALPATH, '-\|', '/usr/bin/fullpath', '-t', $path) or
	655	die "Can't open /usr/bin/fullpath: $!";
	656	my $realpath = <REALPATH>;
	657	close REALPATH;
	658	chomp $realpath;
7fbf1995	659	return $realpath;
	660	}
	661
ed79a026	662	sub _epoc_cwd {
	663	$ENV{'PWD'} = EPOC::getcwd();
	664	return $ENV{'PWD'};
	665	}
	666
4633a7c4	667
09122b95	668	# Now that all the base-level functions are set up, alias the
	669	# user-level functions to the right places
	670
	671	if (exists $METHOD_MAP{$^O}) {
	672	my $map = $METHOD_MAP{$^O};
	673	foreach my $name (keys %$map) {
	674	no warnings; # assignments trigger 'subroutine redefined' warning
	675	no strict 'refs';
	676	*{$name} = \&{$map->{$name}};
	677	}
55497cff	678	}
4633a7c4	679
4633a7c4	680
a0d0e21e	681	1;