=item *
-Can the OS unlink an open file? If it can't then the
+Can the OS unlink an open file? If it can not then the
C<_can_unlink_opened_file> method should be modified.
=item *
use File::Spec 0.8;
use File::Path qw/ rmtree /;
use Fcntl 1.03;
-use Errno qw( EEXIST ENOENT ENOTDIR EINVAL );
+use Errno;
require VMS::Stdio if $^O eq 'VMS';
# Need the Symbol package if we are running older perl
# Version number
-$VERSION = '0.10';
+$VERSION = '0.12';
# This is a list of characters that can be used in random filenames
for my $oflag (qw/ FOLLOW BINARY LARGEFILE EXLOCK NOINHERIT /) {
my ($bit, $func) = (0, "Fcntl::O_" . $oflag);
no strict 'refs';
- $OPENFLAGS |= $bit if eval { $bit = &$func(); 1 };
+ $OPENFLAGS |= $bit if eval {
+ # Make sure that redefined die handlers do not cause problems
+ # eg CGI::Carp
+ local $SIG{__DIE__} = sub {};
+ local $SIG{__WARN__} = sub {};
+ $bit = &$func();
+ 1;
+ };
}
# On some systems the O_TEMPORARY flag can be used to tell the OS
for my $oflag (qw/ TEMPORARY /) {
my ($bit, $func) = (0, "Fcntl::O_" . $oflag);
no strict 'refs';
- $OPENTEMPFLAGS |= $bit if eval { $bit = &$func(); 1 };
+ $OPENTEMPFLAGS |= $bit if eval {
+ # Make sure that redefined die handlers do not cause problems
+ # eg CGI::Carp
+ local $SIG{__DIE__} = sub {};
+ local $SIG{__WARN__} = sub {};
+ $bit = &$func();
+ 1;
+ };
}
-
# INTERNAL ROUTINES - not to be used outside of package
# Generic routine for getting a temporary filename
# use of the O_TEMPORARY flag to sysopen.
# Usually irrelevant on unix
+# 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.
# ($fh, $name) = _gettemp($template, "open" => 1);
# for the current version, failures are associated with
-# a carp to give the reason whilst debugging
-
+# stored in an error string and returned to give the reason whilst debugging
+# This routine is not called by any external function
sub _gettemp {
croak 'Usage: ($fh, $name) = _gettemp($template, OPTIONS);'
unless scalar(@_) >= 1;
+ # the internal error string - expect it to be overridden
+ # 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,
"mkdir" => 0,
"suffixlen" => 0,
"unlink_on_close" => 0,
+ "ErrStr" => \$tempErrStr,
);
# Read the template
my $template = shift;
if (ref($template)) {
+ # Use a warning here since we have not yet merged ErrStr
carp "File::Temp::_gettemp: template must not be a reference";
return ();
}
# Check that the number of entries on stack are even
if (scalar(@_) % 2 != 0) {
+ # Use a warning here since we have not yet merged ErrStr
carp "File::Temp::_gettemp: Must have even number of options";
return ();
}
# Read the options and merge with defaults
%options = (%options, @_) if @_;
+ # 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"}) {
- carp "File::Temp::_gettemp: doopen and domkdir can not both be true\n";
+ ${$options{ErrStr}} = "doopen and domkdir can not both be true\n";
return ();
}
# we know where we are looking and what we are looking for
if (substr($template, $start - MINX + 1, MINX) ne 'X' x MINX) {
- carp "File::Temp::_gettemp: The template must contain at least ". MINX ." 'X' characters\n";
+ ${$options{ErrStr}} = "The template must contain at least ".
+ MINX . " 'X' characters\n";
return ();
}
if ($^O eq 'VMS') { # need volume to avoid relative dir spec
$parent = File::Spec->catdir($volume, @dirs[0..$#dirs-1]);
+ $parent = 'sys$disk:[]' if $parent eq '';
} else {
# Put it back together without the last one
# not a file -- no point returning a name that includes a directory
# that does not exist or is not writable
- unless (-d $parent && -w _) {
- carp "File::Temp::_gettemp: Parent directory ($parent) is not a directory"
- . " or is not writable\n";
+ unless (-d $parent) {
+ ${$options{ErrStr}} = "Parent directory ($parent) is not a directory";
+ return ();
+ }
+ unless (-w _) {
+ ${$options{ErrStr}} = "Parent directory ($parent) is not writable\n";
return ();
}
+
# Check the stickiness of the directory and chown giveaway if required
# If the directory is world writable the sticky bit
# must be set
if (File::Temp->safe_level == MEDIUM) {
- unless (_is_safe($parent)) {
- carp "File::Temp::_gettemp: Parent directory ($parent) is not safe (sticky bit not set when world writable?)";
+ my $safeerr;
+ unless (_is_safe($parent,\$safeerr)) {
+ ${$options{ErrStr}} = "Parent directory ($parent) is not safe ($safeerr)";
return ();
}
} elsif (File::Temp->safe_level == HIGH) {
- unless (_is_verysafe($parent)) {
- carp "File::Temp::_gettemp: Parent directory ($parent) is not safe (sticky bit not set when world writable?)";
+ my $safeerr;
+ unless (_is_verysafe($parent, \$safeerr)) {
+ ${$options{ErrStr}} = "Parent directory ($parent) is not safe ($safeerr)";
return ();
}
}
# Try to make sure this will be marked close-on-exec
# XXX: Win32 doesn't respect this, nor the proper fcntl,
# but may have O_NOINHERIT. This may or may not be in Fcntl.
- local $^F = 2;
+ local $^F = 2;
# Store callers umask
my $umask = umask();
# Error opening file - abort with error
# if the reason was anything but EEXIST
- unless ($! == EEXIST) {
- carp "File::Temp: Could not create temp file $path: $!";
+ unless ($!{EEXIST}) {
+ ${$options{ErrStr}} = "Could not create temp file $path: $!";
return ();
}
# Abort with error if the reason for failure was anything
# except EEXIST
- unless ($! == EEXIST) {
- carp "File::Temp: Could not create directory $path: $!";
+ unless ($!{EEXIST}) {
+ ${$options{ErrStr}} = "Could not create directory $path: $!";
return ();
}
# Check for out of control looping
if ($counter > $MAX_GUESS) {
- carp "Tried to get a new temp name different to the previous value $MAX_GUESS times.\nSomething wrong with template?? ($template)";
+ ${$options{ErrStr}} = "Tried to get a new temp name different to the previous value $MAX_GUESS times.\nSomething wrong with template?? ($template)";
return ();
}
}
# If we get here, we have run out of tries
- carp "Have exceeded the maximum number of attempts (".MAX_TRIES .
- ") to open temp file/dir";
+ ${ $options{ErrStr} } = "Have exceeded the maximum number of attempts ("
+ . MAX_TRIES . ") to open temp file/dir";
return ();
# Will not work on systems that do not support sticky bit
#Args: directory path to check
+# Optionally: reference to scalar to contain error message
# Returns true if the path is safe and false otherwise.
# Returns undef if can not even run stat() on the path
sub _is_safe {
my $path = shift;
+ my $err_ref = shift;
# Stat path
my @info = stat($path);
- return 0 unless scalar(@info);
+ unless (scalar(@info)) {
+ $$err_ref = "stat(path) returned no values";
+ return 0;
+ };
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
# UID is in [4]
- if ( $info[4] > File::Temp->top_system_uid() && $info[4] != $<) {
- carp "Directory owned neither by root nor the current user";
+ if ($info[4] > File::Temp->top_system_uid() && $info[4] != $<) {
+
+ Carp::cluck(sprintf "uid=$info[4] topuid=%s \$<=$< path='$path'",
+ File::Temp->top_system_uid());
+
+ $$err_ref = "Directory owned neither by root nor the current user"
+ if ref($err_ref);
return 0;
}
# mode is in info[2]
if (($info[2] & &Fcntl::S_IWGRP) || # Is group writable?
($info[2] & &Fcntl::S_IWOTH) ) { # Is world writable?
- return 0 unless -d _; # Must be a directory
- return 0 unless -k _; # Must be sticky
+ # Must be a directory
+ unless (-d _) {
+ $$err_ref = "Path ($path) is not a directory"
+ if ref($err_ref);
+ return 0;
+ }
+ # Must have sticky bit set
+ unless (-k _) {
+ $$err_ref = "Sticky bit not set on $path when dir is group|world writable"
+ if ref($err_ref);
+ return 0;
+ }
}
return 1;
# If _PC_CHOWN_RESTRICTED is not set, does the full test of each
# 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
require POSIX;
my $path = shift;
+ print "_is_verysafe testing $path\n" if $DEBUG;
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;
if (defined $chown_restricted) {
# Return if the current directory is safe
- return _is_safe($path) if POSIX::sysconf( $chown_restricted );
+ return _is_safe($path,$err_ref) if POSIX::sysconf( $chown_restricted );
}
print "TESTING DIR $dir\n" if $DEBUG;
# Check the directory
- return 0 unless _is_safe($dir);
+ return 0 unless _is_safe($dir,$err_ref);
}
}
}
-
}
# This is the sub called to register a file for deferred unlinking
push (@dirs_to_unlink, $fname);
} else {
- carp "Request to remove directory $fname could not be completed since it does not exist!\n";
+ carp "Request to remove directory $fname could not be completed since it does not exist!\n" if $^W;
}
} else {
push(@files_to_unlink, [$fh, $fname]);
} else {
- carp "Request to remove file $fname could not be completed since it is not there!\n";
+ carp "Request to remove file $fname could not be completed since it is not there!\n" if $^W;
}
}
Return the filename and filehandle as before except that the file is
automatically removed when the program exits. Default is for the file
to be removed if a file handle is requested and to be kept if the
-filename is requested.
+filename is requested. In a scalar context (where no filename is
+returned) the file is always deleted either on exit or when it is closed.
If the template is not specified, a template is always
automatically generated. This temporary file is placed in tmpdir()
This is the preferred mode of operation, as if you only
have a filehandle, you can never create a race condition
by fumbling with the filename. On systems that can not unlink
-an open file (for example, Windows NT) the file is marked for
-deletion when the program ends (equivalent to setting UNLINK to 1).
+an open file or can not mark a file as temporary when it is opened
+(for example, Windows NT uses the C<O_TEMPORARY> flag))
+the file is marked for deletion when the program ends (equivalent
+to setting UNLINK to 1). The C<UNLINK> flag is ignored if present.
(undef, $filename) = tempfile($template, OPEN => 0);
# Now add a suffix
$template .= $options{"SUFFIX"};
+ # Determine whether we should tell _gettemp to unlink the file
+ # On unix this is irrelevant and can be worked out after the file is
+ # opened (simply by unlinking the open filehandle). On Windows or VMS
+ # we have to indicate temporary-ness when we open the file. In general
+ # we only want a true temporary file if we are returning just the
+ # filehandle - if the user wants the filename they probably do not
+ # want the file to disappear as soon as they close it.
+ # For this reason, tie unlink_on_close to the return context regardless
+ # of OS.
+ my $unlink_on_close = ( wantarray ? 0 : 1);
+
# Create the file
- my ($fh, $path);
- croak "Error in tempfile() using $template"
+ my ($fh, $path, $errstr);
+ croak "Error in tempfile() using $template: $errstr"
unless (($fh, $path) = _gettemp($template,
"open" => $options{'OPEN'},
"mkdir"=> 0 ,
- "unlink_on_close" => $options{'UNLINK'},
+ "unlink_on_close" => $unlink_on_close,
"suffixlen" => length($options{'SUFFIX'}),
+ "ErrStr" => \$errstr,
) );
# 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
+ # system. This removes files at exit when requested explicitly or when
+ # system is asked to unlink_on_close but is unable to do so because
+ # of OS limitations.
+ # The latter should be achieved by using a tied filehandle.
+ # Do not check return status since this is all done with END blocks.
_deferred_unlink($fh, $path, 0) if $options{"UNLINK"};
# Return
# Prepend the supplied directory or temp dir
if ($options{"DIR"}) {
- $template = File::Spec->catfile($options{"DIR"}, $template);
+ $template = File::Spec->catdir($options{"DIR"}, $template);
} elsif ($options{TMPDIR}) {
$template =~ m/([\.\]:>]+)$/;
$suffixlen = length($1);
}
- croak "Error in tempdir() using $template"
+
+ my $errstr;
+ croak "Error in tempdir() using $template: $errstr"
unless ((undef, $tempdir) = _gettemp($template,
"open" => 0,
"mkdir"=> 1 ,
"suffixlen" => $suffixlen,
+ "ErrStr" => \$errstr,
) );
# Install exit handler; must be dynamic to get lexical
my $template = shift;
- my ($fh, $path);
- croak "Error in mkstemp using $template"
+ my ($fh, $path, $errstr);
+ croak "Error in mkstemp using $template: $errstr"
unless (($fh, $path) = _gettemp($template,
"open" => 1,
"mkdir"=> 0 ,
"suffixlen" => 0,
+ "ErrStr" => \$errstr,
) );
if (wantarray()) {
$template .= $suffix;
- my ($fh, $path);
- croak "Error in mkstemps using $template"
+ my ($fh, $path, $errstr);
+ croak "Error in mkstemps using $template: $errstr"
unless (($fh, $path) = _gettemp($template,
- "open" => 1,
+ "open" => 1,
"mkdir"=> 0 ,
"suffixlen" => length($suffix),
+ "ErrStr" => \$errstr,
) );
if (wantarray()) {
$template =~ m/([\.\]:>]+)$/;
$suffixlen = length($1);
}
- my ($junk, $tmpdir);
- croak "Error creating temp directory from template $template\n"
+ my ($junk, $tmpdir, $errstr);
+ croak "Error creating temp directory from template $template\: $errstr"
unless (($junk, $tmpdir) = _gettemp($template,
"open" => 0,
"mkdir"=> 1 ,
"suffixlen" => $suffixlen,
+ "ErrStr" => \$errstr,
) );
return $tmpdir;
my $template = shift;
- my ($tmpname, $junk);
- croak "Error getting name to temp file from template $template\n"
+ my ($tmpname, $junk, $errstr);
+ croak "Error getting name to temp file from template $template: $errstr"
unless (($junk, $tmpname) = _gettemp($template,
"open" => 0,
"mkdir"=> 0 ,
"suffixlen" => 0,
+ "ErrStr" => \$errstr,
) );
return $tmpname;
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 {
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;
my @fh = stat $fh;
if ($fh[3] > 1 && $^W) {
- carp "unlink0: fstat found too many links; SB=@fh";
+ carp "unlink0: fstat found too many links; SB=@fh" if $^W;
}
# Stat the path
# 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 {
if (@_) {
my $level = shift;
if (($level != STANDARD) && ($level != MEDIUM) && ($level != HIGH)) {
- carp "safe_level: Specified level ($level) not STANDARD, MEDIUM or HIGH - ignoring\n";
+ carp "safe_level: Specified level ($level) not STANDARD, MEDIUM or HIGH - ignoring\n" if $^W;
} else {
# Dont allow this on perl 5.005 or earlier
if ($] < 5.006 && $level != STANDARD) {
fcntl($tmpfh, F_SETFD, 0)
or die "Can't clear close-on-exec flag on temp fh: $!\n";
+=head2 Temporary files and NFS
+
+Some problems are associated with using temporary files that reside
+on NFS file systems and it is recommended that a local filesystem
+is used whenever possible. Some of the security tests will most probably
+fail when the temp file is not local. Additionally, be aware that
+the performance of I/O operations over NFS will not be as good as for
+a local disk.
+
=head1 HISTORY
Originally began life in May 1999 as an XS interface to the system
L<POSIX/tmpnam>, L<POSIX/tmpfile>, L<File::Spec>, L<File::Path>
-See L<File::MkTemp> for a different implementation of temporary
-file handling.
+See L<IO::File> and L<File::MkTemp> for different implementations of
+temporary file handling.
=head1 AUTHOR
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.
projects / p5sagit/p5-mst-13.2.git / blobdiff