diff options
| -rw-r--r-- | lib/File/Temp.pm | 19 | ||||
| -rwxr-xr-x | t/lib/ftmp-mktemp.t | 17 | ||||
| -rwxr-xr-x | t/lib/ftmp-posix.t | 50 |
3 files changed, 61 insertions, 25 deletions
diff --git a/lib/File/Temp.pm b/lib/File/Temp.pm index 90a70ed919..b686682e5a 100644 --- a/lib/File/Temp.pm +++ b/lib/File/Temp.pm @@ -259,6 +259,7 @@ for my $oflag (qw/ TEMPORARY /) { # Optionally a reference to a scalar can be passed into the function # On error this will be used to store the reason for the error # "ErrStr" => \$errstr + # "open" and "mkdir" can not both be true # "unlink_on_close" is not used when "mkdir" is true. @@ -283,6 +284,7 @@ sub _gettemp { # Need this in case the caller decides not to supply us a value # need an anonymous scalar my $tempErrStr; + # Default options my %options = ( "open" => 0, @@ -312,6 +314,7 @@ sub _gettemp { # Make sure the error string is set to undef ${$options{ErrStr}} = undef; + # Can not open the file and make a directory in a single call if ($options{"open"} && $options{"mkdir"}) { ${$options{ErrStr}} = "doopen and domkdir can not both be true\n"; @@ -406,6 +409,7 @@ sub _gettemp { return (); } + # Check the stickiness of the directory and chown giveaway if required # If the directory is world writable the sticky bit # must be set @@ -688,6 +692,7 @@ sub _is_safe { # directory anyway. # Takes optional second arg as scalar ref to error reason + sub _is_verysafe { # Need POSIX - but only want to bother if really necessary due to overhead @@ -698,6 +703,7 @@ sub _is_verysafe { return 1 if $^O eq 'VMS'; # owner delete control at file level my $err_ref = shift; + # Should Get the value of _PC_CHOWN_RESTRICTED if it is defined # and If it is not there do the extensive test my $chown_restricted; @@ -1207,6 +1213,7 @@ sub tempdir { $template =~ m/([\.\]:>]+)$/; $suffixlen = length($1); } + my $errstr; croak "Error in tempdir() using $template: $errstr" unless ((undef, $tempdir) = _gettemp($template, @@ -1458,6 +1465,10 @@ In scalar context, returns the filehandle of a temporary file. The file is removed when the filehandle is closed or when the program exits. No access to the filename is provided. +If the temporary file can not be created undef is returned. +Currently this command will probably not work when the temporary +directory is on an NFS file system. + =cut sub tmpfile { @@ -1466,7 +1477,9 @@ sub tmpfile { my ($fh, $file) = tmpnam(); # Make sure file is removed when filehandle is closed - unlink0($fh, $file) or croak "Unable to unlink temporary file: $!"; + # This will fail on NFS + unlink0($fh, $file) + or return undef; return $fh; @@ -1637,6 +1650,8 @@ sub unlink0 { # Make sure that the link count is zero # - Cygwin provides deferred unlinking, however, # on Win9x the link count remains 1 + # On NFS the link count may still be 1 but we cant know that + # we are on NFS return ( $fh[3] == 0 or $^O eq 'cygwin' ? 1 : 0); } else { @@ -1832,7 +1847,7 @@ temporary file handling. Tim Jenness E<lt>t.jenness@jach.hawaii.eduE<gt> -Copyright (C) 1999, 2000 Tim Jenness and the UK Particle Physics and +Copyright (C) 1999-2001 Tim Jenness and the UK Particle Physics and Astronomy Research Council. All Rights Reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/t/lib/ftmp-mktemp.t b/t/lib/ftmp-mktemp.t index 2209baa025..4e31d01a3f 100755 --- a/t/lib/ftmp-mktemp.t +++ b/t/lib/ftmp-mktemp.t @@ -31,7 +31,7 @@ print "# MKSTEMP: FH is $fh File is $template fileno=".fileno($fh)."\n"; ok( (-e $template) ); # Autoflush -$fh->autoflush(1) if $] >= 5.006; +$fh->autoflush(1) if $] >= 5.006; # Try printing something to the file my $string = "woohoo\n"; @@ -56,11 +56,16 @@ ok($string, $line); if ($^O eq 'MSWin32') { sleep 3; } -ok( unlink0($fh, $template) ); - +my $status = unlink0($fh, $template); +if ($status) { + ok( $status ); +} else { + skip("Skip test failed probably due to \$TMPDIR being on NFS",1); +} # MKSTEMPS -# File with suffix. This is created in the current directory +# File with suffix. This is created in the current directory so +# may be problematic on NFS $template = "suffixXXXXXX"; my $suffix = ".dat"; @@ -73,12 +78,12 @@ ok( (-e $fname) ); # This fails if you are running on NFS # If this test fails simply skip it rather than doing a hard failure -my $status = unlink0($fh, $fname); +$status = unlink0($fh, $fname); if ($status) { ok($status); } else { - skip("Skip test failed probably due to NFS",1) + skip("Skip test failed probably due to cwd being on NFS",1) } # MKDTEMP diff --git a/t/lib/ftmp-posix.t b/t/lib/ftmp-posix.t index bc3845c22b..0a5e86061b 100755 --- a/t/lib/ftmp-posix.t +++ b/t/lib/ftmp-posix.t @@ -36,32 +36,48 @@ print "# TMPNAM: in list context: $fh $tmpnam\n"; # File is opened - make sure it exists ok( (-e $tmpnam )); -# Unlink it -ok( unlink0($fh, $tmpnam) ); +# Unlink it - a possible NFS issue again if TMPDIR is not a local disk +my $status = unlink0($fh, $tmpnam); +if ($status) { + ok( $status ); +} else { + skip("Skip test failed probably due to \$TMPDIR being on NFS",1); +} # TMPFILE $fh = tmpfile(); -ok( $fh ); -print "# TMPFILE: tmpfile got FH $fh\n"; +if (defined $fh) { + ok( $fh ); + print "# TMPFILE: tmpfile got FH $fh\n"; + + $fh->autoflush(1) if $] >= 5.006; + + # print something to it + my $original = "Hello a test\n"; + print "# TMPFILE: Wrote line: $original"; + print $fh $original + or die "Error printing to tempfile\n"; -$fh->autoflush(1) if $] >= 5.006; + # rewind it + ok( seek($fh,0,0) ); -# print something to it -my $original = "Hello a test\n"; -print "# TMPFILE: Wrote line: $original"; -print $fh $original - or die "Error printing to tempfile\n"; + # Read from it + my $line = <$fh>; -# rewind it -ok( seek($fh,0,0) ); + print "# TMPFILE: Read line: $line"; + ok( $original, $line); + + close($fh); + +} else { + # Skip all the remaining tests + foreach (1..3) { + skip("Skip test failed probably due to \$TMPDIR being on NFS",1); + } +} -# Read from it -my $line = <$fh>; -print "# TMPFILE: Read line: $line"; -ok( $original, $line); -close($fh); |