Upgrade to version.pm 0.71, by John Peacock

[perl5.git] / lib / File / Basename.pm

diff --git a/lib/File/Basename.pm b/lib/File/Basename.pm
index 345edcf..2c5e8a9 100644 (file)
--- a/lib/File/Basename.pm
+++ b/lib/File/Basename.pm
@@ -20,7 +20,7 @@ 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.  If your concern is just parsing
+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.
 
@@ -54,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.74";
+$VERSION = "2.76";
 
 fileparse_set_fstype($^O);
 
@@ -62,6 +62,7 @@ fileparse_set_fstype($^O);
 =over 4
 
 =item C<fileparse>
+X<fileparse>
 
     my($filename, $directories, $suffix) = fileparse($path);
     my($filename, $directories, $suffix) = fileparse($path, @suffixes);
@@ -88,7 +89,7 @@ C<qr//>) matched against the end of the $filename.  The matching
 portion is removed and becomes the $suffix.
 
      # On Unix returns ("baz", "/foo/bar", ".txt")
-     fileparse("/foo/bar/baz", qr/\.[^.]*/);
+     fileparse("/foo/bar/baz.txt", qr/\.[^.]*/);
 
 If type is non-Unix (see C<fileparse_set_fstype()>) then the pattern
 matching for suffix removal is performed case-insensitively, since
@@ -143,13 +144,13 @@ sub fileparse {
     $dirpath ||= '';  # should always be defined
   }
   else { # Default to Unix semantics.
-    ($dirpath,$basename) = ($fullname =~ m#^(.*/)?(.*)#s);
-    if ($orig_type eq 'VMS' and $fullname =~ m:^(/[^/]+/000000(/|$))(.*):) {
+    ($dirpath,$basename) = ($fullname =~ m{^(.*/)?(.*)}s);
+    if ($orig_type eq 'VMS' and $fullname =~ m{^(/[^/]+/000000(/|$))(.*)}) {
       # dev:[000000] is top of VMS tree, similar to Unix '/'
       # so strip it off and treat the rest as "normal"
       my $devspec  = $1;
       my $remainder = $3;
-      ($dirpath,$basename) = ($remainder =~ m#^(.*/)?(.*)#s);
+      ($dirpath,$basename) = ($remainder =~ m{^(.*/)?(.*)}s);
       $dirpath ||= '';  # should always be defined
       $dirpath = $devspec.$dirpath;
     }
@@ -157,9 +158,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) {
@@ -170,7 +171,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);
 }
@@ -178,11 +179,12 @@ sub fileparse {
 
 
 =item C<basename>
+X<basename> X<filename>
 
     my $filename = basename($path);
     my $filename = basename($path, @suffixes);
 
-This function is provided for compatibility with the Unix shell command 
+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()>.
@@ -202,18 +204,42 @@ quoted.
     my $filename = basename("/foo/bar/baz.txt",  ".txt");
     my $filename = fileparse("/foo/bar/baz.txt", qr/\Q.txt\E/);
 
+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;
-  _strip_trailing_sep($name);
-  (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;
 }
 
 
 
 =item C<dirname>
+X<dirname>
 
 This function is provided for compatibility with the Unix shell
 command C<dirname(1)> and has inherited some of its quirks.  In spite of
@@ -287,7 +313,7 @@ sub dirname {
     elsif ($type eq 'AmigaOS') {
         if ( $dirname =~ /:\z/) { return $dirname }
         chop $dirname;
-        $dirname =~ s#[^:/]+\z## unless length($basename);
+        $dirname =~ s{[^:/]+\z}{} unless length($basename);
     }
     else {
         _strip_trailing_sep($dirname);
@@ -318,6 +344,7 @@ sub _strip_trailing_sep  {
 
 
 =item C<fileparse_set_fstype>
+X<filesystem>
 
   my $type = fileparse_set_fstype();
   my $previous_type = fileparse_set_fstype($type);