This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
speed up building with less disk IO pod moves+__END__+misc
[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
f4eedc6b 6$VERSION = '3.51';
07f43755 7my $xs_version = $VERSION;
3d2a0adf 8$VERSION =~ tr/_//;
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
BF
187 elsif ($] < 5.007) { # No ${^TAINT} before 5.8
188 @dirlist = grep { eval { eval('1'.substr $_,0,0) } } @dirlist;
189 }
190
b4c5e263 191 foreach (@dirlist) {
cbc7acb0
JD
192 next unless defined && -d && -w _;
193 $tmpdir = $_;
194 last;
195 }
07824bd1
JH
196 $tmpdir = $self->curdir unless defined $tmpdir;
197 $tmpdir = defined $tmpdir && $self->canonpath($tmpdir);
bb38eb53 198 if ( !$self->file_name_is_absolute($tmpdir) ) {
e0580a69 199 # See [perl #120593] for the full details
bb38eb53
BF
200 # If possible, return a full path, rather than '.' or 'lib', but
201 # jump through some hoops to avoid returning a tainted value.
e0580a69
BF
202 ($tmpdir) = grep {
203 $taint ? ! Scalar::Util::tainted($_) :
204 $] < 5.007 ? eval { eval('1'.substr $_,0,0) } : 1
205 } $self->rel2abs($tmpdir), $tmpdir;
206 }
cbc7acb0
JD
207 return $tmpdir;
208}
209
07824bd1 210sub tmpdir {
82730d4c
FC
211 my $cached = $_[0]->_cached_tmpdir('TMPDIR');
212 return $cached if defined $cached;
213 $_[0]->_cache_tmpdir($_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp" ), 'TMPDIR');
07824bd1
JH
214}
215
270d1e39
GS
216=item updir
217
cbc7acb0 218Returns a string representation of the parent directory. ".." on UNIX.
270d1e39
GS
219
220=cut
221
486bcc50 222sub updir { '..' }
07f43755 223use constant _fn_updir => "..";
270d1e39
GS
224
225=item no_upwards
226
227Given a list of file names, strip out those that refer to a parent
228directory. (Does not strip symlinks, only '.', '..', and equivalents.)
229
230=cut
231
232sub no_upwards {
cbc7acb0 233 my $self = shift;
e9475de8 234 return grep(!/^\.{1,2}\z/s, @_);
270d1e39
GS
235}
236
46726cbe
CB
237=item case_tolerant
238
239Returns a true or false value indicating, respectively, that alphabetic
240is not or is significant when comparing file specifications.
241
242=cut
243
486bcc50 244sub case_tolerant { 0 }
07f43755 245use constant _fn_case_tolerant => 0;
46726cbe 246
270d1e39
GS
247=item file_name_is_absolute
248
3c32ced9
BS
249Takes as argument a path and returns true if it is an absolute path.
250
2586ba89
JH
251This does not consult the local filesystem on Unix, Win32, OS/2 or Mac
252OS (Classic). It does consult the working environment for VMS (see
3c32ced9 253L<File::Spec::VMS/file_name_is_absolute>).
270d1e39
GS
254
255=cut
256
257sub file_name_is_absolute {
cbc7acb0 258 my ($self,$file) = @_;
1b1e14d3 259 return scalar($file =~ m:^/:s);
270d1e39
GS
260}
261
262=item path
263
264Takes no argument, returns the environment variable PATH as an array.
265
266=cut
267
268sub path {
802aa3ba 269 return () unless exists $ENV{PATH};
cbc7acb0
JD
270 my @path = split(':', $ENV{PATH});
271 foreach (@path) { $_ = '.' if $_ eq '' }
272 return @path;
270d1e39
GS
273}
274
275=item join
276
277join is the same as catfile.
278
279=cut
280
281sub join {
cbc7acb0
JD
282 my $self = shift;
283 return $self->catfile(@_);
270d1e39
GS
284}
285
c27914c9
BS
286=item splitpath
287
288 ($volume,$directories,$file) = File::Spec->splitpath( $path );
7302ea77
FC
289 ($volume,$directories,$file) = File::Spec->splitpath( $path,
290 $no_file );
c27914c9 291
40d020d9
RGS
292Splits a path into volume, directory, and filename portions. On systems
293with no concept of volume, returns '' for volume.
c27914c9
BS
294
295For systems with no syntax differentiating filenames from directories,
296assumes that the last file is a path unless $no_file is true or a
297trailing separator or /. or /.. is present. On Unix this means that $no_file
298true makes this return ( '', $path, '' ).
299
300The directory portion may or may not be returned with a trailing '/'.
301
302The results can be passed to L</catpath()> to get back a path equivalent to
303(usually identical to) the original path.
304
305=cut
306
307sub splitpath {
308 my ($self,$path, $nofile) = @_;
309
310 my ($volume,$directory,$file) = ('','','');
311
312 if ( $nofile ) {
313 $directory = $path;
314 }
315 else {
e9475de8 316 $path =~ m|^ ( (?: .* / (?: \.\.?\z )? )? ) ([^/]*) |xs;
c27914c9
BS
317 $directory = $1;
318 $file = $2;
319 }
320
321 return ($volume,$directory,$file);
322}
323
324
325=item splitdir
326
327The opposite of L</catdir()>.
328
329 @dirs = File::Spec->splitdir( $directories );
330
331$directories must be only the directory portion of the path on systems
332that have the concept of a volume or that have path syntax that differentiates
333files from directories.
334
200f06d0
GS
335Unlike just splitting the directories on the separator, empty
336directory names (C<''>) can be returned, because these are significant
2586ba89 337on some OSs.
c27914c9 338
200f06d0
GS
339On Unix,
340
341 File::Spec->splitdir( "/a/b//c/" );
c27914c9
BS
342
343Yields:
344
345 ( '', 'a', 'b', '', 'c', '' )
346
347=cut
348
349sub splitdir {
e021ab8e 350 return split m|/|, $_[1], -1; # Preserve trailing fields
c27914c9
BS
351}
352
353
59605c55 354=item catpath()
c27914c9
BS
355
356Takes volume, directory and file portions and returns an entire path. Under
3099fc99 357Unix, $volume is ignored, and directory and file are concatenated. A '/' is
529a1a84
SB
358inserted if needed (though if the directory portion doesn't start with
359'/' it is not added). On other OSs, $volume is significant.
c27914c9
BS
360
361=cut
362
363sub catpath {
364 my ($self,$volume,$directory,$file) = @_;
365
366 if ( $directory ne '' &&
367 $file ne '' &&
368 substr( $directory, -1 ) ne '/' &&
369 substr( $file, 0, 1 ) ne '/'
370 ) {
371 $directory .= "/$file" ;
372 }
373 else {
374 $directory .= $file ;
375 }
376
377 return $directory ;
378}
379
380=item abs2rel
381
382Takes a destination path and an optional base path returns a relative path
383from the base path to the destination path:
384
3c32ced9
BS
385 $rel_path = File::Spec->abs2rel( $path ) ;
386 $rel_path = File::Spec->abs2rel( $path, $base ) ;
c27914c9 387
c063e98f
JH
388If $base is not present or '', then L<cwd()|Cwd> is used. If $base is
389relative, then it is converted to absolute form using
390L</rel2abs()>. This means that it is taken to be relative to
391L<cwd()|Cwd>.
c27914c9 392
c27914c9 393On systems that have a grammar that indicates filenames, this ignores the
638113eb 394$base filename. Otherwise all path components are assumed to be
c27914c9
BS
395directories.
396
397If $path is relative, it is converted to absolute form using L</rel2abs()>.
59605c55 398This means that it is taken to be relative to L<cwd()|Cwd>.
c27914c9 399
70b6afc1 400No checks against the filesystem are made, so the result may not be correct if
393ad6ef
FC
401C<$base> contains symbolic links. (Apply
402L<Cwd::abs_path()|Cwd/abs_path> beforehand if that
70b6afc1
VS
403is a concern.) On VMS, there is interaction with the working environment, as
404logicals and macros are expanded.
c27914c9 405
3c32ced9 406Based on code written by Shigio Yamaguchi.
c27914c9
BS
407
408=cut
409
410sub abs2rel {
411 my($self,$path,$base) = @_;
9d5071ba 412 $base = $self->_cwd() unless defined $base and length $base;
c27914c9 413
81a4c762 414 ($path, $base) = map $self->canonpath($_), $path, $base;
c27914c9 415
70b6afc1
VS
416 my $path_directories;
417 my $base_directories;
418
e0dc0ff1 419 if (grep $self->file_name_is_absolute($_), $path, $base) {
81a4c762 420 ($path, $base) = map $self->rel2abs($_), $path, $base;
9d5071ba 421
70b6afc1
VS
422 my ($path_volume) = $self->splitpath($path, 1);
423 my ($base_volume) = $self->splitpath($base, 1);
110c90cc 424
70b6afc1
VS
425 # Can't relativize across volumes
426 return $path unless $path_volume eq $base_volume;
110c90cc 427
70b6afc1
VS
428 $path_directories = ($self->splitpath($path, 1))[1];
429 $base_directories = ($self->splitpath($base, 1))[1];
c27914c9 430
70b6afc1
VS
431 # For UNC paths, the user might give a volume like //foo/bar that
432 # strictly speaking has no directory portion. Treat it as if it
433 # had the root directory for that volume.
434 if (!length($base_directories) and $self->file_name_is_absolute($base)) {
435 $base_directories = $self->rootdir;
436 }
437 }
438 else {
439 my $wd= ($self->splitpath($self->_cwd(), 1))[1];
440 $path_directories = $self->catdir($wd, $path);
441 $base_directories = $self->catdir($wd, $base);
fa52125f
SP
442 }
443
c27914c9 444 # Now, remove all leading components that are the same
9d5071ba
SP
445 my @pathchunks = $self->splitdir( $path_directories );
446 my @basechunks = $self->splitdir( $base_directories );
6fd19b73 447
fa52125f 448 if ($base_directories eq $self->rootdir) {
70b6afc1 449 return $self->curdir if $path_directories eq $self->rootdir;
fa52125f
SP
450 shift @pathchunks;
451 return $self->canonpath( $self->catpath('', $self->catdir( @pathchunks ), '') );
452 }
453
70b6afc1 454 my @common;
9d5071ba 455 while (@pathchunks && @basechunks && $self->_same($pathchunks[0], $basechunks[0])) {
70b6afc1 456 push @common, shift @pathchunks ;
c27914c9
BS
457 shift @basechunks ;
458 }
9d5071ba 459 return $self->curdir unless @pathchunks || @basechunks;
6fd19b73 460
70b6afc1
VS
461 # @basechunks now contains the directories the resulting relative path
462 # must ascend out of before it can descend to $path_directory. If there
463 # are updir components, we must descend into the corresponding directories
464 # (this only works if they are no symlinks).
465 my @reverse_base;
466 while( defined(my $dir= shift @basechunks) ) {
467 if( $dir ne $self->updir ) {
468 unshift @reverse_base, $self->updir;
469 push @common, $dir;
470 }
471 elsif( @common ) {
472 if( @reverse_base && $reverse_base[0] eq $self->updir ) {
473 shift @reverse_base;
474 pop @common;
475 }
476 else {
477 unshift @reverse_base, pop @common;
478 }
479 }
480 }
481 my $result_dirs = $self->catdir( @reverse_base, @pathchunks );
9d5071ba
SP
482 return $self->canonpath( $self->catpath('', $result_dirs, '') );
483}
c27914c9 484
9d5071ba
SP
485sub _same {
486 $_[1] eq $_[2];
c27914c9
BS
487}
488
59605c55 489=item rel2abs()
c27914c9
BS
490
491Converts a relative path to an absolute path.
492
3c32ced9
BS
493 $abs_path = File::Spec->rel2abs( $path ) ;
494 $abs_path = File::Spec->rel2abs( $path, $base ) ;
c27914c9 495
0fab864c
JH
496If $base is not present or '', then L<cwd()|Cwd> is used. If $base is
497relative, then it is converted to absolute form using
498L</rel2abs()>. This means that it is taken to be relative to
499L<cwd()|Cwd>.
c27914c9 500
638113eb
JH
501On systems that have a grammar that indicates filenames, this ignores
502the $base filename. Otherwise all path components are assumed to be
c27914c9
BS
503directories.
504
505If $path is absolute, it is cleaned up and returned using L</canonpath()>.
506
2586ba89 507No checks against the filesystem are made. On VMS, there is
3c32ced9
BS
508interaction with the working environment, as logicals and
509macros are expanded.
c27914c9 510
3c32ced9 511Based on code written by Shigio Yamaguchi.
c27914c9
BS
512
513=cut
514
786b702f 515sub rel2abs {
c27914c9
BS
516 my ($self,$path,$base ) = @_;
517
518 # Clean up $path
519 if ( ! $self->file_name_is_absolute( $path ) ) {
520 # Figure out the effective $base and clean it up.
521 if ( !defined( $base ) || $base eq '' ) {
0fab864c 522 $base = $self->_cwd();
c27914c9
BS
523 }
524 elsif ( ! $self->file_name_is_absolute( $base ) ) {
525 $base = $self->rel2abs( $base ) ;
526 }
527 else {
528 $base = $self->canonpath( $base ) ;
529 }
530
531 # Glom them together
6fd19b73 532 $path = $self->catdir( $base, $path ) ;
c27914c9
BS
533 }
534
535 return $self->canonpath( $path ) ;
536}
537
270d1e39
GS
538=back
539
99f36a73
RGS
540=head1 COPYRIGHT
541
542Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
543
544This program is free software; you can redistribute it and/or modify
545it under the same terms as Perl itself.
546
70b6afc1
VS
547Please submit bug reports and patches to perlbug@perl.org.
548
270d1e39
GS
549=head1 SEE ALSO
550
551L<File::Spec>
552
553=cut
554
0fab864c
JH
555# Internal routine to File::Spec, no point in making this public since
556# it is the standard Cwd interface. Most of the platform-specific
557# File::Spec subclasses use this.
558sub _cwd {
c063e98f 559 require Cwd;
7241d76a 560 Cwd::getcwd();
c063e98f
JH
561}
562
9596c75c
RGS
563
564# Internal method to reduce xx\..\yy -> yy
565sub _collapse {
566 my($fs, $path) = @_;
567
568 my $updir = $fs->updir;
569 my $curdir = $fs->curdir;
570
571 my($vol, $dirs, $file) = $fs->splitpath($path);
572 my @dirs = $fs->splitdir($dirs);
c47834cd 573 pop @dirs if @dirs && $dirs[-1] eq '';
9596c75c
RGS
574
575 my @collapsed;
576 foreach my $dir (@dirs) {
577 if( $dir eq $updir and # if we have an updir
578 @collapsed and # and something to collapse
579 length $collapsed[-1] and # and its not the rootdir
580 $collapsed[-1] ne $updir and # nor another updir
581 $collapsed[-1] ne $curdir # nor the curdir
582 )
583 { # then
584 pop @collapsed; # collapse
585 }
586 else { # else
587 push @collapsed, $dir; # just hang onto it
588 }
589 }
590
591 return $fs->catpath($vol,
592 $fs->catdir(@collapsed),
593 $file
594 );
595}
596
597
270d1e39 5981;