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