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