Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | package File::Basename; |
2 | ||
3 | =head1 NAME | |
4 | ||
5 | fileparse - split a pathname into pieces | |
6 | ||
7 | basename - extract just the filename from a path | |
8 | ||
9 | dirname - extract just the directory from a path | |
10 | ||
11 | =head1 SYNOPSIS | |
12 | ||
13 | use File::Basename; | |
14 | ||
15 | ($name,$path,$suffix) = fileparse($fullname,@suffixlist) | |
16 | fileparse_set_fstype($os_string); | |
17 | $basename = basename($fullname,@suffixlist); | |
18 | $dirname = dirname($fullname); | |
19 | ||
20 | ($name,$path,$suffix) = fileparse("lib/File/Basename.pm",qr{\.pm}); | |
21 | fileparse_set_fstype("VMS"); | |
22 | $basename = basename("lib/File/Basename.pm",qr{\.pm}); | |
23 | $dirname = dirname("lib/File/Basename.pm"); | |
24 | ||
25 | =head1 DESCRIPTION | |
26 | ||
27 | These routines allow you to parse file specifications into useful | |
28 | pieces using the syntax of different operating systems. | |
29 | ||
30 | =over 4 | |
31 | ||
32 | =item fileparse_set_fstype | |
33 | ||
34 | You select the syntax via the routine fileparse_set_fstype(). | |
35 | ||
36 | If the argument passed to it contains one of the substrings | |
37 | "VMS", "MSDOS", "MacOS", "AmigaOS" or "MSWin32", the file specification | |
38 | syntax of that operating system is used in future calls to | |
39 | fileparse(), basename(), and dirname(). If it contains none of | |
40 | these substrings, Unix syntax is used. This pattern matching is | |
41 | case-insensitive. If you've selected VMS syntax, and the file | |
42 | specification you pass to one of these routines contains a "/", | |
43 | they assume you are using Unix emulation and apply the Unix syntax | |
44 | rules instead, for that function call only. | |
45 | ||
46 | If the argument passed to it contains one of the substrings "VMS", | |
47 | "MSDOS", "MacOS", "AmigaOS", "os2", "MSWin32" or "RISCOS", then the pattern | |
48 | matching for suffix removal is performed without regard for case, | |
49 | since those systems are not case-sensitive when opening existing files | |
50 | (though some of them preserve case on file creation). | |
51 | ||
52 | If you haven't called fileparse_set_fstype(), the syntax is chosen | |
53 | by examining the builtin variable C<$^O> according to these rules. | |
54 | ||
55 | =item fileparse | |
56 | ||
57 | The fileparse() routine divides a file specification into three | |
58 | parts: a leading B<path>, a file B<name>, and a B<suffix>. The | |
59 | B<path> contains everything up to and including the last directory | |
60 | separator in the input file specification. The remainder of the input | |
61 | file specification is then divided into B<name> and B<suffix> based on | |
62 | the optional patterns you specify in C<@suffixlist>. Each element of | |
63 | this list can be a qr-quoted pattern (or a string which is interpreted | |
64 | as a regular expression), and is matched | |
65 | against the end of B<name>. If this succeeds, the matching portion of | |
66 | B<name> is removed and prepended to B<suffix>. By proper use of | |
67 | C<@suffixlist>, you can remove file types or versions for examination. | |
68 | ||
69 | You are guaranteed that if you concatenate B<path>, B<name>, and | |
70 | B<suffix> together in that order, the result will denote the same | |
71 | file as the input file specification. | |
72 | ||
73 | =back | |
74 | ||
75 | =head1 EXAMPLES | |
76 | ||
77 | Using Unix file syntax: | |
78 | ||
79 | ($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7', | |
80 | qr{\.book\d+}); | |
81 | ||
82 | would yield | |
83 | ||
84 | $base eq 'draft' | |
85 | $path eq '/virgil/aeneid/', | |
86 | $type eq '.book7' | |
87 | ||
88 | Similarly, using VMS syntax: | |
89 | ||
90 | ($name,$dir,$type) = fileparse('Doc_Root:[Help]Rhetoric.Rnh', | |
91 | qr{\..*}); | |
92 | ||
93 | would yield | |
94 | ||
95 | $name eq 'Rhetoric' | |
96 | $dir eq 'Doc_Root:[Help]' | |
97 | $type eq '.Rnh' | |
98 | ||
99 | =over | |
100 | ||
101 | =item C<basename> | |
102 | ||
103 | The basename() routine returns the first element of the list produced | |
104 | by calling fileparse() with the same arguments, except that it always | |
105 | quotes metacharacters in the given suffixes. It is provided for | |
106 | programmer compatibility with the Unix shell command basename(1). | |
107 | ||
108 | =item C<dirname> | |
109 | ||
110 | The dirname() routine returns the directory portion of the input file | |
111 | specification. When using VMS or MacOS syntax, this is identical to the | |
112 | second element of the list produced by calling fileparse() with the same | |
113 | input file specification. (Under VMS, if there is no directory information | |
114 | in the input file specification, then the current default device and | |
115 | directory are returned.) When using Unix or MSDOS syntax, the return | |
116 | value conforms to the behavior of the Unix shell command dirname(1). This | |
117 | is usually the same as the behavior of fileparse(), but differs in some | |
118 | cases. For example, for the input file specification F<lib/>, fileparse() | |
119 | considers the directory name to be F<lib/>, while dirname() considers the | |
120 | directory name to be F<.>). | |
121 | ||
122 | =back | |
123 | ||
124 | =cut | |
125 | ||
126 | ||
127 | ## use strict; | |
128 | # A bit of juggling to insure that C<use re 'taint';> always works, since | |
129 | # File::Basename is used during the Perl build, when the re extension may | |
130 | # not be available. | |
131 | BEGIN { | |
132 | unless (eval { require re; }) | |
133 | { eval ' sub re::import { $^H |= 0x00100000; } ' } | |
134 | import re 'taint'; | |
135 | } | |
136 | ||
137 | ||
138 | ||
139 | use 5.006; | |
140 | use warnings; | |
141 | our(@ISA, @EXPORT, $VERSION, $Fileparse_fstype, $Fileparse_igncase); | |
142 | require Exporter; | |
143 | @ISA = qw(Exporter); | |
144 | @EXPORT = qw(fileparse fileparse_set_fstype basename dirname); | |
145 | $VERSION = "2.71"; | |
146 | ||
147 | ||
148 | # fileparse_set_fstype() - specify OS-based rules used in future | |
149 | # calls to routines in this package | |
150 | # | |
151 | # Currently recognized values: VMS, MSDOS, MacOS, AmigaOS, os2, RISCOS | |
152 | # Any other name uses Unix-style rules and is case-sensitive | |
153 | ||
154 | sub fileparse_set_fstype { | |
155 | my @old = ($Fileparse_fstype, $Fileparse_igncase); | |
156 | if (@_) { | |
157 | $Fileparse_fstype = $_[0]; | |
158 | $Fileparse_igncase = ($_[0] =~ /^(?:MacOS|VMS|AmigaOS|os2|RISCOS|MSWin32|MSDOS)/i); | |
159 | } | |
160 | wantarray ? @old : $old[0]; | |
161 | } | |
162 | ||
163 | # fileparse() - parse file specification | |
164 | # | |
165 | # Version 2.4 27-Sep-1996 Charles Bailey bailey@genetics.upenn.edu | |
166 | ||
167 | ||
168 | sub fileparse { | |
169 | my($fullname,@suffices) = @_; | |
170 | unless (defined $fullname) { | |
171 | require Carp; | |
172 | Carp::croak "fileparse(): need a valid pathname"; | |
173 | } | |
174 | my($fstype,$igncase) = ($Fileparse_fstype, $Fileparse_igncase); | |
175 | my($dirpath,$tail,$suffix,$basename); | |
176 | my($taint) = substr($fullname,0,0); # Is $fullname tainted? | |
177 | ||
178 | if ($fstype =~ /^VMS/i) { | |
179 | if ($fullname =~ m#/#) { $fstype = '' } # We're doing Unix emulation | |
180 | else { | |
181 | ($dirpath,$basename) = ($fullname =~ /^(.*[:>\]])?(.*)/s); | |
182 | $dirpath ||= ''; # should always be defined | |
183 | } | |
184 | } | |
185 | if ($fstype =~ /^MS(DOS|Win32)|epoc/i) { | |
186 | ($dirpath,$basename) = ($fullname =~ /^((?:.*[:\\\/])?)(.*)/s); | |
187 | $dirpath .= '.\\' unless $dirpath =~ /[\\\/]\z/; | |
188 | } | |
189 | elsif ($fstype =~ /^os2/i) { | |
190 | ($dirpath,$basename) = ($fullname =~ m#^((?:.*[:\\/])?)(.*)#s); | |
191 | $dirpath = './' unless $dirpath; # Can't be 0 | |
192 | $dirpath .= '/' unless $dirpath =~ m#[\\/]\z#; | |
193 | } | |
194 | elsif ($fstype =~ /^MacOS/si) { | |
195 | ($dirpath,$basename) = ($fullname =~ /^(.*:)?(.*)/s); | |
196 | $dirpath = ':' unless $dirpath; | |
197 | } | |
198 | elsif ($fstype =~ /^AmigaOS/i) { | |
199 | ($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/s); | |
200 | $dirpath = './' unless $dirpath; | |
201 | } | |
202 | elsif ($fstype !~ /^VMS/i) { # default to Unix | |
203 | ($dirpath,$basename) = ($fullname =~ m#^(.*/)?(.*)#s); | |
204 | if ($^O eq 'VMS' and $fullname =~ m:^(/[^/]+/000000(/|$))(.*):) { | |
205 | # dev:[000000] is top of VMS tree, similar to Unix '/' | |
206 | # so strip it off and treat the rest as "normal" | |
207 | my $devspec = $1; | |
208 | my $remainder = $3; | |
209 | ($dirpath,$basename) = ($remainder =~ m#^(.*/)?(.*)#s); | |
210 | $dirpath ||= ''; # should always be defined | |
211 | $dirpath = $devspec.$dirpath; | |
212 | } | |
213 | $dirpath = './' unless $dirpath; | |
214 | } | |
215 | ||
216 | if (@suffices) { | |
217 | $tail = ''; | |
218 | foreach $suffix (@suffices) { | |
219 | my $pat = ($igncase ? '(?i)' : '') . "($suffix)\$"; | |
220 | if ($basename =~ s/$pat//s) { | |
221 | $taint .= substr($suffix,0,0); | |
222 | $tail = $1 . $tail; | |
223 | } | |
224 | } | |
225 | } | |
226 | ||
227 | $tail .= $taint if defined $tail; # avoid warning if $tail == undef | |
228 | wantarray ? ($basename .= $taint, $dirpath .= $taint, $tail) | |
229 | : ($basename .= $taint); | |
230 | } | |
231 | ||
232 | ||
233 | # basename() - returns first element of list returned by fileparse() | |
234 | ||
235 | sub basename { | |
236 | my($name) = shift; | |
237 | (fileparse($name, map("\Q$_\E",@_)))[0]; | |
238 | } | |
239 | ||
240 | ||
241 | # dirname() - returns device and directory portion of file specification | |
242 | # Behavior matches that of Unix dirname(1) exactly for Unix and MSDOS | |
243 | # filespecs except for names ending with a separator, e.g., "/xx/yy/". | |
244 | # This differs from the second element of the list returned | |
245 | # by fileparse() in that the trailing '/' (Unix) or '\' (MSDOS) (and | |
246 | # the last directory name if the filespec ends in a '/' or '\'), is lost. | |
247 | ||
248 | sub dirname { | |
249 | my($basename,$dirname) = fileparse($_[0]); | |
250 | my($fstype) = $Fileparse_fstype; | |
251 | ||
252 | if ($fstype =~ /VMS/i) { | |
253 | if ($_[0] =~ m#/#) { $fstype = '' } | |
254 | else { return $dirname || $ENV{DEFAULT} } | |
255 | } | |
256 | if ($fstype =~ /MacOS/i) { | |
257 | if( !length($basename) && $dirname !~ /^[^:]+:\z/) { | |
258 | $dirname =~ s/([^:]):\z/$1/s; | |
259 | ($basename,$dirname) = fileparse $dirname; | |
260 | } | |
261 | $dirname .= ":" unless $dirname =~ /:\z/; | |
262 | } | |
263 | elsif ($fstype =~ /MS(DOS|Win32)|os2/i) { | |
264 | $dirname =~ s/([^:])[\\\/]*\z/$1/; | |
265 | unless( length($basename) ) { | |
266 | ($basename,$dirname) = fileparse $dirname; | |
267 | $dirname =~ s/([^:])[\\\/]*\z/$1/; | |
268 | } | |
269 | } | |
270 | elsif ($fstype =~ /AmigaOS/i) { | |
271 | if ( $dirname =~ /:\z/) { return $dirname } | |
272 | chop $dirname; | |
273 | $dirname =~ s#[^:/]+\z## unless length($basename); | |
274 | } | |
275 | else { | |
276 | $dirname =~ s:(.)/*\z:$1:s; | |
277 | unless( length($basename) ) { | |
278 | local($File::Basename::Fileparse_fstype) = $fstype; | |
279 | ($basename,$dirname) = fileparse $dirname; | |
280 | $dirname =~ s:(.)/*\z:$1:s; | |
281 | } | |
282 | } | |
283 | ||
284 | $dirname; | |
285 | } | |
286 | ||
287 | fileparse_set_fstype $^O; | |
288 | ||
289 | 1; |