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