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