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