X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FFile%2FBasename.pm;h=3b0685f166deb0989f21be61e138ea0e38a686f2;hb=fa76202e3aa22e9755f1a461416769c368b47afc;hp=4581e7e93c26c35070760d1e79e307abbb48913f;hpb=c7b9dd210bc8835ea8e4750a4d97a670da01ea70;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/lib/File/Basename.pm b/lib/File/Basename.pm
index 4581e7e..3b0685f 100644
--- a/lib/File/Basename.pm
+++ b/lib/File/Basename.pm
@@ -17,7 +17,7 @@ dirname - extract just the directory from a path
     $basename = basename($fullname,@suffixlist);
     $dirname = dirname($fullname);
 
-    ($name,$path,$suffix) = fileparse("lib/File/Basename.pm","\.pm");
+    ($name,$path,$suffix) = fileparse("lib/File/Basename.pm",qr{\.pm});
     fileparse_set_fstype("VMS");
     $basename = basename("lib/File/Basename.pm",".pm");
     $dirname = dirname("lib/File/Basename.pm");
@@ -60,7 +60,8 @@ B<path> contains everything up to and including the last directory
 separator in the input file specification.  The remainder of the input
 file specification is then divided into B<name> and B<suffix> based on
 the optional patterns you specify in C<@suffixlist>.  Each element of
-this list is interpreted as a regular expression, and is matched
+this list can be a qr-quoted pattern (or a string which is interpreted
+as a regular expression), and is matched
 against the end of B<name>.  If this succeeds, the matching portion of
 B<name> is removed and prepended to B<suffix>.  By proper use of
 C<@suffixlist>, you can remove file types or versions for examination.
@@ -76,7 +77,7 @@ file as the input file specification.
 Using Unix file syntax:
 
     ($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7',
-				    '\.book\d+');
+				    qr{\.book\d+});
 
 would yield
 
@@ -87,7 +88,7 @@ would yield
 Similarly, using VMS syntax:
 
     ($name,$dir,$type) = fileparse('Doc_Root:[Help]Rhetoric.Rnh',
-				   '\..*');
+				   qr{\..*});
 
 would yield
 
@@ -129,18 +130,19 @@ directory name to be F<.>).
 # not be available.
 BEGIN {
   unless (eval { require re; })
-    { eval ' sub re::import { $^H |= 0x00100000; } ' }
+    { eval ' sub re::import { $^H |= 0x00100000; } ' } # HINT_RE_TAINT
   import re 'taint';
 }
 
 
 
-use 5.005_64;
+use 5.006;
+use warnings;
 our(@ISA, @EXPORT, $VERSION, $Fileparse_fstype, $Fileparse_igncase);
 require Exporter;
 @ISA = qw(Exporter);
 @EXPORT = qw(fileparse fileparse_set_fstype basename dirname);
-$VERSION = "2.6";
+$VERSION = "2.71";
 
 
 #   fileparse_set_fstype() - specify OS-based rules used in future
@@ -165,6 +167,10 @@ sub fileparse_set_fstype {
 
 sub fileparse {
   my($fullname,@suffices) = @_;
+  unless (defined $fullname) {
+      require Carp;
+      Carp::croak("fileparse(): need a valid pathname");
+  }
   my($fstype,$igncase) = ($Fileparse_fstype, $Fileparse_igncase);
   my($dirpath,$tail,$suffix,$basename);
   my($taint) = substr($fullname,0,0);  # Is $fullname tainted?
@@ -176,12 +182,18 @@ sub fileparse {
       $dirpath ||= '';  # should always be defined
     }
   }
-  if ($fstype =~ /^MS(DOS|Win32)/i) {
+  if ($fstype =~ /^MS(DOS|Win32)|epoc/i) {
     ($dirpath,$basename) = ($fullname =~ /^((?:.*[:\\\/])?)(.*)/s);
     $dirpath .= '.\\' unless $dirpath =~ /[\\\/]\z/;
   }
+  elsif ($fstype =~ /^os2/i) {
+    ($dirpath,$basename) = ($fullname =~ m#^((?:.*[:\\/])?)(.*)#s);
+    $dirpath = './' unless $dirpath;	# Can't be 0
+    $dirpath .= '/' unless $dirpath =~ m#[\\/]\z#;
+  }
   elsif ($fstype =~ /^MacOS/si) {
     ($dirpath,$basename) = ($fullname =~ /^(.*:)?(.*)/s);
+    $dirpath = ':' unless $dirpath;
   }
   elsif ($fstype =~ /^AmigaOS/i) {
     ($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/s);
@@ -189,9 +201,14 @@ sub fileparse {
   }
   elsif ($fstype !~ /^VMS/i) {  # default to Unix
     ($dirpath,$basename) = ($fullname =~ m#^(.*/)?(.*)#s);
-    if ($^O eq 'VMS' and $fullname =~ m:/[^/]+/000000/?:) {
+    if ($^O eq 'VMS' and $fullname =~ m:^(/[^/]+/000000(/|$))(.*):) {
       # dev:[000000] is top of VMS tree, similar to Unix '/'
-      ($basename,$dirpath) = ('',$fullname);
+      # so strip it off and treat the rest as "normal"
+      my $devspec  = $1;
+      my $remainder = $3;
+      ($dirpath,$basename) = ($remainder =~ m#^(.*/)?(.*)#s);
+      $dirpath ||= '';  # should always be defined
+      $dirpath = $devspec.$dirpath;
     }
     $dirpath = './' unless $dirpath;
   }
@@ -208,8 +225,8 @@ sub fileparse {
   }
 
   $tail .= $taint if defined $tail; # avoid warning if $tail == undef
-  wantarray ? ($basename . $taint, $dirpath . $taint, $tail)
-            : $basename . $taint;
+  wantarray ? ($basename .= $taint, $dirpath .= $taint, $tail)
+            : ($basename .= $taint);
 }
 
 
@@ -236,15 +253,14 @@ sub dirname {
         if ($_[0] =~ m#/#) { $fstype = '' }
         else { return $dirname || $ENV{DEFAULT} }
     }
-    if ($fstype =~ /MacOS/i) { return $dirname }
-    elsif ($fstype =~ /MSDOS/i) { 
-        $dirname =~ s/([^:])[\\\/]*\z/$1/;
-        unless( length($basename) ) {
+    if ($fstype =~ /MacOS/i) {
+	if( !length($basename) && $dirname !~ /^[^:]+:\z/) {
+	    $dirname =~ s/([^:]):\z/$1/s;
 	    ($basename,$dirname) = fileparse $dirname;
-	    $dirname =~ s/([^:])[\\\/]*\z/$1/;
 	}
+	$dirname .= ":" unless $dirname =~ /:\z/;
     }
-    elsif ($fstype =~ /MSWin32/i) { 
+    elsif ($fstype =~ /MS(DOS|Win32)|os2/i) { 
         $dirname =~ s/([^:])[\\\/]*\z/$1/;
         unless( length($basename) ) {
 	    ($basename,$dirname) = fileparse $dirname;
@@ -256,7 +272,7 @@ sub dirname {
         chop $dirname;
         $dirname =~ s#[^:/]+\z## unless length($basename);
     }
-    else { 
+    else {
         $dirname =~ s:(.)/*\z:$1:s;
         unless( length($basename) ) {
 	    local($File::Basename::Fileparse_fstype) = $fstype;