special VMS handling no longer needed since we now close the file

[p5sagit/p5-mst-13.2.git] / lib / File / Basename.pm

diff --git a/lib/File/Basename.pm b/lib/File/Basename.pm
index 21008da..837b753 100644 (file)
--- a/lib/File/Basename.pm
+++ b/lib/File/Basename.pm
@@ -18,9 +18,19 @@ File::Basename - Parse file paths into directory, filename and suffix.
 These routines allow you to parse file paths into their directory, filename
 and suffix.
 
-B<NOTE>: C<dirname()> and C<basename()> emulate the behaviours, and quirks, of
-the shell and C functions of the same name.  See each function's documention
-for details.
+B<NOTE>: C<dirname()> and C<basename()> emulate the behaviours, and
+quirks, of the shell and C functions of the same name.  See each
+function's documentation for details.  If your concern is just parsing
+paths it is safer to use L<File::Spec>'s C<splitpath()> and
+C<splitdir()> methods.
+
+It is guaranteed that
+
+    # Where $path_separator is / for Unix, \ for Windows, etc...
+    dirname($path) . $path_separator . basename($path);
+
+is equivalent to the original path for all systems but VMS.
+
 
 =cut
 
@@ -44,7 +54,7 @@ our(@ISA, @EXPORT, $VERSION, $Fileparse_fstype, $Fileparse_igncase);
 require Exporter;
 @ISA = qw(Exporter);
 @EXPORT = qw(fileparse fileparse_set_fstype basename dirname);
-$VERSION = "2.73";
+$VERSION = "2.74";
 
 fileparse_set_fstype($^O);
 
@@ -147,9 +157,9 @@ sub fileparse {
   }
       
 
-  my($tail, $suffix);
+  my $tail   = '';
+  my $suffix = '';
   if (@suffices) {
-    $tail = '';
     foreach $suffix (@suffices) {
       my $pat = ($igncase ? '(?i)' : '') . "($suffix)\$";
       if ($basename =~ s/$pat//s) {
@@ -160,7 +170,7 @@ sub fileparse {
   }
 
   # Ensure taint is propgated from the path to its pieces.
-  $tail .= $taint if defined $tail; # avoid warning if $tail == undef
+  $tail .= $taint;
   wantarray ? ($basename .= $taint, $dirpath .= $taint, $tail)
             : ($basename .= $taint);
 }
@@ -172,22 +182,56 @@ sub fileparse {
     my $filename = basename($path);
     my $filename = basename($path, @suffixes);
 
-C<basename()> works just like C<fileparse()> in scalar context - you only get
-the $filename - except that it always quotes metacharacters in the @suffixes.
+This function is provided for compatibility with the Unix shell command 
+C<basename(1)>.  It does B<NOT> always return the file name portion of a
+path as you might expect.  To be safe, if you want the file name portion of
+a path use C<fileparse()>.
+
+C<basename()> returns the last level of a filepath even if the last
+level is clearly directory.  In effect, it is acting like C<pop()> for
+paths.  This differs from C<fileparse()>'s behaviour.
+
+    # Both return "bar"
+    basename("/foo/bar");
+    basename("/foo/bar/");
+
+@suffixes work as in C<fileparse()> except all regex metacharacters are
+quoted.
 
     # These two function calls are equivalent.
     my $filename = basename("/foo/bar/baz.txt",  ".txt");
     my $filename = fileparse("/foo/bar/baz.txt", qr/\Q.txt\E/);
 
-This function is provided for compatibility with the Unix shell command 
-C<basename(1)>.
+Also note that in order to be compatible with the shell command,
+C<basename()> does not strip off a suffix if it is identical to the
+remaining characters in the filename.
 
 =cut
 
 
 sub basename {
-  my($name) = shift;
-  (fileparse($name, map("\Q$_\E",@_)))[0];
+  my($path) = shift;
+
+  # From BSD basename(1)
+  # The basename utility deletes any prefix ending with the last slash `/'
+  # character present in string (after first stripping trailing slashes)
+  _strip_trailing_sep($path);
+
+  my($basename, $dirname, $suffix) = fileparse( $path, map("\Q$_\E",@_) );
+
+  # From BSD basename(1)
+  # The suffix is not stripped if it is identical to the remaining 
+  # characters in string.
+  if( length $suffix and !length $basename ) {
+      $basename = $suffix;
+  }
+  
+  # Ensure that basename '/' == '/'
+  if( !length $basename ) {
+      $basename = $dirname;
+  }
+
+  return $basename;
 }
 
 
@@ -251,16 +295,16 @@ sub dirname {
     }
     elsif ($type eq 'MacOS') {
        if( !length($basename) && $dirname !~ /^[^:]+:\z/) {
-           $dirname =~ s/([^:]):\z/$1/s;
+            _strip_trailing_sep($dirname);
            ($basename,$dirname) = fileparse $dirname;
        }
        $dirname .= ":" unless $dirname =~ /:\z/;
     }
     elsif (grep { $type eq $_ } qw(MSDOS DOS MSWin32 OS2)) { 
-        $dirname =~ s/([^:])[\\\/]*\z/$1/;
+        _strip_trailing_sep($dirname);
         unless( length($basename) ) {
            ($basename,$dirname) = fileparse $dirname;
-           $dirname =~ s/([^:])[\\\/]*\z/$1/;
+           _strip_trailing_sep($dirname);
        }
     }
     elsif ($type eq 'AmigaOS') {
@@ -269,10 +313,10 @@ sub dirname {
         $dirname =~ s#[^:/]+\z## unless length($basename);
     }
     else {
-        $dirname =~ s{(.)/*\z}{$1}s;
+        _strip_trailing_sep($dirname);
         unless( length($basename) ) {
            ($basename,$dirname) = fileparse $dirname;
-           $dirname =~ s{(.)/*\z}{$1}s;
+           _strip_trailing_sep($dirname);
        }
     }
 
@@ -280,6 +324,22 @@ sub dirname {
 }
 
 
+# Strip the trailing path separator.
+sub _strip_trailing_sep  {
+    my $type = $Fileparse_fstype;
+
+    if ($type eq 'MacOS') {
+        $_[0] =~ s/([^:]):\z/$1/s;
+    }
+    elsif (grep { $type eq $_ } qw(MSDOS DOS MSWin32 OS2)) { 
+        $_[0] =~ s/([^:])[\\\/]*\z/$1/;
+    }
+    else {
+        $_[0] =~ s{(.)/*\z}{$1}s;
+    }
+}
+
+
 =item C<fileparse_set_fstype>
 
   my $type = fileparse_set_fstype();
@@ -331,3 +391,8 @@ sub fileparse_set_fstype {
 
 
 1;
+
+
+=head1 SEE ALSO
+
+L<dirname(1)>, L<basename(1)>, L<File::Spec>