← Index
NYTProf Performance Profile   « block view • line view • sub view »
For t/app_dpath.t
  Run on Tue Jun 5 15:25:28 2012
Reported on Tue Jun 5 15:26:05 2012

Filename/home/ss5/perl5/perlbrew/perls/perl-5.14.1/lib/5.14.1/x86_64-linux-thread-multi/File/Spec/Unix.pm
StatementsExecuted 10 statements in 7.11ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
11154µs67µsFile::Spec::Unix::::BEGIN@3File::Spec::Unix::BEGIN@3
11137µs98µsFile::Spec::Unix::::BEGIN@149File::Spec::Unix::BEGIN@149
11125µs110µsFile::Spec::Unix::::BEGIN@4File::Spec::Unix::BEGIN@4
0000s0sFile::Spec::Unix::::_collapseFile::Spec::Unix::_collapse
0000s0sFile::Spec::Unix::::_cwdFile::Spec::Unix::_cwd
0000s0sFile::Spec::Unix::::_sameFile::Spec::Unix::_same
0000s0sFile::Spec::Unix::::_tmpdirFile::Spec::Unix::_tmpdir
0000s0sFile::Spec::Unix::::abs2relFile::Spec::Unix::abs2rel
0000s0sFile::Spec::Unix::::canonpathFile::Spec::Unix::canonpath
0000s0sFile::Spec::Unix::::case_tolerantFile::Spec::Unix::case_tolerant
0000s0sFile::Spec::Unix::::catdirFile::Spec::Unix::catdir
0000s0sFile::Spec::Unix::::catfileFile::Spec::Unix::catfile
0000s0sFile::Spec::Unix::::catpathFile::Spec::Unix::catpath
0000s0sFile::Spec::Unix::::curdirFile::Spec::Unix::curdir
0000s0sFile::Spec::Unix::::devnullFile::Spec::Unix::devnull
0000s0sFile::Spec::Unix::::file_name_is_absoluteFile::Spec::Unix::file_name_is_absolute
0000s0sFile::Spec::Unix::::joinFile::Spec::Unix::join
0000s0sFile::Spec::Unix::::no_upwardsFile::Spec::Unix::no_upwards
0000s0sFile::Spec::Unix::::pathFile::Spec::Unix::path
0000s0sFile::Spec::Unix::::rel2absFile::Spec::Unix::rel2abs
0000s0sFile::Spec::Unix::::rootdirFile::Spec::Unix::rootdir
0000s0sFile::Spec::Unix::::splitdirFile::Spec::Unix::splitdir
0000s0sFile::Spec::Unix::::splitpathFile::Spec::Unix::splitpath
0000s0sFile::Spec::Unix::::tmpdirFile::Spec::Unix::tmpdir
0000s0sFile::Spec::Unix::::updirFile::Spec::Unix::updir
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package File::Spec::Unix;
2
32103µs280µs
# spent 67µs (54+13) within File::Spec::Unix::BEGIN@3 which was called: # once (54µs+13µs) by IO::File::BEGIN@134 at line 3
use strict;
# spent 67µs making 1 call to File::Spec::Unix::BEGIN@3 # spent 13µs making 1 call to strict::import
421.98ms2196µs
# spent 110µs (25+86) within File::Spec::Unix::BEGIN@4 which was called: # once (25µs+86µs) by IO::File::BEGIN@134 at line 4
use vars qw($VERSION);
# spent 110µs making 1 call to File::Spec::Unix::BEGIN@4 # spent 86µs making 1 call to vars::import
5
613µs$VERSION = '3.33';
7169µs$VERSION = eval $VERSION;
# spent 10µs executing statements in string eval
8
9=head1 NAME
10
11File::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
19Methods for manipulating file specifications. Other File::Spec
20modules, such as File::Spec::Mac, inherit from File::Spec::Unix and
21override specific methods.
22
23=head1 METHODS
24
25=over 2
26
27=item canonpath()
28
29No physical check on the filesystem, but a logical cleanup of a
30path. On UNIX eliminates successive slashes and successive "/.".
31
32 $cpath = File::Spec->canonpath( $path ) ;
33
34Note that this does *not* collapse F<x/../y> sections into F<y>. This
35is by design. If F</foo> on your system is a symlink to F</bar/baz>,
36then F</foo/../quux> is actually F</bar/quux>, not F</quux> as a naive
37F<../>-removal would give you. If you want to do this kind of
38processing, you probably want C<Cwd>'s C<realpath()> function to
39actually traverse the filesystem cleaning up paths like this.
40
41=cut
42
43sub 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
75Concatenate two or more directory names to form a complete path ending
76with a directory. But remove the trailing slash from the resulting
77string, because it doesn't look good, isn't necessary and confuses
78OS2. Of course, if this is the root directory, don't cut off the
79trailing slash :-)
80
81=cut
82
83sub catdir {
84 my $self = shift;
85
86 $self->canonpath(join('/', @_, '')); # '' because need a trailing '/'
87}
88
89=item catfile
90
91Concatenate one or more directory names and a filename to form a
92complete path ending with a filename
93
94=cut
95
96sub 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
107Returns a string representation of the current directory. "." on UNIX.
108
109=cut
110
111sub curdir { '.' }
112
113=item devnull
114
115Returns a string representation of the null device. "/dev/null" on UNIX.
116
117=cut
118
119sub devnull { '/dev/null' }
120
121=item rootdir
122
123Returns a string representation of the root directory. "/" on UNIX.
124
125=cut
126
127sub rootdir { '/' }
128
129=item tmpdir
130
131Returns a string representation of the first writable directory from
132the following list or the current directory if none from the list are
133writable:
134
135 $ENV{TMPDIR}
136 /tmp
137
138Since perl 5.8.0, if running under taint mode, and if $ENV{TMPDIR}
139is tainted, it is not used.
140
141=cut
142
14311µsmy $tmpdir;
144sub _tmpdir {
145 return $tmpdir if defined $tmpdir;
146 my $self = shift;
147 my @dirlist = @_;
148 {
14924.93ms2160µs
# spent 98µs (37+61) within File::Spec::Unix::BEGIN@149 which was called: # once (37µs+61µs) by IO::File::BEGIN@134 at line 149
no strict 'refs';
# spent 98µs making 1 call to File::Spec::Unix::BEGIN@149 # spent 61µs making 1 call to strict::unimport
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
165sub tmpdir {
166 return $tmpdir if defined $tmpdir;
167 $tmpdir = $_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp" );
168}
169
170=item updir
171
172Returns a string representation of the parent directory. ".." on UNIX.
173
174=cut
175
176sub updir { '..' }
177
178=item no_upwards
179
180Given a list of file names, strip out those that refer to a parent
181directory. (Does not strip symlinks, only '.', '..', and equivalents.)
182
183=cut
184
185sub no_upwards {
186 my $self = shift;
187 return grep(!/^\.{1,2}\z/s, @_);
188}
189
190=item case_tolerant
191
192Returns a true or false value indicating, respectively, that alphabetic
193is not or is significant when comparing file specifications.
194
195=cut
196
197sub case_tolerant { 0 }
198
199=item file_name_is_absolute
200
201Takes as argument a path and returns true if it is an absolute path.
202
203This does not consult the local filesystem on Unix, Win32, OS/2 or Mac
204OS (Classic). It does consult the working environment for VMS (see
205L<File::Spec::VMS/file_name_is_absolute>).
206
207=cut
208
209sub file_name_is_absolute {
210 my ($self,$file) = @_;
211 return scalar($file =~ m:^/:s);
212}
213
214=item path
215
216Takes no argument, returns the environment variable PATH as an array.
217
218=cut
219
220sub 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
229join is the same as catfile.
230
231=cut
232
233sub 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
243Splits a path into volume, directory, and filename portions. On systems
244with no concept of volume, returns '' for volume.
245
246For systems with no syntax differentiating filenames from directories,
247assumes that the last file is a path unless $no_file is true or a
248trailing separator or /. or /.. is present. On Unix this means that $no_file
249true makes this return ( '', $path, '' ).
250
251The directory portion may or may not be returned with a trailing '/'.
252
253The 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
258sub 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
278The 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
283that have the concept of a volume or that have path syntax that differentiates
284files from directories.
285
286Unlike just splitting the directories on the separator, empty
287directory names (C<''>) can be returned, because these are significant
288on some OSs.
289
290On Unix,
291
292 File::Spec->splitdir( "/a/b//c/" );
293
294Yields:
295
296 ( '', 'a', 'b', '', 'c', '' )
297
298=cut
299
300sub splitdir {
301 return split m|/|, $_[1], -1; # Preserve trailing fields
302}
303
304
305=item catpath()
306
307Takes volume, directory and file portions and returns an entire path. Under
308Unix, $volume is ignored, and directory and file are concatenated. A '/' is
309inserted 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
314sub 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
333Takes a destination path and an optional base path returns a relative path
334from the base path to the destination path:
335
336 $rel_path = File::Spec->abs2rel( $path ) ;
337 $rel_path = File::Spec->abs2rel( $path, $base ) ;
338
339If $base is not present or '', then L<cwd()|Cwd> is used. If $base is
340relative, then it is converted to absolute form using
341L</rel2abs()>. This means that it is taken to be relative to
342L<cwd()|Cwd>.
343
344On systems that have a grammar that indicates filenames, this ignores the
345$base filename. Otherwise all path components are assumed to be
346directories.
347
348If $path is relative, it is converted to absolute form using L</rel2abs()>.
349This means that it is taken to be relative to L<cwd()|Cwd>.
350
351No checks against the filesystem are made. On VMS, there is
352interaction with the working environment, as logicals and
353macros are expanded.
354
355Based on code written by Shigio Yamaguchi.
356
357=cut
358
359sub 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
410sub _same {
411 $_[1] eq $_[2];
412}
413
414=item rel2abs()
415
416Converts a relative path to an absolute path.
417
418 $abs_path = File::Spec->rel2abs( $path ) ;
419 $abs_path = File::Spec->rel2abs( $path, $base ) ;
420
421If $base is not present or '', then L<cwd()|Cwd> is used. If $base is
422relative, then it is converted to absolute form using
423L</rel2abs()>. This means that it is taken to be relative to
424L<cwd()|Cwd>.
425
426On systems that have a grammar that indicates filenames, this ignores
427the $base filename. Otherwise all path components are assumed to be
428directories.
429
430If $path is absolute, it is cleaned up and returned using L</canonpath()>.
431
432No checks against the filesystem are made. On VMS, there is
433interaction with the working environment, as logicals and
434macros are expanded.
435
436Based on code written by Shigio Yamaguchi.
437
438=cut
439
440sub 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
467Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
468
469This program is free software; you can redistribute it and/or modify
470it under the same terms as Perl itself.
471
472=head1 SEE ALSO
473
474L<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.
481sub _cwd {
482 require Cwd;
483 Cwd::getcwd();
484}
485
486
487# Internal method to reduce xx\..\yy -> yy
488sub _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
521112µs1;