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