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