lib/Cwd.pm

   1 package Cwd;
   2 require 5.000;
   3
   4 =head1 NAME
   5
   6 Cwd - get pathname of current working directory
   7
   8 =head1 SYNOPSIS
   9
  10     use Cwd;
  11     $dir = cwd;
  12
  13     use Cwd;
  14     $dir = getcwd;
  15
  16     use Cwd;
  17     $dir = fastcwd;
  18
  19     use Cwd;
  20     $dir = fastgetcwd;
  21
  22     use Cwd 'chdir';
  23     chdir "/tmp";
  24     print $ENV{'PWD'};
  25
  26     use Cwd 'abs_path';     # aka realpath()
  27     print abs_path($ENV{'PWD'});
  28
  29     use Cwd 'fast_abs_path';
  30     print fast_abs_path($ENV{'PWD'});
  31
  32 =head1 DESCRIPTION
  33
  34 This module provides functions for determining the pathname of the
  35 current working directory.  By default, it exports the functions
  36 cwd(), getcwd(), fastcwd(), and fastgetcwd() into the caller's
  37 namespace.  Each of these functions are called without arguments and
  38 return the absolute path of the current working directory.  It is
  39 recommended that cwd (or another *cwd() function) be used in I<all>
  40 code to ensure portability.
  41
  42 The cwd() is the most natural and safe form for the current
  43 architecture. For most systems it is identical to `pwd` (but without
  44 the trailing line terminator).
  45
  46 The getcwd() function re-implements the getcwd(3) (or getwd(3)) functions
  47 in Perl.
  48
  49 The fastcwd() function looks the same as getcwd(), but runs faster.
  50 It's also more dangerous because it might conceivably chdir() you out
  51 of a directory that it can't chdir() you back into.  If fastcwd
  52 encounters a problem it will return undef but will probably leave you
  53 in a different directory.  For a measure of extra security, if
  54 everything appears to have worked, the fastcwd() function will check
  55 that it leaves you in the same directory that it started in. If it has
  56 changed it will C<die> with the message "Unstable directory path,
  57 current directory changed unexpectedly". That should never happen.
  58
  59 The fastgetcwd() function is provided as a synonym for cwd().
  60
  61 The abs_path() function takes a single argument and returns the
  62 absolute pathname for that argument.  It uses the same algorithm as
  63 getcwd().  (Actually, getcwd() is abs_path("."))  Symbolic links and
  64 relative-path components ("." and "..") are resolved to return the
  65 canonical pathname, just like realpath(3).  This function is also
  66 callable as realpath().
  67
  68 The fast_abs_path() function looks the same as abs_path() but runs
  69 faster and, like fastcwd(), is more dangerous.
  70
  71 If you ask to override your chdir() built-in function, then your PWD
  72 environment variable will be kept up to date.  (See
  73 L<perlsub/Overriding Builtin Functions>.) Note that it will only be
  74 kept up to date if all packages which use chdir import it from Cwd.
  75
  76 =cut
  77
  78 use strict;
  79
  80 use Carp;
  81
  82 our $VERSION = '2.04';
  83
  84 use base qw/ Exporter /;
  85 our @EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
  86 our @EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath);
  87
  88
  89 # The 'natural and safe form' for UNIX (pwd may be setuid root)
  90
  91 sub _backtick_pwd {
  92     my $cwd = `pwd`;
  93     # `pwd` may fail e.g. if the disk is full
  94     chomp($cwd) if defined $cwd;
  95     $cwd;
  96 }
  97
  98 # Since some ports may predefine cwd internally (e.g., NT)
  99 # we take care not to override an existing definition for cwd().
 100
 101 unless(defined &cwd) {
 102     # The pwd command is not available in some chroot(2)'ed environments
 103     if($^O eq 'MacOS' || grep { -x "$_/pwd" } split(':', $ENV{PATH})) {
 104         *cwd = \&_backtick_pwd;
 105     }
 106     else {
 107         *cwd = \&getcwd;
 108     }
 109 }
 110
 111 # set a reasonable (and very safe) default for fastgetcwd, in case it
 112 # isn't redefined later (20001212 rspier)
 113 *fastgetcwd = \&cwd;
 114
 115 # By Brandon S. Allbery
 116 #
 117 # Usage: $cwd = getcwd();
 118
 119 sub getcwd
 120 {
 121     abs_path('.');
 122 }
 123
 124 # By John Bazik
 125 #
 126 # Usage: $cwd = &fastcwd;
 127 #
 128 # This is a faster version of getcwd.  It's also more dangerous because
 129 # you might chdir out of a directory that you can't chdir back into.
 130
 131 sub fastcwd {
 132     my($odev, $oino, $cdev, $cino, $tdev, $tino);
 133     my(@path, $path);
 134     local(*DIR);
 135
 136     my($orig_cdev, $orig_cino) = stat('.');
 137     ($cdev, $cino) = ($orig_cdev, $orig_cino);
 138     for (;;) {
 139         my $direntry;
 140         ($odev, $oino) = ($cdev, $cino);
 141         CORE::chdir('..') || return undef;
 142         ($cdev, $cino) = stat('.');
 143         last if $odev == $cdev && $oino == $cino;
 144         opendir(DIR, '.') || return undef;
 145         for (;;) {
 146             $direntry = readdir(DIR);
 147             last unless defined $direntry;
 148             next if $direntry eq '.';
 149             next if $direntry eq '..';
 150
 151             ($tdev, $tino) = lstat($direntry);
 152             last unless $tdev != $odev || $tino != $oino;
 153         }
 154         closedir(DIR);
 155         return undef unless defined $direntry; # should never happen
 156         unshift(@path, $direntry);
 157     }
 158     $path = '/' . join('/', @path);
 159     if ($^O eq 'apollo') { $path = "/".$path; }
 160     # At this point $path may be tainted (if tainting) and chdir would fail.
 161     # To be more useful we untaint it then check that we landed where we started.
 162     $path = $1 if $path =~ /^(.*)\z/s;  # untaint
 163     CORE::chdir($path) || return undef;
 164     ($cdev, $cino) = stat('.');
 165     die "Unstable directory path, current directory changed unexpectedly"
 166         if $cdev != $orig_cdev || $cino != $orig_cino;
 167     $path;
 168 }
 169
 170
 171 # Keeps track of current working directory in PWD environment var
 172 # Usage:
 173 #       use Cwd 'chdir';
 174 #       chdir $newdir;
 175
 176 my $chdir_init = 0;
 177
 178 sub chdir_init {
 179     if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos' and $^O ne 'MSWin32') {
 180         my($dd,$di) = stat('.');
 181         my($pd,$pi) = stat($ENV{'PWD'});
 182         if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
 183             $ENV{'PWD'} = cwd();
 184         }
 185     }
 186     else {
 187         my $wd = cwd();
 188         $wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32';
 189         $ENV{'PWD'} = $wd;
 190     }
 191     # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar)
 192     if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) {
 193         my($pd,$pi) = stat($2);
 194         my($dd,$di) = stat($1);
 195         if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
 196             $ENV{'PWD'}="$2$3";
 197         }
 198     }
 199     $chdir_init = 1;
 200 }
 201
 202 sub chdir {
 203     my $newdir = @_ ? shift : '';       # allow for no arg (chdir to HOME dir)
 204     $newdir =~ s|///*|/|g unless $^O eq 'MSWin32';
 205     chdir_init() unless $chdir_init;
 206     return 0 unless CORE::chdir $newdir;
 207     if ($^O eq 'VMS') {
 208         return $ENV{'PWD'} = $ENV{'DEFAULT'}
 209     }
 210     elsif ($^O eq 'MacOS') {
 211         return $ENV{'PWD'} = cwd();
 212     }
 213     elsif ($^O eq 'MSWin32') {
 214         $ENV{'PWD'} = Win32::GetFullPathName($newdir);
 215         return 1;
 216     }
 217
 218     if ($newdir =~ m#^/#s) {
 219         $ENV{'PWD'} = $newdir;
 220     } else {
 221         my @curdir = split(m#/#,$ENV{'PWD'});
 222         @curdir = ('') unless @curdir;
 223         my $component;
 224         foreach $component (split(m#/#, $newdir)) {
 225             next if $component eq '.';
 226             pop(@curdir),next if $component eq '..';
 227             push(@curdir,$component);
 228         }
 229         $ENV{'PWD'} = join('/',@curdir) || '/';
 230     }
 231     1;
 232 }
 233
 234 # Taken from Cwd.pm It is really getcwd with an optional
 235 # parameter instead of '.'
 236 #
 237
 238 sub abs_path
 239 {
 240     my $start = @_ ? shift : '.';
 241     my($dotdots, $cwd, @pst, @cst, $dir, @tst);
 242
 243     unless (@cst = stat( $start ))
 244     {
 245         carp "stat($start): $!";
 246         return '';
 247     }
 248     $cwd = '';
 249     $dotdots = $start;
 250     do
 251     {
 252         $dotdots .= '/..';
 253         @pst = @cst;
 254         unless (opendir(PARENT, $dotdots))
 255         {
 256             carp "opendir($dotdots): $!";
 257             return '';
 258         }
 259         unless (@cst = stat($dotdots))
 260         {
 261             carp "stat($dotdots): $!";
 262             closedir(PARENT);
 263             return '';
 264         }
 265         if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
 266         {
 267             $dir = undef;
 268         }
 269         else
 270         {
 271             do
 272             {
 273                 unless (defined ($dir = readdir(PARENT)))
 274                 {
 275                     carp "readdir($dotdots): $!";
 276                     closedir(PARENT);
 277                     return '';
 278                 }
 279                 $tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir"))
 280             }
 281             while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
 282                    $tst[1] != $pst[1]);
 283         }
 284         $cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ;
 285         closedir(PARENT);
 286     } while (defined $dir);
 287     chop($cwd) unless $cwd eq '/'; # drop the trailing /
 288     $cwd;
 289 }
 290
 291 # added function alias for those of us more
 292 # used to the libc function.  --tchrist 27-Jan-00
 293 *realpath = \&abs_path;
 294
 295 sub fast_abs_path {
 296     my $cwd = getcwd();
 297     my $path = @_ ? shift : '.';
 298     CORE::chdir($path) || croak "Cannot chdir to $path:$!";
 299     my $realpath = getcwd();
 300     CORE::chdir($cwd)  || croak "Cannot chdir back to $cwd:$!";
 301     $realpath;
 302 }
 303
 304 # added function alias to follow principle of least surprise
 305 # based on previous aliasing.  --tchrist 27-Jan-00
 306 *fast_realpath = \&fast_abs_path;
 307
 308
 309 # --- PORTING SECTION ---
 310
 311 # VMS: $ENV{'DEFAULT'} points to default directory at all times
 312 # 06-Mar-1996  Charles Bailey  bailey@newman.upenn.edu
 313 # Note: Use of Cwd::chdir() causes the logical name PWD to be defined
 314 #   in the process logical name table as the default device and directory
 315 #   seen by Perl. This may not be the same as the default device
 316 #   and directory seen by DCL after Perl exits, since the effects
 317 #   the CRTL chdir() function persist only until Perl exits.
 318
 319 sub _vms_cwd {
 320     return $ENV{'DEFAULT'};
 321 }
 322
 323 sub _vms_abs_path {
 324     return $ENV{'DEFAULT'} unless @_;
 325     my $path = VMS::Filespec::pathify($_[0]);
 326     croak("Invalid path name $_[0]") unless defined $path;
 327     return VMS::Filespec::rmsexpand($path);
 328 }
 329
 330 sub _os2_cwd {
 331     $ENV{'PWD'} = `cmd /c cd`;
 332     chop $ENV{'PWD'};
 333     $ENV{'PWD'} =~ s:\\:/:g ;
 334     return $ENV{'PWD'};
 335 }
 336
 337 sub _win32_cwd {
 338     $ENV{'PWD'} = Win32::GetCwd();
 339     $ENV{'PWD'} =~ s:\\:/:g ;
 340     return $ENV{'PWD'};
 341 }
 342
 343 *_NT_cwd = \&_win32_cwd if (!defined &_NT_cwd &&
 344                             defined &Win32::GetCwd);
 345
 346 *_NT_cwd = \&_os2_cwd unless defined &_NT_cwd;
 347
 348 sub _dos_cwd {
 349     if (!defined &Dos::GetCwd) {
 350         $ENV{'PWD'} = `command /c cd`;
 351         chop $ENV{'PWD'};
 352         $ENV{'PWD'} =~ s:\\:/:g ;
 353     } else {
 354         $ENV{'PWD'} = Dos::GetCwd();
 355     }
 356     return $ENV{'PWD'};
 357 }
 358
 359 sub _qnx_cwd {
 360     $ENV{'PWD'} = `/usr/bin/fullpath -t`;
 361     chop $ENV{'PWD'};
 362     return $ENV{'PWD'};
 363 }
 364
 365 sub _qnx_abs_path {
 366     my $path = @_ ? shift : '.';
 367     my $realpath=`/usr/bin/fullpath -t $path`;
 368     chop $realpath;
 369     return $realpath;
 370 }
 371
 372 sub _epoc_cwd {
 373     $ENV{'PWD'} = EPOC::getcwd();
 374     return $ENV{'PWD'};
 375 }
 376
 377 {
 378     no warnings;        # assignments trigger 'subroutine redefined' warning
 379
 380     if ($^O eq 'VMS') {
 381         *cwd            = \&_vms_cwd;
 382         *getcwd         = \&_vms_cwd;
 383         *fastcwd        = \&_vms_cwd;
 384         *fastgetcwd     = \&_vms_cwd;
 385         *abs_path       = \&_vms_abs_path;
 386         *fast_abs_path  = \&_vms_abs_path;
 387     }
 388     elsif ($^O eq 'NT' or $^O eq 'MSWin32') {
 389         # We assume that &_NT_cwd is defined as an XSUB or in the core.
 390         *cwd            = \&_NT_cwd;
 391         *getcwd         = \&_NT_cwd;
 392         *fastcwd        = \&_NT_cwd;
 393         *fastgetcwd     = \&_NT_cwd;
 394         *abs_path       = \&fast_abs_path;
 395     }
 396     elsif ($^O eq 'os2') {
 397         # sys_cwd may keep the builtin command
 398         *cwd            = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
 399         *getcwd         = \&cwd;
 400         *fastgetcwd     = \&cwd;
 401         *fastcwd        = \&cwd;
 402         *abs_path       = \&fast_abs_path;
 403     }
 404     elsif ($^O eq 'dos') {
 405         *cwd            = \&_dos_cwd;
 406         *getcwd         = \&_dos_cwd;
 407         *fastgetcwd     = \&_dos_cwd;
 408         *fastcwd        = \&_dos_cwd;
 409         *abs_path       = \&fast_abs_path;
 410     }
 411     elsif ($^O eq 'qnx') {
 412         *cwd            = \&_qnx_cwd;
 413         *getcwd         = \&_qnx_cwd;
 414         *fastgetcwd     = \&_qnx_cwd;
 415         *fastcwd        = \&_qnx_cwd;
 416         *abs_path       = \&_qnx_abs_path;
 417         *fast_abs_path  = \&_qnx_abs_path;
 418     }
 419     elsif ($^O eq 'cygwin') {
 420         *getcwd = \&cwd;
 421         *fastgetcwd     = \&cwd;
 422         *fastcwd        = \&cwd;
 423         *abs_path       = \&fast_abs_path;
 424     }
 425     elsif ($^O eq 'epoc') {
 426         *cwd            = \&_epoc_cwd;
 427         *getcwd         = \&_epoc_cwd;
 428         *fastgetcwd     = \&_epoc_cwd;
 429         *fastcwd        = \&_epoc_cwd;
 430         *abs_path       = \&fast_abs_path;
 431     }
 432     elsif ($^O eq 'MacOS') {
 433         *getcwd     = \&cwd;
 434         *fastgetcwd = \&cwd;
 435         *fastcwd    = \&cwd;
 436         *abs_path   = \&fast_abs_path;
 437     }
 438 }
 439
 440 # package main; eval join('',<DATA>) || die $@; # quick test
 441
 442 1;
 443
 444 __END__
 445 BEGIN { import Cwd qw(:DEFAULT chdir); }
 446 print join("\n", cwd, getcwd, fastcwd, "");
 447 chdir('..');
 448 print join("\n", cwd, getcwd, fastcwd, "");
 449 print "$ENV{PWD}\n";