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