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