lib/Cwd.pm

   1 package Cwd;
   2 require 5.6.0;
   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 =begin _private
 126
 127 =item *
 128
 129 Actually, on Mac OS, the C<getcwd()>, C<fastgetcwd()> and C<fastcwd()>
 130 functions  are all aliases for the C<cwd()> function, which, on Mac OS,
 131 calls `pwd`. Likewise, the C<abs_path()> function is an alias for
 132 C<fast_abs_path()>.
 133
 134 =end _private
 135
 136 =back
 137
 138 =head1 SEE ALSO
 139
 140 L<File::chdir>
 141
 142 =cut
 143
 144 use strict;
 145
 146 use Carp;
 147
 148 our $VERSION = '2.06';
 149
 150 use base qw/ Exporter /;
 151 our @EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
 152 our @EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath);
 153
 154 # sys_cwd may keep the builtin command
 155
 156 # All the functionality of this module may provided by builtins,
 157 # there is no sense to process the rest of the file.
 158 # The best choice may be to have this in BEGIN, but how to return from BEGIN?
 159
 160 if ($^O eq 'os2' && defined &sys_cwd && defined &sys_abspath) {
 161     local $^W = 0;
 162     *cwd                = \&sys_cwd;
 163     *getcwd             = \&cwd;
 164     *fastgetcwd         = \&cwd;
 165     *fastcwd            = \&cwd;
 166     *abs_path           = \&sys_abspath;
 167     *fast_abs_path      = \&abs_path;
 168     *realpath           = \&abs_path;
 169     *fast_realpath      = \&abs_path;
 170     return 1;
 171 }
 172
 173 eval {
 174     require XSLoader;
 175     XSLoader::load('Cwd');
 176 };
 177
 178
 179 # Find the pwd command in the expected locations.  We assume these
 180 # are safe.  This prevents _backtick_pwd() consulting $ENV{PATH}
 181 # so everything works under taint mode.
 182 my $pwd_cmd;
 183 foreach my $try (qw(/bin/pwd /usr/bin/pwd)) {
 184     if( -x $try ) {
 185         $pwd_cmd = $try;
 186         last;
 187     }
 188 }
 189 $pwd_cmd ||= 'pwd';
 190
 191 # The 'natural and safe form' for UNIX (pwd may be setuid root)
 192 sub _backtick_pwd {
 193     my $cwd = `$pwd_cmd`;
 194     # `pwd` may fail e.g. if the disk is full
 195     chomp($cwd) if defined $cwd;
 196     $cwd;
 197 }
 198
 199 # Since some ports may predefine cwd internally (e.g., NT)
 200 # we take care not to override an existing definition for cwd().
 201
 202 unless(defined &cwd) {
 203     # The pwd command is not available in some chroot(2)'ed environments
 204     if($^O eq 'MacOS' || grep { -x "$_/pwd" } split(':', $ENV{PATH})) {
 205         *cwd = \&_backtick_pwd;
 206     }
 207     else {
 208         *cwd = \&getcwd;
 209     }
 210 }
 211
 212 # set a reasonable (and very safe) default for fastgetcwd, in case it
 213 # isn't redefined later (20001212 rspier)
 214 *fastgetcwd = \&cwd;
 215
 216 # By Brandon S. Allbery
 217 #
 218 # Usage: $cwd = getcwd();
 219
 220 sub getcwd
 221 {
 222     abs_path('.');
 223 }
 224
 225 # Keeps track of current working directory in PWD environment var
 226 # Usage:
 227 #       use Cwd 'chdir';
 228 #       chdir $newdir;
 229
 230 my $chdir_init = 0;
 231
 232 sub chdir_init {
 233     if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos' and $^O ne 'MSWin32') {
 234         my($dd,$di) = stat('.');
 235         my($pd,$pi) = stat($ENV{'PWD'});
 236         if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
 237             $ENV{'PWD'} = cwd();
 238         }
 239     }
 240     else {
 241         my $wd = cwd();
 242         $wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32';
 243         $ENV{'PWD'} = $wd;
 244     }
 245     # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar)
 246     if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) {
 247         my($pd,$pi) = stat($2);
 248         my($dd,$di) = stat($1);
 249         if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
 250             $ENV{'PWD'}="$2$3";
 251         }
 252     }
 253     $chdir_init = 1;
 254 }
 255
 256 sub chdir {
 257     my $newdir = @_ ? shift : '';       # allow for no arg (chdir to HOME dir)
 258     $newdir =~ s|///*|/|g unless $^O eq 'MSWin32';
 259     chdir_init() unless $chdir_init;
 260     my $newpwd;
 261     if ($^O eq 'MSWin32') {
 262         # get the full path name *before* the chdir()
 263         $newpwd = Win32::GetFullPathName($newdir);
 264     }
 265
 266     return 0 unless CORE::chdir $newdir;
 267
 268     if ($^O eq 'VMS') {
 269         return $ENV{'PWD'} = $ENV{'DEFAULT'}
 270     }
 271     elsif ($^O eq 'MacOS') {
 272         return $ENV{'PWD'} = cwd();
 273     }
 274     elsif ($^O eq 'MSWin32') {
 275         $ENV{'PWD'} = $newpwd;
 276         return 1;
 277     }
 278
 279     if ($newdir =~ m#^/#s) {
 280         $ENV{'PWD'} = $newdir;
 281     } else {
 282         my @curdir = split(m#/#,$ENV{'PWD'});
 283         @curdir = ('') unless @curdir;
 284         my $component;
 285         foreach $component (split(m#/#, $newdir)) {
 286             next if $component eq '.';
 287             pop(@curdir),next if $component eq '..';
 288             push(@curdir,$component);
 289         }
 290         $ENV{'PWD'} = join('/',@curdir) || '/';
 291     }
 292     1;
 293 }
 294
 295 # added function alias for those of us more
 296 # used to the libc function.  --tchrist 27-Jan-00
 297 *realpath = \&abs_path;
 298
 299 sub fast_abs_path {
 300     my $cwd = getcwd();
 301     require File::Spec;
 302     my $path = @_ ? shift : File::Spec->curdir;
 303     CORE::chdir($path) || croak "Cannot chdir to $path:$!";
 304     my $realpath = getcwd();
 305     CORE::chdir($cwd)  || croak "Cannot chdir back to $cwd:$!";
 306     $realpath;
 307 }
 308
 309 # added function alias to follow principle of least surprise
 310 # based on previous aliasing.  --tchrist 27-Jan-00
 311 *fast_realpath = \&fast_abs_path;
 312
 313
 314 # --- PORTING SECTION ---
 315
 316 # VMS: $ENV{'DEFAULT'} points to default directory at all times
 317 # 06-Mar-1996  Charles Bailey  bailey@newman.upenn.edu
 318 # Note: Use of Cwd::chdir() causes the logical name PWD to be defined
 319 #   in the process logical name table as the default device and directory
 320 #   seen by Perl. This may not be the same as the default device
 321 #   and directory seen by DCL after Perl exits, since the effects
 322 #   the CRTL chdir() function persist only until Perl exits.
 323
 324 sub _vms_cwd {
 325     return $ENV{'DEFAULT'};
 326 }
 327
 328 sub _vms_abs_path {
 329     return $ENV{'DEFAULT'} unless @_;
 330     my $path = VMS::Filespec::pathify($_[0]);
 331     croak("Invalid path name $_[0]") unless defined $path;
 332     return VMS::Filespec::rmsexpand($path);
 333 }
 334
 335 sub _os2_cwd {
 336     $ENV{'PWD'} = `cmd /c cd`;
 337     chop $ENV{'PWD'};
 338     $ENV{'PWD'} =~ s:\\:/:g ;
 339     return $ENV{'PWD'};
 340 }
 341
 342 sub _win32_cwd {
 343     $ENV{'PWD'} = Win32::GetCwd();
 344     $ENV{'PWD'} =~ s:\\:/:g ;
 345     return $ENV{'PWD'};
 346 }
 347
 348 *_NT_cwd = \&_win32_cwd if (!defined &_NT_cwd &&
 349                             defined &Win32::GetCwd);
 350
 351 *_NT_cwd = \&_os2_cwd unless defined &_NT_cwd;
 352
 353 sub _dos_cwd {
 354     if (!defined &Dos::GetCwd) {
 355         $ENV{'PWD'} = `command /c cd`;
 356         chop $ENV{'PWD'};
 357         $ENV{'PWD'} =~ s:\\:/:g ;
 358     } else {
 359         $ENV{'PWD'} = Dos::GetCwd();
 360     }
 361     return $ENV{'PWD'};
 362 }
 363
 364 sub _qnx_cwd {
 365     $ENV{'PWD'} = `/usr/bin/fullpath -t`;
 366     chop $ENV{'PWD'};
 367     return $ENV{'PWD'};
 368 }
 369
 370 sub _qnx_abs_path {
 371     my $path = @_ ? shift : '.';
 372     my $realpath=`/usr/bin/fullpath -t $path`;
 373     chop $realpath;
 374     return $realpath;
 375 }
 376
 377 sub _epoc_cwd {
 378     $ENV{'PWD'} = EPOC::getcwd();
 379     return $ENV{'PWD'};
 380 }
 381
 382 {
 383     no warnings;        # assignments trigger 'subroutine redefined' warning
 384
 385     if ($^O eq 'VMS') {
 386         *cwd            = \&_vms_cwd;
 387         *getcwd         = \&_vms_cwd;
 388         *fastcwd        = \&_vms_cwd;
 389         *fastgetcwd     = \&_vms_cwd;
 390         *abs_path       = \&_vms_abs_path;
 391         *fast_abs_path  = \&_vms_abs_path;
 392     }
 393     elsif ($^O eq 'NT' or $^O eq 'MSWin32') {
 394         # We assume that &_NT_cwd is defined as an XSUB or in the core.
 395         *cwd            = \&_NT_cwd;
 396         *getcwd         = \&_NT_cwd;
 397         *fastcwd        = \&_NT_cwd;
 398         *fastgetcwd     = \&_NT_cwd;
 399         *abs_path       = \&fast_abs_path;
 400     }
 401     elsif ($^O eq 'os2') {
 402         # sys_cwd may keep the builtin command
 403         *cwd            = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
 404         *getcwd         = \&cwd;
 405         *fastgetcwd     = \&cwd;
 406         *fastcwd        = \&cwd;
 407         *abs_path       = \&fast_abs_path;
 408     }
 409     elsif ($^O eq 'dos') {
 410         *cwd            = \&_dos_cwd;
 411         *getcwd         = \&_dos_cwd;
 412         *fastgetcwd     = \&_dos_cwd;
 413         *fastcwd        = \&_dos_cwd;
 414         *abs_path       = \&fast_abs_path;
 415     }
 416     elsif ($^O =~ m/^(?:qnx|nto)$/ ) {
 417         *cwd            = \&_qnx_cwd;
 418         *getcwd         = \&_qnx_cwd;
 419         *fastgetcwd     = \&_qnx_cwd;
 420         *fastcwd        = \&_qnx_cwd;
 421         *abs_path       = \&_qnx_abs_path;
 422         *fast_abs_path  = \&_qnx_abs_path;
 423     }
 424     elsif ($^O eq 'cygwin') {
 425         *getcwd = \&cwd;
 426         *fastgetcwd     = \&cwd;
 427         *fastcwd        = \&cwd;
 428         *abs_path       = \&fast_abs_path;
 429     }
 430     elsif ($^O eq 'epoc') {
 431         *cwd            = \&_epoc_cwd;
 432         *getcwd         = \&_epoc_cwd;
 433         *fastgetcwd     = \&_epoc_cwd;
 434         *fastcwd        = \&_epoc_cwd;
 435         *abs_path       = \&fast_abs_path;
 436     }
 437     elsif ($^O eq 'MacOS') {
 438         *getcwd     = \&cwd;
 439         *fastgetcwd = \&cwd;
 440         *fastcwd    = \&cwd;
 441         *abs_path   = \&fast_abs_path;
 442     }
 443 }
 444
 445 # package main; eval join('',<DATA>) || die $@; # quick test
 446
 447 1;
 448
 449 __END__
 450 BEGIN { import Cwd qw(:DEFAULT chdir); }
 451 print join("\n", cwd, getcwd, fastcwd, "");
 452 chdir('..');
 453 print join("\n", cwd, getcwd, fastcwd, "");
 454 print "$ENV{PWD}\n";