lib/File/Basename.pm

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