lib/Cwd.pm

   1 package Cwd;
   2 use 5.006;
   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 SEE ALSO
 134
 135 L<File::chdir>
 136
 137 =cut
 138
 139 use strict;
 140
 141 use Carp;
 142
 143 our $VERSION = '2.08';
 144
 145 use base qw/ Exporter /;
 146 our @EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
 147 our @EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath);
 148
 149 # sys_cwd may keep the builtin command
 150
 151 # All the functionality of this module may provided by builtins,
 152 # there is no sense to process the rest of the file.
 153 # The best choice may be to have this in BEGIN, but how to return from BEGIN?
 154
 155 if ($^O eq 'os2' && defined &sys_cwd && defined &sys_abspath) {
 156     local $^W = 0;
 157     *cwd                = \&sys_cwd;
 158     *getcwd             = \&cwd;
 159     *fastgetcwd         = \&cwd;
 160     *fastcwd            = \&cwd;
 161     *abs_path           = \&sys_abspath;
 162     *fast_abs_path      = \&abs_path;
 163     *realpath           = \&abs_path;
 164     *fast_realpath      = \&abs_path;
 165     return 1;
 166 }
 167
 168 eval {
 169     require XSLoader;
 170     local $^W = 0;
 171     XSLoader::load('Cwd');
 172 };
 173
 174
 175 # Find the pwd command in the expected locations.  We assume these
 176 # are safe.  This prevents _backtick_pwd() consulting $ENV{PATH}
 177 # so everything works under taint mode.
 178 my $pwd_cmd;
 179 foreach my $try (qw(/bin/pwd /usr/bin/pwd)) {
 180     if( -x $try ) {
 181         $pwd_cmd = $try;
 182         last;
 183     }
 184 }
 185 unless ($pwd_cmd) {
 186     if (-x '/QOpenSys/bin/pwd') { # OS/400 PASE.
 187         $pwd_cmd = '/QOpenSys/bin/pwd' ;
 188     } else {
 189         # Isn't this wrong?  _backtick_pwd() will fail if somenone has
 190         # pwd in their path but it is not /bin/pwd or /usr/bin/pwd?
 191         # See [perl #16774]. --jhi
 192         $pwd_cmd = 'pwd';
 193     }
 194 }
 195
 196 # The 'natural and safe form' for UNIX (pwd may be setuid root)
 197 sub _backtick_pwd {
 198     local @ENV{qw(PATH IFS CDPATH ENV BASH_ENV)};
 199     my $cwd = `$pwd_cmd`;
 200     # Belt-and-suspenders in case someone said "undef $/".
 201     local $/ = "\n";
 202     # `pwd` may fail e.g. if the disk is full
 203     chomp($cwd) if defined $cwd;
 204     $cwd;
 205 }
 206
 207 # Since some ports may predefine cwd internally (e.g., NT)
 208 # we take care not to override an existing definition for cwd().
 209
 210 unless(defined &cwd) {
 211     # The pwd command is not available in some chroot(2)'ed environments
 212     if( $^O eq 'MacOS' || (defined $ENV{PATH} &&
 213                            grep { -x "$_/pwd" } split(':', $ENV{PATH})) )
 214     {
 215         *cwd = \&_backtick_pwd;
 216     }
 217     else {
 218         *cwd = \&getcwd;
 219     }
 220 }
 221
 222 # set a reasonable (and very safe) default for fastgetcwd, in case it
 223 # isn't redefined later (20001212 rspier)
 224 *fastgetcwd = \&cwd;
 225
 226 # By Brandon S. Allbery
 227 #
 228 # Usage: $cwd = getcwd();
 229
 230 sub getcwd
 231 {
 232     abs_path('.');
 233 }
 234
 235
 236 # By John Bazik
 237 #
 238 # Usage: $cwd = &fastcwd;
 239 #
 240 # This is a faster version of getcwd.  It's also more dangerous because
 241 # you might chdir out of a directory that you can't chdir back into.
 242
 243 sub fastcwd {
 244     my($odev, $oino, $cdev, $cino, $tdev, $tino);
 245     my(@path, $path);
 246     local(*DIR);
 247
 248     my($orig_cdev, $orig_cino) = stat('.');
 249     ($cdev, $cino) = ($orig_cdev, $orig_cino);
 250     for (;;) {
 251         my $direntry;
 252         ($odev, $oino) = ($cdev, $cino);
 253         CORE::chdir('..') || return undef;
 254         ($cdev, $cino) = stat('.');
 255         last if $odev == $cdev && $oino == $cino;
 256         opendir(DIR, '.') || return undef;
 257         for (;;) {
 258             $direntry = readdir(DIR);
 259             last unless defined $direntry;
 260             next if $direntry eq '.';
 261             next if $direntry eq '..';
 262
 263             ($tdev, $tino) = lstat($direntry);
 264             last unless $tdev != $odev || $tino != $oino;
 265         }
 266         closedir(DIR);
 267         return undef unless defined $direntry; # should never happen
 268         unshift(@path, $direntry);
 269     }
 270     $path = '/' . join('/', @path);
 271     if ($^O eq 'apollo') { $path = "/".$path; }
 272     # At this point $path may be tainted (if tainting) and chdir would fail.
 273     # Untaint it then check that we landed where we started.
 274     $path =~ /^(.*)\z/s         # untaint
 275         && CORE::chdir($1) or return undef;
 276     ($cdev, $cino) = stat('.');
 277     die "Unstable directory path, current directory changed unexpectedly"
 278         if $cdev != $orig_cdev || $cino != $orig_cino;
 279     $path;
 280 }
 281
 282
 283 # Keeps track of current working directory in PWD environment var
 284 # Usage:
 285 #       use Cwd 'chdir';
 286 #       chdir $newdir;
 287
 288 my $chdir_init = 0;
 289
 290 sub chdir_init {
 291     if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos' and $^O ne 'MSWin32') {
 292         my($dd,$di) = stat('.');
 293         my($pd,$pi) = stat($ENV{'PWD'});
 294         if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
 295             $ENV{'PWD'} = cwd();
 296         }
 297     }
 298     else {
 299         my $wd = cwd();
 300         $wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32';
 301         $ENV{'PWD'} = $wd;
 302     }
 303     # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar)
 304     if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) {
 305         my($pd,$pi) = stat($2);
 306         my($dd,$di) = stat($1);
 307         if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
 308             $ENV{'PWD'}="$2$3";
 309         }
 310     }
 311     $chdir_init = 1;
 312 }
 313
 314 sub chdir {
 315     my $newdir = @_ ? shift : '';       # allow for no arg (chdir to HOME dir)
 316     $newdir =~ s|///*|/|g unless $^O eq 'MSWin32';
 317     chdir_init() unless $chdir_init;
 318     my $newpwd;
 319     if ($^O eq 'MSWin32') {
 320         # get the full path name *before* the chdir()
 321         $newpwd = Win32::GetFullPathName($newdir);
 322     }
 323
 324     return 0 unless CORE::chdir $newdir;
 325
 326     if ($^O eq 'VMS') {
 327         return $ENV{'PWD'} = $ENV{'DEFAULT'}
 328     }
 329     elsif ($^O eq 'MacOS') {
 330         return $ENV{'PWD'} = cwd();
 331     }
 332     elsif ($^O eq 'MSWin32') {
 333         $ENV{'PWD'} = $newpwd;
 334         return 1;
 335     }
 336
 337     if ($newdir =~ m#^/#s) {
 338         $ENV{'PWD'} = $newdir;
 339     } else {
 340         my @curdir = split(m#/#,$ENV{'PWD'});
 341         @curdir = ('') unless @curdir;
 342         my $component;
 343         foreach $component (split(m#/#, $newdir)) {
 344             next if $component eq '.';
 345             pop(@curdir),next if $component eq '..';
 346             push(@curdir,$component);
 347         }
 348         $ENV{'PWD'} = join('/',@curdir) || '/';
 349     }
 350     1;
 351 }
 352
 353
 354 # In case the XS version doesn't load.
 355 *abs_path = \&_perl_abs_path unless defined &abs_path;
 356 sub _perl_abs_path
 357 {
 358     my $start = @_ ? shift : '.';
 359     my($dotdots, $cwd, @pst, @cst, $dir, @tst);
 360
 361     unless (@cst = stat( $start ))
 362     {
 363         carp "stat($start): $!";
 364         return '';
 365     }
 366     $cwd = '';
 367     $dotdots = $start;
 368     do
 369     {
 370         $dotdots .= '/..';
 371         @pst = @cst;
 372         local *PARENT;
 373         unless (opendir(PARENT, $dotdots))
 374         {
 375             carp "opendir($dotdots): $!";
 376             return '';
 377         }
 378         unless (@cst = stat($dotdots))
 379         {
 380             carp "stat($dotdots): $!";
 381             closedir(PARENT);
 382             return '';
 383         }
 384         if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
 385         {
 386             $dir = undef;
 387         }
 388         else
 389         {
 390             do
 391             {
 392                 unless (defined ($dir = readdir(PARENT)))
 393                 {
 394                     carp "readdir($dotdots): $!";
 395                     closedir(PARENT);
 396                     return '';
 397                 }
 398                 $tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir"))
 399             }
 400             while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
 401                    $tst[1] != $pst[1]);
 402         }
 403         $cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ;
 404         closedir(PARENT);
 405     } while (defined $dir);
 406     chop($cwd) unless $cwd eq '/'; # drop the trailing /
 407     $cwd;
 408 }
 409
 410
 411 # added function alias for those of us more
 412 # used to the libc function.  --tchrist 27-Jan-00
 413 *realpath = \&abs_path;
 414
 415 my $Curdir;
 416 sub fast_abs_path {
 417     my $cwd = getcwd();
 418     require File::Spec;
 419     my $path = @_ ? shift : ($Curdir ||= File::Spec->curdir);
 420
 421     # Detaint else we'll explode in taint mode.  This is safe because
 422     # we're not doing anything dangerous with it.
 423     ($path) = $path =~ /(.*)/;
 424     ($cwd)  = $cwd  =~ /(.*)/;
 425
 426     CORE::chdir($path) || croak "Cannot chdir to $path: $!";
 427     my $realpath = getcwd();
 428     -d $cwd && CORE::chdir($cwd) ||
 429         croak "Cannot chdir back to $cwd: $!";
 430     $realpath;
 431 }
 432
 433 # added function alias to follow principle of least surprise
 434 # based on previous aliasing.  --tchrist 27-Jan-00
 435 *fast_realpath = \&fast_abs_path;
 436
 437
 438 # --- PORTING SECTION ---
 439
 440 # VMS: $ENV{'DEFAULT'} points to default directory at all times
 441 # 06-Mar-1996  Charles Bailey  bailey@newman.upenn.edu
 442 # Note: Use of Cwd::chdir() causes the logical name PWD to be defined
 443 #   in the process logical name table as the default device and directory
 444 #   seen by Perl. This may not be the same as the default device
 445 #   and directory seen by DCL after Perl exits, since the effects
 446 #   the CRTL chdir() function persist only until Perl exits.
 447
 448 sub _vms_cwd {
 449     return $ENV{'DEFAULT'};
 450 }
 451
 452 sub _vms_abs_path {
 453     return $ENV{'DEFAULT'} unless @_;
 454     my $path = VMS::Filespec::pathify($_[0]);
 455     croak("Invalid path name $_[0]") unless defined $path;
 456     return VMS::Filespec::rmsexpand($path);
 457 }
 458
 459 sub _os2_cwd {
 460     $ENV{'PWD'} = `cmd /c cd`;
 461     chop $ENV{'PWD'};
 462     $ENV{'PWD'} =~ s:\\:/:g ;
 463     return $ENV{'PWD'};
 464 }
 465
 466 sub _win32_cwd {
 467     $ENV{'PWD'} = Win32::GetCwd();
 468     $ENV{'PWD'} =~ s:\\:/:g ;
 469     return $ENV{'PWD'};
 470 }
 471
 472 *_NT_cwd = \&_win32_cwd if (!defined &_NT_cwd &&
 473                             defined &Win32::GetCwd);
 474
 475 *_NT_cwd = \&_os2_cwd unless defined &_NT_cwd;
 476
 477 sub _dos_cwd {
 478     if (!defined &Dos::GetCwd) {
 479         $ENV{'PWD'} = `command /c cd`;
 480         chop $ENV{'PWD'};
 481         $ENV{'PWD'} =~ s:\\:/:g ;
 482     } else {
 483         $ENV{'PWD'} = Dos::GetCwd();
 484     }
 485     return $ENV{'PWD'};
 486 }
 487
 488 sub _qnx_cwd {
 489         local $ENV{PATH} = '';
 490         local $ENV{CDPATH} = '';
 491         local $ENV{ENV} = '';
 492     $ENV{'PWD'} = `/usr/bin/fullpath -t`;
 493     chop $ENV{'PWD'};
 494     return $ENV{'PWD'};
 495 }
 496
 497 sub _qnx_abs_path {
 498         local $ENV{PATH} = '';
 499         local $ENV{CDPATH} = '';
 500         local $ENV{ENV} = '';
 501     my $path = @_ ? shift : '.';
 502     my $realpath=`/usr/bin/fullpath -t $path`;
 503     chop $realpath;
 504     return $realpath;
 505 }
 506
 507 sub _epoc_cwd {
 508     $ENV{'PWD'} = EPOC::getcwd();
 509     return $ENV{'PWD'};
 510 }
 511
 512 {
 513     no warnings;        # assignments trigger 'subroutine redefined' warning
 514
 515     if ($^O eq 'VMS') {
 516         *cwd            = \&_vms_cwd;
 517         *getcwd         = \&_vms_cwd;
 518         *fastcwd        = \&_vms_cwd;
 519         *fastgetcwd     = \&_vms_cwd;
 520         *abs_path       = \&_vms_abs_path;
 521         *fast_abs_path  = \&_vms_abs_path;
 522     }
 523     elsif ($^O eq 'NT' or $^O eq 'MSWin32') {
 524         # We assume that &_NT_cwd is defined as an XSUB or in the core.
 525         *cwd            = \&_NT_cwd;
 526         *getcwd         = \&_NT_cwd;
 527         *fastcwd        = \&_NT_cwd;
 528         *fastgetcwd     = \&_NT_cwd;
 529         *abs_path       = \&fast_abs_path;
 530         *realpath   = \&fast_abs_path;
 531     }
 532     elsif ($^O eq 'os2') {
 533         # sys_cwd may keep the builtin command
 534         *cwd            = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
 535         *getcwd         = \&cwd;
 536         *fastgetcwd     = \&cwd;
 537         *fastcwd        = \&cwd;
 538         *abs_path       = \&fast_abs_path;
 539     }
 540     elsif ($^O eq 'dos') {
 541         *cwd            = \&_dos_cwd;
 542         *getcwd         = \&_dos_cwd;
 543         *fastgetcwd     = \&_dos_cwd;
 544         *fastcwd        = \&_dos_cwd;
 545         *abs_path       = \&fast_abs_path;
 546     }
 547     elsif ($^O =~ m/^(?:qnx|nto)$/ ) {
 548         *cwd            = \&_qnx_cwd;
 549         *getcwd         = \&_qnx_cwd;
 550         *fastgetcwd     = \&_qnx_cwd;
 551         *fastcwd        = \&_qnx_cwd;
 552         *abs_path       = \&_qnx_abs_path;
 553         *fast_abs_path  = \&_qnx_abs_path;
 554     }
 555     elsif ($^O eq 'cygwin') {
 556         *getcwd = \&cwd;
 557         *fastgetcwd     = \&cwd;
 558         *fastcwd        = \&cwd;
 559         *abs_path       = \&fast_abs_path;
 560     }
 561     elsif ($^O eq 'epoc') {
 562         *cwd            = \&_epoc_cwd;
 563         *getcwd         = \&_epoc_cwd;
 564         *fastgetcwd     = \&_epoc_cwd;
 565         *fastcwd        = \&_epoc_cwd;
 566         *abs_path       = \&fast_abs_path;
 567     }
 568     elsif ($^O eq 'MacOS') {
 569         *getcwd     = \&cwd;
 570         *fastgetcwd = \&cwd;
 571         *fastcwd    = \&cwd;
 572         *abs_path   = \&fast_abs_path;
 573     }
 574 }
 575
 576
 577 1;