Fix when( scalar ... ) bug
[perl.git] / ext / Cwd / lib / File / Spec / Unix.pm
1 package File::Spec::Unix;
2
3 use strict;
4 use vars qw($VERSION);
5
6 $VERSION = '3.30';
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, $no_file );
242
243 Splits a path into volume, directory, and filename portions. On systems
244 with no concept of volume, returns '' for volume. 
245
246 For systems with no syntax differentiating filenames from directories, 
247 assumes that the last file is a path unless $no_file is true or a 
248 trailing separator or /. or /.. is present. On Unix this means that $no_file
249 true makes this return ( '', $path, '' ).
250
251 The directory portion may or may not be returned with a trailing '/'.
252
253 The results can be passed to L</catpath()> to get back a path equivalent to
254 (usually identical to) the original path.
255
256 =cut
257
258 sub splitpath {
259     my ($self,$path, $nofile) = @_;
260
261     my ($volume,$directory,$file) = ('','','');
262
263     if ( $nofile ) {
264         $directory = $path;
265     }
266     else {
267         $path =~ m|^ ( (?: .* / (?: \.\.?\z )? )? ) ([^/]*) |xs;
268         $directory = $1;
269         $file      = $2;
270     }
271
272     return ($volume,$directory,$file);
273 }
274
275
276 =item splitdir
277
278 The opposite of L</catdir()>.
279
280     @dirs = File::Spec->splitdir( $directories );
281
282 $directories must be only the directory portion of the path on systems 
283 that have the concept of a volume or that have path syntax that differentiates
284 files from directories.
285
286 Unlike just splitting the directories on the separator, empty
287 directory names (C<''>) can be returned, because these are significant
288 on some OSs.
289
290 On Unix,
291
292     File::Spec->splitdir( "/a/b//c/" );
293
294 Yields:
295
296     ( '', 'a', 'b', '', 'c', '' )
297
298 =cut
299
300 sub splitdir {
301     return split m|/|, $_[1], -1;  # Preserve trailing fields
302 }
303
304
305 =item catpath()
306
307 Takes volume, directory and file portions and returns an entire path. Under
308 Unix, $volume is ignored, and directory and file are concatenated.  A '/' is
309 inserted if needed (though if the directory portion doesn't start with
310 '/' it is not added).  On other OSs, $volume is significant.
311
312 =cut
313
314 sub catpath {
315     my ($self,$volume,$directory,$file) = @_;
316
317     if ( $directory ne ''                && 
318          $file ne ''                     && 
319          substr( $directory, -1 ) ne '/' && 
320          substr( $file, 0, 1 ) ne '/' 
321     ) {
322         $directory .= "/$file" ;
323     }
324     else {
325         $directory .= $file ;
326     }
327
328     return $directory ;
329 }
330
331 =item abs2rel
332
333 Takes a destination path and an optional base path returns a relative path
334 from the base path to the destination path:
335
336     $rel_path = File::Spec->abs2rel( $path ) ;
337     $rel_path = File::Spec->abs2rel( $path, $base ) ;
338
339 If $base is not present or '', then L<cwd()|Cwd> is used. If $base is
340 relative, then it is converted to absolute form using
341 L</rel2abs()>. This means that it is taken to be relative to
342 L<cwd()|Cwd>.
343
344 On systems that have a grammar that indicates filenames, this ignores the 
345 $base filename. Otherwise all path components are assumed to be
346 directories.
347
348 If $path is relative, it is converted to absolute form using L</rel2abs()>.
349 This means that it is taken to be relative to L<cwd()|Cwd>.
350
351 No checks against the filesystem are made.  On VMS, there is
352 interaction with the working environment, as logicals and
353 macros are expanded.
354
355 Based on code written by Shigio Yamaguchi.
356
357 =cut
358
359 sub abs2rel {
360     my($self,$path,$base) = @_;
361     $base = $self->_cwd() unless defined $base and length $base;
362
363     ($path, $base) = map $self->canonpath($_), $path, $base;
364
365     if (grep $self->file_name_is_absolute($_), $path, $base) {
366         ($path, $base) = map $self->rel2abs($_), $path, $base;
367     }
368     else {
369         # save a couple of cwd()s if both paths are relative
370         ($path, $base) = map $self->catdir('/', $_), $path, $base;
371     }
372
373     my ($path_volume) = $self->splitpath($path, 1);
374     my ($base_volume) = $self->splitpath($base, 1);
375
376     # Can't relativize across volumes
377     return $path unless $path_volume eq $base_volume;
378
379     my $path_directories = ($self->splitpath($path, 1))[1];
380     my $base_directories = ($self->splitpath($base, 1))[1];
381
382     # For UNC paths, the user might give a volume like //foo/bar that
383     # strictly speaking has no directory portion.  Treat it as if it
384     # had the root directory for that volume.
385     if (!length($base_directories) and $self->file_name_is_absolute($base)) {
386       $base_directories = $self->rootdir;
387     }
388
389     # Now, remove all leading components that are the same
390     my @pathchunks = $self->splitdir( $path_directories );
391     my @basechunks = $self->splitdir( $base_directories );
392
393     if ($base_directories eq $self->rootdir) {
394       shift @pathchunks;
395       return $self->canonpath( $self->catpath('', $self->catdir( @pathchunks ), '') );
396     }
397
398     while (@pathchunks && @basechunks && $self->_same($pathchunks[0], $basechunks[0])) {
399         shift @pathchunks ;
400         shift @basechunks ;
401     }
402     return $self->curdir unless @pathchunks || @basechunks;
403
404     # $base now contains the directories the resulting relative path 
405     # must ascend out of before it can descend to $path_directory.
406     my $result_dirs = $self->catdir( ($self->updir) x @basechunks, @pathchunks );
407     return $self->canonpath( $self->catpath('', $result_dirs, '') );
408 }
409
410 sub _same {
411   $_[1] eq $_[2];
412 }
413
414 =item rel2abs()
415
416 Converts a relative path to an absolute path. 
417
418     $abs_path = File::Spec->rel2abs( $path ) ;
419     $abs_path = File::Spec->rel2abs( $path, $base ) ;
420
421 If $base is not present or '', then L<cwd()|Cwd> is used. If $base is
422 relative, then it is converted to absolute form using
423 L</rel2abs()>. This means that it is taken to be relative to
424 L<cwd()|Cwd>.
425
426 On systems that have a grammar that indicates filenames, this ignores
427 the $base filename. Otherwise all path components are assumed to be
428 directories.
429
430 If $path is absolute, it is cleaned up and returned using L</canonpath()>.
431
432 No checks against the filesystem are made.  On VMS, there is
433 interaction with the working environment, as logicals and
434 macros are expanded.
435
436 Based on code written by Shigio Yamaguchi.
437
438 =cut
439
440 sub rel2abs {
441     my ($self,$path,$base ) = @_;
442
443     # Clean up $path
444     if ( ! $self->file_name_is_absolute( $path ) ) {
445         # Figure out the effective $base and clean it up.
446         if ( !defined( $base ) || $base eq '' ) {
447             $base = $self->_cwd();
448         }
449         elsif ( ! $self->file_name_is_absolute( $base ) ) {
450             $base = $self->rel2abs( $base ) ;
451         }
452         else {
453             $base = $self->canonpath( $base ) ;
454         }
455
456         # Glom them together
457         $path = $self->catdir( $base, $path ) ;
458     }
459
460     return $self->canonpath( $path ) ;
461 }
462
463 =back
464
465 =head1 COPYRIGHT
466
467 Copyright (c) 2004 by the Perl 5 Porters.  All rights reserved.
468
469 This program is free software; you can redistribute it and/or modify
470 it under the same terms as Perl itself.
471
472 =head1 SEE ALSO
473
474 L<File::Spec>
475
476 =cut
477
478 # Internal routine to File::Spec, no point in making this public since
479 # it is the standard Cwd interface.  Most of the platform-specific
480 # File::Spec subclasses use this.
481 sub _cwd {
482     require Cwd;
483     Cwd::getcwd();
484 }
485
486
487 # Internal method to reduce xx\..\yy -> yy
488 sub _collapse {
489     my($fs, $path) = @_;
490
491     my $updir  = $fs->updir;
492     my $curdir = $fs->curdir;
493
494     my($vol, $dirs, $file) = $fs->splitpath($path);
495     my @dirs = $fs->splitdir($dirs);
496     pop @dirs if @dirs && $dirs[-1] eq '';
497
498     my @collapsed;
499     foreach my $dir (@dirs) {
500         if( $dir eq $updir              and   # if we have an updir
501             @collapsed                  and   # and something to collapse
502             length $collapsed[-1]       and   # and its not the rootdir
503             $collapsed[-1] ne $updir    and   # nor another updir
504             $collapsed[-1] ne $curdir         # nor the curdir
505           ) 
506         {                                     # then
507             pop @collapsed;                   # collapse
508         }
509         else {                                # else
510             push @collapsed, $dir;            # just hang onto it
511         }
512     }
513
514     return $fs->catpath($vol,
515                         $fs->catdir(@collapsed),
516                         $file
517                        );
518 }
519
520
521 1;