File::Temp patches for VMS and OS/2 from Tim Jenness.

p4raw-id: //depot/perl@6447

1 files changed, 74 insertions, 50 deletions

diff --git a/lib/File/Temp.pm b/lib/File/Temp.pm
index f19e5ce21d..dd0ee9c7eb 100644
--- a/lib/File/Temp.pm
+++ b/lib/File/Temp.pm
@@ -113,7 +113,7 @@ use base qw/Exporter/;
 	      tmpnam
 	      tmpfile
 	      mktemp
-	      mkstemp 
+	      mkstemp
 	      mkstemps
 	      mkdtemp
 	      unlink0
@@ -131,13 +131,13 @@ Exporter::export_tags('POSIX','mktemp');
 
 # Version number 
 
-$VERSION = '0.08';
+$VERSION = '0.09';
 
 # This is a list of characters that can be used in random filenames
 
 my @CHARS = (qw/ A B C D E F G H I J K L M N O P Q R S T U V W X Y Z
 	         a b c d e f g h i j k l m n o p q r s t u v w x y z
-	         0 1 2 3 4 5 6 7 8 9 _ 
+	         0 1 2 3 4 5 6 7 8 9 _
 	     /);
 
 # Maximum number of tries to make a temp file before failing
@@ -175,7 +175,7 @@ for my $oflag (qw/FOLLOW BINARY LARGEFILE EXLOCK NOINHERIT TEMPORARY/) {
 # Generic routine for getting a temporary filename
 # modelled on OpenBSD _gettemp() in mktemp.c
 
-# The template must contain X's that are to be replaced 
+# The template must contain X's that are to be replaced
 # with the random values
 
 #  Arguments:
@@ -231,7 +231,7 @@ sub _gettemp {
 
   # Read the options and merge with defaults
   %options = (%options, @_)  if @_;
-  
+
   # Can not open the file and make a directory in a single call
   if ($options{"open"} && $options{"mkdir"}) {
     carp "File::Temp::_gettemp: doopen and domkdir can not both be true\n";
@@ -283,11 +283,16 @@ sub _gettemp {
       $parent = File::Spec->curdir;
     } else {
 
-      # Put it back together without the last one
-      $parent = File::Spec->catdir(@dirs[0..$#dirs-1]);
+      if ($^O eq 'VMS') {  # need volume to avoid relative dir spec
+        $parent = File::Spec->catdir($volume, @dirs[0..$#dirs-1]);
+      } else {
+
+	# Put it back together without the last one
+	$parent = File::Spec->catdir(@dirs[0..$#dirs-1]);
 
-      # ...and attach the volume (no filename)
-      $parent = File::Spec->catpath($volume, $parent, '');
+	# ...and attach the volume (no filename)
+	$parent = File::Spec->catpath($volume, $parent, '');
+      }
 
     }
 
@@ -311,7 +316,7 @@ sub _gettemp {
   # that does not exist or is not writable
 
   unless (-d $parent && -w _) {
-    carp "File::Temp::_gettemp: Parent directory ($parent) is not a directory" 
+    carp "File::Temp::_gettemp: Parent directory ($parent) is not a directory"
       . " or is not writable\n";
       return ();
   }
@@ -347,7 +352,6 @@ sub _gettemp {
 #    }
 
 #  }
-  
 
   # Now try MAX_TRIES time to open the file
   for (my $i = 0; $i < MAX_TRIES; $i++) {
@@ -433,10 +437,10 @@ sub _gettemp {
 
       return (undef, $path) unless -e $path;
 
-      # Try again until MAX_TRIES 
+      # Try again until MAX_TRIES
 
     }
-    
+
     # Did not successfully open the tempfile/dir
     # so try again with a different set of random letters
     # No point in trying to increment unless we have only
@@ -524,9 +528,9 @@ sub _replace_XX {
 }
 
 # internal routine to check to see if the directory is safe
-# First checks to see if the directory is not owned by the 
+# First checks to see if the directory is not owned by the
 # current user or root. Then checks to see if anyone else
-# can write to the directory and if so, checks to see if 
+# can write to the directory and if so, checks to see if
 # it has the sticky bit set
 
 # Will not work on systems that do not support sticky bit
@@ -548,6 +552,7 @@ sub _is_safe {
   # Stat path
   my @info = stat($path);
   return 0 unless scalar(@info);
+  return 1 if $^O eq 'VMS';  # owner delete control at file level
 
   # Check to see whether owner is neither superuser (or a system uid) nor me
   # Use the real uid from the $< variable
@@ -585,6 +590,7 @@ sub _is_verysafe {
   require POSIX;
 
   my $path = shift;
+  return 1 if $^O eq 'VMS';  # owner delete control at file level
 
   # Should Get the value of _PC_CHOWN_RESTRICTED if it is defined
   # and If it is not there do the extensive test
@@ -644,11 +650,14 @@ sub _is_verysafe {
 # platform for files that are currently open.
 # Returns true if we can, false otherwise.
 
-# Currently WinNT and OS/2 can not unlink an opened file
+# Currently WinNT, OS/2 and VMS can not unlink an opened file
+# On VMS this is because the O_EXCL flag is used to open the
+# temporary file. Currently I do not know enough about the issues
+# on VMS to decide whether O_EXCL is a requirement.
 
 sub _can_unlink_opened_file {
 
-  if ($^O eq 'MSWin32' || $^O eq 'os2') {
+  if ($^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'VMS') {
     return 0;
   } else {
     return 1;
@@ -672,7 +681,7 @@ sub _can_do_level {
   return 1 if $level == STANDARD;
 
   # Currently, the systems that can do HIGH or MEDIUM are identical
-  if ( $^O eq 'MSWin32' ) {
+  if ( $^O eq 'MSWin32' || $^O eq 'os2') {
     return 0;
   } else {
     return 1;
@@ -682,7 +691,7 @@ sub _can_do_level {
 
 # This routine sets up a deferred unlinking of a specified
 # filename and filehandle. It is used in the following cases:
-#  - Called by unlink0 if an opend file can not be unlinked
+#  - Called by unlink0 if an opened file can not be unlinked
 #  - Called by tempfile() if files are to be removed on shutdown
 #  - Called by tempdir() if directories are to be removed on shutdown
 
@@ -737,12 +746,12 @@ sub _can_do_level {
 
     croak 'Usage:  _deferred_unlink($fh, $fname, $isdir)'
       unless scalar(@_) == 3;
-    
+
     my ($fh, $fname, $isdir) = @_;
 
     warn "Setting up deferred removal of $fname\n"
       if $DEBUG;
-    
+
     # If we have a directory, check that it is a directory
     if ($isdir) {
 
@@ -755,7 +764,6 @@ sub _can_do_level {
 	carp "Request to remove directory $fname could not be completed since it does not exists!\n";
       }
 
-      
     } else {
 
       if (-f $fname) {
@@ -865,7 +873,7 @@ sub tempfile {
 
   }
 
-  # Construct the template 
+  # Construct the template
 
   # Have a choice of trying to work around the mkstemp/mktemp/tmpnam etc
   # functions or simply constructing a template and using _gettemp()
@@ -887,11 +895,11 @@ sub tempfile {
       $template = File::Spec->catfile($options{"DIR"}, TEMPXXX);
 
     } else {
-      
+
       $template = File::Spec->catfile(File::Spec->tmpdir, TEMPXXX);
 
     }
-    
+
   }
 
   # Now add a suffix
@@ -904,13 +912,13 @@ sub tempfile {
 				    "open" => $options{'OPEN'}, 
 				    "mkdir"=> 0 ,
 				    "suffixlen" => length($options{'SUFFIX'}),
-				   ) );  
+				   ) );
 
   # Set up an exit handler that can do whatever is right for the
   # system. Do not check return status since this is all done with
   # END blocks
   _deferred_unlink($fh, $path, 0) if $options{"UNLINK"};
-  
+
   # Return
   if (wantarray()) {
 
@@ -925,7 +933,7 @@ sub tempfile {
     # Unlink the file. It is up to unlink0 to decide what to do with
     # this (whether to unlink now or to defer until later)
     unlink0($fh, $path) or croak "Error unlinking file $path using unlink0";
-    
+
     # Return just the filehandle.
     return $fh;
   }
@@ -1043,26 +1051,31 @@ sub tempdir  {
       $template = File::Spec->catdir($options{"DIR"}, TEMPXXX);
 
     } else {
-      
+
       $template = File::Spec->catdir(File::Spec->tmpdir, TEMPXXX);
 
     }
-    
+
   }
 
   # Create the directory
   my $tempdir;
+  my $suffixlen = 0;
+  if ($^O eq 'VMS') {  # dir names can end in delimiters
+    $template =~ m/([\.\]:>]+)$/;
+    $suffixlen = length($1);
+  }
   croak "Error in tempdir() using $template"
     unless ((undef, $tempdir) = _gettemp($template,
-				    "open" => 0, 
+				    "open" => 0,
 				    "mkdir"=> 1 ,
-				    "suffixlen" => 0,
-				   ) );  
-  
+				    "suffixlen" => $suffixlen,
+				   ) );
+
   # Install exit handler; must be dynamic to get lexical
-  if ( $options{'CLEANUP'} && -d $tempdir) { 
+  if ( $options{'CLEANUP'} && -d $tempdir) {
     _deferred_unlink(undef, $tempdir, 1);
-  } 
+  }
 
   # Return the dir name
   return $tempdir;
@@ -1104,8 +1117,8 @@ sub mkstemp {
 
   my ($fh, $path);
   croak "Error in mkstemp using $template"
-    unless (($fh, $path) = _gettemp($template, 
-				    "open" => 1, 
+    unless (($fh, $path) = _gettemp($template,
+				    "open" => 1,
 				    "mkdir"=> 0 ,
 				    "suffixlen" => 0,
 				   ) );
@@ -1143,7 +1156,7 @@ sub mkstemps {
   my $suffix   = shift;
 
   $template .= $suffix;
-  
+
   my ($fh, $path);
   croak "Error in mkstemps using $template"
     unless (($fh, $path) = _gettemp($template,
@@ -1180,15 +1193,19 @@ sub mkdtemp {
 
   croak "Usage: mkdtemp(template)"
     if scalar(@_) != 1;
-  
-  my $template = shift;
 
+  my $template = shift;
+  my $suffixlen = 0;
+  if ($^O eq 'VMS') {  # dir names can end in delimiters
+    $template =~ m/([\.\]:>]+)$/;
+    $suffixlen = length($1);
+  }
   my ($junk, $tmpdir);
   croak "Error creating temp directory from template $template\n"
     unless (($junk, $tmpdir) = _gettemp($template,
-					"open" => 0, 
+					"open" => 0,
 					"mkdir"=> 1 ,
-					"suffixlen" => 0,
+					"suffixlen" => $suffixlen,
 				       ) );
 
   return $tmpdir;
@@ -1216,7 +1233,7 @@ sub mktemp {
   my ($tmpname, $junk);
   croak "Error getting name to temp file from template $template\n"
     unless (($junk, $tmpname) = _gettemp($template,
-					 "open" => 0, 
+					 "open" => 0,
 					 "mkdir"=> 0 ,
 					 "suffixlen" => 0,
 					 ) );
@@ -1275,7 +1292,7 @@ sub tmpnam {
 
    # Use a ten character template and append to tmpdir
    my $template = File::Spec->catfile($tmpdir, TEMPXXX);
-  
+
    if (wantarray() ) {
        return mkstemp($template);
    } else {
@@ -1414,7 +1431,7 @@ sub unlink0 {
 
   if ($fh[3] > 1 && $^W) {
     carp "unlink0: fstat found too many links; SB=@fh";
-  } 
+  }
 
   # Stat the path
   my @path = stat $path;
@@ -1422,12 +1439,12 @@ sub unlink0 {
   unless (@path) {
     carp "unlink0: $path is gone already" if $^W;
     return;
-  } 
+  }
 
   # this is no longer a file, but may be a directory, or worse
   unless (-f _) {
     confess "panic: $path is no longer a file: SB=@fh";
-  } 
+  }
 
   # Do comparison of each member of the array
   # On WinNT dev and rdev seem to be different
@@ -1437,17 +1454,24 @@ sub unlink0 {
   my @okstat = (0..$#fh);  # Use all by default
   if ($^O eq 'MSWin32') {
     @okstat = (1,2,3,4,5,7,8,9,10);
+  }  elsif ($^O eq 'VMS') {
+    @okstat = (0,1,2,3,4,5,7,8,9,10);
+  } elsif ($^O eq 'os2') {
+    @okstat = (0, 2..10, 13..$#fh);
   }
 
   # Now compare each entry explicitly by number
   for (@okstat) {
     print "Comparing: $_ : $fh[$_] and $path[$_]\n" if $DEBUG;
-    unless ($fh[$_] == $path[$_]) {
+    # Use eq rather than == since on OS/2 elements 11 and 12 return
+    # the empty string rather than a null. This is fine since we
+    # are only comparing integers.
+    unless ($fh[$_] eq $path[$_]) {
       warn "Did not match $_ element of stat\n" if $DEBUG;
       return 0;
     }
   }
-  
+
   # attempt remove the file (does not work on some platforms)
   if (_can_unlink_opened_file()) {
     # XXX: do *not* call this on a directory; possible race