lib/Cwd.pm

   1 package Cwd;
   2 $VERSION = $VERSION = '2.17';
   3
   4 =head1 NAME
   5
   6 Cwd - get pathname of current working directory
   7
   8 =head1 SYNOPSIS
   9
  10     use Cwd;
  11     my $dir = getcwd;
  12
  13     use Cwd 'abs_path';
  14     my $abs_path = abs_path($file);
  15
  16 =head1 DESCRIPTION
  17
  18 This module provides functions for determining the pathname of the
  19 current working directory.  It is recommended that getcwd (or another
  20 *cwd() function) be used in I<all> code to ensure portability.
  21
  22 By default, it exports the functions cwd(), getcwd(), fastcwd(), and
  23 fastgetcwd() into the caller's namespace.
  24
  25
  26 =head2 getcwd and friends
  27
  28 Each of these functions are called without arguments and return the
  29 absolute path of the current working directory.
  30
  31 =over 4
  32
  33 =item getcwd
  34
  35     my $cwd = getcwd();
  36
  37 Returns the current working directory.
  38
  39 Re-implements the getcwd(3) (or getwd(3)) functions in Perl.
  40
  41 =item cwd
  42
  43     my $cwd = cwd();
  44
  45 The cwd() is the most natural form for the current architecture. For
  46 most systems it is identical to `pwd` (but without the trailing line
  47 terminator).
  48
  49 =item fastcwd
  50
  51     my $cwd = fastcwd();
  52
  53 A more dangerous version of getcwd(), but potentially faster.
  54
  55 It might conceivably chdir() you out of a directory that it can't
  56 chdir() you back into.  If fastcwd encounters a problem it will return
  57 undef but will probably leave you in a different directory.  For a
  58 measure of extra security, if everything appears to have worked, the
  59 fastcwd() function will check that it leaves you in the same directory
  60 that it started in. If it has changed it will C<die> with the message
  61 "Unstable directory path, current directory changed
  62 unexpectedly". That should never happen.
  63
  64 =item fastgetcwd
  65
  66   my $cwd = fastgetcwd();
  67
  68 The fastgetcwd() function is provided as a synonym for cwd().
  69
  70 =back
  71
  72
  73 =head2 abs_path and friends
  74
  75 These functions are exported only on request.  They each take a single
  76 argument and return the absolute pathname for it.  If no argument is
  77 given they'll use the current working directory.
  78
  79 =over 4
  80
  81 =item abs_path
  82
  83   my $abs_path = abs_path($file);
  84
  85 Uses the same algorithm as getcwd().  Symbolic links and relative-path
  86 components ("." and "..") are resolved to return the canonical
  87 pathname, just like realpath(3).
  88
  89 =item realpath
  90
  91   my $abs_path = realpath($file);
  92
  93 A synonym for abs_path().
  94
  95 =item fast_abs_path
  96
  97   my $abs_path = fast_abs_path($file);
  98
  99 A more dangerous, but potentially faster version of abs_path.
 100
 101 =back
 102
 103 =head2 $ENV{PWD}
 104
 105 If you ask to override your chdir() built-in function,
 106
 107   use Cwd qw(chdir);
 108
 109 then your PWD environment variable will be kept up to date.  Note that
 110 it will only be kept up to date if all packages which use chdir import
 111 it from Cwd.
 112
 113
 114 =head1 NOTES
 115
 116 =over 4
 117
 118 =item *
 119
 120 Since the path seperators are different on some operating systems ('/'
 121 on Unix, ':' on MacPerl, etc...) we recommend you use the File::Spec
 122 modules wherever portability is a concern.
 123
 124 =item *
 125
 126 Actually, on Mac OS, the C<getcwd()>, C<fastgetcwd()> and C<fastcwd()>
 127 functions  are all aliases for the C<cwd()> function, which, on Mac OS,
 128 calls `pwd`. Likewise, the C<abs_path()> function is an alias for
 129 C<fast_abs_path()>.
 130
 131 =back
 132
 133 =head1 AUTHOR
 134
 135 Originally by the perl5-porters.
 136
 137 Now maintained by Ken Williams <KWILLIAMS@cpan.org>
 138
 139 =head1 SEE ALSO
 140
 141 L<File::chdir>
 142
 143 =cut
 144
 145 use strict;
 146 use Exporter;
 147 use vars qw(@ISA @EXPORT @EXPORT_OK);
 148
 149 @ISA = qw/ Exporter /;
 150 @EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
 151 @EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath);
 152
 153 # sys_cwd may keep the builtin command
 154
 155 # All the functionality of this module may provided by builtins,
 156 # there is no sense to process the rest of the file.
 157 # The best choice may be to have this in BEGIN, but how to return from BEGIN?
 158
 159 if ($^O eq 'os2') {
 160     local $^W = 0;
 161
 162     *cwd                = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
 163     *getcwd             = \&cwd;
 164     *fastgetcwd         = \&cwd;
 165     *fastcwd            = \&cwd;
 166
 167     *fast_abs_path      = \&sys_abspath if defined &sys_abspath;
 168     *abs_path           = \&fast_abs_path;
 169     *realpath           = \&fast_abs_path;
 170     *fast_realpath      = \&fast_abs_path;
 171
 172     return 1;
 173 }
 174
 175 eval {
 176     require XSLoader;
 177     local $^W = 0;
 178     XSLoader::load('Cwd');
 179 };
 180
 181
 182 # Find the pwd command in the expected locations.  We assume these
 183 # are safe.  This prevents _backtick_pwd() consulting $ENV{PATH}
 184 # so everything works under taint mode.
 185 my $pwd_cmd;
 186 foreach my $try ('/bin/pwd',
 187                  '/usr/bin/pwd',
 188                  '/QOpenSys/bin/pwd', # OS/400 PASE.
 189                 ) {
 190
 191     if( -x $try ) {
 192         $pwd_cmd = $try;
 193         last;
 194     }
 195 }
 196 unless ($pwd_cmd) {
 197     # Isn't this wrong?  _backtick_pwd() will fail if somenone has
 198     # pwd in their path but it is not /bin/pwd or /usr/bin/pwd?
 199     # See [perl #16774]. --jhi
 200     $pwd_cmd = 'pwd';
 201 }
 202
 203 # Lazy-load Carp
 204 sub _carp  { require Carp; Carp::carp(@_)  }
 205 sub _croak { require Carp; Carp::croak(@_) }
 206
 207 # The 'natural and safe form' for UNIX (pwd may be setuid root)
 208 sub _backtick_pwd {
 209     local @ENV{qw(PATH IFS CDPATH ENV BASH_ENV)};
 210     my $cwd = `$pwd_cmd`;
 211     # Belt-and-suspenders in case someone said "undef $/".
 212     local $/ = "\n";
 213     # `pwd` may fail e.g. if the disk is full
 214     chomp($cwd) if defined $cwd;
 215     $cwd;
 216 }
 217
 218 # Since some ports may predefine cwd internally (e.g., NT)
 219 # we take care not to override an existing definition for cwd().
 220
 221 unless(defined &cwd) {
 222     # The pwd command is not available in some chroot(2)'ed environments
 223     if( $^O eq 'MacOS' || (defined $ENV{PATH} &&
 224                            grep { -x "$_/pwd" } split(':', $ENV{PATH})) )
 225     {
 226         *cwd = \&_backtick_pwd;
 227     }
 228     else {
 229         *cwd = \&getcwd;
 230     }
 231 }
 232
 233 # set a reasonable (and very safe) default for fastgetcwd, in case it
 234 # isn't redefined later (20001212 rspier)
 235 *fastgetcwd = \&cwd;
 236
 237 # By Brandon S. Allbery
 238 #
 239 # Usage: $cwd = getcwd();
 240
 241 sub getcwd
 242 {
 243     abs_path('.');
 244 }
 245
 246
 247 # By John Bazik
 248 #
 249 # Usage: $cwd = &fastcwd;
 250 #
 251 # This is a faster version of getcwd.  It's also more dangerous because
 252 # you might chdir out of a directory that you can't chdir back into.
 253
 254 sub fastcwd {
 255     my($odev, $oino, $cdev, $cino, $tdev, $tino);
 256     my(@path, $path);
 257     local(*DIR);
 258
 259     my($orig_cdev, $orig_cino) = stat('.');
 260     ($cdev, $cino) = ($orig_cdev, $orig_cino);
 261     for (;;) {
 262         my $direntry;
 263         ($odev, $oino) = ($cdev, $cino);
 264         CORE::chdir('..') || return undef;
 265         ($cdev, $cino) = stat('.');
 266         last if $odev == $cdev && $oino == $cino;
 267         opendir(DIR, '.') || return undef;
 268         for (;;) {
 269             $direntry = readdir(DIR);
 270             last unless defined $direntry;
 271             next if $direntry eq '.';
 272             next if $direntry eq '..';
 273
 274             ($tdev, $tino) = lstat($direntry);
 275             last unless $tdev != $odev || $tino != $oino;
 276         }
 277         closedir(DIR);
 278         return undef unless defined $direntry; # should never happen
 279         unshift(@path, $direntry);
 280     }
 281     $path = '/' . join('/', @path);
 282     if ($^O eq 'apollo') { $path = "/".$path; }
 283     # At this point $path may be tainted (if tainting) and chdir would fail.
 284     # Untaint it then check that we landed where we started.
 285     $path =~ /^(.*)\z/s         # untaint
 286         && CORE::chdir($1) or return undef;
 287     ($cdev, $cino) = stat('.');
 288     die "Unstable directory path, current directory changed unexpectedly"
 289         if $cdev != $orig_cdev || $cino != $orig_cino;
 290     $path;
 291 }
 292
 293
 294 # Keeps track of current working directory in PWD environment var
 295 # Usage:
 296 #       use Cwd 'chdir';
 297 #       chdir $newdir;
 298
 299 my $chdir_init = 0;
 300
 301 sub chdir_init {
 302     if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos' and $^O ne 'MSWin32') {
 303         my($dd,$di) = stat('.');
 304         my($pd,$pi) = stat($ENV{'PWD'});
 305         if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
 306             $ENV{'PWD'} = cwd();
 307         }
 308     }
 309     else {
 310         my $wd = cwd();
 311         $wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32';
 312         $ENV{'PWD'} = $wd;
 313     }
 314     # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar)
 315     if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) {
 316         my($pd,$pi) = stat($2);
 317         my($dd,$di) = stat($1);
 318         if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
 319             $ENV{'PWD'}="$2$3";
 320         }
 321     }
 322     $chdir_init = 1;
 323 }
 324
 325 sub chdir {
 326     my $newdir = @_ ? shift : '';       # allow for no arg (chdir to HOME dir)
 327     $newdir =~ s|///*|/|g unless $^O eq 'MSWin32';
 328     chdir_init() unless $chdir_init;
 329     my $newpwd;
 330     if ($^O eq 'MSWin32') {
 331         # get the full path name *before* the chdir()
 332         $newpwd = Win32::GetFullPathName($newdir);
 333     }
 334
 335     return 0 unless CORE::chdir $newdir;
 336
 337     if ($^O eq 'VMS') {
 338         return $ENV{'PWD'} = $ENV{'DEFAULT'}
 339     }
 340     elsif ($^O eq 'MacOS') {
 341         return $ENV{'PWD'} = cwd();
 342     }
 343     elsif ($^O eq 'MSWin32') {
 344         $ENV{'PWD'} = $newpwd;
 345         return 1;
 346     }
 347
 348     if ($newdir =~ m#^/#s) {
 349         $ENV{'PWD'} = $newdir;
 350     } else {
 351         my @curdir = split(m#/#,$ENV{'PWD'});
 352         @curdir = ('') unless @curdir;
 353         my $component;
 354         foreach $component (split(m#/#, $newdir)) {
 355             next if $component eq '.';
 356             pop(@curdir),next if $component eq '..';
 357             push(@curdir,$component);
 358         }
 359         $ENV{'PWD'} = join('/',@curdir) || '/';
 360     }
 361     1;
 362 }
 363
 364
 365 # In case the XS version doesn't load.
 366 *abs_path = \&_perl_abs_path unless defined &abs_path;
 367 sub _perl_abs_path
 368 {
 369     my $start = @_ ? shift : '.';
 370     my($dotdots, $cwd, @pst, @cst, $dir, @tst);
 371
 372     unless (@cst = stat( $start ))
 373     {
 374         _carp("stat($start): $!");
 375         return '';
 376     }
 377     $cwd = '';
 378     $dotdots = $start;
 379     do
 380     {
 381         $dotdots .= '/..';
 382         @pst = @cst;
 383         local *PARENT;
 384         unless (opendir(PARENT, $dotdots))
 385         {
 386             _carp("opendir($dotdots): $!");
 387             return '';
 388         }
 389         unless (@cst = stat($dotdots))
 390         {
 391             _carp("stat($dotdots): $!");
 392             closedir(PARENT);
 393             return '';
 394         }
 395         if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
 396         {
 397             $dir = undef;
 398         }
 399         else
 400         {
 401             do
 402             {
 403                 unless (defined ($dir = readdir(PARENT)))
 404                 {
 405                     _carp("readdir($dotdots): $!");
 406                     closedir(PARENT);
 407                     return '';
 408                 }
 409                 $tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir"))
 410             }
 411             while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
 412                    $tst[1] != $pst[1]);
 413         }
 414         $cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ;
 415         closedir(PARENT);
 416     } while (defined $dir);
 417     chop($cwd) unless $cwd eq '/'; # drop the trailing /
 418     $cwd;
 419 }
 420
 421
 422 # added function alias for those of us more
 423 # used to the libc function.  --tchrist 27-Jan-00
 424 *realpath = \&abs_path;
 425
 426 my $Curdir;
 427 sub fast_abs_path {
 428     my $cwd = getcwd();
 429     require File::Spec;
 430     my $path = @_ ? shift : ($Curdir ||= File::Spec->curdir);
 431
 432     # Detaint else we'll explode in taint mode.  This is safe because
 433     # we're not doing anything dangerous with it.
 434     ($path) = $path =~ /(.*)/;
 435     ($cwd)  = $cwd  =~ /(.*)/;
 436
 437     if (!CORE::chdir($path)) {
 438         _croak("Cannot chdir to $path: $!");
 439     }
 440     my $realpath = getcwd();
 441     if (! ((-d $cwd) && (CORE::chdir($cwd)))) {
 442         _croak("Cannot chdir back to $cwd: $!");
 443     }
 444     $realpath;
 445 }
 446
 447 # added function alias to follow principle of least surprise
 448 # based on previous aliasing.  --tchrist 27-Jan-00
 449 *fast_realpath = \&fast_abs_path;
 450
 451
 452 # --- PORTING SECTION ---
 453
 454 # VMS: $ENV{'DEFAULT'} points to default directory at all times
 455 # 06-Mar-1996  Charles Bailey  bailey@newman.upenn.edu
 456 # Note: Use of Cwd::chdir() causes the logical name PWD to be defined
 457 #   in the process logical name table as the default device and directory
 458 #   seen by Perl. This may not be the same as the default device
 459 #   and directory seen by DCL after Perl exits, since the effects
 460 #   the CRTL chdir() function persist only until Perl exits.
 461
 462 sub _vms_cwd {
 463     return $ENV{'DEFAULT'};
 464 }
 465
 466 sub _vms_abs_path {
 467     return $ENV{'DEFAULT'} unless @_;
 468     my $path = VMS::Filespec::pathify($_[0]);
 469     if (! defined $path)
 470         {
 471         _croak("Invalid path name $_[0]")
 472         }
 473     return VMS::Filespec::rmsexpand($path);
 474 }
 475
 476 sub _os2_cwd {
 477     $ENV{'PWD'} = `cmd /c cd`;
 478     chomp $ENV{'PWD'};
 479     $ENV{'PWD'} =~ s:\\:/:g ;
 480     return $ENV{'PWD'};
 481 }
 482
 483 sub _win32_cwd {
 484     $ENV{'PWD'} = Win32::GetCwd();
 485     $ENV{'PWD'} =~ s:\\:/:g ;
 486     return $ENV{'PWD'};
 487 }
 488
 489 *_NT_cwd = \&_win32_cwd if (!defined &_NT_cwd &&
 490                             defined &Win32::GetCwd);
 491
 492 *_NT_cwd = \&_os2_cwd unless defined &_NT_cwd;
 493
 494 sub _dos_cwd {
 495     if (!defined &Dos::GetCwd) {
 496         $ENV{'PWD'} = `command /c cd`;
 497         chomp $ENV{'PWD'};
 498         $ENV{'PWD'} =~ s:\\:/:g ;
 499     } else {
 500         $ENV{'PWD'} = Dos::GetCwd();
 501     }
 502     return $ENV{'PWD'};
 503 }
 504
 505 sub _qnx_cwd {
 506         local $ENV{PATH} = '';
 507         local $ENV{CDPATH} = '';
 508         local $ENV{ENV} = '';
 509     $ENV{'PWD'} = `/usr/bin/fullpath -t`;
 510     chomp $ENV{'PWD'};
 511     return $ENV{'PWD'};
 512 }
 513
 514 sub _qnx_abs_path {
 515         local $ENV{PATH} = '';
 516         local $ENV{CDPATH} = '';
 517         local $ENV{ENV} = '';
 518     my $path = @_ ? shift : '.';
 519     local *REALPATH;
 520
 521     open(REALPATH, '-|', '/usr/bin/fullpath', '-t', $path) or
 522       die "Can't open /usr/bin/fullpath: $!";
 523     my $realpath = <REALPATH>;
 524     close REALPATH;
 525     chomp $realpath;
 526     return $realpath;
 527 }
 528
 529 sub _epoc_cwd {
 530     $ENV{'PWD'} = EPOC::getcwd();
 531     return $ENV{'PWD'};
 532 }
 533
 534 {
 535     no warnings;        # assignments trigger 'subroutine redefined' warning
 536
 537     if ($^O eq 'VMS') {
 538         *cwd            = \&_vms_cwd;
 539         *getcwd         = \&_vms_cwd;
 540         *fastcwd        = \&_vms_cwd;
 541         *fastgetcwd     = \&_vms_cwd;
 542         *abs_path       = \&_vms_abs_path;
 543         *fast_abs_path  = \&_vms_abs_path;
 544     }
 545     elsif ($^O eq 'NT' or $^O eq 'MSWin32') {
 546         # We assume that &_NT_cwd is defined as an XSUB or in the core.
 547         *cwd            = \&_NT_cwd;
 548         *getcwd         = \&_NT_cwd;
 549         *fastcwd        = \&_NT_cwd;
 550         *fastgetcwd     = \&_NT_cwd;
 551         *abs_path       = \&fast_abs_path;
 552         *realpath   = \&fast_abs_path;
 553     }
 554     elsif ($^O eq 'dos') {
 555         *cwd            = \&_dos_cwd;
 556         *getcwd         = \&_dos_cwd;
 557         *fastgetcwd     = \&_dos_cwd;
 558         *fastcwd        = \&_dos_cwd;
 559         *abs_path       = \&fast_abs_path;
 560     }
 561     elsif ($^O =~ m/^(?:qnx|nto)$/ ) {
 562         *cwd            = \&_qnx_cwd;
 563         *getcwd         = \&_qnx_cwd;
 564         *fastgetcwd     = \&_qnx_cwd;
 565         *fastcwd        = \&_qnx_cwd;
 566         *abs_path       = \&_qnx_abs_path;
 567         *fast_abs_path  = \&_qnx_abs_path;
 568     }
 569     elsif ($^O eq 'cygwin') {
 570         *getcwd = \&cwd;
 571         *fastgetcwd     = \&cwd;
 572         *fastcwd        = \&cwd;
 573         *abs_path       = \&fast_abs_path;
 574         *realpath       = \&abs_path;
 575     }
 576     elsif ($^O eq 'epoc') {
 577         *cwd            = \&_epoc_cwd;
 578         *getcwd         = \&_epoc_cwd;
 579         *fastgetcwd     = \&_epoc_cwd;
 580         *fastcwd        = \&_epoc_cwd;
 581         *abs_path       = \&fast_abs_path;
 582     }
 583     elsif ($^O eq 'MacOS') {
 584         *getcwd     = \&cwd;
 585         *fastgetcwd = \&cwd;
 586         *fastcwd    = \&cwd;
 587         *abs_path   = \&fast_abs_path;
 588     }
 589 }
 590
 591
 592 1;