Filename | /home/hinrik/perl5/perlbrew/perls/perl-5.13.5/lib/5.13.5/File/Basename.pm |
Statements | Executed 57 statements in 1.27ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 77µs | 120µs | fileparse_set_fstype | File::Basename::
1 | 1 | 1 | 34µs | 38µs | fileparse | File::Basename::
9 | 1 | 1 | 31µs | 31µs | CORE:regcomp (opcode) | File::Basename::
1 | 1 | 1 | 26µs | 97µs | basename | File::Basename::
1 | 1 | 1 | 22µs | 33µs | _strip_trailing_sep | File::Basename::
1 | 1 | 1 | 21µs | 21µs | BEGIN@51 | File::Basename::
1 | 1 | 1 | 19µs | 19µs | BEGIN@42 | File::Basename::
10 | 2 | 1 | 16µs | 16µs | CORE:match (opcode) | File::Basename::
1 | 1 | 1 | 11µs | 16µs | BEGIN@50 | File::Basename::
1 | 1 | 1 | 10µs | 20µs | BEGIN@52 | File::Basename::
1 | 1 | 1 | 10µs | 10µs | BEGIN@357 | File::Basename::
1 | 1 | 1 | 6µs | 6µs | CORE:subst (opcode) | File::Basename::
2 | 1 | 1 | 5µs | 5µs | CORE:substcont (opcode) | File::Basename::
0 | 0 | 0 | 0s | 0s | dirname | File::Basename::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | =head1 NAME | ||||
2 | |||||
3 | File::Basename - Parse file paths into directory, filename and suffix. | ||||
4 | |||||
5 | =head1 SYNOPSIS | ||||
6 | |||||
7 | use File::Basename; | ||||
8 | |||||
9 | ($name,$path,$suffix) = fileparse($fullname,@suffixlist); | ||||
10 | $name = fileparse($fullname,@suffixlist); | ||||
11 | |||||
12 | $basename = basename($fullname,@suffixlist); | ||||
13 | $dirname = dirname($fullname); | ||||
14 | |||||
15 | |||||
16 | =head1 DESCRIPTION | ||||
17 | |||||
18 | These routines allow you to parse file paths into their directory, filename | ||||
19 | and suffix. | ||||
20 | |||||
21 | B<NOTE>: C<dirname()> and C<basename()> emulate the behaviours, and | ||||
22 | quirks, of the shell and C functions of the same name. See each | ||||
23 | function's documentation for details. If your concern is just parsing | ||||
24 | paths it is safer to use L<File::Spec>'s C<splitpath()> and | ||||
25 | C<splitdir()> methods. | ||||
26 | |||||
27 | It is guaranteed that | ||||
28 | |||||
29 | # Where $path_separator is / for Unix, \ for Windows, etc... | ||||
30 | dirname($path) . $path_separator . basename($path); | ||||
31 | |||||
32 | is equivalent to the original path for all systems but VMS. | ||||
33 | |||||
34 | |||||
35 | =cut | ||||
36 | |||||
37 | |||||
38 | package File::Basename; | ||||
39 | |||||
40 | # File::Basename is used during the Perl build, when the re extension may | ||||
41 | # not be available, but we only actually need it if running under tainting. | ||||
42 | # spent 19µs within File::Basename::BEGIN@42 which was called:
# once (19µs+0s) by Getopt::Long::Descriptive::BEGIN@6 at line 47 | ||||
43 | 1 | 7µs | if (${^TAINT}) { | ||
44 | require re; | ||||
45 | re->import('taint'); | ||||
46 | } | ||||
47 | 1 | 18µs | 1 | 19µs | } # spent 19µs making 1 call to File::Basename::BEGIN@42 |
48 | |||||
49 | |||||
50 | 2 | 24µs | 2 | 20µs | # spent 16µs (11+5) within File::Basename::BEGIN@50 which was called:
# once (11µs+5µs) by Getopt::Long::Descriptive::BEGIN@6 at line 50 # spent 16µs making 1 call to File::Basename::BEGIN@50
# spent 5µs making 1 call to strict::import |
51 | 2 | 41µs | 1 | 21µs | # spent 21µs within File::Basename::BEGIN@51 which was called:
# once (21µs+0s) by Getopt::Long::Descriptive::BEGIN@6 at line 51 # spent 21µs making 1 call to File::Basename::BEGIN@51 |
52 | 2 | 915µs | 2 | 29µs | # spent 20µs (10+9) within File::Basename::BEGIN@52 which was called:
# once (10µs+9µs) by Getopt::Long::Descriptive::BEGIN@6 at line 52 # spent 20µs making 1 call to File::Basename::BEGIN@52
# spent 9µs making 1 call to warnings::import |
53 | 1 | 1µs | our(@ISA, @EXPORT, $VERSION, $Fileparse_fstype, $Fileparse_igncase); | ||
54 | 1 | 2µs | require Exporter; | ||
55 | 1 | 6µs | @ISA = qw(Exporter); | ||
56 | 1 | 2µs | @EXPORT = qw(fileparse fileparse_set_fstype basename dirname); | ||
57 | 1 | 1µs | $VERSION = "2.79"; | ||
58 | |||||
59 | 1 | 4µs | 1 | 120µs | fileparse_set_fstype($^O); # spent 120µs making 1 call to File::Basename::fileparse_set_fstype |
60 | |||||
61 | |||||
62 | =over 4 | ||||
63 | |||||
64 | =item C<fileparse> | ||||
65 | X<fileparse> | ||||
66 | |||||
67 | my($filename, $directories, $suffix) = fileparse($path); | ||||
68 | my($filename, $directories, $suffix) = fileparse($path, @suffixes); | ||||
69 | my $filename = fileparse($path, @suffixes); | ||||
70 | |||||
71 | The C<fileparse()> routine divides a file path into its $directories, $filename | ||||
72 | and (optionally) the filename $suffix. | ||||
73 | |||||
74 | $directories contains everything up to and including the last | ||||
75 | directory separator in the $path including the volume (if applicable). | ||||
76 | The remainder of the $path is the $filename. | ||||
77 | |||||
78 | # On Unix returns ("baz", "/foo/bar/", "") | ||||
79 | fileparse("/foo/bar/baz"); | ||||
80 | |||||
81 | # On Windows returns ("baz", "C:\foo\bar\", "") | ||||
82 | fileparse("C:\foo\bar\baz"); | ||||
83 | |||||
84 | # On Unix returns ("", "/foo/bar/baz/", "") | ||||
85 | fileparse("/foo/bar/baz/"); | ||||
86 | |||||
87 | If @suffixes are given each element is a pattern (either a string or a | ||||
88 | C<qr//>) matched against the end of the $filename. The matching | ||||
89 | portion is removed and becomes the $suffix. | ||||
90 | |||||
91 | # On Unix returns ("baz", "/foo/bar/", ".txt") | ||||
92 | fileparse("/foo/bar/baz.txt", qr/\.[^.]*/); | ||||
93 | |||||
94 | If type is non-Unix (see C<fileparse_set_fstype()>) then the pattern | ||||
95 | matching for suffix removal is performed case-insensitively, since | ||||
96 | those systems are not case-sensitive when opening existing files. | ||||
97 | |||||
98 | You are guaranteed that C<$directories . $filename . $suffix> will | ||||
99 | denote the same location as the original $path. | ||||
100 | |||||
101 | =cut | ||||
102 | |||||
103 | |||||
104 | # spent 38µs (34+4) within File::Basename::fileparse which was called:
# once (34µs+4µs) by File::Basename::basename at line 218 | ||||
105 | 13 | 31µs | my($fullname,@suffices) = @_; | ||
106 | |||||
107 | unless (defined $fullname) { | ||||
108 | require Carp; | ||||
109 | Carp::croak("fileparse(): need a valid pathname"); | ||||
110 | } | ||||
111 | |||||
112 | my $orig_type = ''; | ||||
113 | my($type,$igncase) = ($Fileparse_fstype, $Fileparse_igncase); | ||||
114 | |||||
115 | my($taint) = substr($fullname,0,0); # Is $fullname tainted? | ||||
116 | |||||
117 | if ($type eq "VMS" and $fullname =~ m{/} ) { | ||||
118 | # We're doing Unix emulation | ||||
119 | $orig_type = $type; | ||||
120 | $type = 'Unix'; | ||||
121 | } | ||||
122 | |||||
123 | my($dirpath, $basename); | ||||
124 | |||||
125 | 3 | 12µs | if (grep { $type eq $_ } qw(MSDOS DOS MSWin32 Epoc)) { | ||
126 | ($dirpath,$basename) = ($fullname =~ /^((?:.*[:\\\/])?)(.*)/s); | ||||
127 | $dirpath .= '.\\' unless $dirpath =~ /[\\\/]\z/; | ||||
128 | } | ||||
129 | elsif ($type eq "OS2") { | ||||
130 | ($dirpath,$basename) = ($fullname =~ m#^((?:.*[:\\/])?)(.*)#s); | ||||
131 | $dirpath = './' unless $dirpath; # Can't be 0 | ||||
132 | $dirpath .= '/' unless $dirpath =~ m#[\\/]\z#; | ||||
133 | } | ||||
134 | elsif ($type eq "AmigaOS") { | ||||
135 | ($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/s); | ||||
136 | $dirpath = './' unless $dirpath; | ||||
137 | } | ||||
138 | elsif ($type eq 'VMS' ) { | ||||
139 | ($dirpath,$basename) = ($fullname =~ /^(.*[:>\]])?(.*)/s); | ||||
140 | $dirpath ||= ''; # should always be defined | ||||
141 | } | ||||
142 | else { # Default to Unix semantics. | ||||
143 | 1 | 4µs | ($dirpath,$basename) = ($fullname =~ m{^(.*/)?(.*)}s); # spent 4µs making 1 call to File::Basename::CORE:match | ||
144 | if ($orig_type eq 'VMS' and $fullname =~ m{^(/[^/]+/000000(/|$))(.*)}) { | ||||
145 | # dev:[000000] is top of VMS tree, similar to Unix '/' | ||||
146 | # so strip it off and treat the rest as "normal" | ||||
147 | my $devspec = $1; | ||||
148 | my $remainder = $3; | ||||
149 | ($dirpath,$basename) = ($remainder =~ m{^(.*/)?(.*)}s); | ||||
150 | $dirpath ||= ''; # should always be defined | ||||
151 | $dirpath = $devspec.$dirpath; | ||||
152 | } | ||||
153 | $dirpath = './' unless $dirpath; | ||||
154 | } | ||||
155 | |||||
156 | |||||
157 | my $tail = ''; | ||||
158 | my $suffix = ''; | ||||
159 | if (@suffices) { | ||||
160 | foreach $suffix (@suffices) { | ||||
161 | my $pat = ($igncase ? '(?i)' : '') . "($suffix)\$"; | ||||
162 | if ($basename =~ s/$pat//s) { | ||||
163 | $taint .= substr($suffix,0,0); | ||||
164 | $tail = $1 . $tail; | ||||
165 | } | ||||
166 | } | ||||
167 | } | ||||
168 | |||||
169 | # Ensure taint is propgated from the path to its pieces. | ||||
170 | $tail .= $taint; | ||||
171 | wantarray ? ($basename .= $taint, $dirpath .= $taint, $tail) | ||||
172 | : ($basename .= $taint); | ||||
173 | } | ||||
174 | |||||
- - | |||||
177 | =item C<basename> | ||||
178 | X<basename> X<filename> | ||||
179 | |||||
180 | my $filename = basename($path); | ||||
181 | my $filename = basename($path, @suffixes); | ||||
182 | |||||
183 | This function is provided for compatibility with the Unix shell command | ||||
184 | C<basename(1)>. It does B<NOT> always return the file name portion of a | ||||
185 | path as you might expect. To be safe, if you want the file name portion of | ||||
186 | a path use C<fileparse()>. | ||||
187 | |||||
188 | C<basename()> returns the last level of a filepath even if the last | ||||
189 | level is clearly directory. In effect, it is acting like C<pop()> for | ||||
190 | paths. This differs from C<fileparse()>'s behaviour. | ||||
191 | |||||
192 | # Both return "bar" | ||||
193 | basename("/foo/bar"); | ||||
194 | basename("/foo/bar/"); | ||||
195 | |||||
196 | @suffixes work as in C<fileparse()> except all regex metacharacters are | ||||
197 | quoted. | ||||
198 | |||||
199 | # These two function calls are equivalent. | ||||
200 | my $filename = basename("/foo/bar/baz.txt", ".txt"); | ||||
201 | my $filename = fileparse("/foo/bar/baz.txt", qr/\Q.txt\E/); | ||||
202 | |||||
203 | Also note that in order to be compatible with the shell command, | ||||
204 | C<basename()> does not strip off a suffix if it is identical to the | ||||
205 | remaining characters in the filename. | ||||
206 | |||||
207 | =cut | ||||
208 | |||||
209 | |||||
210 | # spent 97µs (26+71) within File::Basename::basename which was called:
# once (26µs+71µs) by Getopt::Long::Descriptive::BEGIN@254 at line 256 of Getopt/Long/Descriptive.pm | ||||
211 | 6 | 22µs | my($path) = shift; | ||
212 | |||||
213 | # From BSD basename(1) | ||||
214 | # The basename utility deletes any prefix ending with the last slash `/' | ||||
215 | # character present in string (after first stripping trailing slashes) | ||||
216 | 1 | 33µs | _strip_trailing_sep($path); # spent 33µs making 1 call to File::Basename::_strip_trailing_sep | ||
217 | |||||
218 | 1 | 38µs | my($basename, $dirname, $suffix) = fileparse( $path, map("\Q$_\E",@_) ); # spent 38µs making 1 call to File::Basename::fileparse | ||
219 | |||||
220 | # From BSD basename(1) | ||||
221 | # The suffix is not stripped if it is identical to the remaining | ||||
222 | # characters in string. | ||||
223 | if( length $suffix and !length $basename ) { | ||||
224 | $basename = $suffix; | ||||
225 | } | ||||
226 | |||||
227 | # Ensure that basename '/' == '/' | ||||
228 | if( !length $basename ) { | ||||
229 | $basename = $dirname; | ||||
230 | } | ||||
231 | |||||
232 | return $basename; | ||||
233 | } | ||||
234 | |||||
- - | |||||
237 | =item C<dirname> | ||||
238 | X<dirname> | ||||
239 | |||||
240 | This function is provided for compatibility with the Unix shell | ||||
241 | command C<dirname(1)> and has inherited some of its quirks. In spite of | ||||
242 | its name it does B<NOT> always return the directory name as you might | ||||
243 | expect. To be safe, if you want the directory name of a path use | ||||
244 | C<fileparse()>. | ||||
245 | |||||
246 | Only on VMS (where there is no ambiguity between the file and directory | ||||
247 | portions of a path) and AmigaOS (possibly due to an implementation quirk in | ||||
248 | this module) does C<dirname()> work like C<fileparse($path)>, returning just the | ||||
249 | $directories. | ||||
250 | |||||
251 | # On VMS and AmigaOS | ||||
252 | my $directories = dirname($path); | ||||
253 | |||||
254 | When using Unix or MSDOS syntax this emulates the C<dirname(1)> shell function | ||||
255 | which is subtly different from how C<fileparse()> works. It returns all but | ||||
256 | the last level of a file path even if the last level is clearly a directory. | ||||
257 | In effect, it is not returning the directory portion but simply the path one | ||||
258 | level up acting like C<chop()> for file paths. | ||||
259 | |||||
260 | Also unlike C<fileparse()>, C<dirname()> does not include a trailing slash on | ||||
261 | its returned path. | ||||
262 | |||||
263 | # returns /foo/bar. fileparse() would return /foo/bar/ | ||||
264 | dirname("/foo/bar/baz"); | ||||
265 | |||||
266 | # also returns /foo/bar despite the fact that baz is clearly a | ||||
267 | # directory. fileparse() would return /foo/bar/baz/ | ||||
268 | dirname("/foo/bar/baz/"); | ||||
269 | |||||
270 | # returns '.'. fileparse() would return 'foo/' | ||||
271 | dirname("foo/"); | ||||
272 | |||||
273 | Under VMS, if there is no directory information in the $path, then the | ||||
274 | current default device and directory is used. | ||||
275 | |||||
276 | =cut | ||||
277 | |||||
278 | |||||
279 | sub dirname { | ||||
280 | my $path = shift; | ||||
281 | |||||
282 | my($type) = $Fileparse_fstype; | ||||
283 | |||||
284 | if( $type eq 'VMS' and $path =~ m{/} ) { | ||||
285 | # Parse as Unix | ||||
286 | local($File::Basename::Fileparse_fstype) = ''; | ||||
287 | return dirname($path); | ||||
288 | } | ||||
289 | |||||
290 | my($basename, $dirname) = fileparse($path); | ||||
291 | |||||
292 | if ($type eq 'VMS') { | ||||
293 | $dirname ||= $ENV{DEFAULT}; | ||||
294 | } | ||||
295 | elsif (grep { $type eq $_ } qw(MSDOS DOS MSWin32 OS2)) { | ||||
296 | _strip_trailing_sep($dirname); | ||||
297 | unless( length($basename) ) { | ||||
298 | ($basename,$dirname) = fileparse $dirname; | ||||
299 | _strip_trailing_sep($dirname); | ||||
300 | } | ||||
301 | } | ||||
302 | elsif ($type eq 'AmigaOS') { | ||||
303 | if ( $dirname =~ /:\z/) { return $dirname } | ||||
304 | chop $dirname; | ||||
305 | $dirname =~ s{[^:/]+\z}{} unless length($basename); | ||||
306 | } | ||||
307 | else { | ||||
308 | _strip_trailing_sep($dirname); | ||||
309 | unless( length($basename) ) { | ||||
310 | ($basename,$dirname) = fileparse $dirname; | ||||
311 | _strip_trailing_sep($dirname); | ||||
312 | } | ||||
313 | } | ||||
314 | |||||
315 | $dirname; | ||||
316 | } | ||||
317 | |||||
318 | |||||
319 | # Strip the trailing path separator. | ||||
320 | # spent 33µs (22+11) within File::Basename::_strip_trailing_sep which was called:
# once (22µs+11µs) by File::Basename::basename at line 216 | ||||
321 | 2 | 9µs | my $type = $Fileparse_fstype; | ||
322 | |||||
323 | 1 | 25µs | if (grep { $type eq $_ } qw(MSDOS DOS MSWin32 OS2)) { | ||
324 | $_[0] =~ s/([^:])[\\\/]*\z/$1/; | ||||
325 | } | ||||
326 | else { | ||||
327 | 3 | 11µs | $_[0] =~ s{(.)/*\z}{$1}s; # spent 6µs making 1 call to File::Basename::CORE:subst
# spent 5µs making 2 calls to File::Basename::CORE:substcont, avg 3µs/call | ||
328 | } | ||||
329 | } | ||||
330 | |||||
331 | |||||
332 | =item C<fileparse_set_fstype> | ||||
333 | X<filesystem> | ||||
334 | |||||
335 | my $type = fileparse_set_fstype(); | ||||
336 | my $previous_type = fileparse_set_fstype($type); | ||||
337 | |||||
338 | Normally File::Basename will assume a file path type native to your current | ||||
339 | operating system (ie. /foo/bar style on Unix, \foo\bar on Windows, etc...). | ||||
340 | With this function you can override that assumption. | ||||
341 | |||||
342 | Valid $types are "VMS", "AmigaOS", "OS2", "RISCOS", | ||||
343 | "MSWin32", "DOS" (also "MSDOS" for backwards bug compatibility), | ||||
344 | "Epoc" and "Unix" (all case-insensitive). If an unrecognized $type is | ||||
345 | given "Unix" will be assumed. | ||||
346 | |||||
347 | If you've selected VMS syntax, and the file specification you pass to | ||||
348 | one of these routines contains a "/", they assume you are using Unix | ||||
349 | emulation and apply the Unix syntax rules instead, for that function | ||||
350 | call only. | ||||
351 | |||||
352 | =back | ||||
353 | |||||
354 | =cut | ||||
355 | |||||
356 | |||||
357 | # spent 10µs within File::Basename::BEGIN@357 which was called:
# once (10µs+0s) by Getopt::Long::Descriptive::BEGIN@6 at line 380 | ||||
358 | |||||
359 | 2 | 10µs | my @Ignore_Case = qw(VMS AmigaOS OS2 RISCOS MSWin32 MSDOS DOS Epoc); | ||
360 | my @Types = (@Ignore_Case, qw(Unix)); | ||||
361 | |||||
362 | # spent 120µs (77+43) within File::Basename::fileparse_set_fstype which was called:
# once (77µs+43µs) by Getopt::Long::Descriptive::BEGIN@6 at line 59 | ||||
363 | 3 | 9µs | my $old = $Fileparse_fstype; | ||
364 | |||||
365 | 4 | 8µs | if (@_) { | ||
366 | my $new_type = shift; | ||||
367 | |||||
368 | $Fileparse_fstype = 'Unix'; # default | ||||
369 | foreach my $type (@Types) { | ||||
370 | 9 | 106µs | 18 | 43µs | $Fileparse_fstype = $type if $new_type =~ /^$type/i; # spent 31µs making 9 calls to File::Basename::CORE:regcomp, avg 3µs/call
# spent 12µs making 9 calls to File::Basename::CORE:match, avg 1µs/call |
371 | } | ||||
372 | |||||
373 | $Fileparse_igncase = | ||||
374 | (grep $Fileparse_fstype eq $_, @Ignore_Case) ? 1 : 0; | ||||
375 | } | ||||
376 | |||||
377 | return $old; | ||||
378 | } | ||||
379 | |||||
380 | 1 | 15µs | 1 | 10µs | } # spent 10µs making 1 call to File::Basename::BEGIN@357 |
381 | |||||
382 | |||||
383 | 1 | 6µs | 1; | ||
384 | |||||
385 | |||||
386 | =head1 SEE ALSO | ||||
387 | |||||
388 | L<dirname(1)>, L<basename(1)>, L<File::Spec> | ||||
sub File::Basename::CORE:match; # opcode | |||||
# spent 31µs within File::Basename::CORE:regcomp which was called 9 times, avg 3µs/call:
# 9 times (31µs+0s) by File::Basename::fileparse_set_fstype at line 370, avg 3µs/call | |||||
# spent 6µs within File::Basename::CORE:subst which was called:
# once (6µs+0s) by File::Basename::_strip_trailing_sep at line 327 | |||||
# spent 5µs within File::Basename::CORE:substcont which was called 2 times, avg 3µs/call:
# 2 times (5µs+0s) by File::Basename::_strip_trailing_sep at line 327, avg 3µs/call |