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