perl/lib/Cwd.pm

package Cwd;

=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 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);

$VERSION = '3.05';

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

# If loading the XS stuff doesn't work, we can fall back to pure perl
eval {
  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}
# 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} &&
                           $^O ne 'MSWin32' &&  # no pwd on Windows
                           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;
}
if (not defined &fastcwd) { *fastcwd = \&fastcwd_ }


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


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 $dir ? abs_path($dir) . "/$file" : "/$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;
}


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);

    # 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);
        }
        
        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: $!");
    }
    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;

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

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