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