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.01';
  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     abs_path('.');
  86 }
  87
  88 # By John Bazik
  89 #
  90 # Usage: $cwd = &fastcwd;
  91 #
  92 # This is a faster version of getcwd.  It's also more dangerous because
  93 # you might chdir out of a directory that you can't chdir back into.
  94
  95 # List of metachars taken from do_exec() in doio.c
  96 my $quoted_shell_meta = quotemeta('$&*(){}[]";\\|?<>~`'."'\n");
  97
  98 sub fastcwd {
  99     my($odev, $oino, $cdev, $cino, $tdev, $tino);
 100     my(@path, $path);
 101     local(*DIR);
 102
 103     my($orig_cdev, $orig_cino) = stat('.');
 104     ($cdev, $cino) = ($orig_cdev, $orig_cino);
 105     for (;;) {
 106         my $direntry;
 107         ($odev, $oino) = ($cdev, $cino);
 108         chdir('..') || return undef;
 109         ($cdev, $cino) = stat('.');
 110         last if $odev == $cdev && $oino == $cino;
 111         opendir(DIR, '.') || return undef;
 112         for (;;) {
 113             $direntry = readdir(DIR);
 114             last unless defined $direntry;
 115             next if $direntry eq '.';
 116             next if $direntry eq '..';
 117
 118             ($tdev, $tino) = lstat($direntry);
 119             last unless $tdev != $odev || $tino != $oino;
 120         }
 121         closedir(DIR);
 122         return undef unless defined $direntry; # should never happen
 123         unshift(@path, $direntry);
 124     }
 125     $path = '/' . join('/', @path);
 126     # At this point $path may be tainted (if tainting) and chdir would fail.
 127     # To be more useful we untaint it then check that we landed where we started.
 128     $path = $1 if $path =~ /^(.*)$/;    # untaint
 129     chdir($path) || return undef;
 130     ($cdev, $cino) = stat('.');
 131     die "Unstable directory path, current directory changed unexpectedly"
 132         if $cdev != $orig_cdev || $cino != $orig_cino;
 133     $path;
 134 }
 135
 136
 137 # Keeps track of current working directory in PWD environment var
 138 # Usage:
 139 #       use Cwd 'chdir';
 140 #       chdir $newdir;
 141
 142 my $chdir_init = 0;
 143
 144 sub chdir_init {
 145     if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos') {
 146         my($dd,$di) = stat('.');
 147         my($pd,$pi) = stat($ENV{'PWD'});
 148         if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
 149             $ENV{'PWD'} = cwd();
 150         }
 151     }
 152     else {
 153         $ENV{'PWD'} = cwd();
 154     }
 155     # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar)
 156     if ($ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|) {
 157         my($pd,$pi) = stat($2);
 158         my($dd,$di) = stat($1);
 159         if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
 160             $ENV{'PWD'}="$2$3";
 161         }
 162     }
 163     $chdir_init = 1;
 164 }
 165
 166 sub chdir {
 167     my $newdir = shift || '';   # allow for no arg (chdir to HOME dir)
 168     $newdir =~ s|///*|/|g;
 169     chdir_init() unless $chdir_init;
 170     return 0 unless CORE::chdir $newdir;
 171     if ($^O eq 'VMS') { return $ENV{'PWD'} = $ENV{'DEFAULT'} }
 172
 173     if ($newdir =~ m#^/#) {
 174         $ENV{'PWD'} = $newdir;
 175     } else {
 176         my @curdir = split(m#/#,$ENV{'PWD'});
 177         @curdir = ('') unless @curdir;
 178         my $component;
 179         foreach $component (split(m#/#, $newdir)) {
 180             next if $component eq '.';
 181             pop(@curdir),next if $component eq '..';
 182             push(@curdir,$component);
 183         }
 184         $ENV{'PWD'} = join('/',@curdir) || '/';
 185     }
 186     1;
 187 }
 188
 189 # Taken from Cwd.pm It is really getcwd with an optional
 190 # parameter instead of '.'
 191 #
 192
 193 sub abs_path
 194 {
 195     my $start = @_ ? shift : '.';
 196     my($dotdots, $cwd, @pst, @cst, $dir, @tst);
 197
 198     unless (@cst = stat( $start ))
 199     {
 200         carp "stat($start): $!";
 201         return '';
 202     }
 203     $cwd = '';
 204     $dotdots = $start;
 205     do
 206     {
 207         $dotdots .= '/..';
 208         @pst = @cst;
 209         unless (opendir(PARENT, $dotdots))
 210         {
 211             carp "opendir($dotdots): $!";
 212             return '';
 213         }
 214         unless (@cst = stat($dotdots))
 215         {
 216             carp "stat($dotdots): $!";
 217             closedir(PARENT);
 218             return '';
 219         }
 220         if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
 221         {
 222             $dir = undef;
 223         }
 224         else
 225         {
 226             do
 227             {
 228                 unless (defined ($dir = readdir(PARENT)))
 229                 {
 230                     carp "readdir($dotdots): $!";
 231                     closedir(PARENT);
 232                     return '';
 233                 }
 234                 $tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir"))
 235             }
 236             while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
 237                    $tst[1] != $pst[1]);
 238         }
 239         $cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ;
 240         closedir(PARENT);
 241     } while (defined $dir);
 242     chop($cwd) unless $cwd eq '/'; # drop the trailing /
 243     $cwd;
 244 }
 245
 246 sub fast_abs_path {
 247     my $cwd = getcwd();
 248     my $path = shift || '.';
 249     chdir($path) || croak "Cannot chdir to $path:$!";
 250     my $realpath = getcwd();
 251     chdir($cwd)  || croak "Cannot chdir back to $cwd:$!";
 252     $realpath;
 253 }
 254
 255
 256 # --- PORTING SECTION ---
 257
 258 # VMS: $ENV{'DEFAULT'} points to default directory at all times
 259 # 06-Mar-1996  Charles Bailey  bailey@genetics.upenn.edu
 260 # Note: Use of Cwd::chdir() causes the logical name PWD to be defined
 261 #   in the process logical name table as the default device and directory
 262 #   seen by Perl. This may not be the same as the default device
 263 #   and directory seen by DCL after Perl exits, since the effects
 264 #   the CRTL chdir() function persist only until Perl exits.
 265
 266 sub _vms_cwd {
 267     return $ENV{'DEFAULT'};
 268 }
 269
 270 sub _vms_abs_path {
 271     return $ENV{'DEFAULT'} unless @_;
 272     my $path = VMS::Filespec::pathify($_[0]);
 273     croak("Invalid path name $_[0]") unless defined $path;
 274     return VMS::Filespec::rmsexpand($path);
 275 }
 276
 277 sub _os2_cwd {
 278     $ENV{'PWD'} = `cmd /c cd`;
 279     chop $ENV{'PWD'};
 280     $ENV{'PWD'} =~ s:\\:/:g ;
 281     return $ENV{'PWD'};
 282 }
 283
 284 sub _win32_cwd {
 285     $ENV{'PWD'} = Win32::GetCwd();
 286     $ENV{'PWD'} =~ s:\\:/:g ;
 287     return $ENV{'PWD'};
 288 }
 289
 290 *_NT_cwd = \&_win32_cwd if (!defined &_NT_cwd &&
 291                             defined &Win32::GetCwd);
 292
 293 *_NT_cwd = \&_os2_cwd unless defined &_NT_cwd;
 294
 295 sub _dos_cwd {
 296     if (!defined &Dos::GetCwd) {
 297         $ENV{'PWD'} = `command /c cd`;
 298         chop $ENV{'PWD'};
 299         $ENV{'PWD'} =~ s:\\:/:g ;
 300     } else {
 301         $ENV{'PWD'} = Dos::GetCwd();
 302     }
 303     return $ENV{'PWD'};
 304 }
 305
 306 sub _qnx_cwd {
 307     $ENV{'PWD'} = `/usr/bin/fullpath -t`;
 308     chop $ENV{'PWD'};
 309     return $ENV{'PWD'};
 310 }
 311
 312 sub _qnx_abs_path {
 313     my $path = shift || '.';
 314     my $realpath=`/usr/bin/fullpath -t $path`;
 315     chop $realpath;
 316     return $realpath;
 317 }
 318
 319 {
 320     local $^W = 0;      # assignments trigger 'subroutine redefined' warning
 321
 322     if ($^O eq 'VMS') {
 323         *cwd            = \&_vms_cwd;
 324         *getcwd         = \&_vms_cwd;
 325         *fastcwd        = \&_vms_cwd;
 326         *fastgetcwd     = \&_vms_cwd;
 327         *abs_path       = \&_vms_abs_path;
 328         *fast_abs_path  = \&_vms_abs_path;
 329     }
 330     elsif ($^O eq 'NT' or $^O eq 'MSWin32') {
 331         # We assume that &_NT_cwd is defined as an XSUB or in the core.
 332         *cwd            = \&_NT_cwd;
 333         *getcwd         = \&_NT_cwd;
 334         *fastcwd        = \&_NT_cwd;
 335         *fastgetcwd     = \&_NT_cwd;
 336         *abs_path       = \&fast_abs_path;
 337     }
 338     elsif ($^O eq 'os2') {
 339         # sys_cwd may keep the builtin command
 340         *cwd            = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
 341         *getcwd         = \&cwd;
 342         *fastgetcwd     = \&cwd;
 343         *fastcwd        = \&cwd;
 344         *abs_path       = \&fast_abs_path;
 345     }
 346     elsif ($^O eq 'dos') {
 347         *cwd            = \&_dos_cwd;
 348         *getcwd         = \&_dos_cwd;
 349         *fastgetcwd     = \&_dos_cwd;
 350         *fastcwd        = \&_dos_cwd;
 351         *abs_path       = \&fast_abs_path;
 352     }
 353     elsif ($^O eq 'qnx') {
 354         *cwd            = \&_qnx_cwd;
 355         *getcwd         = \&_qnx_cwd;
 356         *fastgetcwd     = \&_qnx_cwd;
 357         *fastcwd        = \&_qnx_cwd;
 358         *abs_path       = \&_qnx_abs_path;
 359         *fast_abs_path  = \&_qnx_abs_path;
 360     }
 361 }
 362
 363 # package main; eval join('',<DATA>) || die $@; # quick test
 364
 365 1;
 366
 367 __END__
 368 BEGIN { import Cwd qw(:DEFAULT chdir); }
 369 print join("\n", cwd, getcwd, fastcwd, "");
 370 chdir('..');
 371 print join("\n", cwd, getcwd, fastcwd, "");
 372 print "$ENV{PWD}\n";