| 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() (and, on Win32, getdcwd()) 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 |
=item getdcwd |
| 70 |
|
| 71 |
my $cwd = getdcwd(); |
| 72 |
my $cwd = getdcwd('C:'); |
| 73 |
|
| 74 |
The getdcwd() function is also provided on Win32 to get the current working |
| 75 |
directory on the specified drive, since Windows maintains a separate current |
| 76 |
working directory for each drive. If no drive is specified then the current |
| 77 |
drive is assumed. |
| 78 |
|
| 79 |
This function simply calls the Microsoft C library _getdcwd() function. |
| 80 |
|
| 81 |
=back |
| 82 |
|
| 83 |
|
| 84 |
=head2 abs_path and friends |
| 85 |
|
| 86 |
These functions are exported only on request. They each take a single |
| 87 |
argument and return the absolute pathname for it. If no argument is |
| 88 |
given they'll use the current working directory. |
| 89 |
|
| 90 |
=over 4 |
| 91 |
|
| 92 |
=item abs_path |
| 93 |
|
| 94 |
my $abs_path = abs_path($file); |
| 95 |
|
| 96 |
Uses the same algorithm as getcwd(). Symbolic links and relative-path |
| 97 |
components ("." and "..") are resolved to return the canonical |
| 98 |
pathname, just like realpath(3). |
| 99 |
|
| 100 |
=item realpath |
| 101 |
|
| 102 |
my $abs_path = realpath($file); |
| 103 |
|
| 104 |
A synonym for abs_path(). |
| 105 |
|
| 106 |
=item fast_abs_path |
| 107 |
|
| 108 |
my $abs_path = fast_abs_path($file); |
| 109 |
|
| 110 |
A more dangerous, but potentially faster version of abs_path. |
| 111 |
|
| 112 |
=back |
| 113 |
|
| 114 |
=head2 $ENV{PWD} |
| 115 |
|
| 116 |
If you ask to override your chdir() built-in function, |
| 117 |
|
| 118 |
use Cwd qw(chdir); |
| 119 |
|
| 120 |
then your PWD environment variable will be kept up to date. Note that |
| 121 |
it will only be kept up to date if all packages which use chdir import |
| 122 |
it from Cwd. |
| 123 |
|
| 124 |
|
| 125 |
=head1 NOTES |
| 126 |
|
| 127 |
=over 4 |
| 128 |
|
| 129 |
=item * |
| 130 |
|
| 131 |
Since the path seperators are different on some operating systems ('/' |
| 132 |
on Unix, ':' on MacPerl, etc...) we recommend you use the File::Spec |
| 133 |
modules wherever portability is a concern. |
| 134 |
|
| 135 |
=item * |
| 136 |
|
| 137 |
Actually, on Mac OS, the C<getcwd()>, C<fastgetcwd()> and C<fastcwd()> |
| 138 |
functions are all aliases for the C<cwd()> function, which, on Mac OS, |
| 139 |
calls `pwd`. Likewise, the C<abs_path()> function is an alias for |
| 140 |
C<fast_abs_path()>. |
| 141 |
|
| 142 |
=back |
| 143 |
|
| 144 |
=head1 AUTHOR |
| 145 |
|
| 146 |
Originally by the perl5-porters. |
| 147 |
|
| 148 |
Maintained by Ken Williams <KWILLIAMS@cpan.org> |
| 149 |
|
| 150 |
=head1 COPYRIGHT |
| 151 |
|
| 152 |
Copyright (c) 2004 by the Perl 5 Porters. All rights reserved. |
| 153 |
|
| 154 |
This program is free software; you can redistribute it and/or modify |
| 155 |
it under the same terms as Perl itself. |
| 156 |
|
| 157 |
Portions of the C code in this library are copyright (c) 1994 by the |
| 158 |
Regents of the University of California. All rights reserved. The |
| 159 |
license on this code is compatible with the licensing of the rest of |
| 160 |
the distribution - please see the source code in F<Cwd.xs> for the |
| 161 |
details. |
| 162 |
|
| 163 |
=head1 SEE ALSO |
| 164 |
|
| 165 |
L<File::chdir> |
| 166 |
|
| 167 |
=cut |
| 168 |
|
| 169 |
use strict; |
| 170 |
use Exporter; |
| 171 |
use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION); |
| 172 |
|
| 173 |
$VERSION = '3.05'; |
| 174 |
|
| 175 |
@ISA = qw/ Exporter /; |
| 176 |
@EXPORT = qw(cwd getcwd fastcwd fastgetcwd); |
| 177 |
push @EXPORT, qw(getdcwd) if $^O eq 'MSWin32'; |
| 178 |
@EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath); |
| 179 |
|
| 180 |
# sys_cwd may keep the builtin command |
| 181 |
|
| 182 |
# All the functionality of this module may provided by builtins, |
| 183 |
# there is no sense to process the rest of the file. |
| 184 |
# The best choice may be to have this in BEGIN, but how to return from BEGIN? |
| 185 |
|
| 186 |
if ($^O eq 'os2') { |
| 187 |
local $^W = 0; |
| 188 |
|
| 189 |
*cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd; |
| 190 |
*getcwd = \&cwd; |
| 191 |
*fastgetcwd = \&cwd; |
| 192 |
*fastcwd = \&cwd; |
| 193 |
|
| 194 |
*fast_abs_path = \&sys_abspath if defined &sys_abspath; |
| 195 |
*abs_path = \&fast_abs_path; |
| 196 |
*realpath = \&fast_abs_path; |
| 197 |
*fast_realpath = \&fast_abs_path; |
| 198 |
|
| 199 |
return 1; |
| 200 |
} |
| 201 |
|
| 202 |
# If loading the XS stuff doesn't work, we can fall back to pure perl |
| 203 |
eval { |
| 204 |
if ( $] >= 5.006 ) { |
| 205 |
require XSLoader; |
| 206 |
XSLoader::load( __PACKAGE__, $VERSION ); |
| 207 |
} else { |
| 208 |
require DynaLoader; |
| 209 |
push @ISA, 'DynaLoader'; |
| 210 |
__PACKAGE__->bootstrap( $VERSION ); |
| 211 |
} |
| 212 |
}; |
| 213 |
|
| 214 |
# Must be after the DynaLoader stuff: |
| 215 |
$VERSION = eval $VERSION; |
| 216 |
|
| 217 |
# Big nasty table of function aliases |
| 218 |
my %METHOD_MAP = |
| 219 |
( |
| 220 |
VMS => |
| 221 |
{ |
| 222 |
cwd => '_vms_cwd', |
| 223 |
getcwd => '_vms_cwd', |
| 224 |
fastcwd => '_vms_cwd', |
| 225 |
fastgetcwd => '_vms_cwd', |
| 226 |
abs_path => '_vms_abs_path', |
| 227 |
fast_abs_path => '_vms_abs_path', |
| 228 |
}, |
| 229 |
|
| 230 |
MSWin32 => |
| 231 |
{ |
| 232 |
# We assume that &_NT_cwd is defined as an XSUB or in the core. |
| 233 |
cwd => '_NT_cwd', |
| 234 |
getcwd => '_NT_cwd', |
| 235 |
fastcwd => '_NT_cwd', |
| 236 |
fastgetcwd => '_NT_cwd', |
| 237 |
abs_path => 'fast_abs_path', |
| 238 |
realpath => 'fast_abs_path', |
| 239 |
}, |
| 240 |
|
| 241 |
dos => |
| 242 |
{ |
| 243 |
cwd => '_dos_cwd', |
| 244 |
getcwd => '_dos_cwd', |
| 245 |
fastgetcwd => '_dos_cwd', |
| 246 |
fastcwd => '_dos_cwd', |
| 247 |
abs_path => 'fast_abs_path', |
| 248 |
}, |
| 249 |
|
| 250 |
qnx => |
| 251 |
{ |
| 252 |
cwd => '_qnx_cwd', |
| 253 |
getcwd => '_qnx_cwd', |
| 254 |
fastgetcwd => '_qnx_cwd', |
| 255 |
fastcwd => '_qnx_cwd', |
| 256 |
abs_path => '_qnx_abs_path', |
| 257 |
fast_abs_path => '_qnx_abs_path', |
| 258 |
}, |
| 259 |
|
| 260 |
cygwin => |
| 261 |
{ |
| 262 |
getcwd => 'cwd', |
| 263 |
fastgetcwd => 'cwd', |
| 264 |
fastcwd => 'cwd', |
| 265 |
abs_path => 'fast_abs_path', |
| 266 |
realpath => 'fast_abs_path', |
| 267 |
}, |
| 268 |
|
| 269 |
epoc => |
| 270 |
{ |
| 271 |
cwd => '_epoc_cwd', |
| 272 |
getcwd => '_epoc_cwd', |
| 273 |
fastgetcwd => '_epoc_cwd', |
| 274 |
fastcwd => '_epoc_cwd', |
| 275 |
abs_path => 'fast_abs_path', |
| 276 |
}, |
| 277 |
|
| 278 |
MacOS => |
| 279 |
{ |
| 280 |
getcwd => 'cwd', |
| 281 |
fastgetcwd => 'cwd', |
| 282 |
fastcwd => 'cwd', |
| 283 |
abs_path => 'fast_abs_path', |
| 284 |
}, |
| 285 |
); |
| 286 |
|
| 287 |
$METHOD_MAP{NT} = $METHOD_MAP{MSWin32}; |
| 288 |
$METHOD_MAP{nto} = $METHOD_MAP{qnx}; |
| 289 |
|
| 290 |
|
| 291 |
# Find the pwd command in the expected locations. We assume these |
| 292 |
# are safe. This prevents _backtick_pwd() consulting $ENV{PATH} |
| 293 |
# so everything works under taint mode. |
| 294 |
my $pwd_cmd; |
| 295 |
foreach my $try ('/bin/pwd', |
| 296 |
'/usr/bin/pwd', |
| 297 |
'/QOpenSys/bin/pwd', # OS/400 PASE. |
| 298 |
) { |
| 299 |
|
| 300 |
if( -x $try ) { |
| 301 |
$pwd_cmd = $try; |
| 302 |
last; |
| 303 |
} |
| 304 |
} |
| 305 |
unless ($pwd_cmd) { |
| 306 |
# Isn't this wrong? _backtick_pwd() will fail if somenone has |
| 307 |
# pwd in their path but it is not /bin/pwd or /usr/bin/pwd? |
| 308 |
# See [perl #16774]. --jhi |
| 309 |
$pwd_cmd = 'pwd'; |
| 310 |
} |
| 311 |
|
| 312 |
# Lazy-load Carp |
| 313 |
sub _carp { require Carp; Carp::carp(@_) } |
| 314 |
sub _croak { require Carp; Carp::croak(@_) } |
| 315 |
|
| 316 |
# The 'natural and safe form' for UNIX (pwd may be setuid root) |
| 317 |
sub _backtick_pwd { |
| 318 |
local @ENV{qw(PATH IFS CDPATH ENV BASH_ENV)}; |
| 319 |
my $cwd = `$pwd_cmd`; |
| 320 |
# Belt-and-suspenders in case someone said "undef $/". |
| 321 |
local $/ = "\n"; |
| 322 |
# `pwd` may fail e.g. if the disk is full |
| 323 |
chomp($cwd) if defined $cwd; |
| 324 |
$cwd; |
| 325 |
} |
| 326 |
|
| 327 |
# Since some ports may predefine cwd internally (e.g., NT) |
| 328 |
# we take care not to override an existing definition for cwd(). |
| 329 |
|
| 330 |
unless ($METHOD_MAP{$^O}{cwd} or defined &cwd) { |
| 331 |
# The pwd command is not available in some chroot(2)'ed environments |
| 332 |
my $sep = $Config::Config{path_sep} || ':'; |
| 333 |
if( $^O eq 'MacOS' || (defined $ENV{PATH} && |
| 334 |
$^O ne 'MSWin32' && # no pwd on Windows |
| 335 |
grep { -x "$_/pwd" } split($sep, $ENV{PATH})) ) |
| 336 |
{ |
| 337 |
*cwd = \&_backtick_pwd; |
| 338 |
} |
| 339 |
else { |
| 340 |
*cwd = \&getcwd; |
| 341 |
} |
| 342 |
} |
| 343 |
|
| 344 |
# set a reasonable (and very safe) default for fastgetcwd, in case it |
| 345 |
# isn't redefined later (20001212 rspier) |
| 346 |
*fastgetcwd = \&cwd; |
| 347 |
|
| 348 |
# By Brandon S. Allbery |
| 349 |
# |
| 350 |
# Usage: $cwd = getcwd(); |
| 351 |
|
| 352 |
sub getcwd |
| 353 |
{ |
| 354 |
abs_path('.'); |
| 355 |
} |
| 356 |
|
| 357 |
|
| 358 |
# By John Bazik |
| 359 |
# |
| 360 |
# Usage: $cwd = &fastcwd; |
| 361 |
# |
| 362 |
# This is a faster version of getcwd. It's also more dangerous because |
| 363 |
# you might chdir out of a directory that you can't chdir back into. |
| 364 |
|
| 365 |
sub fastcwd_ { |
| 366 |
my($odev, $oino, $cdev, $cino, $tdev, $tino); |
| 367 |
my(@path, $path); |
| 368 |
local(*DIR); |
| 369 |
|
| 370 |
my($orig_cdev, $orig_cino) = stat('.'); |
| 371 |
($cdev, $cino) = ($orig_cdev, $orig_cino); |
| 372 |
for (;;) { |
| 373 |
my $direntry; |
| 374 |
($odev, $oino) = ($cdev, $cino); |
| 375 |
CORE::chdir('..') || return undef; |
| 376 |
($cdev, $cino) = stat('.'); |
| 377 |
last if $odev == $cdev && $oino == $cino; |
| 378 |
opendir(DIR, '.') || return undef; |
| 379 |
for (;;) { |
| 380 |
$direntry = readdir(DIR); |
| 381 |
last unless defined $direntry; |
| 382 |
next if $direntry eq '.'; |
| 383 |
next if $direntry eq '..'; |
| 384 |
|
| 385 |
($tdev, $tino) = lstat($direntry); |
| 386 |
last unless $tdev != $odev || $tino != $oino; |
| 387 |
} |
| 388 |
closedir(DIR); |
| 389 |
return undef unless defined $direntry; # should never happen |
| 390 |
unshift(@path, $direntry); |
| 391 |
} |
| 392 |
$path = '/' . join('/', @path); |
| 393 |
if ($^O eq 'apollo') { $path = "/".$path; } |
| 394 |
# At this point $path may be tainted (if tainting) and chdir would fail. |
| 395 |
# Untaint it then check that we landed where we started. |
| 396 |
$path =~ /^(.*)\z/s # untaint |
| 397 |
&& CORE::chdir($1) or return undef; |
| 398 |
($cdev, $cino) = stat('.'); |
| 399 |
die "Unstable directory path, current directory changed unexpectedly" |
| 400 |
if $cdev != $orig_cdev || $cino != $orig_cino; |
| 401 |
$path; |
| 402 |
} |
| 403 |
if (not defined &fastcwd) { *fastcwd = \&fastcwd_ } |
| 404 |
|
| 405 |
|
| 406 |
# Keeps track of current working directory in PWD environment var |
| 407 |
# Usage: |
| 408 |
# use Cwd 'chdir'; |
| 409 |
# chdir $newdir; |
| 410 |
|
| 411 |
my $chdir_init = 0; |
| 412 |
|
| 413 |
sub chdir_init { |
| 414 |
if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos' and $^O ne 'MSWin32') { |
| 415 |
my($dd,$di) = stat('.'); |
| 416 |
my($pd,$pi) = stat($ENV{'PWD'}); |
| 417 |
if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) { |
| 418 |
$ENV{'PWD'} = cwd(); |
| 419 |
} |
| 420 |
} |
| 421 |
else { |
| 422 |
my $wd = cwd(); |
| 423 |
$wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32'; |
| 424 |
$ENV{'PWD'} = $wd; |
| 425 |
} |
| 426 |
# Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar) |
| 427 |
if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) { |
| 428 |
my($pd,$pi) = stat($2); |
| 429 |
my($dd,$di) = stat($1); |
| 430 |
if (defined $pd and defined $dd and $di == $pi and $dd == $pd) { |
| 431 |
$ENV{'PWD'}="$2$3"; |
| 432 |
} |
| 433 |
} |
| 434 |
$chdir_init = 1; |
| 435 |
} |
| 436 |
|
| 437 |
sub chdir { |
| 438 |
my $newdir = @_ ? shift : ''; # allow for no arg (chdir to HOME dir) |
| 439 |
$newdir =~ s|///*|/|g unless $^O eq 'MSWin32'; |
| 440 |
chdir_init() unless $chdir_init; |
| 441 |
my $newpwd; |
| 442 |
if ($^O eq 'MSWin32') { |
| 443 |
# get the full path name *before* the chdir() |
| 444 |
$newpwd = Win32::GetFullPathName($newdir); |
| 445 |
} |
| 446 |
|
| 447 |
return 0 unless CORE::chdir $newdir; |
| 448 |
|
| 449 |
if ($^O eq 'VMS') { |
| 450 |
return $ENV{'PWD'} = $ENV{'DEFAULT'} |
| 451 |
} |
| 452 |
elsif ($^O eq 'MacOS') { |
| 453 |
return $ENV{'PWD'} = cwd(); |
| 454 |
} |
| 455 |
elsif ($^O eq 'MSWin32') { |
| 456 |
$ENV{'PWD'} = $newpwd; |
| 457 |
return 1; |
| 458 |
} |
| 459 |
|
| 460 |
if ($newdir =~ m#^/#s) { |
| 461 |
$ENV{'PWD'} = $newdir; |
| 462 |
} else { |
| 463 |
my @curdir = split(m#/#,$ENV{'PWD'}); |
| 464 |
@curdir = ('') unless @curdir; |
| 465 |
my $component; |
| 466 |
foreach $component (split(m#/#, $newdir)) { |
| 467 |
next if $component eq '.'; |
| 468 |
pop(@curdir),next if $component eq '..'; |
| 469 |
push(@curdir,$component); |
| 470 |
} |
| 471 |
$ENV{'PWD'} = join('/',@curdir) || '/'; |
| 472 |
} |
| 473 |
1; |
| 474 |
} |
| 475 |
|
| 476 |
|
| 477 |
sub _perl_abs_path |
| 478 |
{ |
| 479 |
my $start = @_ ? shift : '.'; |
| 480 |
my($dotdots, $cwd, @pst, @cst, $dir, @tst); |
| 481 |
|
| 482 |
unless (@cst = stat( $start )) |
| 483 |
{ |
| 484 |
_carp("stat($start): $!"); |
| 485 |
return ''; |
| 486 |
} |
| 487 |
|
| 488 |
unless (-d _) { |
| 489 |
# Make sure we can be invoked on plain files, not just directories. |
| 490 |
# NOTE that this routine assumes that '/' is the only directory separator. |
| 491 |
|
| 492 |
my ($dir, $file) = $start =~ m{^(.*)/(.+)$} |
| 493 |
or return cwd() . '/' . $start; |
| 494 |
|
| 495 |
# Can't use "-l _" here, because the previous stat was a stat(), not an lstat(). |
| 496 |
if (-l $start) { |
| 497 |
my $link_target = readlink($start); |
| 498 |
die "Can't resolve link $start: $!" unless defined $link_target; |
| 499 |
|
| 500 |
require File::Spec; |
| 501 |
$link_target = $dir . '/' . $link_target |
| 502 |
unless File::Spec->file_name_is_absolute($link_target); |
| 503 |
|
| 504 |
return abs_path($link_target); |
| 505 |
} |
| 506 |
|
| 507 |
return $dir ? abs_path($dir) . "/$file" : "/$file"; |
| 508 |
} |
| 509 |
|
| 510 |
$cwd = ''; |
| 511 |
$dotdots = $start; |
| 512 |
do |
| 513 |
{ |
| 514 |
$dotdots .= '/..'; |
| 515 |
@pst = @cst; |
| 516 |
local *PARENT; |
| 517 |
unless (opendir(PARENT, $dotdots)) |
| 518 |
{ |
| 519 |
_carp("opendir($dotdots): $!"); |
| 520 |
return ''; |
| 521 |
} |
| 522 |
unless (@cst = stat($dotdots)) |
| 523 |
{ |
| 524 |
_carp("stat($dotdots): $!"); |
| 525 |
closedir(PARENT); |
| 526 |
return ''; |
| 527 |
} |
| 528 |
if ($pst[0] == $cst[0] && $pst[1] == $cst[1]) |
| 529 |
{ |
| 530 |
$dir = undef; |
| 531 |
} |
| 532 |
else |
| 533 |
{ |
| 534 |
do |
| 535 |
{ |
| 536 |
unless (defined ($dir = readdir(PARENT))) |
| 537 |
{ |
| 538 |
_carp("readdir($dotdots): $!"); |
| 539 |
closedir(PARENT); |
| 540 |
return ''; |
| 541 |
} |
| 542 |
$tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir")) |
| 543 |
} |
| 544 |
while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] || |
| 545 |
$tst[1] != $pst[1]); |
| 546 |
} |
| 547 |
$cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ; |
| 548 |
closedir(PARENT); |
| 549 |
} while (defined $dir); |
| 550 |
chop($cwd) unless $cwd eq '/'; # drop the trailing / |
| 551 |
$cwd; |
| 552 |
} |
| 553 |
|
| 554 |
|
| 555 |
my $Curdir; |
| 556 |
sub fast_abs_path { |
| 557 |
local $ENV{PWD} = $ENV{PWD} || ''; # Guard against clobberage |
| 558 |
my $cwd = getcwd(); |
| 559 |
require File::Spec; |
| 560 |
my $path = @_ ? shift : ($Curdir ||= File::Spec->curdir); |
| 561 |
|
| 562 |
# Detaint else we'll explode in taint mode. This is safe because |
| 563 |
# we're not doing anything dangerous with it. |
| 564 |
($path) = $path =~ /(.*)/; |
| 565 |
($cwd) = $cwd =~ /(.*)/; |
| 566 |
|
| 567 |
unless (-e $path) { |
| 568 |
_croak("$path: No such file or directory"); |
| 569 |
} |
| 570 |
|
| 571 |
unless (-d _) { |
| 572 |
# Make sure we can be invoked on plain files, not just directories. |
| 573 |
|
| 574 |
my ($vol, $dir, $file) = File::Spec->splitpath($path); |
| 575 |
return File::Spec->catfile($cwd, $path) unless length $dir; |
| 576 |
|
| 577 |
if (-l $path) { |
| 578 |
my $link_target = readlink($path); |
| 579 |
die "Can't resolve link $path: $!" unless defined $link_target; |
| 580 |
|
| 581 |
$link_target = File::Spec->catpath($vol, $dir, $link_target) |
| 582 |
unless File::Spec->file_name_is_absolute($link_target); |
| 583 |
|
| 584 |
return fast_abs_path($link_target); |
| 585 |
} |
| 586 |
|
| 587 |
my $tdir = $dir; |
| 588 |
$tdir =~ s!\\!/!g if $^O eq 'MSWin32'; |
| 589 |
return $tdir eq File::Spec->rootdir |
| 590 |
? File::Spec->catpath($vol, $dir, $file) |
| 591 |
: fast_abs_path(File::Spec->catpath($vol, $dir, '')) . '/' . $file; |
| 592 |
} |
| 593 |
|
| 594 |
if (!CORE::chdir($path)) { |
| 595 |
_croak("Cannot chdir to $path: $!"); |
| 596 |
} |
| 597 |
my $realpath = getcwd(); |
| 598 |
if (! ((-d $cwd) && (CORE::chdir($cwd)))) { |
| 599 |
_croak("Cannot chdir back to $cwd: $!"); |
| 600 |
} |
| 601 |
$realpath; |
| 602 |
} |
| 603 |
|
| 604 |
# added function alias to follow principle of least surprise |
| 605 |
# based on previous aliasing. --tchrist 27-Jan-00 |
| 606 |
*fast_realpath = \&fast_abs_path; |
| 607 |
|
| 608 |
|
| 609 |
# --- PORTING SECTION --- |
| 610 |
|
| 611 |
# VMS: $ENV{'DEFAULT'} points to default directory at all times |
| 612 |
# 06-Mar-1996 Charles Bailey bailey@newman.upenn.edu |
| 613 |
# Note: Use of Cwd::chdir() causes the logical name PWD to be defined |
| 614 |
# in the process logical name table as the default device and directory |
| 615 |
# seen by Perl. This may not be the same as the default device |
| 616 |
# and directory seen by DCL after Perl exits, since the effects |
| 617 |
# the CRTL chdir() function persist only until Perl exits. |
| 618 |
|
| 619 |
sub _vms_cwd { |
| 620 |
return $ENV{'DEFAULT'}; |
| 621 |
} |
| 622 |
|
| 623 |
sub _vms_abs_path { |
| 624 |
return $ENV{'DEFAULT'} unless @_; |
| 625 |
|
| 626 |
# may need to turn foo.dir into [.foo] |
| 627 |
my $path = VMS::Filespec::pathify($_[0]); |
| 628 |
$path = $_[0] unless defined $path; |
| 629 |
|
| 630 |
return VMS::Filespec::rmsexpand($path); |
| 631 |
} |
| 632 |
|
| 633 |
sub _os2_cwd { |
| 634 |
$ENV{'PWD'} = `cmd /c cd`; |
| 635 |
chomp $ENV{'PWD'}; |
| 636 |
$ENV{'PWD'} =~ s:\\:/:g ; |
| 637 |
return $ENV{'PWD'}; |
| 638 |
} |
| 639 |
|
| 640 |
sub _win32_cwd { |
| 641 |
$ENV{'PWD'} = Win32::GetCwd(); |
| 642 |
$ENV{'PWD'} =~ s:\\:/:g ; |
| 643 |
return $ENV{'PWD'}; |
| 644 |
} |
| 645 |
|
| 646 |
*_NT_cwd = \&_win32_cwd if (!defined &_NT_cwd && |
| 647 |
defined &Win32::GetCwd); |
| 648 |
|
| 649 |
*_NT_cwd = \&_os2_cwd unless defined &_NT_cwd; |
| 650 |
|
| 651 |
sub _dos_cwd { |
| 652 |
if (!defined &Dos::GetCwd) { |
| 653 |
$ENV{'PWD'} = `command /c cd`; |
| 654 |
chomp $ENV{'PWD'}; |
| 655 |
$ENV{'PWD'} =~ s:\\:/:g ; |
| 656 |
} else { |
| 657 |
$ENV{'PWD'} = Dos::GetCwd(); |
| 658 |
} |
| 659 |
return $ENV{'PWD'}; |
| 660 |
} |
| 661 |
|
| 662 |
sub _qnx_cwd { |
| 663 |
local $ENV{PATH} = ''; |
| 664 |
local $ENV{CDPATH} = ''; |
| 665 |
local $ENV{ENV} = ''; |
| 666 |
$ENV{'PWD'} = `/usr/bin/fullpath -t`; |
| 667 |
chomp $ENV{'PWD'}; |
| 668 |
return $ENV{'PWD'}; |
| 669 |
} |
| 670 |
|
| 671 |
sub _qnx_abs_path { |
| 672 |
local $ENV{PATH} = ''; |
| 673 |
local $ENV{CDPATH} = ''; |
| 674 |
local $ENV{ENV} = ''; |
| 675 |
my $path = @_ ? shift : '.'; |
| 676 |
local *REALPATH; |
| 677 |
|
| 678 |
defined( open(REALPATH, '-|') || exec '/usr/bin/fullpath', '-t', $path ) or |
| 679 |
die "Can't open /usr/bin/fullpath: $!"; |
| 680 |
my $realpath = <REALPATH>; |
| 681 |
close REALPATH; |
| 682 |
chomp $realpath; |
| 683 |
return $realpath; |
| 684 |
} |
| 685 |
|
| 686 |
sub _epoc_cwd { |
| 687 |
$ENV{'PWD'} = EPOC::getcwd(); |
| 688 |
return $ENV{'PWD'}; |
| 689 |
} |
| 690 |
|
| 691 |
|
| 692 |
# Now that all the base-level functions are set up, alias the |
| 693 |
# user-level functions to the right places |
| 694 |
|
| 695 |
if (exists $METHOD_MAP{$^O}) { |
| 696 |
my $map = $METHOD_MAP{$^O}; |
| 697 |
foreach my $name (keys %$map) { |
| 698 |
local $^W = 0; # assignments trigger 'subroutine redefined' warning |
| 699 |
no strict 'refs'; |
| 700 |
*{$name} = \&{$map->{$name}}; |
| 701 |
} |
| 702 |
} |
| 703 |
|
| 704 |
# In case the XS version doesn't load. |
| 705 |
*abs_path = \&_perl_abs_path unless defined &abs_path; |
| 706 |
|
| 707 |
# added function alias for those of us more |
| 708 |
# used to the libc function. --tchrist 27-Jan-00 |
| 709 |
*realpath = \&abs_path; |
| 710 |
|
| 711 |
1; |
