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