lib/Cwd.pm

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