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
CommitLineData
270d1e39
GS
1package File::Spec::Unix;
2
270d1e39 3use strict;
07824bd1 4use vars qw($VERSION);
b4296952 5
e0580a69 6$VERSION = '3.45_01';
07f43755 7my $xs_version = $VERSION;
3d2a0adf 8$VERSION =~ tr/_//;
270d1e39 9
07f43755
Z
10unless (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
270d1e39
GS
21=head1 NAME
22
6fad8743 23File::Spec::Unix - File::Spec for Unix, base for other File::Spec modules
270d1e39
GS
24
25=head1 SYNOPSIS
26
cbc7acb0 27 require File::Spec::Unix; # Done automatically by File::Spec
270d1e39
GS
28
29=head1 DESCRIPTION
30
6fad8743
RK
31Methods for manipulating file specifications. Other File::Spec
32modules, such as File::Spec::Mac, inherit from File::Spec::Unix and
33override specific methods.
270d1e39
GS
34
35=head1 METHODS
36
37=over 2
38
59605c55 39=item canonpath()
270d1e39
GS
40
41No physical check on the filesystem, but a logical cleanup of a
6fad8743 42path. On UNIX eliminates successive slashes and successive "/.".
270d1e39 43
c27914c9 44 $cpath = File::Spec->canonpath( $path ) ;
c27914c9 45
60598624
RGS
46Note that this does *not* collapse F<x/../y> sections into F<y>. This
47is by design. If F</foo> on your system is a symlink to F</bar/baz>,
48then F</foo/../quux> is actually F</bar/quux>, not F</quux> as a naive
49F<../>-removal would give you. If you want to do this kind of
50processing, you probably want C<Cwd>'s C<realpath()> function to
51actually traverse the filesystem cleaning up paths like this.
52
270d1e39
GS
53=cut
54
07f43755 55sub _pp_canonpath {
0994714a 56 my ($self,$path) = @_;
bf7c0a3d 57 return unless defined $path;
89bb8afa 58
04ca015e 59 # Handle POSIX-style node names beginning with double slash (qnx, nto)
04ca015e
MC
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.")
89bb8afa 63 my $node = '';
e9475de8 64 my $double_slashes_special = $^O eq 'qnx' || $^O eq 'nto';
4a4ab19c
NC
65
66
67 if ( $double_slashes_special
68 && ( $path =~ s{^(//[^/]+)/?\z}{}s || $path =~ s{^(//[^/]+)/}{/}s ) ) {
89bb8afa
NA
69 $node = $1;
70 }
7aa86a29 71 # This used to be
9d5071ba 72 # $path =~ s|/+|/|g unless ($^O eq 'cygwin');
7aa86a29
JH
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
e9475de8
SP
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
9596c75c 80 $path =~ s|^/\.\.$|/|; # /.. -> /
e9475de8 81 $path =~ s|/\z|| unless $path eq "/"; # xx/ -> xx
89bb8afa 82 return "$node$path";
270d1e39 83}
07f43755 84*canonpath = \&_pp_canonpath unless defined &canonpath;
270d1e39 85
59605c55 86=item catdir()
270d1e39
GS
87
88Concatenate two or more directory names to form a complete path ending
89with a directory. But remove the trailing slash from the resulting
90string, because it doesn't look good, isn't necessary and confuses
91OS2. Of course, if this is the root directory, don't cut off the
92trailing slash :-)
93
94=cut
95
07f43755 96sub _pp_catdir {
cbc7acb0 97 my $self = shift;
638113eb
JH
98
99 $self->canonpath(join('/', @_, '')); # '' because need a trailing '/'
270d1e39 100}
07f43755 101*catdir = \&_pp_catdir unless defined &catdir;
270d1e39
GS
102
103=item catfile
104
105Concatenate one or more directory names and a filename to form a
106complete path ending with a filename
107
108=cut
109
07f43755 110sub _pp_catfile {
cbc7acb0 111 my $self = shift;
63c6dcc1 112 my $file = $self->canonpath(pop @_);
270d1e39
GS
113 return $file unless @_;
114 my $dir = $self->catdir(@_);
cbc7acb0 115 $dir .= "/" unless substr($dir,-1) eq "/";
270d1e39
GS
116 return $dir.$file;
117}
07f43755 118*catfile = \&_pp_catfile unless defined &catfile;
270d1e39
GS
119
120=item curdir
121
cbc7acb0 122Returns a string representation of the current directory. "." on UNIX.
270d1e39
GS
123
124=cut
125
486bcc50 126sub curdir { '.' }
07f43755 127use constant _fn_curdir => ".";
270d1e39 128
99804bbb
GS
129=item devnull
130
cbc7acb0 131Returns a string representation of the null device. "/dev/null" on UNIX.
99804bbb
GS
132
133=cut
134
486bcc50 135sub devnull { '/dev/null' }
07f43755 136use constant _fn_devnull => "/dev/null";
99804bbb 137
270d1e39
GS
138=item rootdir
139
cbc7acb0 140Returns a string representation of the root directory. "/" on UNIX.
270d1e39
GS
141
142=cut
143
486bcc50 144sub rootdir { '/' }
07f43755 145use constant _fn_rootdir => "/";
270d1e39 146
cbc7acb0
JD
147=item tmpdir
148
07824bd1
JH
149Returns a string representation of the first writable directory from
150the following list or the current directory if none from the list are
151writable:
cbc7acb0
JD
152
153 $ENV{TMPDIR}
154 /tmp
155
63a0dcf7 156If running under taint mode, and if $ENV{TMPDIR}
b4c5e263
RGS
157is tainted, it is not used.
158
cbc7acb0
JD
159=cut
160
82730d4c
FC
161my ($tmpdir, %tmpenv);
162# Cache and return the calculated tmpdir, recording which env vars
163# determined it.
164sub _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.
170sub _cached_tmpdir {
171 shift;
172 local $^W;
173 return if grep $ENV{$_} ne $tmpenv{$_}, @_;
174 return $tmpdir;
175}
07824bd1 176sub _tmpdir {
07824bd1
JH
177 my $self = shift;
178 my @dirlist = @_;
e0580a69
BF
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;
b4c5e263 183 }
e0580a69
BF
184 elsif ($] < 5.007) { # No ${^TAINT} before 5.8
185 @dirlist = grep { eval { eval('1'.substr $_,0,0) } } @dirlist;
186 }
187
b4c5e263 188 foreach (@dirlist) {
cbc7acb0
JD
189 next unless defined && -d && -w _;
190 $tmpdir = $_;
191 last;
192 }
07824bd1
JH
193 $tmpdir = $self->curdir unless defined $tmpdir;
194 $tmpdir = defined $tmpdir && $self->canonpath($tmpdir);
e0580a69
BF
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 }
cbc7acb0
JD
205 return $tmpdir;
206}
207
07824bd1 208sub tmpdir {
82730d4c
FC
209 my $cached = $_[0]->_cached_tmpdir('TMPDIR');
210 return $cached if defined $cached;
211 $_[0]->_cache_tmpdir($_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp" ), 'TMPDIR');
07824bd1
JH
212}
213
270d1e39
GS
214=item updir
215
cbc7acb0 216Returns a string representation of the parent directory. ".." on UNIX.
270d1e39
GS
217
218=cut
219
486bcc50 220sub updir { '..' }
07f43755 221use constant _fn_updir => "..";
270d1e39
GS
222
223=item no_upwards
224
225Given a list of file names, strip out those that refer to a parent
226directory. (Does not strip symlinks, only '.', '..', and equivalents.)
227
228=cut
229
230sub no_upwards {
cbc7acb0 231 my $self = shift;
e9475de8 232 return grep(!/^\.{1,2}\z/s, @_);
270d1e39
GS
233}
234
46726cbe
CB
235=item case_tolerant
236
237Returns a true or false value indicating, respectively, that alphabetic
238is not or is significant when comparing file specifications.
239
240=cut
241
486bcc50 242sub case_tolerant { 0 }
07f43755 243use constant _fn_case_tolerant => 0;
46726cbe 244
270d1e39
GS
245=item file_name_is_absolute
246
3c32ced9
BS
247Takes as argument a path and returns true if it is an absolute path.
248
2586ba89
JH
249This does not consult the local filesystem on Unix, Win32, OS/2 or Mac
250OS (Classic). It does consult the working environment for VMS (see
3c32ced9 251L<File::Spec::VMS/file_name_is_absolute>).
270d1e39
GS
252
253=cut
254
255sub file_name_is_absolute {
cbc7acb0 256 my ($self,$file) = @_;
1b1e14d3 257 return scalar($file =~ m:^/:s);
270d1e39
GS
258}
259
260=item path
261
262Takes no argument, returns the environment variable PATH as an array.
263
264=cut
265
266sub path {
802aa3ba 267 return () unless exists $ENV{PATH};
cbc7acb0
JD
268 my @path = split(':', $ENV{PATH});
269 foreach (@path) { $_ = '.' if $_ eq '' }
270 return @path;
270d1e39
GS
271}
272
273=item join
274
275join is the same as catfile.
276
277=cut
278
279sub join {
cbc7acb0
JD
280 my $self = shift;
281 return $self->catfile(@_);
270d1e39
GS
282}
283
c27914c9
BS
284=item splitpath
285
286 ($volume,$directories,$file) = File::Spec->splitpath( $path );
7302ea77
FC
287 ($volume,$directories,$file) = File::Spec->splitpath( $path,
288 $no_file );
c27914c9 289
40d020d9
RGS
290Splits a path into volume, directory, and filename portions. On systems
291with no concept of volume, returns '' for volume.
c27914c9
BS
292
293For systems with no syntax differentiating filenames from directories,
294assumes that the last file is a path unless $no_file is true or a
295trailing separator or /. or /.. is present. On Unix this means that $no_file
296true makes this return ( '', $path, '' ).
297
298The directory portion may or may not be returned with a trailing '/'.
299
300The 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
305sub splitpath {
306 my ($self,$path, $nofile) = @_;
307
308 my ($volume,$directory,$file) = ('','','');
309
310 if ( $nofile ) {
311 $directory = $path;
312 }
313 else {
e9475de8 314 $path =~ m|^ ( (?: .* / (?: \.\.?\z )? )? ) ([^/]*) |xs;
c27914c9
BS
315 $directory = $1;
316 $file = $2;
317 }
318
319 return ($volume,$directory,$file);
320}
321
322
323=item splitdir
324
325The 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
330that have the concept of a volume or that have path syntax that differentiates
331files from directories.
332
200f06d0
GS
333Unlike just splitting the directories on the separator, empty
334directory names (C<''>) can be returned, because these are significant
2586ba89 335on some OSs.
c27914c9 336
200f06d0
GS
337On Unix,
338
339 File::Spec->splitdir( "/a/b//c/" );
c27914c9
BS
340
341Yields:
342
343 ( '', 'a', 'b', '', 'c', '' )
344
345=cut
346
347sub splitdir {
e021ab8e 348 return split m|/|, $_[1], -1; # Preserve trailing fields
c27914c9
BS
349}
350
351
59605c55 352=item catpath()
c27914c9
BS
353
354Takes volume, directory and file portions and returns an entire path. Under
3099fc99 355Unix, $volume is ignored, and directory and file are concatenated. A '/' is
529a1a84
SB
356inserted if needed (though if the directory portion doesn't start with
357'/' it is not added). On other OSs, $volume is significant.
c27914c9
BS
358
359=cut
360
361sub 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
380Takes a destination path and an optional base path returns a relative path
381from the base path to the destination path:
382
3c32ced9
BS
383 $rel_path = File::Spec->abs2rel( $path ) ;
384 $rel_path = File::Spec->abs2rel( $path, $base ) ;
c27914c9 385
c063e98f
JH
386If $base is not present or '', then L<cwd()|Cwd> is used. If $base is
387relative, then it is converted to absolute form using
388L</rel2abs()>. This means that it is taken to be relative to
389L<cwd()|Cwd>.
c27914c9 390
c27914c9 391On systems that have a grammar that indicates filenames, this ignores the
638113eb 392$base filename. Otherwise all path components are assumed to be
c27914c9
BS
393directories.
394
395If $path is relative, it is converted to absolute form using L</rel2abs()>.
59605c55 396This means that it is taken to be relative to L<cwd()|Cwd>.
c27914c9 397
70b6afc1 398No checks against the filesystem are made, so the result may not be correct if
393ad6ef
FC
399C<$base> contains symbolic links. (Apply
400L<Cwd::abs_path()|Cwd/abs_path> beforehand if that
70b6afc1
VS
401is a concern.) On VMS, there is interaction with the working environment, as
402logicals and macros are expanded.
c27914c9 403
3c32ced9 404Based on code written by Shigio Yamaguchi.
c27914c9
BS
405
406=cut
407
408sub abs2rel {
409 my($self,$path,$base) = @_;
9d5071ba 410 $base = $self->_cwd() unless defined $base and length $base;
c27914c9 411
81a4c762 412 ($path, $base) = map $self->canonpath($_), $path, $base;
c27914c9 413
70b6afc1
VS
414 my $path_directories;
415 my $base_directories;
416
e0dc0ff1 417 if (grep $self->file_name_is_absolute($_), $path, $base) {
81a4c762 418 ($path, $base) = map $self->rel2abs($_), $path, $base;
9d5071ba 419
70b6afc1
VS
420 my ($path_volume) = $self->splitpath($path, 1);
421 my ($base_volume) = $self->splitpath($base, 1);
110c90cc 422
70b6afc1
VS
423 # Can't relativize across volumes
424 return $path unless $path_volume eq $base_volume;
110c90cc 425
70b6afc1
VS
426 $path_directories = ($self->splitpath($path, 1))[1];
427 $base_directories = ($self->splitpath($base, 1))[1];
c27914c9 428
70b6afc1
VS
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);
fa52125f
SP
440 }
441
c27914c9 442 # Now, remove all leading components that are the same
9d5071ba
SP
443 my @pathchunks = $self->splitdir( $path_directories );
444 my @basechunks = $self->splitdir( $base_directories );
6fd19b73 445
fa52125f 446 if ($base_directories eq $self->rootdir) {
70b6afc1 447 return $self->curdir if $path_directories eq $self->rootdir;
fa52125f
SP
448 shift @pathchunks;
449 return $self->canonpath( $self->catpath('', $self->catdir( @pathchunks ), '') );
450 }
451
70b6afc1 452 my @common;
9d5071ba 453 while (@pathchunks && @basechunks && $self->_same($pathchunks[0], $basechunks[0])) {
70b6afc1 454 push @common, shift @pathchunks ;
c27914c9
BS
455 shift @basechunks ;
456 }
9d5071ba 457 return $self->curdir unless @pathchunks || @basechunks;
6fd19b73 458
70b6afc1
VS
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 );
9d5071ba
SP
480 return $self->canonpath( $self->catpath('', $result_dirs, '') );
481}
c27914c9 482
9d5071ba
SP
483sub _same {
484 $_[1] eq $_[2];
c27914c9
BS
485}
486
59605c55 487=item rel2abs()
c27914c9
BS
488
489Converts a relative path to an absolute path.
490
3c32ced9
BS
491 $abs_path = File::Spec->rel2abs( $path ) ;
492 $abs_path = File::Spec->rel2abs( $path, $base ) ;
c27914c9 493
0fab864c
JH
494If $base is not present or '', then L<cwd()|Cwd> is used. If $base is
495relative, then it is converted to absolute form using
496L</rel2abs()>. This means that it is taken to be relative to
497L<cwd()|Cwd>.
c27914c9 498
638113eb
JH
499On systems that have a grammar that indicates filenames, this ignores
500the $base filename. Otherwise all path components are assumed to be
c27914c9
BS
501directories.
502
503If $path is absolute, it is cleaned up and returned using L</canonpath()>.
504
2586ba89 505No checks against the filesystem are made. On VMS, there is
3c32ced9
BS
506interaction with the working environment, as logicals and
507macros are expanded.
c27914c9 508
3c32ced9 509Based on code written by Shigio Yamaguchi.
c27914c9
BS
510
511=cut
512
786b702f 513sub rel2abs {
c27914c9
BS
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 '' ) {
0fab864c 520 $base = $self->_cwd();
c27914c9
BS
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
6fd19b73 530 $path = $self->catdir( $base, $path ) ;
c27914c9
BS
531 }
532
533 return $self->canonpath( $path ) ;
534}
535
270d1e39
GS
536=back
537
99f36a73
RGS
538=head1 COPYRIGHT
539
540Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
541
542This program is free software; you can redistribute it and/or modify
543it under the same terms as Perl itself.
544
70b6afc1
VS
545Please submit bug reports and patches to perlbug@perl.org.
546
270d1e39
GS
547=head1 SEE ALSO
548
549L<File::Spec>
550
551=cut
552
0fab864c
JH
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.
556sub _cwd {
c063e98f 557 require Cwd;
7241d76a 558 Cwd::getcwd();
c063e98f
JH
559}
560
9596c75c
RGS
561
562# Internal method to reduce xx\..\yy -> yy
563sub _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);
c47834cd 571 pop @dirs if @dirs && $dirs[-1] eq '';
9596c75c
RGS
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
270d1e39 5961;