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