This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Keep verbatim pod in File::Mac/Unix within 80 cols
[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.34';
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 Since perl 5.8.0, 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     }
155     foreach (@dirlist) {
156         next unless defined && -d && -w _;
157         $tmpdir = $_;
158         last;
159     }
160     $tmpdir = $self->curdir unless defined $tmpdir;
161     $tmpdir = defined $tmpdir && $self->canonpath($tmpdir);
162     return $tmpdir;
163 }
164
165 sub tmpdir {
166     return $tmpdir if defined $tmpdir;
167     $tmpdir = $_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp" );
168 }
169
170 =item updir
171
172 Returns a string representation of the parent directory.  ".." on UNIX.
173
174 =cut
175
176 sub updir { '..' }
177
178 =item no_upwards
179
180 Given a list of file names, strip out those that refer to a parent
181 directory. (Does not strip symlinks, only '.', '..', and equivalents.)
182
183 =cut
184
185 sub no_upwards {
186     my $self = shift;
187     return grep(!/^\.{1,2}\z/s, @_);
188 }
189
190 =item case_tolerant
191
192 Returns a true or false value indicating, respectively, that alphabetic
193 is not or is significant when comparing file specifications.
194
195 =cut
196
197 sub case_tolerant { 0 }
198
199 =item file_name_is_absolute
200
201 Takes as argument a path and returns true if it is an absolute path.
202
203 This does not consult the local filesystem on Unix, Win32, OS/2 or Mac 
204 OS (Classic).  It does consult the working environment for VMS (see
205 L<File::Spec::VMS/file_name_is_absolute>).
206
207 =cut
208
209 sub file_name_is_absolute {
210     my ($self,$file) = @_;
211     return scalar($file =~ m:^/:s);
212 }
213
214 =item path
215
216 Takes no argument, returns the environment variable PATH as an array.
217
218 =cut
219
220 sub path {
221     return () unless exists $ENV{PATH};
222     my @path = split(':', $ENV{PATH});
223     foreach (@path) { $_ = '.' if $_ eq '' }
224     return @path;
225 }
226
227 =item join
228
229 join is the same as catfile.
230
231 =cut
232
233 sub join {
234     my $self = shift;
235     return $self->catfile(@_);
236 }
237
238 =item splitpath
239
240     ($volume,$directories,$file) = File::Spec->splitpath( $path );
241     ($volume,$directories,$file) = File::Spec->splitpath( $path,
242                                                           $no_file );
243
244 Splits a path into volume, directory, and filename portions. On systems
245 with no concept of volume, returns '' for volume. 
246
247 For systems with no syntax differentiating filenames from directories, 
248 assumes that the last file is a path unless $no_file is true or a 
249 trailing separator or /. or /.. is present. On Unix this means that $no_file
250 true makes this return ( '', $path, '' ).
251
252 The directory portion may or may not be returned with a trailing '/'.
253
254 The results can be passed to L</catpath()> to get back a path equivalent to
255 (usually identical to) the original path.
256
257 =cut
258
259 sub splitpath {
260     my ($self,$path, $nofile) = @_;
261
262     my ($volume,$directory,$file) = ('','','');
263
264     if ( $nofile ) {
265         $directory = $path;
266     }
267     else {
268         $path =~ m|^ ( (?: .* / (?: \.\.?\z )? )? ) ([^/]*) |xs;
269         $directory = $1;
270         $file      = $2;
271     }
272
273     return ($volume,$directory,$file);
274 }
275
276
277 =item splitdir
278
279 The opposite of L</catdir()>.
280
281     @dirs = File::Spec->splitdir( $directories );
282
283 $directories must be only the directory portion of the path on systems 
284 that have the concept of a volume or that have path syntax that differentiates
285 files from directories.
286
287 Unlike just splitting the directories on the separator, empty
288 directory names (C<''>) can be returned, because these are significant
289 on some OSs.
290
291 On Unix,
292
293     File::Spec->splitdir( "/a/b//c/" );
294
295 Yields:
296
297     ( '', 'a', 'b', '', 'c', '' )
298
299 =cut
300
301 sub splitdir {
302     return split m|/|, $_[1], -1;  # Preserve trailing fields
303 }
304
305
306 =item catpath()
307
308 Takes volume, directory and file portions and returns an entire path. Under
309 Unix, $volume is ignored, and directory and file are concatenated.  A '/' is
310 inserted if needed (though if the directory portion doesn't start with
311 '/' it is not added).  On other OSs, $volume is significant.
312
313 =cut
314
315 sub catpath {
316     my ($self,$volume,$directory,$file) = @_;
317
318     if ( $directory ne ''                && 
319          $file ne ''                     && 
320          substr( $directory, -1 ) ne '/' && 
321          substr( $file, 0, 1 ) ne '/' 
322     ) {
323         $directory .= "/$file" ;
324     }
325     else {
326         $directory .= $file ;
327     }
328
329     return $directory ;
330 }
331
332 =item abs2rel
333
334 Takes a destination path and an optional base path returns a relative path
335 from the base path to the destination path:
336
337     $rel_path = File::Spec->abs2rel( $path ) ;
338     $rel_path = File::Spec->abs2rel( $path, $base ) ;
339
340 If $base is not present or '', then L<cwd()|Cwd> is used. If $base is
341 relative, then it is converted to absolute form using
342 L</rel2abs()>. This means that it is taken to be relative to
343 L<cwd()|Cwd>.
344
345 On systems that have a grammar that indicates filenames, this ignores the 
346 $base filename. Otherwise all path components are assumed to be
347 directories.
348
349 If $path is relative, it is converted to absolute form using L</rel2abs()>.
350 This means that it is taken to be relative to L<cwd()|Cwd>.
351
352 No checks against the filesystem are made.  On VMS, there is
353 interaction with the working environment, as logicals and
354 macros are expanded.
355
356 Based on code written by Shigio Yamaguchi.
357
358 =cut
359
360 sub abs2rel {
361     my($self,$path,$base) = @_;
362     $base = $self->_cwd() unless defined $base and length $base;
363
364     ($path, $base) = map $self->canonpath($_), $path, $base;
365
366     if (grep $self->file_name_is_absolute($_), $path, $base) {
367         ($path, $base) = map $self->rel2abs($_), $path, $base;
368     }
369     else {
370         # save a couple of cwd()s if both paths are relative
371         ($path, $base) = map $self->catdir('/', $_), $path, $base;
372     }
373
374     my ($path_volume) = $self->splitpath($path, 1);
375     my ($base_volume) = $self->splitpath($base, 1);
376
377     # Can't relativize across volumes
378     return $path unless $path_volume eq $base_volume;
379
380     my $path_directories = ($self->splitpath($path, 1))[1];
381     my $base_directories = ($self->splitpath($base, 1))[1];
382
383     # For UNC paths, the user might give a volume like //foo/bar that
384     # strictly speaking has no directory portion.  Treat it as if it
385     # had the root directory for that volume.
386     if (!length($base_directories) and $self->file_name_is_absolute($base)) {
387       $base_directories = $self->rootdir;
388     }
389
390     # Now, remove all leading components that are the same
391     my @pathchunks = $self->splitdir( $path_directories );
392     my @basechunks = $self->splitdir( $base_directories );
393
394     if ($base_directories eq $self->rootdir) {
395       shift @pathchunks;
396       return $self->canonpath( $self->catpath('', $self->catdir( @pathchunks ), '') );
397     }
398
399     while (@pathchunks && @basechunks && $self->_same($pathchunks[0], $basechunks[0])) {
400         shift @pathchunks ;
401         shift @basechunks ;
402     }
403     return $self->curdir unless @pathchunks || @basechunks;
404
405     # $base now contains the directories the resulting relative path 
406     # must ascend out of before it can descend to $path_directory.
407     my $result_dirs = $self->catdir( ($self->updir) x @basechunks, @pathchunks );
408     return $self->canonpath( $self->catpath('', $result_dirs, '') );
409 }
410
411 sub _same {
412   $_[1] eq $_[2];
413 }
414
415 =item rel2abs()
416
417 Converts a relative path to an absolute path. 
418
419     $abs_path = File::Spec->rel2abs( $path ) ;
420     $abs_path = File::Spec->rel2abs( $path, $base ) ;
421
422 If $base is not present or '', then L<cwd()|Cwd> is used. If $base is
423 relative, then it is converted to absolute form using
424 L</rel2abs()>. This means that it is taken to be relative to
425 L<cwd()|Cwd>.
426
427 On systems that have a grammar that indicates filenames, this ignores
428 the $base filename. Otherwise all path components are assumed to be
429 directories.
430
431 If $path is absolute, it is cleaned up and returned using L</canonpath()>.
432
433 No checks against the filesystem are made.  On VMS, there is
434 interaction with the working environment, as logicals and
435 macros are expanded.
436
437 Based on code written by Shigio Yamaguchi.
438
439 =cut
440
441 sub rel2abs {
442     my ($self,$path,$base ) = @_;
443
444     # Clean up $path
445     if ( ! $self->file_name_is_absolute( $path ) ) {
446         # Figure out the effective $base and clean it up.
447         if ( !defined( $base ) || $base eq '' ) {
448             $base = $self->_cwd();
449         }
450         elsif ( ! $self->file_name_is_absolute( $base ) ) {
451             $base = $self->rel2abs( $base ) ;
452         }
453         else {
454             $base = $self->canonpath( $base ) ;
455         }
456
457         # Glom them together
458         $path = $self->catdir( $base, $path ) ;
459     }
460
461     return $self->canonpath( $path ) ;
462 }
463
464 =back
465
466 =head1 COPYRIGHT
467
468 Copyright (c) 2004 by the Perl 5 Porters.  All rights reserved.
469
470 This program is free software; you can redistribute it and/or modify
471 it under the same terms as Perl itself.
472
473 =head1 SEE ALSO
474
475 L<File::Spec>
476
477 =cut
478
479 # Internal routine to File::Spec, no point in making this public since
480 # it is the standard Cwd interface.  Most of the platform-specific
481 # File::Spec subclasses use this.
482 sub _cwd {
483     require Cwd;
484     Cwd::getcwd();
485 }
486
487
488 # Internal method to reduce xx\..\yy -> yy
489 sub _collapse {
490     my($fs, $path) = @_;
491
492     my $updir  = $fs->updir;
493     my $curdir = $fs->curdir;
494
495     my($vol, $dirs, $file) = $fs->splitpath($path);
496     my @dirs = $fs->splitdir($dirs);
497     pop @dirs if @dirs && $dirs[-1] eq '';
498
499     my @collapsed;
500     foreach my $dir (@dirs) {
501         if( $dir eq $updir              and   # if we have an updir
502             @collapsed                  and   # and something to collapse
503             length $collapsed[-1]       and   # and its not the rootdir
504             $collapsed[-1] ne $updir    and   # nor another updir
505             $collapsed[-1] ne $curdir         # nor the curdir
506           ) 
507         {                                     # then
508             pop @collapsed;                   # collapse
509         }
510         else {                                # else
511             push @collapsed, $dir;            # just hang onto it
512         }
513     }
514
515     return $fs->catpath($vol,
516                         $fs->catdir(@collapsed),
517                         $file
518                        );
519 }
520
521
522 1;