1package Cwd; 2 3=head1 NAME 4 5Cwd - 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 17This module provides functions for determining the pathname of the 18current working directory. It is recommended that getcwd (or another 19*cwd() function) be used in I<all> code to ensure portability. 20 21By default, it exports the functions cwd(), getcwd(), fastcwd(), and 22fastgetcwd() (and, on Win32, getdcwd()) into the caller's namespace. 23 24 25=head2 getcwd and friends 26 27Each of these functions are called without arguments and return the 28absolute path of the current working directory. 29 30=over 4 31 32=item getcwd 33 34 my $cwd = getcwd(); 35 36Returns the current working directory. 37 38Exposes the POSIX function getcwd(3) or re-implements it if it's not 39available. 40 41=item cwd 42 43 my $cwd = cwd(); 44 45The cwd() is the most natural form for the current architecture. For 46most systems it is identical to `pwd` (but without the trailing line 47terminator). 48 49=item fastcwd 50 51 my $cwd = fastcwd(); 52 53A more dangerous version of getcwd(), but potentially faster. 54 55It might conceivably chdir() you out of a directory that it can't 56chdir() you back into. If fastcwd encounters a problem it will return 57undef but will probably leave you in a different directory. For a 58measure of extra security, if everything appears to have worked, the 59fastcwd() function will check that it leaves you in the same directory 60that it started in. If it has changed it will C<die> with the message 61"Unstable directory path, current directory changed 62unexpectedly". That should never happen. 63 64=item fastgetcwd 65 66 my $cwd = fastgetcwd(); 67 68The fastgetcwd() function is provided as a synonym for cwd(). 69 70=item getdcwd 71 72 my $cwd = getdcwd(); 73 my $cwd = getdcwd('C:'); 74 75The getdcwd() function is also provided on Win32 to get the current working 76directory on the specified drive, since Windows maintains a separate current 77working directory for each drive. If no drive is specified then the current 78drive is assumed. 79 80This function simply calls the Microsoft C library _getdcwd() function. 81 82=back 83 84 85=head2 abs_path and friends 86 87These functions are exported only on request. They each take a single 88argument and return the absolute pathname for it. If no argument is 89given they'll use the current working directory. 90 91=over 4 92 93=item abs_path 94 95 my $abs_path = abs_path($file); 96 97Uses the same algorithm as getcwd(). Symbolic links and relative-path 98components ("." and "..") are resolved to return the canonical 99pathname, just like realpath(3). 100 101=item realpath 102 103 my $abs_path = realpath($file); 104 105A synonym for abs_path(). 106 107=item fast_abs_path 108 109 my $abs_path = fast_abs_path($file); 110 111A more dangerous, but potentially faster version of abs_path. 112 113=back 114 115=head2 $ENV{PWD} 116 117If you ask to override your chdir() built-in function, 118 119 use Cwd qw(chdir); 120 121then your PWD environment variable will be kept up to date. Note that 122it will only be kept up to date if all packages which use chdir import 123it from Cwd. 124 125 126=head1 NOTES 127 128=over 4 129 130=item * 131 132Since the path separators are different on some operating systems ('/' 133on Unix, ':' on MacPerl, etc...) we recommend you use the File::Spec 134modules wherever portability is a concern. 135 136=item * 137 138Actually, on Mac OS, the C<getcwd()>, C<fastgetcwd()> and C<fastcwd()> 139functions are all aliases for the C<cwd()> function, which, on Mac OS, 140calls `pwd`. Likewise, the C<abs_path()> function is an alias for 141C<fast_abs_path()>. 142 143=back 144 145=head1 AUTHOR 146 147Originally by the perl5-porters. 148 149Maintained by Ken Williams <KWILLIAMS@cpan.org> 150 151=head1 COPYRIGHT 152 153Copyright (c) 2004 by the Perl 5 Porters. All rights reserved. 154 155This program is free software; you can redistribute it and/or modify 156it under the same terms as Perl itself. 157 158Portions of the C code in this library are copyright (c) 1994 by the 159Regents of the University of California. All rights reserved. The 160license on this code is compatible with the licensing of the rest of 161the distribution - please see the source code in F<Cwd.xs> for the 162details. 163 164=head1 SEE ALSO 165 166L<File::chdir> 167 168=cut 169 170use strict; 171use Exporter; 172use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION); 173 174$VERSION = '3.48_03'; 175my $xs_version = $VERSION; 176$VERSION =~ tr/_//; 177 178@ISA = qw/ Exporter /; 179@EXPORT = qw(cwd getcwd fastcwd fastgetcwd); 180push @EXPORT, qw(getdcwd) if $^O eq 'MSWin32'; 181@EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath); 182 183# sys_cwd may keep the builtin command 184 185# All the functionality of this module may provided by builtins, 186# there is no sense to process the rest of the file. 187# The best choice may be to have this in BEGIN, but how to return from BEGIN? 188 189if ($^O eq 'os2') { 190 local $^W = 0; 191 192 *cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd; 193 *getcwd = \&cwd; 194 *fastgetcwd = \&cwd; 195 *fastcwd = \&cwd; 196 197 *fast_abs_path = \&sys_abspath if defined &sys_abspath; 198 *abs_path = \&fast_abs_path; 199 *realpath = \&fast_abs_path; 200 *fast_realpath = \&fast_abs_path; 201 202 return 1; 203} 204 205# Need to look up the feature settings on VMS. The preferred way is to use the 206# VMS::Feature module, but that may not be available to dual life modules. 207 208my $use_vms_feature; 209BEGIN { 210 if ($^O eq 'VMS') { 211 if (eval { local $SIG{__DIE__}; 212 local @INC = @INC; 213 pop @INC if $INC[-1] eq '.'; 214 require VMS::Feature; }) { 215 $use_vms_feature = 1; 216 } 217 } 218} 219 220# Need to look up the UNIX report mode. This may become a dynamic mode 221# in the future. 222sub _vms_unix_rpt { 223 my $unix_rpt; 224 if ($use_vms_feature) { 225 $unix_rpt = VMS::Feature::current("filename_unix_report"); 226 } else { 227 my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; 228 $unix_rpt = $env_unix_rpt =~ /^[ET1]/i; 229 } 230 return $unix_rpt; 231} 232 233# Need to look up the EFS character set mode. This may become a dynamic 234# mode in the future. 235sub _vms_efs { 236 my $efs; 237 if ($use_vms_feature) { 238 $efs = VMS::Feature::current("efs_charset"); 239 } else { 240 my $env_efs = $ENV{'DECC$EFS_CHARSET'} || ''; 241 $efs = $env_efs =~ /^[ET1]/i; 242 } 243 return $efs; 244} 245 246 247# If loading the XS stuff doesn't work, we can fall back to pure perl 248unless (defined &getcwd) { 249 eval { 250 if ( $] >= 5.006 ) { 251 require XSLoader; 252 XSLoader::load( __PACKAGE__, $xs_version); 253 } else { 254 require DynaLoader; 255 push @ISA, 'DynaLoader'; 256 __PACKAGE__->bootstrap( $xs_version ); 257 } 258 }; 259} 260 261# Big nasty table of function aliases 262my %METHOD_MAP = 263 ( 264 VMS => 265 { 266 cwd => '_vms_cwd', 267 getcwd => '_vms_cwd', 268 fastcwd => '_vms_cwd', 269 fastgetcwd => '_vms_cwd', 270 abs_path => '_vms_abs_path', 271 fast_abs_path => '_vms_abs_path', 272 }, 273 274 MSWin32 => 275 { 276 # We assume that &_NT_cwd is defined as an XSUB or in the core. 277 cwd => '_NT_cwd', 278 getcwd => '_NT_cwd', 279 fastcwd => '_NT_cwd', 280 fastgetcwd => '_NT_cwd', 281 abs_path => 'fast_abs_path', 282 realpath => 'fast_abs_path', 283 }, 284 285 dos => 286 { 287 cwd => '_dos_cwd', 288 getcwd => '_dos_cwd', 289 fastgetcwd => '_dos_cwd', 290 fastcwd => '_dos_cwd', 291 abs_path => 'fast_abs_path', 292 }, 293 294 # QNX4. QNX6 has a $os of 'nto'. 295 qnx => 296 { 297 cwd => '_qnx_cwd', 298 getcwd => '_qnx_cwd', 299 fastgetcwd => '_qnx_cwd', 300 fastcwd => '_qnx_cwd', 301 abs_path => '_qnx_abs_path', 302 fast_abs_path => '_qnx_abs_path', 303 }, 304 305 cygwin => 306 { 307 getcwd => 'cwd', 308 fastgetcwd => 'cwd', 309 fastcwd => 'cwd', 310 abs_path => 'fast_abs_path', 311 realpath => 'fast_abs_path', 312 }, 313 314 epoc => 315 { 316 cwd => '_epoc_cwd', 317 getcwd => '_epoc_cwd', 318 fastgetcwd => '_epoc_cwd', 319 fastcwd => '_epoc_cwd', 320 abs_path => 'fast_abs_path', 321 }, 322 323 MacOS => 324 { 325 getcwd => 'cwd', 326 fastgetcwd => 'cwd', 327 fastcwd => 'cwd', 328 abs_path => 'fast_abs_path', 329 }, 330 ); 331 332$METHOD_MAP{NT} = $METHOD_MAP{MSWin32}; 333 334 335# Find the pwd command in the expected locations. We assume these 336# are safe. This prevents _backtick_pwd() consulting $ENV{PATH} 337# so everything works under taint mode. 338my $pwd_cmd; 339foreach my $try ('/bin/pwd', 340 '/usr/bin/pwd', 341 '/QOpenSys/bin/pwd', # OS/400 PASE. 342 ) { 343 344 if( -x $try ) { 345 $pwd_cmd = $try; 346 last; 347 } 348} 349 350# Android has a built-in pwd. Using $pwd_cmd will DTRT if 351# this perl was compiled with -Dd_useshellcmds, which is the 352# default for Android, but the block below is needed for the 353# miniperl running on the host when cross-compiling, and 354# potentially for native builds with -Ud_useshellcmds. 355if ($^O =~ /android/) { 356 # If targetsh is executable, then we're either a full 357 # perl, or a miniperl for a native build. 358 if (-x $Config::Config{targetsh}) { 359 $pwd_cmd = "$Config::Config{targetsh} -c pwd" 360 } 361 else { 362 my $sh = $Config::Config{sh} || (-x '/system/bin/sh' ? '/system/bin/sh' : 'sh'); 363 $pwd_cmd = "$sh -c pwd" 364 } 365} 366 367my $found_pwd_cmd = defined($pwd_cmd); 368unless ($pwd_cmd) { 369 # Isn't this wrong? _backtick_pwd() will fail if someone has 370 # pwd in their path but it is not /bin/pwd or /usr/bin/pwd? 371 # See [perl #16774]. --jhi 372 $pwd_cmd = 'pwd'; 373} 374 375# Lazy-load Carp 376sub _carp { require Carp; Carp::carp(@_) } 377sub _croak { require Carp; Carp::croak(@_) } 378 379# The 'natural and safe form' for UNIX (pwd may be setuid root) 380sub _backtick_pwd { 381 # Localize %ENV entries in a way that won't create new hash keys 382 my @localize = grep exists $ENV{$_}, qw(PATH IFS CDPATH ENV BASH_ENV); 383 local @ENV{@localize}; 384 385 my $cwd = `$pwd_cmd`; 386 # Belt-and-suspenders in case someone said "undef $/". 387 local $/ = "\n"; 388 # `pwd` may fail e.g. if the disk is full 389 chomp($cwd) if defined $cwd; 390 $cwd; 391} 392 393# Since some ports may predefine cwd internally (e.g., NT) 394# we take care not to override an existing definition for cwd(). 395 396unless ($METHOD_MAP{$^O}{cwd} or defined &cwd) { 397 # The pwd command is not available in some chroot(2)'ed environments 398 my $sep = $Config::Config{path_sep} || ':'; 399 my $os = $^O; # Protect $^O from tainting 400 401 402 # Try again to find a pwd, this time searching the whole PATH. 403 if (defined $ENV{PATH} and $os ne 'MSWin32') { # no pwd on Windows 404 my @candidates = split($sep, $ENV{PATH}); 405 while (!$found_pwd_cmd and @candidates) { 406 my $candidate = shift @candidates; 407 $found_pwd_cmd = 1 if -x "$candidate/pwd"; 408 } 409 } 410 411 # MacOS has some special magic to make `pwd` work. 412 if( $os eq 'MacOS' || $found_pwd_cmd ) 413 { 414 *cwd = \&_backtick_pwd; 415 } 416 else { 417 *cwd = \&getcwd; 418 } 419} 420 421if ($^O eq 'cygwin') { 422 # We need to make sure cwd() is called with no args, because it's 423 # got an arg-less prototype and will die if args are present. 424 local $^W = 0; 425 my $orig_cwd = \&cwd; 426 *cwd = sub { &$orig_cwd() } 427} 428 429 430# set a reasonable (and very safe) default for fastgetcwd, in case it 431# isn't redefined later (20001212 rspier) 432*fastgetcwd = \&cwd; 433 434# A non-XS version of getcwd() - also used to bootstrap the perl build 435# process, when miniperl is running and no XS loading happens. 436sub _perl_getcwd 437{ 438 abs_path('.'); 439} 440 441# By John Bazik 442# 443# Usage: $cwd = &fastcwd; 444# 445# This is a faster version of getcwd. It's also more dangerous because 446# you might chdir out of a directory that you can't chdir back into. 447 448sub fastcwd_ { 449 my($odev, $oino, $cdev, $cino, $tdev, $tino); 450 my(@path, $path); 451 local(*DIR); 452 453 my($orig_cdev, $orig_cino) = stat('.'); 454 ($cdev, $cino) = ($orig_cdev, $orig_cino); 455 for (;;) { 456 my $direntry; 457 ($odev, $oino) = ($cdev, $cino); 458 CORE::chdir('..') || return undef; 459 ($cdev, $cino) = stat('.'); 460 last if $odev == $cdev && $oino == $cino; 461 opendir(DIR, '.') || return undef; 462 for (;;) { 463 $direntry = readdir(DIR); 464 last unless defined $direntry; 465 next if $direntry eq '.'; 466 next if $direntry eq '..'; 467 468 ($tdev, $tino) = lstat($direntry); 469 last unless $tdev != $odev || $tino != $oino; 470 } 471 closedir(DIR); 472 return undef unless defined $direntry; # should never happen 473 unshift(@path, $direntry); 474 } 475 $path = '/' . join('/', @path); 476 if ($^O eq 'apollo') { $path = "/".$path; } 477 # At this point $path may be tainted (if tainting) and chdir would fail. 478 # Untaint it then check that we landed where we started. 479 $path =~ /^(.*)\z/s # untaint 480 && CORE::chdir($1) or return undef; 481 ($cdev, $cino) = stat('.'); 482 die "Unstable directory path, current directory changed unexpectedly" 483 if $cdev != $orig_cdev || $cino != $orig_cino; 484 $path; 485} 486if (not defined &fastcwd) { *fastcwd = \&fastcwd_ } 487 488 489# Keeps track of current working directory in PWD environment var 490# Usage: 491# use Cwd 'chdir'; 492# chdir $newdir; 493 494my $chdir_init = 0; 495 496sub chdir_init { 497 if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos' and $^O ne 'MSWin32') { 498 my($dd,$di) = stat('.'); 499 my($pd,$pi) = stat($ENV{'PWD'}); 500 if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) { 501 $ENV{'PWD'} = cwd(); 502 } 503 } 504 else { 505 my $wd = cwd(); 506 $wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32'; 507 $ENV{'PWD'} = $wd; 508 } 509 # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar) 510 if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) { 511 my($pd,$pi) = stat($2); 512 my($dd,$di) = stat($1); 513 if (defined $pd and defined $dd and $di == $pi and $dd == $pd) { 514 $ENV{'PWD'}="$2$3"; 515 } 516 } 517 $chdir_init = 1; 518} 519 520sub chdir { 521 my $newdir = @_ ? shift : ''; # allow for no arg (chdir to HOME dir) 522 $newdir =~ s|///*|/|g unless $^O eq 'MSWin32'; 523 chdir_init() unless $chdir_init; 524 my $newpwd; 525 if ($^O eq 'MSWin32') { 526 # get the full path name *before* the chdir() 527 $newpwd = Win32::GetFullPathName($newdir); 528 } 529 530 return 0 unless CORE::chdir $newdir; 531 532 if ($^O eq 'VMS') { 533 return $ENV{'PWD'} = $ENV{'DEFAULT'} 534 } 535 elsif ($^O eq 'MacOS') { 536 return $ENV{'PWD'} = cwd(); 537 } 538 elsif ($^O eq 'MSWin32') { 539 $ENV{'PWD'} = $newpwd; 540 return 1; 541 } 542 543 if (ref $newdir eq 'GLOB') { # in case a file/dir handle is passed in 544 $ENV{'PWD'} = cwd(); 545 } elsif ($newdir =~ m#^/#s) { 546 $ENV{'PWD'} = $newdir; 547 } else { 548 my @curdir = split(m#/#,$ENV{'PWD'}); 549 @curdir = ('') unless @curdir; 550 my $component; 551 foreach $component (split(m#/#, $newdir)) { 552 next if $component eq '.'; 553 pop(@curdir),next if $component eq '..'; 554 push(@curdir,$component); 555 } 556 $ENV{'PWD'} = join('/',@curdir) || '/'; 557 } 558 1; 559} 560 561 562sub _perl_abs_path 563{ 564 my $start = @_ ? shift : '.'; 565 my($dotdots, $cwd, @pst, @cst, $dir, @tst); 566 567 unless (@cst = stat( $start )) 568 { 569 _carp("stat($start): $!"); 570 return ''; 571 } 572 573 unless (-d _) { 574 # Make sure we can be invoked on plain files, not just directories. 575 # NOTE that this routine assumes that '/' is the only directory separator. 576 577 my ($dir, $file) = $start =~ m{^(.*)/(.+)$} 578 or return cwd() . '/' . $start; 579 580 # Can't use "-l _" here, because the previous stat was a stat(), not an lstat(). 581 if (-l $start) { 582 my $link_target = readlink($start); 583 die "Can't resolve link $start: $!" unless defined $link_target; 584 585 require File::Spec; 586 $link_target = $dir . '/' . $link_target 587 unless File::Spec->file_name_is_absolute($link_target); 588 589 return abs_path($link_target); 590 } 591 592 return $dir ? abs_path($dir) . "/$file" : "/$file"; 593 } 594 595 $cwd = ''; 596 $dotdots = $start; 597 do 598 { 599 $dotdots .= '/..'; 600 @pst = @cst; 601 local *PARENT; 602 unless (opendir(PARENT, $dotdots)) 603 { 604 # probably a permissions issue. Try the native command. 605 require File::Spec; 606 return File::Spec->rel2abs( $start, _backtick_pwd() ); 607 } 608 unless (@cst = stat($dotdots)) 609 { 610 _carp("stat($dotdots): $!"); 611 closedir(PARENT); 612 return ''; 613 } 614 if ($pst[0] == $cst[0] && $pst[1] == $cst[1]) 615 { 616 $dir = undef; 617 } 618 else 619 { 620 do 621 { 622 unless (defined ($dir = readdir(PARENT))) 623 { 624 _carp("readdir($dotdots): $!"); 625 closedir(PARENT); 626 return ''; 627 } 628 $tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir")) 629 } 630 while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] || 631 $tst[1] != $pst[1]); 632 } 633 $cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ; 634 closedir(PARENT); 635 } while (defined $dir); 636 chop($cwd) unless $cwd eq '/'; # drop the trailing / 637 $cwd; 638} 639 640 641my $Curdir; 642sub fast_abs_path { 643 local $ENV{PWD} = $ENV{PWD} || ''; # Guard against clobberage 644 my $cwd = getcwd(); 645 require File::Spec; 646 my $path = @_ ? shift : ($Curdir ||= File::Spec->curdir); 647 648 # Detaint else we'll explode in taint mode. This is safe because 649 # we're not doing anything dangerous with it. 650 ($path) = $path =~ /(.*)/s; 651 ($cwd) = $cwd =~ /(.*)/s; 652 653 unless (-e $path) { 654 _croak("$path: No such file or directory"); 655 } 656 657 unless (-d _) { 658 # Make sure we can be invoked on plain files, not just directories. 659 660 my ($vol, $dir, $file) = File::Spec->splitpath($path); 661 return File::Spec->catfile($cwd, $path) unless length $dir; 662 663 if (-l $path) { 664 my $link_target = readlink($path); 665 die "Can't resolve link $path: $!" unless defined $link_target; 666 667 $link_target = File::Spec->catpath($vol, $dir, $link_target) 668 unless File::Spec->file_name_is_absolute($link_target); 669 670 return fast_abs_path($link_target); 671 } 672 673 return $dir eq File::Spec->rootdir 674 ? File::Spec->catpath($vol, $dir, $file) 675 : fast_abs_path(File::Spec->catpath($vol, $dir, '')) . '/' . $file; 676 } 677 678 if (!CORE::chdir($path)) { 679 _croak("Cannot chdir to $path: $!"); 680 } 681 my $realpath = getcwd(); 682 if (! ((-d $cwd) && (CORE::chdir($cwd)))) { 683 _croak("Cannot chdir back to $cwd: $!"); 684 } 685 $realpath; 686} 687 688# added function alias to follow principle of least surprise 689# based on previous aliasing. --tchrist 27-Jan-00 690*fast_realpath = \&fast_abs_path; 691 692 693# --- PORTING SECTION --- 694 695# VMS: $ENV{'DEFAULT'} points to default directory at all times 696# 06-Mar-1996 Charles Bailey bailey@newman.upenn.edu 697# Note: Use of Cwd::chdir() causes the logical name PWD to be defined 698# in the process logical name table as the default device and directory 699# seen by Perl. This may not be the same as the default device 700# and directory seen by DCL after Perl exits, since the effects 701# the CRTL chdir() function persist only until Perl exits. 702 703sub _vms_cwd { 704 return $ENV{'DEFAULT'}; 705} 706 707sub _vms_abs_path { 708 return $ENV{'DEFAULT'} unless @_; 709 my $path = shift; 710 711 my $efs = _vms_efs; 712 my $unix_rpt = _vms_unix_rpt; 713 714 if (defined &VMS::Filespec::vmsrealpath) { 715 my $path_unix = 0; 716 my $path_vms = 0; 717 718 $path_unix = 1 if ($path =~ m#(?<=\^)/#); 719 $path_unix = 1 if ($path =~ /^\.\.?$/); 720 $path_vms = 1 if ($path =~ m#[\[<\]]#); 721 $path_vms = 1 if ($path =~ /^--?$/); 722 723 my $unix_mode = $path_unix; 724 if ($efs) { 725 # In case of a tie, the Unix report mode decides. 726 if ($path_vms == $path_unix) { 727 $unix_mode = $unix_rpt; 728 } else { 729 $unix_mode = 0 if $path_vms; 730 } 731 } 732 733 if ($unix_mode) { 734 # Unix format 735 return VMS::Filespec::unixrealpath($path); 736 } 737 738 # VMS format 739 740 my $new_path = VMS::Filespec::vmsrealpath($path); 741 742 # Perl expects directories to be in directory format 743 $new_path = VMS::Filespec::pathify($new_path) if -d $path; 744 return $new_path; 745 } 746 747 # Fallback to older algorithm if correct ones are not 748 # available. 749 750 if (-l $path) { 751 my $link_target = readlink($path); 752 die "Can't resolve link $path: $!" unless defined $link_target; 753 754 return _vms_abs_path($link_target); 755 } 756 757 # may need to turn foo.dir into [.foo] 758 my $pathified = VMS::Filespec::pathify($path); 759 $path = $pathified if defined $pathified; 760 761 return VMS::Filespec::rmsexpand($path); 762} 763 764sub _os2_cwd { 765 $ENV{'PWD'} = `cmd /c cd`; 766 chomp $ENV{'PWD'}; 767 $ENV{'PWD'} =~ s:\\:/:g ; 768 return $ENV{'PWD'}; 769} 770 771sub _win32_cwd_simple { 772 $ENV{'PWD'} = `cd`; 773 chomp $ENV{'PWD'}; 774 $ENV{'PWD'} =~ s:\\:/:g ; 775 return $ENV{'PWD'}; 776} 777 778sub _win32_cwd { 779 # Need to avoid taking any sort of reference to the typeglob or the code in 780 # the optree, so that this tests the runtime state of things, as the 781 # ExtUtils::MakeMaker tests for "miniperl" need to be able to fake things at 782 # runtime by deleting the subroutine. *foo{THING} syntax on a symbol table 783 # lookup avoids needing a string eval, which has been reported to cause 784 # problems (for reasons that we haven't been able to get to the bottom of - 785 # rt.cpan.org #56225) 786 if (*{$DynaLoader::{boot_DynaLoader}}{CODE}) { 787 $ENV{'PWD'} = Win32::GetCwd(); 788 } 789 else { # miniperl 790 chomp($ENV{'PWD'} = `cd`); 791 } 792 $ENV{'PWD'} =~ s:\\:/:g ; 793 return $ENV{'PWD'}; 794} 795 796*_NT_cwd = defined &Win32::GetCwd ? \&_win32_cwd : \&_win32_cwd_simple; 797 798sub _dos_cwd { 799 if (!defined &Dos::GetCwd) { 800 $ENV{'PWD'} = `command /c cd`; 801 chomp $ENV{'PWD'}; 802 $ENV{'PWD'} =~ s:\\:/:g ; 803 } else { 804 $ENV{'PWD'} = Dos::GetCwd(); 805 } 806 return $ENV{'PWD'}; 807} 808 809sub _qnx_cwd { 810 local $ENV{PATH} = ''; 811 local $ENV{CDPATH} = ''; 812 local $ENV{ENV} = ''; 813 $ENV{'PWD'} = `/usr/bin/fullpath -t`; 814 chomp $ENV{'PWD'}; 815 return $ENV{'PWD'}; 816} 817 818sub _qnx_abs_path { 819 local $ENV{PATH} = ''; 820 local $ENV{CDPATH} = ''; 821 local $ENV{ENV} = ''; 822 my $path = @_ ? shift : '.'; 823 local *REALPATH; 824 825 defined( open(REALPATH, '-|') || exec '/usr/bin/fullpath', '-t', $path ) or 826 die "Can't open /usr/bin/fullpath: $!"; 827 my $realpath = <REALPATH>; 828 close REALPATH; 829 chomp $realpath; 830 return $realpath; 831} 832 833sub _epoc_cwd { 834 $ENV{'PWD'} = EPOC::getcwd(); 835 return $ENV{'PWD'}; 836} 837 838 839# Now that all the base-level functions are set up, alias the 840# user-level functions to the right places 841 842if (exists $METHOD_MAP{$^O}) { 843 my $map = $METHOD_MAP{$^O}; 844 foreach my $name (keys %$map) { 845 local $^W = 0; # assignments trigger 'subroutine redefined' warning 846 no strict 'refs'; 847 *{$name} = \&{$map->{$name}}; 848 } 849} 850 851# In case the XS version doesn't load. 852*abs_path = \&_perl_abs_path unless defined &abs_path; 853*getcwd = \&_perl_getcwd unless defined &getcwd; 854 855# added function alias for those of us more 856# used to the libc function. --tchrist 27-Jan-00 857*realpath = \&abs_path; 858 8591; 860