lib/Cwd.pm

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