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