lib/Cwd.pm

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