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