lib/perl5/5.6.1/Cwd.pm

   1 package Cwd;
   2 require 5.6.0;
   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 =head1 NOTES
  77
  78 =over 4
  79
  80 =item *
  81
  82 On Mac OS (Classic), the path separator is ':', not '/', and the
  83 current directory is denoted as ':', not '.'. To move up the directory
  84 tree, you will use '::' to move up one level, but ':::' and so on to
  85 move up the tree two or more levels (i.e. the equivalent to '../../..'
  86 is '::::'). Generally, you should be careful about specifying relative pathnames.
  87 While a full path always begins with a volume name, a relative pathname
  88 should always begin with a ':'.  If specifying a volume name only, a
  89 trailing ':' is required.
  90
  91 Actually, on Mac OS, the C<getcwd()>, C<fastgetcwd()> and C<fastcwd()>
  92 functions  are all aliases for the C<cwd()> function, which, on Mac OS,
  93 calls `pwd`. Likewise, the C<abs_path()> function is an alias for
  94 C<fast_abs_path()>.
  95
  96 =back
  97
  98 =cut
  99
 100 use strict;
 101
 102 use Carp;
 103
 104 our $VERSION = '2.05';
 105
 106 use base qw/ Exporter /;
 107 our @EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
 108 our @EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath);
 109
 110
 111 # The 'natural and safe form' for UNIX (pwd may be setuid root)
 112
 113 sub _backtick_pwd {
 114     my $cwd = `pwd`;
 115     # `pwd` may fail e.g. if the disk is full
 116     chomp($cwd) if defined $cwd;
 117     $cwd;
 118 }
 119
 120 # Since some ports may predefine cwd internally (e.g., NT)
 121 # we take care not to override an existing definition for cwd().
 122
 123 unless(defined &cwd) {
 124     # The pwd command is not available in some chroot(2)'ed environments
 125     if($^O eq 'MacOS' || grep { -x "$_/pwd" } split(':', $ENV{PATH})) {
 126         *cwd = \&_backtick_pwd;
 127     }
 128     else {
 129         *cwd = \&getcwd;
 130     }
 131 }
 132
 133 # set a reasonable (and very safe) default for fastgetcwd, in case it
 134 # isn't redefined later (20001212 rspier)
 135 *fastgetcwd = \&cwd;
 136
 137 # By Brandon S. Allbery
 138 #
 139 # Usage: $cwd = getcwd();
 140
 141 sub getcwd
 142 {
 143     abs_path('.');
 144 }
 145
 146 # By John Bazik
 147 #
 148 # Usage: $cwd = &fastcwd;
 149 #
 150 # This is a faster version of getcwd.  It's also more dangerous because
 151 # you might chdir out of a directory that you can't chdir back into.
 152
 153 sub fastcwd {
 154     my($odev, $oino, $cdev, $cino, $tdev, $tino);
 155     my(@path, $path);
 156     local(*DIR);
 157
 158     my($orig_cdev, $orig_cino) = stat('.');
 159     ($cdev, $cino) = ($orig_cdev, $orig_cino);
 160     for (;;) {
 161         my $direntry;
 162         ($odev, $oino) = ($cdev, $cino);
 163         CORE::chdir('..') || return undef;
 164         ($cdev, $cino) = stat('.');
 165         last if $odev == $cdev && $oino == $cino;
 166         opendir(DIR, '.') || return undef;
 167         for (;;) {
 168             $direntry = readdir(DIR);
 169             last unless defined $direntry;
 170             next if $direntry eq '.';
 171             next if $direntry eq '..';
 172
 173             ($tdev, $tino) = lstat($direntry);
 174             last unless $tdev != $odev || $tino != $oino;
 175         }
 176         closedir(DIR);
 177         return undef unless defined $direntry; # should never happen
 178         unshift(@path, $direntry);
 179     }
 180     $path = '/' . join('/', @path);
 181     if ($^O eq 'apollo') { $path = "/".$path; }
 182     # At this point $path may be tainted (if tainting) and chdir would fail.
 183     # To be more useful we untaint it then check that we landed where we started.
 184     $path = $1 if $path =~ /^(.*)\z/s;  # untaint
 185     CORE::chdir($path) || return undef;
 186     ($cdev, $cino) = stat('.');
 187     die "Unstable directory path, current directory changed unexpectedly"
 188         if $cdev != $orig_cdev || $cino != $orig_cino;
 189     $path;
 190 }
 191
 192
 193 # Keeps track of current working directory in PWD environment var
 194 # Usage:
 195 #       use Cwd 'chdir';
 196 #       chdir $newdir;
 197
 198 my $chdir_init = 0;
 199
 200 sub chdir_init {
 201     if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos' and $^O ne 'MSWin32') {
 202         my($dd,$di) = stat('.');
 203         my($pd,$pi) = stat($ENV{'PWD'});
 204         if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
 205             $ENV{'PWD'} = cwd();
 206         }
 207     }
 208     else {
 209         my $wd = cwd();
 210         $wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32';
 211         $ENV{'PWD'} = $wd;
 212     }
 213     # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar)
 214     if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) {
 215         my($pd,$pi) = stat($2);
 216         my($dd,$di) = stat($1);
 217         if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
 218             $ENV{'PWD'}="$2$3";
 219         }
 220     }
 221     $chdir_init = 1;
 222 }
 223
 224 sub chdir {
 225     my $newdir = @_ ? shift : '';       # allow for no arg (chdir to HOME dir)
 226     $newdir =~ s|///*|/|g unless $^O eq 'MSWin32';
 227     chdir_init() unless $chdir_init;
 228     my $newpwd;
 229     if ($^O eq 'MSWin32') {
 230         # get the full path name *before* the chdir()
 231         $newpwd = Win32::GetFullPathName($newdir);
 232     }
 233
 234     return 0 unless CORE::chdir $newdir;
 235
 236     if ($^O eq 'VMS') {
 237         return $ENV{'PWD'} = $ENV{'DEFAULT'}
 238     }
 239     elsif ($^O eq 'MacOS') {
 240         return $ENV{'PWD'} = cwd();
 241     }
 242     elsif ($^O eq 'MSWin32') {
 243         $ENV{'PWD'} = $newpwd;
 244         return 1;
 245     }
 246
 247     if ($newdir =~ m#^/#s) {
 248         $ENV{'PWD'} = $newdir;
 249     } else {
 250         my @curdir = split(m#/#,$ENV{'PWD'});
 251         @curdir = ('') unless @curdir;
 252         my $component;
 253         foreach $component (split(m#/#, $newdir)) {
 254             next if $component eq '.';
 255             pop(@curdir),next if $component eq '..';
 256             push(@curdir,$component);
 257         }
 258         $ENV{'PWD'} = join('/',@curdir) || '/';
 259     }
 260     1;
 261 }
 262
 263 # Taken from Cwd.pm It is really getcwd with an optional
 264 # parameter instead of '.'
 265 #
 266
 267 sub abs_path
 268 {
 269     my $start = @_ ? shift : '.';
 270     my($dotdots, $cwd, @pst, @cst, $dir, @tst);
 271
 272     unless (@cst = stat( $start ))
 273     {
 274         carp "stat($start): $!";
 275         return '';
 276     }
 277     $cwd = '';
 278     $dotdots = $start;
 279     do
 280     {
 281         $dotdots .= '/..';
 282         @pst = @cst;
 283         unless (opendir(PARENT, $dotdots))
 284         {
 285             carp "opendir($dotdots): $!";
 286             return '';
 287         }
 288         unless (@cst = stat($dotdots))
 289         {
 290             carp "stat($dotdots): $!";
 291             closedir(PARENT);
 292             return '';
 293         }
 294         if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
 295         {
 296             $dir = undef;
 297         }
 298         else
 299         {
 300             do
 301             {
 302                 unless (defined ($dir = readdir(PARENT)))
 303                 {
 304                     carp "readdir($dotdots): $!";
 305                     closedir(PARENT);
 306                     return '';
 307                 }
 308                 $tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir"))
 309             }
 310             while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
 311                    $tst[1] != $pst[1]);
 312         }
 313         $cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ;
 314         closedir(PARENT);
 315     } while (defined $dir);
 316     chop($cwd) unless $cwd eq '/'; # drop the trailing /
 317     $cwd;
 318 }
 319
 320 # added function alias for those of us more
 321 # used to the libc function.  --tchrist 27-Jan-00
 322 *realpath = \&abs_path;
 323
 324 sub fast_abs_path {
 325     my $cwd = getcwd();
 326     require File::Spec;
 327     my $path = @_ ? shift : File::Spec->curdir;
 328     CORE::chdir($path) || croak "Cannot chdir to $path:$!";
 329     my $realpath = getcwd();
 330     CORE::chdir($cwd)  || croak "Cannot chdir back to $cwd:$!";
 331     $realpath;
 332 }
 333
 334 # added function alias to follow principle of least surprise
 335 # based on previous aliasing.  --tchrist 27-Jan-00
 336 *fast_realpath = \&fast_abs_path;
 337
 338
 339 # --- PORTING SECTION ---
 340
 341 # VMS: $ENV{'DEFAULT'} points to default directory at all times
 342 # 06-Mar-1996  Charles Bailey  bailey@newman.upenn.edu
 343 # Note: Use of Cwd::chdir() causes the logical name PWD to be defined
 344 #   in the process logical name table as the default device and directory
 345 #   seen by Perl. This may not be the same as the default device
 346 #   and directory seen by DCL after Perl exits, since the effects
 347 #   the CRTL chdir() function persist only until Perl exits.
 348
 349 sub _vms_cwd {
 350     return $ENV{'DEFAULT'};
 351 }
 352
 353 sub _vms_abs_path {
 354     return $ENV{'DEFAULT'} unless @_;
 355     my $path = VMS::Filespec::pathify($_[0]);
 356     croak("Invalid path name $_[0]") unless defined $path;
 357     return VMS::Filespec::rmsexpand($path);
 358 }
 359
 360 sub _os2_cwd {
 361     $ENV{'PWD'} = `cmd /c cd`;
 362     chop $ENV{'PWD'};
 363     $ENV{'PWD'} =~ s:\\:/:g ;
 364     return $ENV{'PWD'};
 365 }
 366
 367 sub _win32_cwd {
 368     $ENV{'PWD'} = Win32::GetCwd();
 369     $ENV{'PWD'} =~ s:\\:/:g ;
 370     return $ENV{'PWD'};
 371 }
 372
 373 *_NT_cwd = \&_win32_cwd if (!defined &_NT_cwd &&
 374                             defined &Win32::GetCwd);
 375
 376 *_NT_cwd = \&_os2_cwd unless defined &_NT_cwd;
 377
 378 sub _dos_cwd {
 379     if (!defined &Dos::GetCwd) {
 380         $ENV{'PWD'} = `command /c cd`;
 381         chop $ENV{'PWD'};
 382         $ENV{'PWD'} =~ s:\\:/:g ;
 383     } else {
 384         $ENV{'PWD'} = Dos::GetCwd();
 385     }
 386     return $ENV{'PWD'};
 387 }
 388
 389 sub _qnx_cwd {
 390     $ENV{'PWD'} = `/usr/bin/fullpath -t`;
 391     chop $ENV{'PWD'};
 392     return $ENV{'PWD'};
 393 }
 394
 395 sub _qnx_abs_path {
 396     my $path = @_ ? shift : '.';
 397     my $realpath=`/usr/bin/fullpath -t $path`;
 398     chop $realpath;
 399     return $realpath;
 400 }
 401
 402 sub _epoc_cwd {
 403     $ENV{'PWD'} = EPOC::getcwd();
 404     return $ENV{'PWD'};
 405 }
 406
 407 {
 408     no warnings;        # assignments trigger 'subroutine redefined' warning
 409
 410     if ($^O eq 'VMS') {
 411         *cwd            = \&_vms_cwd;
 412         *getcwd         = \&_vms_cwd;
 413         *fastcwd        = \&_vms_cwd;
 414         *fastgetcwd     = \&_vms_cwd;
 415         *abs_path       = \&_vms_abs_path;
 416         *fast_abs_path  = \&_vms_abs_path;
 417     }
 418     elsif ($^O eq 'NT' or $^O eq 'MSWin32') {
 419         # We assume that &_NT_cwd is defined as an XSUB or in the core.
 420         *cwd            = \&_NT_cwd;
 421         *getcwd         = \&_NT_cwd;
 422         *fastcwd        = \&_NT_cwd;
 423         *fastgetcwd     = \&_NT_cwd;
 424         *abs_path       = \&fast_abs_path;
 425     }
 426     elsif ($^O eq 'os2') {
 427         # sys_cwd may keep the builtin command
 428         *cwd            = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
 429         *getcwd         = \&cwd;
 430         *fastgetcwd     = \&cwd;
 431         *fastcwd        = \&cwd;
 432         *abs_path       = \&fast_abs_path;
 433     }
 434     elsif ($^O eq 'dos') {
 435         *cwd            = \&_dos_cwd;
 436         *getcwd         = \&_dos_cwd;
 437         *fastgetcwd     = \&_dos_cwd;
 438         *fastcwd        = \&_dos_cwd;
 439         *abs_path       = \&fast_abs_path;
 440     }
 441     elsif ($^O eq 'qnx') {
 442         *cwd            = \&_qnx_cwd;
 443         *getcwd         = \&_qnx_cwd;
 444         *fastgetcwd     = \&_qnx_cwd;
 445         *fastcwd        = \&_qnx_cwd;
 446         *abs_path       = \&_qnx_abs_path;
 447         *fast_abs_path  = \&_qnx_abs_path;
 448     }
 449     elsif ($^O eq 'msys') {
 450         *getcwd = \&cwd;
 451         *fastgetcwd     = \&cwd;
 452         *fastcwd        = \&cwd;
 453         *abs_path       = \&fast_abs_path;
 454     }
 455     elsif ($^O eq 'cygwin') {
 456         *getcwd = \&cwd;
 457         *fastgetcwd     = \&cwd;
 458         *fastcwd        = \&cwd;
 459         *abs_path       = \&fast_abs_path;
 460     }
 461     elsif ($^O eq 'epoc') {
 462         *cwd            = \&_epoc_cwd;
 463         *getcwd         = \&_epoc_cwd;
 464         *fastgetcwd     = \&_epoc_cwd;
 465         *fastcwd        = \&_epoc_cwd;
 466         *abs_path       = \&fast_abs_path;
 467     }
 468     elsif ($^O eq 'MacOS') {
 469         *getcwd     = \&cwd;
 470         *fastgetcwd = \&cwd;
 471         *fastcwd    = \&cwd;
 472         *abs_path   = \&fast_abs_path;
 473     }
 474 }
 475
 476 # package main; eval join('',<DATA>) || die $@; # quick test
 477
 478 1;
 479
 480 __END__
 481 BEGIN { import Cwd qw(:DEFAULT chdir); }
 482 print join("\n", cwd, getcwd, fastcwd, "");
 483 chdir('..');
 484 print join("\n", cwd, getcwd, fastcwd, "");
 485 print "$ENV{PWD}\n";