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 $pwd_cmd ||= 'pwd';
 196
 197 # The 'natural and safe form' for UNIX (pwd may be setuid root)
 198 sub _backtick_pwd {
 199     local @ENV{qw(PATH IFS CDPATH ENV BASH_ENV)};
 200     my $cwd = `$pwd_cmd`;
 201     # Belt-and-suspenders in case someone said "undef $/".
 202     local $/ = "\n";
 203     # `pwd` may fail e.g. if the disk is full
 204     chomp($cwd) if defined $cwd;
 205     $cwd;
 206 }
 207
 208 # Since some ports may predefine cwd internally (e.g., NT)
 209 # we take care not to override an existing definition for cwd().
 210
 211 unless(defined &cwd) {
 212     # The pwd command is not available in some chroot(2)'ed environments
 213     if( $^O eq 'MacOS' || (defined $ENV{PATH} &&
 214                            grep { -x "$_/pwd" } split(':', $ENV{PATH})) )
 215     {
 216         *cwd = \&_backtick_pwd;
 217     }
 218     else {
 219         *cwd = \&getcwd;
 220     }
 221 }
 222
 223 # set a reasonable (and very safe) default for fastgetcwd, in case it
 224 # isn't redefined later (20001212 rspier)
 225 *fastgetcwd = \&cwd;
 226
 227 # By Brandon S. Allbery
 228 #
 229 # Usage: $cwd = getcwd();
 230
 231 sub getcwd
 232 {
 233     abs_path('.');
 234 }
 235
 236
 237 # By John Bazik
 238 #
 239 # Usage: $cwd = &fastcwd;
 240 #
 241 # This is a faster version of getcwd.  It's also more dangerous because
 242 # you might chdir out of a directory that you can't chdir back into.
 243
 244 sub fastcwd {
 245     my($odev, $oino, $cdev, $cino, $tdev, $tino);
 246     my(@path, $path);
 247     local(*DIR);
 248
 249     my($orig_cdev, $orig_cino) = stat('.');
 250     ($cdev, $cino) = ($orig_cdev, $orig_cino);
 251     for (;;) {
 252         my $direntry;
 253         ($odev, $oino) = ($cdev, $cino);
 254         CORE::chdir('..') || return undef;
 255         ($cdev, $cino) = stat('.');
 256         last if $odev == $cdev && $oino == $cino;
 257         opendir(DIR, '.') || return undef;
 258         for (;;) {
 259             $direntry = readdir(DIR);
 260             last unless defined $direntry;
 261             next if $direntry eq '.';
 262             next if $direntry eq '..';
 263
 264             ($tdev, $tino) = lstat($direntry);
 265             last unless $tdev != $odev || $tino != $oino;
 266         }
 267         closedir(DIR);
 268         return undef unless defined $direntry; # should never happen
 269         unshift(@path, $direntry);
 270     }
 271     $path = '/' . join('/', @path);
 272     if ($^O eq 'apollo') { $path = "/".$path; }
 273     # At this point $path may be tainted (if tainting) and chdir would fail.
 274     # Untaint it then check that we landed where we started.
 275     $path =~ /^(.*)\z/s         # untaint
 276         && CORE::chdir($1) or return undef;
 277     ($cdev, $cino) = stat('.');
 278     die "Unstable directory path, current directory changed unexpectedly"
 279         if $cdev != $orig_cdev || $cino != $orig_cino;
 280     $path;
 281 }
 282
 283
 284 # Keeps track of current working directory in PWD environment var
 285 # Usage:
 286 #       use Cwd 'chdir';
 287 #       chdir $newdir;
 288
 289 my $chdir_init = 0;
 290
 291 sub chdir_init {
 292     if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos' and $^O ne 'MSWin32') {
 293         my($dd,$di) = stat('.');
 294         my($pd,$pi) = stat($ENV{'PWD'});
 295         if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
 296             $ENV{'PWD'} = cwd();
 297         }
 298     }
 299     else {
 300         my $wd = cwd();
 301         $wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32';
 302         $ENV{'PWD'} = $wd;
 303     }
 304     # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar)
 305     if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) {
 306         my($pd,$pi) = stat($2);
 307         my($dd,$di) = stat($1);
 308         if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
 309             $ENV{'PWD'}="$2$3";
 310         }
 311     }
 312     $chdir_init = 1;
 313 }
 314
 315 sub chdir {
 316     my $newdir = @_ ? shift : '';       # allow for no arg (chdir to HOME dir)
 317     $newdir =~ s|///*|/|g unless $^O eq 'MSWin32';
 318     chdir_init() unless $chdir_init;
 319     my $newpwd;
 320     if ($^O eq 'MSWin32') {
 321         # get the full path name *before* the chdir()
 322         $newpwd = Win32::GetFullPathName($newdir);
 323     }
 324
 325     return 0 unless CORE::chdir $newdir;
 326
 327     if ($^O eq 'VMS') {
 328         return $ENV{'PWD'} = $ENV{'DEFAULT'}
 329     }
 330     elsif ($^O eq 'MacOS') {
 331         return $ENV{'PWD'} = cwd();
 332     }
 333     elsif ($^O eq 'MSWin32') {
 334         $ENV{'PWD'} = $newpwd;
 335         return 1;
 336     }
 337
 338     if ($newdir =~ m#^/#s) {
 339         $ENV{'PWD'} = $newdir;
 340     } else {
 341         my @curdir = split(m#/#,$ENV{'PWD'});
 342         @curdir = ('') unless @curdir;
 343         my $component;
 344         foreach $component (split(m#/#, $newdir)) {
 345             next if $component eq '.';
 346             pop(@curdir),next if $component eq '..';
 347             push(@curdir,$component);
 348         }
 349         $ENV{'PWD'} = join('/',@curdir) || '/';
 350     }
 351     1;
 352 }
 353
 354
 355 # In case the XS version doesn't load.
 356 *abs_path = \&_perl_abs_path unless defined &abs_path;
 357 sub _perl_abs_path
 358 {
 359     my $start = @_ ? shift : '.';
 360     my($dotdots, $cwd, @pst, @cst, $dir, @tst);
 361
 362     unless (@cst = stat( $start ))
 363     {
 364         carp "stat($start): $!";
 365         return '';
 366     }
 367     $cwd = '';
 368     $dotdots = $start;
 369     do
 370     {
 371         $dotdots .= '/..';
 372         @pst = @cst;
 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 sub fast_abs_path {
 416     my $cwd = getcwd();
 417     require File::Spec;
 418     my $path = @_ ? shift : File::Spec->curdir;
 419     CORE::chdir($path) || croak "Cannot chdir to $path: $!";
 420     my $realpath = getcwd();
 421     -d $cwd && CORE::chdir($cwd) ||
 422         croak "Cannot chdir back to $cwd: $!";
 423     $realpath;
 424 }
 425
 426 # added function alias to follow principle of least surprise
 427 # based on previous aliasing.  --tchrist 27-Jan-00
 428 *fast_realpath = \&fast_abs_path;
 429
 430
 431 # --- PORTING SECTION ---
 432
 433 # VMS: $ENV{'DEFAULT'} points to default directory at all times
 434 # 06-Mar-1996  Charles Bailey  bailey@newman.upenn.edu
 435 # Note: Use of Cwd::chdir() causes the logical name PWD to be defined
 436 #   in the process logical name table as the default device and directory
 437 #   seen by Perl. This may not be the same as the default device
 438 #   and directory seen by DCL after Perl exits, since the effects
 439 #   the CRTL chdir() function persist only until Perl exits.
 440
 441 sub _vms_cwd {
 442     return $ENV{'DEFAULT'};
 443 }
 444
 445 sub _vms_abs_path {
 446     return $ENV{'DEFAULT'} unless @_;
 447     my $path = VMS::Filespec::pathify($_[0]);
 448     croak("Invalid path name $_[0]") unless defined $path;
 449     return VMS::Filespec::rmsexpand($path);
 450 }
 451
 452 sub _os2_cwd {
 453     $ENV{'PWD'} = `cmd /c cd`;
 454     chop $ENV{'PWD'};
 455     $ENV{'PWD'} =~ s:\\:/:g ;
 456     return $ENV{'PWD'};
 457 }
 458
 459 sub _win32_cwd {
 460     $ENV{'PWD'} = Win32::GetCwd();
 461     $ENV{'PWD'} =~ s:\\:/:g ;
 462     return $ENV{'PWD'};
 463 }
 464
 465 *_NT_cwd = \&_win32_cwd if (!defined &_NT_cwd &&
 466                             defined &Win32::GetCwd);
 467
 468 *_NT_cwd = \&_os2_cwd unless defined &_NT_cwd;
 469
 470 sub _dos_cwd {
 471     if (!defined &Dos::GetCwd) {
 472         $ENV{'PWD'} = `command /c cd`;
 473         chop $ENV{'PWD'};
 474         $ENV{'PWD'} =~ s:\\:/:g ;
 475     } else {
 476         $ENV{'PWD'} = Dos::GetCwd();
 477     }
 478     return $ENV{'PWD'};
 479 }
 480
 481 sub _qnx_cwd {
 482         local $ENV{PATH} = '';
 483         local $ENV{CDPATH} = '';
 484         local $ENV{ENV} = '';
 485     $ENV{'PWD'} = `/usr/bin/fullpath -t`;
 486     chop $ENV{'PWD'};
 487     return $ENV{'PWD'};
 488 }
 489
 490 sub _qnx_abs_path {
 491         local $ENV{PATH} = '';
 492         local $ENV{CDPATH} = '';
 493         local $ENV{ENV} = '';
 494     my $path = @_ ? shift : '.';
 495     my $realpath=`/usr/bin/fullpath -t $path`;
 496     chop $realpath;
 497     return $realpath;
 498 }
 499
 500 sub _epoc_cwd {
 501     $ENV{'PWD'} = EPOC::getcwd();
 502     return $ENV{'PWD'};
 503 }
 504
 505 {
 506     no warnings;        # assignments trigger 'subroutine redefined' warning
 507
 508     if ($^O eq 'VMS') {
 509         *cwd            = \&_vms_cwd;
 510         *getcwd         = \&_vms_cwd;
 511         *fastcwd        = \&_vms_cwd;
 512         *fastgetcwd     = \&_vms_cwd;
 513         *abs_path       = \&_vms_abs_path;
 514         *fast_abs_path  = \&_vms_abs_path;
 515     }
 516     elsif ($^O eq 'NT' or $^O eq 'MSWin32') {
 517         # We assume that &_NT_cwd is defined as an XSUB or in the core.
 518         *cwd            = \&_NT_cwd;
 519         *getcwd         = \&_NT_cwd;
 520         *fastcwd        = \&_NT_cwd;
 521         *fastgetcwd     = \&_NT_cwd;
 522         *abs_path       = \&fast_abs_path;
 523         *realpath   = \&fast_abs_path;
 524     }
 525     elsif ($^O eq 'os2') {
 526         # sys_cwd may keep the builtin command
 527         *cwd            = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
 528         *getcwd         = \&cwd;
 529         *fastgetcwd     = \&cwd;
 530         *fastcwd        = \&cwd;
 531         *abs_path       = \&fast_abs_path;
 532     }
 533     elsif ($^O eq 'dos') {
 534         *cwd            = \&_dos_cwd;
 535         *getcwd         = \&_dos_cwd;
 536         *fastgetcwd     = \&_dos_cwd;
 537         *fastcwd        = \&_dos_cwd;
 538         *abs_path       = \&fast_abs_path;
 539     }
 540     elsif ($^O =~ m/^(?:qnx|nto)$/ ) {
 541         *cwd            = \&_qnx_cwd;
 542         *getcwd         = \&_qnx_cwd;
 543         *fastgetcwd     = \&_qnx_cwd;
 544         *fastcwd        = \&_qnx_cwd;
 545         *abs_path       = \&_qnx_abs_path;
 546         *fast_abs_path  = \&_qnx_abs_path;
 547     }
 548     elsif ($^O eq 'cygwin') {
 549         *getcwd = \&cwd;
 550         *fastgetcwd     = \&cwd;
 551         *fastcwd        = \&cwd;
 552         *abs_path       = \&fast_abs_path;
 553     }
 554     elsif ($^O eq 'epoc') {
 555         *cwd            = \&_epoc_cwd;
 556         *getcwd         = \&_epoc_cwd;
 557         *fastgetcwd     = \&_epoc_cwd;
 558         *fastcwd        = \&_epoc_cwd;
 559         *abs_path       = \&fast_abs_path;
 560     }
 561     elsif ($^O eq 'MacOS') {
 562         *getcwd     = \&cwd;
 563         *fastgetcwd = \&cwd;
 564         *fastcwd    = \&cwd;
 565         *abs_path   = \&fast_abs_path;
 566     }
 567 }
 568
 569
 570 1;