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