dist/PathTools/Cwd.pm

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