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