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