From: Jarkko Hietaniemi Date: Wed, 26 Jul 2000 18:13:04 +0000 (+0000) Subject: File::Temp patches for VMS and OS/2 from Tim Jenness. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=669b450af2b2151b89f574fc0d92b80a181c8b58;p=p5sagit%2Fp5-mst-13.2.git File::Temp patches for VMS and OS/2 from Tim Jenness. p4raw-id: //depot/perl@6447 --- diff --git a/lib/File/Temp.pm b/lib/File/Temp.pm index f19e5ce..dd0ee9c 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 diff --git a/t/lib/ftmp-security.t b/t/lib/ftmp-security.t index 06799b3..5f30f96 100755 --- a/t/lib/ftmp-security.t +++ b/t/lib/ftmp-security.t @@ -25,7 +25,7 @@ use File::Temp qw/ tempfile unlink0 /; ok(1); # The high security tests must currently be skipped on Windows -my $skipplat = ( $^O eq 'MSWin32' ? 1 : 0 ); +my $skipplat = ( ($^O eq 'MSWin32' || $^O eq 'os2') ? 1 : 0 ); # Can not run high security tests in perls before 5.6.0 my $skipperl = ($] < 5.006 ? 1 : 0 ); @@ -82,13 +82,13 @@ sub test_security { # of tests -- we dont use skip since the tempfile() commands will # fail with MEDIUM/HIGH security before the skip() command would be run if ($skip) { - + skip($skip,1); skip($skip,1); - + # plus we need an end block so the tests come out in the right order eval q{ END { skip($skip,1); skip($skip,1) } 1; } || die; - + return; }