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