This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
File::Spec::Unix->tmpdir: Always return an absolute path
[perl5.git] / dist / PathTools / lib / File / Spec / Unix.pm
1 package File::Spec::Unix;
2
3 use strict;
4 use vars qw($VERSION);
5
6 $VERSION = '3.45_01';
7 my $xs_version = $VERSION;
8 $VERSION =~ tr/_//;
9
10 unless (defined &canonpath) {
11   eval {
12     if ( $] >= 5.006 ) {
13         require XSLoader;
14         XSLoader::load("Cwd", $xs_version);
15     } else {
16         require Cwd;
17     }
18   };
19 }
20
21 =head1 NAME
22
23 File::Spec::Unix - File::Spec for Unix, base for other File::Spec modules
24
25 =head1 SYNOPSIS
26
27  require File::Spec::Unix; # Done automatically by File::Spec
28
29 =head1 DESCRIPTION
30
31 Methods for manipulating file specifications.  Other File::Spec
32 modules, such as File::Spec::Mac, inherit from File::Spec::Unix and
33 override specific methods.
34
35 =head1 METHODS
36
37 =over 2
38
39 =item canonpath()
40
41 No physical check on the filesystem, but a logical cleanup of a
42 path. On UNIX eliminates successive slashes and successive "/.".
43
44     $cpath = File::Spec->canonpath( $path ) ;
45
46 Note that this does *not* collapse F<x/../y> sections into F<y>.  This
47 is by design.  If F</foo> on your system is a symlink to F</bar/baz>,
48 then F</foo/../quux> is actually F</bar/quux>, not F</quux> as a naive
49 F<../>-removal would give you.  If you want to do this kind of
50 processing, you probably want C<Cwd>'s C<realpath()> function to
51 actually traverse the filesystem cleaning up paths like this.
52
53 =cut
54
55 sub _pp_canonpath {
56     my ($self,$path) = @_;
57     return unless defined $path;
58     
59     # Handle POSIX-style node names beginning with double slash (qnx, nto)
60     # (POSIX says: "a pathname that begins with two successive slashes
61     # may be interpreted in an implementation-defined manner, although
62     # more than two leading slashes shall be treated as a single slash.")
63     my $node = '';
64     my $double_slashes_special = $^O eq 'qnx' || $^O eq 'nto';
65
66
67     if ( $double_slashes_special
68          && ( $path =~ s{^(//[^/]+)/?\z}{}s || $path =~ s{^(//[^/]+)/}{/}s ) ) {
69       $node = $1;
70     }
71     # This used to be
72     # $path =~ s|/+|/|g unless ($^O eq 'cygwin');
73     # but that made tests 29, 30, 35, 46, and 213 (as of #13272) to fail
74     # (Mainly because trailing "" directories didn't get stripped).
75     # Why would cygwin avoid collapsing multiple slashes into one? --jhi
76     $path =~ s|/{2,}|/|g;                            # xx////xx  -> xx/xx
77     $path =~ s{(?:/\.)+(?:/|\z)}{/}g;                # xx/././xx -> xx/xx
78     $path =~ s|^(?:\./)+||s unless $path eq "./";    # ./xx      -> xx
79     $path =~ s|^/(?:\.\./)+|/|;                      # /../../xx -> xx
80     $path =~ s|^/\.\.$|/|;                         # /..       -> /
81     $path =~ s|/\z|| unless $path eq "/";          # xx/       -> xx
82     return "$node$path";
83 }
84 *canonpath = \&_pp_canonpath unless defined &canonpath;
85
86 =item catdir()
87
88 Concatenate two or more directory names to form a complete path ending
89 with a directory. But remove the trailing slash from the resulting
90 string, because it doesn't look good, isn't necessary and confuses
91 OS2. Of course, if this is the root directory, don't cut off the
92 trailing slash :-)
93
94 =cut
95
96 sub _pp_catdir {
97     my $self = shift;
98
99     $self->canonpath(join('/', @_, '')); # '' because need a trailing '/'
100 }
101 *catdir = \&_pp_catdir unless defined &catdir;
102
103 =item catfile
104
105 Concatenate one or more directory names and a filename to form a
106 complete path ending with a filename
107
108 =cut
109
110 sub _pp_catfile {
111     my $self = shift;
112     my $file = $self->canonpath(pop @_);
113     return $file unless @_;
114     my $dir = $self->catdir(@_);
115     $dir .= "/" unless substr($dir,-1) eq "/";
116     return $dir.$file;
117 }
118 *catfile = \&_pp_catfile unless defined &catfile;
119
120 =item curdir
121
122 Returns a string representation of the current directory.  "." on UNIX.
123
124 =cut
125
126 sub curdir { '.' }
127 use constant _fn_curdir => ".";
128
129 =item devnull
130
131 Returns a string representation of the null device. "/dev/null" on UNIX.
132
133 =cut
134
135 sub devnull { '/dev/null' }
136 use constant _fn_devnull => "/dev/null";
137
138 =item rootdir
139
140 Returns a string representation of the root directory.  "/" on UNIX.
141
142 =cut
143
144 sub rootdir { '/' }
145 use constant _fn_rootdir => "/";
146
147 =item tmpdir
148
149 Returns a string representation of the first writable directory from
150 the following list or the current directory if none from the list are
151 writable:
152
153     $ENV{TMPDIR}
154     /tmp
155
156 If running under taint mode, and if $ENV{TMPDIR}
157 is tainted, it is not used.
158
159 =cut
160
161 my ($tmpdir, %tmpenv);
162 # Cache and return the calculated tmpdir, recording which env vars
163 # determined it.
164 sub _cache_tmpdir {
165     @tmpenv{@_[2..$#_]} = @ENV{@_[2..$#_]};
166     return $tmpdir = $_[1];
167 }
168 # Retrieve the cached tmpdir, checking first whether relevant env vars have
169 # changed and invalidated the cache.
170 sub _cached_tmpdir {
171     shift;
172     local $^W;
173     return if grep $ENV{$_} ne $tmpenv{$_}, @_;
174     return $tmpdir;
175 }
176 sub _tmpdir {
177     my $self = shift;
178     my @dirlist = @_;
179     my $taint = do { no strict 'refs'; ${"\cTAINT"} };
180     if ($taint) { # Check for taint mode on perl >= 5.8.0
181         require Scalar::Util;
182         @dirlist = grep { ! Scalar::Util::tainted($_) } @dirlist;
183     }
184     elsif ($] < 5.007) { # No ${^TAINT} before 5.8
185         @dirlist = grep { eval { eval('1'.substr $_,0,0) } } @dirlist;
186     }
187     
188     foreach (@dirlist) {
189         next unless defined && -d && -w _;
190         $tmpdir = $_;
191         last;
192     }
193     $tmpdir = $self->curdir unless defined $tmpdir;
194     $tmpdir = defined $tmpdir && $self->canonpath($tmpdir);
195     if ( $tmpdir eq '.' ) {
196         # See [perl #120593] for the full details
197         # If possible, return a full path, rather than '.', but
198         # we have to avoid returning a tainted value, so we jump
199         # through some hoops.
200         ($tmpdir) = grep {
201             $taint     ? ! Scalar::Util::tainted($_) :
202             $] < 5.007 ? eval { eval('1'.substr $_,0,0) } : 1
203         } $self->rel2abs($tmpdir), $tmpdir;
204     }
205     return $tmpdir;
206 }
207
208 sub tmpdir {
209     my $cached = $_[0]->_cached_tmpdir('TMPDIR');
210     return $cached if defined $cached;
211     $_[0]->_cache_tmpdir($_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp" ), 'TMPDIR');
212 }
213
214 =item updir
215
216 Returns a string representation of the parent directory.  ".." on UNIX.
217
218 =cut
219
220 sub updir { '..' }
221 use constant _fn_updir => "..";
222
223 =item no_upwards
224
225 Given a list of file names, strip out those that refer to a parent
226 directory. (Does not strip symlinks, only '.', '..', and equivalents.)
227
228 =cut
229
230 sub no_upwards {
231     my $self = shift;
232     return grep(!/^\.{1,2}\z/s, @_);
233 }
234
235 =item case_tolerant
236
237 Returns a true or false value indicating, respectively, that alphabetic
238 is not or is significant when comparing file specifications.
239
240 =cut
241
242 sub case_tolerant { 0 }
243 use constant _fn_case_tolerant => 0;
244
245 =item file_name_is_absolute
246
247 Takes as argument a path and returns true if it is an absolute path.
248
249 This does not consult the local filesystem on Unix, Win32, OS/2 or Mac 
250 OS (Classic).  It does consult the working environment for VMS (see
251 L<File::Spec::VMS/file_name_is_absolute>).
252
253 =cut
254
255 sub file_name_is_absolute {
256     my ($self,$file) = @_;
257     return scalar($file =~ m:^/:s);
258 }
259
260 =item path
261
262 Takes no argument, returns the environment variable PATH as an array.
263
264 =cut
265
266 sub path {
267     return () unless exists $ENV{PATH};
268     my @path = split(':', $ENV{PATH});
269     foreach (@path) { $_ = '.' if $_ eq '' }
270     return @path;
271 }
272
273 =item join
274
275 join is the same as catfile.
276
277 =cut
278
279 sub join {
280     my $self = shift;
281     return $self->catfile(@_);
282 }
283
284 =item splitpath
285
286     ($volume,$directories,$file) = File::Spec->splitpath( $path );
287     ($volume,$directories,$file) = File::Spec->splitpath( $path,
288                                                           $no_file );
289
290 Splits a path into volume, directory, and filename portions. On systems
291 with no concept of volume, returns '' for volume. 
292
293 For systems with no syntax differentiating filenames from directories, 
294 assumes that the last file is a path unless $no_file is true or a 
295 trailing separator or /. or /.. is present. On Unix this means that $no_file
296 true makes this return ( '', $path, '' ).
297
298 The directory portion may or may not be returned with a trailing '/'.
299
300 The results can be passed to L</catpath()> to get back a path equivalent to
301 (usually identical to) the original path.
302
303 =cut
304
305 sub splitpath {
306     my ($self,$path, $nofile) = @_;
307
308     my ($volume,$directory,$file) = ('','','');
309
310     if ( $nofile ) {
311         $directory = $path;
312     }
313     else {
314         $path =~ m|^ ( (?: .* / (?: \.\.?\z )? )? ) ([^/]*) |xs;
315         $directory = $1;
316         $file      = $2;
317     }
318
319     return ($volume,$directory,$file);
320 }
321
322
323 =item splitdir
324
325 The opposite of L</catdir()>.
326
327     @dirs = File::Spec->splitdir( $directories );
328
329 $directories must be only the directory portion of the path on systems 
330 that have the concept of a volume or that have path syntax that differentiates
331 files from directories.
332
333 Unlike just splitting the directories on the separator, empty
334 directory names (C<''>) can be returned, because these are significant
335 on some OSs.
336
337 On Unix,
338
339     File::Spec->splitdir( "/a/b//c/" );
340
341 Yields:
342
343     ( '', 'a', 'b', '', 'c', '' )
344
345 =cut
346
347 sub splitdir {
348     return split m|/|, $_[1], -1;  # Preserve trailing fields
349 }
350
351
352 =item catpath()
353
354 Takes volume, directory and file portions and returns an entire path. Under
355 Unix, $volume is ignored, and directory and file are concatenated.  A '/' is
356 inserted if needed (though if the directory portion doesn't start with
357 '/' it is not added).  On other OSs, $volume is significant.
358
359 =cut
360
361 sub catpath {
362     my ($self,$volume,$directory,$file) = @_;
363
364     if ( $directory ne ''                && 
365          $file ne ''                     && 
366          substr( $directory, -1 ) ne '/' && 
367          substr( $file, 0, 1 ) ne '/' 
368     ) {
369         $directory .= "/$file" ;
370     }
371     else {
372         $directory .= $file ;
373     }
374
375     return $directory ;
376 }
377
378 =item abs2rel
379
380 Takes a destination path and an optional base path returns a relative path
381 from the base path to the destination path:
382
383     $rel_path = File::Spec->abs2rel( $path ) ;
384     $rel_path = File::Spec->abs2rel( $path, $base ) ;
385
386 If $base is not present or '', then L<cwd()|Cwd> is used. If $base is
387 relative, then it is converted to absolute form using
388 L</rel2abs()>. This means that it is taken to be relative to
389 L<cwd()|Cwd>.
390
391 On systems that have a grammar that indicates filenames, this ignores the 
392 $base filename. Otherwise all path components are assumed to be
393 directories.
394
395 If $path is relative, it is converted to absolute form using L</rel2abs()>.
396 This means that it is taken to be relative to L<cwd()|Cwd>.
397
398 No checks against the filesystem are made, so the result may not be correct if
399 C<$base> contains symbolic links.  (Apply
400 L<Cwd::abs_path()|Cwd/abs_path> beforehand if that
401 is a concern.)  On VMS, there is interaction with the working environment, as
402 logicals and macros are expanded.
403
404 Based on code written by Shigio Yamaguchi.
405
406 =cut
407
408 sub abs2rel {
409     my($self,$path,$base) = @_;
410     $base = $self->_cwd() unless defined $base and length $base;
411
412     ($path, $base) = map $self->canonpath($_), $path, $base;
413
414     my $path_directories;
415     my $base_directories;
416
417     if (grep $self->file_name_is_absolute($_), $path, $base) {
418         ($path, $base) = map $self->rel2abs($_), $path, $base;
419
420         my ($path_volume) = $self->splitpath($path, 1);
421         my ($base_volume) = $self->splitpath($base, 1);
422
423         # Can't relativize across volumes
424         return $path unless $path_volume eq $base_volume;
425
426         $path_directories = ($self->splitpath($path, 1))[1];
427         $base_directories = ($self->splitpath($base, 1))[1];
428
429         # For UNC paths, the user might give a volume like //foo/bar that
430         # strictly speaking has no directory portion.  Treat it as if it
431         # had the root directory for that volume.
432         if (!length($base_directories) and $self->file_name_is_absolute($base)) {
433             $base_directories = $self->rootdir;
434         }
435     }
436     else {
437         my $wd= ($self->splitpath($self->_cwd(), 1))[1];
438         $path_directories = $self->catdir($wd, $path);
439         $base_directories = $self->catdir($wd, $base);
440     }
441
442     # Now, remove all leading components that are the same
443     my @pathchunks = $self->splitdir( $path_directories );
444     my @basechunks = $self->splitdir( $base_directories );
445
446     if ($base_directories eq $self->rootdir) {
447       return $self->curdir if $path_directories eq $self->rootdir;
448       shift @pathchunks;
449       return $self->canonpath( $self->catpath('', $self->catdir( @pathchunks ), '') );
450     }
451
452     my @common;
453     while (@pathchunks && @basechunks && $self->_same($pathchunks[0], $basechunks[0])) {
454         push @common, shift @pathchunks ;
455         shift @basechunks ;
456     }
457     return $self->curdir unless @pathchunks || @basechunks;
458
459     # @basechunks now contains the directories the resulting relative path 
460     # must ascend out of before it can descend to $path_directory.  If there
461     # are updir components, we must descend into the corresponding directories
462     # (this only works if they are no symlinks).
463     my @reverse_base;
464     while( defined(my $dir= shift @basechunks) ) {
465         if( $dir ne $self->updir ) {
466             unshift @reverse_base, $self->updir;
467             push @common, $dir;
468         }
469         elsif( @common ) {
470             if( @reverse_base && $reverse_base[0] eq $self->updir ) {
471                 shift @reverse_base;
472                 pop @common;
473             }
474             else {
475                 unshift @reverse_base, pop @common;
476             }
477         }
478     }
479     my $result_dirs = $self->catdir( @reverse_base, @pathchunks );
480     return $self->canonpath( $self->catpath('', $result_dirs, '') );
481 }
482
483 sub _same {
484   $_[1] eq $_[2];
485 }
486
487 =item rel2abs()
488
489 Converts a relative path to an absolute path. 
490
491     $abs_path = File::Spec->rel2abs( $path ) ;
492     $abs_path = File::Spec->rel2abs( $path, $base ) ;
493
494 If $base is not present or '', then L<cwd()|Cwd> is used. If $base is
495 relative, then it is converted to absolute form using
496 L</rel2abs()>. This means that it is taken to be relative to
497 L<cwd()|Cwd>.
498
499 On systems that have a grammar that indicates filenames, this ignores
500 the $base filename. Otherwise all path components are assumed to be
501 directories.
502
503 If $path is absolute, it is cleaned up and returned using L</canonpath()>.
504
505 No checks against the filesystem are made.  On VMS, there is
506 interaction with the working environment, as logicals and
507 macros are expanded.
508
509 Based on code written by Shigio Yamaguchi.
510
511 =cut
512
513 sub rel2abs {
514     my ($self,$path,$base ) = @_;
515
516     # Clean up $path
517     if ( ! $self->file_name_is_absolute( $path ) ) {
518         # Figure out the effective $base and clean it up.
519         if ( !defined( $base ) || $base eq '' ) {
520             $base = $self->_cwd();
521         }
522         elsif ( ! $self->file_name_is_absolute( $base ) ) {
523             $base = $self->rel2abs( $base ) ;
524         }
525         else {
526             $base = $self->canonpath( $base ) ;
527         }
528
529         # Glom them together
530         $path = $self->catdir( $base, $path ) ;
531     }
532
533     return $self->canonpath( $path ) ;
534 }
535
536 =back
537
538 =head1 COPYRIGHT
539
540 Copyright (c) 2004 by the Perl 5 Porters.  All rights reserved.
541
542 This program is free software; you can redistribute it and/or modify
543 it under the same terms as Perl itself.
544
545 Please submit bug reports and patches to perlbug@perl.org.
546
547 =head1 SEE ALSO
548
549 L<File::Spec>
550
551 =cut
552
553 # Internal routine to File::Spec, no point in making this public since
554 # it is the standard Cwd interface.  Most of the platform-specific
555 # File::Spec subclasses use this.
556 sub _cwd {
557     require Cwd;
558     Cwd::getcwd();
559 }
560
561
562 # Internal method to reduce xx\..\yy -> yy
563 sub _collapse {
564     my($fs, $path) = @_;
565
566     my $updir  = $fs->updir;
567     my $curdir = $fs->curdir;
568
569     my($vol, $dirs, $file) = $fs->splitpath($path);
570     my @dirs = $fs->splitdir($dirs);
571     pop @dirs if @dirs && $dirs[-1] eq '';
572
573     my @collapsed;
574     foreach my $dir (@dirs) {
575         if( $dir eq $updir              and   # if we have an updir
576             @collapsed                  and   # and something to collapse
577             length $collapsed[-1]       and   # and its not the rootdir
578             $collapsed[-1] ne $updir    and   # nor another updir
579             $collapsed[-1] ne $curdir         # nor the curdir
580           ) 
581         {                                     # then
582             pop @collapsed;                   # collapse
583         }
584         else {                                # else
585             push @collapsed, $dir;            # just hang onto it
586         }
587     }
588
589     return $fs->catpath($vol,
590                         $fs->catdir(@collapsed),
591                         $file
592                        );
593 }
594
595
596 1;