1package File::Basename; 2 3=head1 NAME 4 5fileparse - split a pathname into pieces 6 7basename - extract just the filename from a path 8 9dirname - 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",".pm"); 23 $dirname = dirname("lib/File/Basename.pm"); 24 25=head1 DESCRIPTION 26 27These routines allow you to parse file specifications into useful 28pieces using the syntax of different operating systems. 29 30=over 4 31 32=item fileparse_set_fstype 33 34You select the syntax via the routine fileparse_set_fstype(). 35 36If the argument passed to it contains one of the substrings 37"VMS", "MSDOS", "MacOS", "AmigaOS" or "MSWin32", the file specification 38syntax of that operating system is used in future calls to 39fileparse(), basename(), and dirname(). If it contains none of 40these substrings, Unix syntax is used. This pattern matching is 41case-insensitive. If you've selected VMS syntax, and the file 42specification you pass to one of these routines contains a "/", 43they assume you are using Unix emulation and apply the Unix syntax 44rules instead, for that function call only. 45 46If the argument passed to it contains one of the substrings "VMS", 47"MSDOS", "MacOS", "AmigaOS", "os2", "MSWin32" or "RISCOS", then the pattern 48matching for suffix removal is performed without regard for case, 49since those systems are not case-sensitive when opening existing files 50(though some of them preserve case on file creation). 51 52If you haven't called fileparse_set_fstype(), the syntax is chosen 53by examining the builtin variable C<$^O> according to these rules. 54 55=item fileparse 56 57The fileparse() routine divides a file specification into three 58parts: a leading B<path>, a file B<name>, and a B<suffix>. The 59B<path> contains everything up to and including the last directory 60separator in the input file specification. The remainder of the input 61file specification is then divided into B<name> and B<suffix> based on 62the optional patterns you specify in C<@suffixlist>. Each element of 63this list can be a qr-quoted pattern (or a string which is interpreted 64as a regular expression), and is matched 65against the end of B<name>. If this succeeds, the matching portion of 66B<name> is removed and prepended to B<suffix>. By proper use of 67C<@suffixlist>, you can remove file types or versions for examination. 68 69You are guaranteed that if you concatenate B<path>, B<name>, and 70B<suffix> together in that order, the result will denote the same 71file as the input file specification. 72 73=back 74 75=head1 EXAMPLES 76 77Using Unix file syntax: 78 79 ($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7', 80 qr{\.book\d+}); 81 82would yield 83 84 $base eq 'draft' 85 $path eq '/virgil/aeneid/', 86 $type eq '.book7' 87 88Similarly, using VMS syntax: 89 90 ($name,$dir,$type) = fileparse('Doc_Root:[Help]Rhetoric.Rnh', 91 qr{\..*}); 92 93would 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 103The basename() routine returns the first element of the list produced 104by calling fileparse() with the same arguments, except that it always 105quotes metacharacters in the given suffixes. It is provided for 106programmer compatibility with the Unix shell command basename(1). 107 108=item C<dirname> 109 110The dirname() routine returns the directory portion of the input file 111specification. When using VMS or MacOS syntax, this is identical to the 112second element of the list produced by calling fileparse() with the same 113input file specification. (Under VMS, if there is no directory information 114in the input file specification, then the current default device and 115directory are returned.) When using Unix or MSDOS syntax, the return 116value conforms to the behavior of the Unix shell command dirname(1). This 117is usually the same as the behavior of fileparse(), but differs in some 118cases. For example, for the input file specification F<lib/>, fileparse() 119considers the directory name to be F<lib/>, while dirname() considers the 120directory 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. 131BEGIN { 132 unless (eval { require re; }) 133 { eval ' sub re::import { $^H |= 0x00100000; } ' } # HINT_RE_TAINT 134 import re 'taint'; 135} 136 137 138 139use 5.006; 140use warnings; 141our(@ISA, @EXPORT, $VERSION, $Fileparse_fstype, $Fileparse_igncase); 142require Exporter; 143@ISA = qw(Exporter); 144@EXPORT = qw(fileparse fileparse_set_fstype basename dirname); 145$VERSION = "2.72"; 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 154sub 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 168sub 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 235sub 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 248sub 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 287fileparse_set_fstype $^O; 288 2891; 290