This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
avoid runtime module loading in File::Spec
[perl5.git] / dist / PathTools / lib / File / Spec / Unix.pm
1 package File::Spec::Unix;
2
3 use strict;
4 use Cwd ();
5
6 our $VERSION = '3.69';
7 $VERSION =~ tr/_//d;
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 _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
76 Concatenate two or more directory names to form a complete path ending
77 with a directory. But remove the trailing slash from the resulting
78 string, because it doesn't look good, isn't necessary and confuses
79 OS2. Of course, if this is the root directory, don't cut off the
80 trailing slash :-)
81
82 =cut
83
84 sub _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
93 Concatenate one or more directory names and a filename to form a
94 complete path ending with a filename
95
96 =cut
97
98 sub _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
110 Returns a string representation of the current directory.  "." on UNIX.
111
112 =cut
113
114 sub curdir { '.' }
115 use constant _fn_curdir => ".";
116
117 =item devnull
118
119 Returns a string representation of the null device. "/dev/null" on UNIX.
120
121 =cut
122
123 sub devnull { '/dev/null' }
124 use constant _fn_devnull => "/dev/null";
125
126 =item rootdir
127
128 Returns a string representation of the root directory.  "/" on UNIX.
129
130 =cut
131
132 sub rootdir { '/' }
133 use constant _fn_rootdir => "/";
134
135 =item tmpdir
136
137 Returns a string representation of the first writable directory from
138 the following list or the current directory if none from the list are
139 writable:
140
141     $ENV{TMPDIR}
142     /tmp
143
144 If running under taint mode, and if $ENV{TMPDIR}
145 is tainted, it is not used.
146
147 =cut
148
149 my ($tmpdir, %tmpenv);
150 # Cache and return the calculated tmpdir, recording which env vars
151 # determined it.
152 sub _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.
158 sub _cached_tmpdir {
159     shift;
160     local $^W;
161     return if grep $ENV{$_} ne $tmpenv{$_}, @_;
162     return $tmpdir;
163 }
164 sub _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
196 sub 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
204 Returns a string representation of the parent directory.  ".." on UNIX.
205
206 =cut
207
208 sub updir { '..' }
209 use constant _fn_updir => "..";
210
211 =item no_upwards
212
213 Given a list of file names, strip out those that refer to a parent
214 directory. (Does not strip symlinks, only '.', '..', and equivalents.)
215
216 =cut
217
218 sub no_upwards {
219     my $self = shift;
220     return grep(!/^\.{1,2}\z/s, @_);
221 }
222
223 =item case_tolerant
224
225 Returns a true or false value indicating, respectively, that alphabetic
226 is not or is significant when comparing file specifications.
227
228 =cut
229
230 sub case_tolerant { 0 }
231 use constant _fn_case_tolerant => 0;
232
233 =item file_name_is_absolute
234
235 Takes as argument a path and returns true if it is an absolute path.
236
237 This does not consult the local filesystem on Unix, Win32, OS/2 or Mac 
238 OS (Classic).  It does consult the working environment for VMS (see
239 L<File::Spec::VMS/file_name_is_absolute>).
240
241 =cut
242
243 sub file_name_is_absolute {
244     my ($self,$file) = @_;
245     return scalar($file =~ m:^/:s);
246 }
247
248 =item path
249
250 Takes no argument, returns the environment variable PATH as an array.
251
252 =cut
253
254 sub 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
263 join is the same as catfile.
264
265 =cut
266
267 sub 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
278 Splits a path into volume, directory, and filename portions. On systems
279 with no concept of volume, returns '' for volume. 
280
281 For systems with no syntax differentiating filenames from directories, 
282 assumes that the last file is a path unless $no_file is true or a 
283 trailing separator or /. or /.. is present. On Unix this means that $no_file
284 true makes this return ( '', $path, '' ).
285
286 The directory portion may or may not be returned with a trailing '/'.
287
288 The 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
293 sub 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
313 The 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 
318 that have the concept of a volume or that have path syntax that differentiates
319 files from directories.
320
321 Unlike just splitting the directories on the separator, empty
322 directory names (C<''>) can be returned, because these are significant
323 on some OSs.
324
325 On Unix,
326
327     File::Spec->splitdir( "/a/b//c/" );
328
329 Yields:
330
331     ( '', 'a', 'b', '', 'c', '' )
332
333 =cut
334
335 sub splitdir {
336     return split m|/|, $_[1], -1;  # Preserve trailing fields
337 }
338
339
340 =item catpath()
341
342 Takes volume, directory and file portions and returns an entire path. Under
343 Unix, $volume is ignored, and directory and file are concatenated.  A '/' is
344 inserted 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
349 sub 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
368 Takes a destination path and an optional base path returns a relative path
369 from the base path to the destination path:
370
371     $rel_path = File::Spec->abs2rel( $path ) ;
372     $rel_path = File::Spec->abs2rel( $path, $base ) ;
373
374 If $base is not present or '', then L<cwd()|Cwd> is used. If $base is
375 relative, then it is converted to absolute form using
376 L</rel2abs()>. This means that it is taken to be relative to
377 L<cwd()|Cwd>.
378
379 On systems that have a grammar that indicates filenames, this ignores the 
380 $base filename. Otherwise all path components are assumed to be
381 directories.
382
383 If $path is relative, it is converted to absolute form using L</rel2abs()>.
384 This means that it is taken to be relative to L<cwd()|Cwd>.
385
386 No checks against the filesystem are made, so the result may not be correct if
387 C<$base> contains symbolic links.  (Apply
388 L<Cwd::abs_path()|Cwd/abs_path> beforehand if that
389 is a concern.)  On VMS, there is interaction with the working environment, as
390 logicals and macros are expanded.
391
392 Based on code written by Shigio Yamaguchi.
393
394 =cut
395
396 sub 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
471 sub _same {
472   $_[1] eq $_[2];
473 }
474
475 =item rel2abs()
476
477 Converts a relative path to an absolute path. 
478
479     $abs_path = File::Spec->rel2abs( $path ) ;
480     $abs_path = File::Spec->rel2abs( $path, $base ) ;
481
482 If $base is not present or '', then L<cwd()|Cwd> is used. If $base is
483 relative, then it is converted to absolute form using
484 L</rel2abs()>. This means that it is taken to be relative to
485 L<cwd()|Cwd>.
486
487 On systems that have a grammar that indicates filenames, this ignores
488 the $base filename. Otherwise all path components are assumed to be
489 directories.
490
491 If $path is absolute, it is cleaned up and returned using L</canonpath()>.
492
493 No checks against the filesystem are made.  On VMS, there is
494 interaction with the working environment, as logicals and
495 macros are expanded.
496
497 Based on code written by Shigio Yamaguchi.
498
499 =cut
500
501 sub 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
528 Copyright (c) 2004 by the Perl 5 Porters.  All rights reserved.
529
530 This program is free software; you can redistribute it and/or modify
531 it under the same terms as Perl itself.
532
533 Please submit bug reports and patches to perlbug@perl.org.
534
535 =head1 SEE ALSO
536
537 L<File::Spec>
538
539 =cut
540
541 # Internal method to reduce xx\..\yy -> yy
542 sub _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
575 1;