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