This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
OS/400 PASE port
[perl5.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 Taint-safe.
42
43 =item cwd
44
45     my $cwd = cwd();
46
47 The cwd() is the most natural form for the current architecture. For
48 most systems it is identical to `pwd` (but without the trailing line
49 terminator).
50
51 Taint-safe.
52
53 =item fastcwd
54
55     my $cwd = fastcwd();
56
57 A more dangerous version of getcwd(), but potentially faster.
58
59 It might conceivably chdir() you out of a directory that it can't
60 chdir() you back into.  If fastcwd encounters a problem it will return
61 undef but will probably leave you in a different directory.  For a
62 measure of extra security, if everything appears to have worked, the
63 fastcwd() function will check that it leaves you in the same directory
64 that it started in. If it has changed it will C<die> with the message
65 "Unstable directory path, current directory changed
66 unexpectedly". That should never happen.
67
68 =item fastgetcwd
69
70   my $cwd = fastgetcwd();
71
72 The fastgetcwd() function is provided as a synonym for cwd().
73
74 =back
75
76
77 =head2 abs_path and friends
78
79 These functions are exported only on request.  They each take a single
80 argument and return the absolute pathname for it.
81
82 =over 4
83
84 =item abs_path
85
86   my $abs_path = abs_path($file);
87
88 Uses the same algorithm as getcwd().  Symbolic links and relative-path
89 components ("." and "..") are resolved to return the canonical
90 pathname, just like realpath(3).
91
92 Taint-safe.
93
94 =item realpath
95
96   my $abs_path = realpath($file);
97
98 A synonym for abs_path().
99
100 Taint-safe.
101
102 =item fast_abs_path
103
104   my $abs_path = fast_abs_path($file);
105
106 A more dangerous, but potentially faster version of abs_path.
107
108 This function is B<Not> taint-safe : you can't use it in programs
109 that work under taint mode.
110
111 =back
112
113 =head2 $ENV{PWD}
114
115 If you ask to override your chdir() built-in function, 
116
117   use Cwd qw(chdir);
118
119 then your PWD environment variable will be kept up to date.  Note that
120 it will only be kept up to date if all packages which use chdir import
121 it from Cwd.
122
123
124 =head1 NOTES
125
126 =over 4
127
128 =item *
129
130 Since the path seperators are different on some operating systems ('/'
131 on Unix, ':' on MacPerl, etc...) we recommend you use the File::Spec
132 modules wherever portability is a concern.
133
134 =item *
135
136 Actually, on Mac OS, the C<getcwd()>, C<fastgetcwd()> and C<fastcwd()>
137 functions  are all aliases for the C<cwd()> function, which, on Mac OS,
138 calls `pwd`. Likewise, the C<abs_path()> function is an alias for
139 C<fast_abs_path()>.
140
141 =back
142
143 =head1 SEE ALSO
144
145 L<File::chdir>
146
147 =cut
148
149 use strict;
150
151 use Carp;
152
153 our $VERSION = '2.06';
154
155 use base qw/ Exporter /;
156 our @EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
157 our @EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath);
158
159 # sys_cwd may keep the builtin command
160
161 # All the functionality of this module may provided by builtins,
162 # there is no sense to process the rest of the file.
163 # The best choice may be to have this in BEGIN, but how to return from BEGIN?
164
165 if ($^O eq 'os2' && defined &sys_cwd && defined &sys_abspath) {
166     local $^W = 0;
167     *cwd                = \&sys_cwd;
168     *getcwd             = \&cwd;
169     *fastgetcwd         = \&cwd;
170     *fastcwd            = \&cwd;
171     *abs_path           = \&sys_abspath;
172     *fast_abs_path      = \&abs_path;
173     *realpath           = \&abs_path;
174     *fast_realpath      = \&abs_path;
175     return 1;
176 }
177
178 eval {
179     require XSLoader;
180     undef *Cwd::fastcwd; # avoid redefinition warning
181     XSLoader::load('Cwd');
182 };
183
184
185 # Find the pwd command in the expected locations.  We assume these
186 # are safe.  This prevents _backtick_pwd() consulting $ENV{PATH}
187 # so everything works under taint mode.
188 my $pwd_cmd;
189 foreach my $try (qw(/bin/pwd /usr/bin/pwd)) {
190     if( -x $try ) {
191         $pwd_cmd = $try;
192         last;
193     }
194 }
195 unless ($pwd_cmd) {
196     if (-x '/QOpenSys/bin/pwd') { # OS/400 PASE.
197         $pwd_cmd = '/QOpenSys/bin/pwd' ;
198     } else {
199         # Isn't this wrong?  _backtick_pwd() will fail if somenone has
200         # pwd in their path but it is not /bin/pwd or /usr/bin/pwd?
201         # See [perl #16774]. --jhi
202         $pwd_cmd = 'pwd';
203     }
204 }
205
206 # The 'natural and safe form' for UNIX (pwd may be setuid root)
207 sub _backtick_pwd {
208     local @ENV{qw(PATH IFS CDPATH ENV BASH_ENV)};
209     my $cwd = `$pwd_cmd`;
210     # Belt-and-suspenders in case someone said "undef $/".
211     local $/ = "\n";
212     # `pwd` may fail e.g. if the disk is full
213     chomp($cwd) if defined $cwd;
214     $cwd;
215 }
216
217 # Since some ports may predefine cwd internally (e.g., NT)
218 # we take care not to override an existing definition for cwd().
219
220 unless(defined &cwd) {
221     # The pwd command is not available in some chroot(2)'ed environments
222     if( $^O eq 'MacOS' || (defined $ENV{PATH} && 
223                            grep { -x "$_/pwd" } split(':', $ENV{PATH})) ) 
224     {
225         *cwd = \&_backtick_pwd;
226     }
227     else {
228         *cwd = \&getcwd;
229     }
230 }
231
232 # set a reasonable (and very safe) default for fastgetcwd, in case it
233 # isn't redefined later (20001212 rspier)
234 *fastgetcwd = \&cwd;
235
236 # By Brandon S. Allbery
237 #
238 # Usage: $cwd = getcwd();
239
240 sub getcwd
241 {
242     abs_path('.');
243 }
244
245
246 # By John Bazik
247 #
248 # Usage: $cwd = &fastcwd;
249 #
250 # This is a faster version of getcwd.  It's also more dangerous because
251 # you might chdir out of a directory that you can't chdir back into.
252     
253 sub fastcwd {
254     my($odev, $oino, $cdev, $cino, $tdev, $tino);
255     my(@path, $path);
256     local(*DIR);
257
258     my($orig_cdev, $orig_cino) = stat('.');
259     ($cdev, $cino) = ($orig_cdev, $orig_cino);
260     for (;;) {
261         my $direntry;
262         ($odev, $oino) = ($cdev, $cino);
263         CORE::chdir('..') || return undef;
264         ($cdev, $cino) = stat('.');
265         last if $odev == $cdev && $oino == $cino;
266         opendir(DIR, '.') || return undef;
267         for (;;) {
268             $direntry = readdir(DIR);
269             last unless defined $direntry;
270             next if $direntry eq '.';
271             next if $direntry eq '..';
272
273             ($tdev, $tino) = lstat($direntry);
274             last unless $tdev != $odev || $tino != $oino;
275         }
276         closedir(DIR);
277         return undef unless defined $direntry; # should never happen
278         unshift(@path, $direntry);
279     }
280     $path = '/' . join('/', @path);
281     if ($^O eq 'apollo') { $path = "/".$path; }
282     # At this point $path may be tainted (if tainting) and chdir would fail.
283     # Untaint it then check that we landed where we started.
284     $path =~ /^(.*)\z/s         # untaint
285         && CORE::chdir($1) or return undef;
286     ($cdev, $cino) = stat('.');
287     die "Unstable directory path, current directory changed unexpectedly"
288         if $cdev != $orig_cdev || $cino != $orig_cino;
289     $path;
290 }
291
292
293 # Keeps track of current working directory in PWD environment var
294 # Usage:
295 #       use Cwd 'chdir';
296 #       chdir $newdir;
297
298 my $chdir_init = 0;
299
300 sub chdir_init {
301     if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos' and $^O ne 'MSWin32') {
302         my($dd,$di) = stat('.');
303         my($pd,$pi) = stat($ENV{'PWD'});
304         if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
305             $ENV{'PWD'} = cwd();
306         }
307     }
308     else {
309         my $wd = cwd();
310         $wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32';
311         $ENV{'PWD'} = $wd;
312     }
313     # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar)
314     if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) {
315         my($pd,$pi) = stat($2);
316         my($dd,$di) = stat($1);
317         if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
318             $ENV{'PWD'}="$2$3";
319         }
320     }
321     $chdir_init = 1;
322 }
323
324 sub chdir {
325     my $newdir = @_ ? shift : '';       # allow for no arg (chdir to HOME dir)
326     $newdir =~ s|///*|/|g unless $^O eq 'MSWin32';
327     chdir_init() unless $chdir_init;
328     my $newpwd;
329     if ($^O eq 'MSWin32') {
330         # get the full path name *before* the chdir()
331         $newpwd = Win32::GetFullPathName($newdir);
332     }
333
334     return 0 unless CORE::chdir $newdir;
335
336     if ($^O eq 'VMS') {
337         return $ENV{'PWD'} = $ENV{'DEFAULT'}
338     }
339     elsif ($^O eq 'MacOS') {
340         return $ENV{'PWD'} = cwd();
341     }
342     elsif ($^O eq 'MSWin32') {
343         $ENV{'PWD'} = $newpwd;
344         return 1;
345     }
346
347     if ($newdir =~ m#^/#s) {
348         $ENV{'PWD'} = $newdir;
349     } else {
350         my @curdir = split(m#/#,$ENV{'PWD'});
351         @curdir = ('') unless @curdir;
352         my $component;
353         foreach $component (split(m#/#, $newdir)) {
354             next if $component eq '.';
355             pop(@curdir),next if $component eq '..';
356             push(@curdir,$component);
357         }
358         $ENV{'PWD'} = join('/',@curdir) || '/';
359     }
360     1;
361 }
362
363
364 # In case the XS version doesn't load.
365 *abs_path = \&_perl_abs_path unless defined &abs_path;
366 sub _perl_abs_path
367 {
368     my $start = @_ ? shift : '.';
369     my($dotdots, $cwd, @pst, @cst, $dir, @tst);
370
371     unless (@cst = stat( $start ))
372     {
373         carp "stat($start): $!";
374         return '';
375     }
376     $cwd = '';
377     $dotdots = $start;
378     do
379     {
380         $dotdots .= '/..';
381         @pst = @cst;
382         unless (opendir(PARENT, $dotdots))
383         {
384             carp "opendir($dotdots): $!";
385             return '';
386         }
387         unless (@cst = stat($dotdots))
388         {
389             carp "stat($dotdots): $!";
390             closedir(PARENT);
391             return '';
392         }
393         if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
394         {
395             $dir = undef;
396         }
397         else
398         {
399             do
400             {
401                 unless (defined ($dir = readdir(PARENT)))
402                 {
403                     carp "readdir($dotdots): $!";
404                     closedir(PARENT);
405                     return '';
406                 }
407                 $tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir"))
408             }
409             while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
410                    $tst[1] != $pst[1]);
411         }
412         $cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ;
413         closedir(PARENT);
414     } while (defined $dir);
415     chop($cwd) unless $cwd eq '/'; # drop the trailing /
416     $cwd;
417 }
418
419
420 # added function alias for those of us more
421 # used to the libc function.  --tchrist 27-Jan-00
422 *realpath = \&abs_path;
423
424 sub fast_abs_path {
425     my $cwd = getcwd();
426     require File::Spec;
427     my $path = @_ ? shift : File::Spec->curdir;
428     CORE::chdir($path) || croak "Cannot chdir to $path: $!";
429     my $realpath = getcwd();
430     -d $cwd && CORE::chdir($cwd) ||
431         croak "Cannot chdir back to $cwd: $!";
432     $realpath;
433 }
434
435 # added function alias to follow principle of least surprise
436 # based on previous aliasing.  --tchrist 27-Jan-00
437 *fast_realpath = \&fast_abs_path;
438
439
440 # --- PORTING SECTION ---
441
442 # VMS: $ENV{'DEFAULT'} points to default directory at all times
443 # 06-Mar-1996  Charles Bailey  bailey@newman.upenn.edu
444 # Note: Use of Cwd::chdir() causes the logical name PWD to be defined
445 #   in the process logical name table as the default device and directory
446 #   seen by Perl. This may not be the same as the default device
447 #   and directory seen by DCL after Perl exits, since the effects
448 #   the CRTL chdir() function persist only until Perl exits.
449
450 sub _vms_cwd {
451     return $ENV{'DEFAULT'};
452 }
453
454 sub _vms_abs_path {
455     return $ENV{'DEFAULT'} unless @_;
456     my $path = VMS::Filespec::pathify($_[0]);
457     croak("Invalid path name $_[0]") unless defined $path;
458     return VMS::Filespec::rmsexpand($path);
459 }
460
461 sub _os2_cwd {
462     $ENV{'PWD'} = `cmd /c cd`;
463     chop $ENV{'PWD'};
464     $ENV{'PWD'} =~ s:\\:/:g ;
465     return $ENV{'PWD'};
466 }
467
468 sub _win32_cwd {
469     $ENV{'PWD'} = Win32::GetCwd();
470     $ENV{'PWD'} =~ s:\\:/:g ;
471     return $ENV{'PWD'};
472 }
473
474 *_NT_cwd = \&_win32_cwd if (!defined &_NT_cwd && 
475                             defined &Win32::GetCwd);
476
477 *_NT_cwd = \&_os2_cwd unless defined &_NT_cwd;
478
479 sub _dos_cwd {
480     if (!defined &Dos::GetCwd) {
481         $ENV{'PWD'} = `command /c cd`;
482         chop $ENV{'PWD'};
483         $ENV{'PWD'} =~ s:\\:/:g ;
484     } else {
485         $ENV{'PWD'} = Dos::GetCwd();
486     }
487     return $ENV{'PWD'};
488 }
489
490 sub _qnx_cwd {
491         local $ENV{PATH} = '';
492         local $ENV{CDPATH} = '';
493         local $ENV{ENV} = '';
494     $ENV{'PWD'} = `/usr/bin/fullpath -t`;
495     chop $ENV{'PWD'};
496     return $ENV{'PWD'};
497 }
498
499 sub _qnx_abs_path {
500         local $ENV{PATH} = '';
501         local $ENV{CDPATH} = '';
502         local $ENV{ENV} = '';
503     my $path = @_ ? shift : '.';
504     my $realpath=`/usr/bin/fullpath -t $path`;
505     chop $realpath;
506     return $realpath;
507 }
508
509 sub _epoc_cwd {
510     $ENV{'PWD'} = EPOC::getcwd();
511     return $ENV{'PWD'};
512 }
513
514 {
515     no warnings;        # assignments trigger 'subroutine redefined' warning
516
517     if ($^O eq 'VMS') {
518         *cwd            = \&_vms_cwd;
519         *getcwd         = \&_vms_cwd;
520         *fastcwd        = \&_vms_cwd;
521         *fastgetcwd     = \&_vms_cwd;
522         *abs_path       = \&_vms_abs_path;
523         *fast_abs_path  = \&_vms_abs_path;
524     }
525     elsif ($^O eq 'NT' or $^O eq 'MSWin32') {
526         # We assume that &_NT_cwd is defined as an XSUB or in the core.
527         *cwd            = \&_NT_cwd;
528         *getcwd         = \&_NT_cwd;
529         *fastcwd        = \&_NT_cwd;
530         *fastgetcwd     = \&_NT_cwd;
531         *abs_path       = \&fast_abs_path;
532         *realpath   = \&fast_abs_path;
533     }
534     elsif ($^O eq 'os2') {
535         # sys_cwd may keep the builtin command
536         *cwd            = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
537         *getcwd         = \&cwd;
538         *fastgetcwd     = \&cwd;
539         *fastcwd        = \&cwd;
540         *abs_path       = \&fast_abs_path;
541     }
542     elsif ($^O eq 'dos') {
543         *cwd            = \&_dos_cwd;
544         *getcwd         = \&_dos_cwd;
545         *fastgetcwd     = \&_dos_cwd;
546         *fastcwd        = \&_dos_cwd;
547         *abs_path       = \&fast_abs_path;
548     }
549     elsif ($^O =~ m/^(?:qnx|nto)$/ ) {
550         *cwd            = \&_qnx_cwd;
551         *getcwd         = \&_qnx_cwd;
552         *fastgetcwd     = \&_qnx_cwd;
553         *fastcwd        = \&_qnx_cwd;
554         *abs_path       = \&_qnx_abs_path;
555         *fast_abs_path  = \&_qnx_abs_path;
556     }
557     elsif ($^O eq 'cygwin') {
558         *getcwd = \&cwd;
559         *fastgetcwd     = \&cwd;
560         *fastcwd        = \&cwd;
561         *abs_path       = \&fast_abs_path;
562     }
563     elsif ($^O eq 'epoc') {
564         *cwd            = \&_epoc_cwd;
565         *getcwd         = \&_epoc_cwd;
566         *fastgetcwd     = \&_epoc_cwd;
567         *fastcwd        = \&_epoc_cwd;
568         *abs_path       = \&fast_abs_path;
569     }
570     elsif ($^O eq 'MacOS') {
571         *getcwd     = \&cwd;
572         *fastgetcwd = \&cwd;
573         *fastcwd    = \&cwd;
574         *abs_path   = \&fast_abs_path;
575     }
576 }
577
578
579 1;