Add new File::Spec::VMS methods

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

diff --git a/lib/File/Basename.pm b/lib/File/Basename.pm
index e4863f8..da2caee 100644 (file)
--- a/lib/File/Basename.pm
+++ b/lib/File/Basename.pm
@@ -122,13 +122,25 @@ directory name to be F<.>).
 
 =cut
 
-require 5.002;
+
+## use strict;
+# A bit of juggling to insure that C<use re 'taint';> always works, since
+# File::Basename is used during the Perl build, when the re extension may
+# not be available.
+BEGIN {
+  unless (eval { require re; })
+    { eval ' sub re::import { $^H |= 0x00100000; } ' }
+  import re 'taint';
+}
+
+
+
+use 5.005_64;
+our(@ISA, @EXPORT, $VERSION, $Fileparse_fstype, $Fileparse_igncase);
 require Exporter;
 @ISA = qw(Exporter);
 @EXPORT = qw(fileparse fileparse_set_fstype basename dirname);
-#use strict;
-#use vars qw($VERSION $Fileparse_fstype $Fileparse_igncase);
-$VERSION = "2.5";
+$VERSION = "2.6";
 
 
 #   fileparse_set_fstype() - specify OS-based rules used in future
@@ -141,7 +153,7 @@ sub fileparse_set_fstype {
   my @old = ($Fileparse_fstype, $Fileparse_igncase);
   if (@_) {
     $Fileparse_fstype = $_[0];
-    $Fileparse_igncase = ($_[0] =~ /^(?:MacOS|VMS|AmigaOS|os2|RISCOS|MSWin32)/i);
+    $Fileparse_igncase = ($_[0] =~ /^(?:MacOS|VMS|AmigaOS|os2|RISCOS|MSWin32|MSDOS)/i);
   }
   wantarray ? @old : $old[0];
 }
@@ -155,11 +167,13 @@ sub fileparse {
   my($fullname,@suffices) = @_;
   my($fstype,$igncase) = ($Fileparse_fstype, $Fileparse_igncase);
   my($dirpath,$tail,$suffix,$basename);
+  my($taint) = substr($fullname,0,0);  # Is $fullname tainted?
 
   if ($fstype =~ /^VMS/i) {
     if ($fullname =~ m#/#) { $fstype = '' }  # We're doing Unix emulation
     else {
       ($dirpath,$basename) = ($fullname =~ /^(.*[:>\]])?(.*)/);
+      $dirpath ||= '';  # should always be defined
     }
   }
   if ($fstype =~ /^MS(DOS|Win32)/i) {
@@ -175,6 +189,10 @@ sub fileparse {
   }
   elsif ($fstype !~ /^VMS/i) {  # default to Unix
     ($dirpath,$basename) = ($fullname =~ m#^(.*/)?(.*)#);
+    if ($^O eq 'VMS' and $fullname =~ m:/[^/]+/000000/?:) {
+      # dev:[000000] is top of VMS tree, similar to Unix '/'
+      ($basename,$dirpath) = ('',$fullname);
+    }
     $dirpath = './' unless $dirpath;
   }
 
@@ -183,12 +201,15 @@ sub fileparse {
     foreach $suffix (@suffices) {
       my $pat = ($igncase ? '(?i)' : '') . "($suffix)\$";
       if ($basename =~ s/$pat//) {
+        $taint .= substr($suffix,0,0);
         $tail = $1 . $tail;
       }
     }
   }
 
-  wantarray ? ($basename,$dirpath,$tail) : $basename;
+  $tail .= $taint if defined $tail; # avoid warning if $tail == undef
+  wantarray ? ($basename . $taint, $dirpath . $taint, $tail)
+            : $basename . $taint;
 }