On Wed, 21 Feb 2001, H.Merijn Brand wrote:
> I'm getting sick and tired of that known not-error:
>
> File::Temp::_gettemp: Parent directory (/tmp/) is not safe (sticky bit not set
>when world writable?) at lib/ftmp-security.t line 100
>
> Can we make that warning either environment checkable ($PERLTESTFILETEMP=FALSE)
> or Configurable (Configure -Uwarnontestfiletemp) please?
This patch to File::Temp does two things:
1. Fixes the problem with CGI::Carp when determining the Fcntl constants
2. Removes most of the carps and consolidates them so that all the
reasons are included in a single die that is caught by the test. This
means that the correct skipping behaviour is displayed by the test.
I'm assuming that a proper skip is fine with everyone (most people don't
complain about skips) now that the worrying warning has gone.
Since this makes everything less scary it would be good if it was accepted
into 5.6.1 as well.
--
Tim Jenness
JCMT software engineer/Support scientist
http://www.jach.hawaii.edu/~timj
*** lib/File/Temp.pm.orig Wed Feb 21 11:49:04 2001
--- lib/File/Temp.pm Wed Feb 21 22:04:34 2001
***************
*** 17,23 ****
=item *
! Can the OS unlink an open file? If it can't then the
C<_can_unlink_opened_file> method should be modified.
=item *
--- 17,23 ----
=item *
! Can the OS unlink an open file? If it can not then the
C<_can_unlink_opened_file> method should be modified.
=item *
***************
*** 166,172 ****
# Version number
! $VERSION = '0.11';
# This is a list of characters that can be used in random filenames
--- 166,172 ----
# Version number
! $VERSION = '0.12';
# This is a list of characters that can be used in random filenames
***************
*** 200,206 ****
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 };
}
# On some systems the O_TEMPORARY flag can be used to tell the OS
--- 200,213 ----
for my $oflag (qw/ FOLLOW BINARY LARGEFILE EXLOCK NOINHERIT /) {
my ($bit, $func) = (0, "Fcntl::O_" . $oflag);
no strict 'refs';
! $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
***************
*** 214,223 ****
for my $oflag (qw/ TEMPORARY /) {
my ($bit, $func) = (0, "Fcntl::O_" . $oflag);
no strict 'refs';
! $OPENTEMPFLAGS |= $bit if eval { $bit = &$func(); 1 };
}
-
# INTERNAL ROUTINES - not to be used outside of package
# Generic routine for getting a temporary filename
--- 221,236 ----
for my $oflag (qw/ TEMPORARY /) {
my ($bit, $func) = (0, "Fcntl::O_" . $oflag);
no strict 'refs';
! $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
***************
*** 243,248 ****
--- 256,265 ----
# 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.
***************
*** 256,285 ****
# ($fh, $name) = _gettemp($template, "open" => 1);
# for the current version, failures are associated with
! # a carp to give the reason whilst debugging
!
sub _gettemp {
croak 'Usage: ($fh, $name) = _gettemp($template, OPTIONS);'
unless scalar(@_) >= 1;
# Default options
my %options = (
"open" => 0,
"mkdir" => 0,
"suffixlen" => 0,
"unlink_on_close" => 0,
);
# Read the template
my $template = shift;
if (ref($template)) {
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) {
carp "File::Temp::_gettemp: Must have even number of options";
return ();
}
--- 273,310 ----
# ($fh, $name) = _gettemp($template, "open" => 1);
# for the current version, failures are associated with
! # 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 ();
}
***************
*** 287,295 ****
# 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";
return ();
}
--- 312,323 ----
# 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"}) {
! ${$options{ErrStr}} = "doopen and domkdir can not both be true\n";
return ();
}
***************
*** 304,310 ****
# 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";
return ();
}
--- 332,339 ----
# we know where we are looking and what we are looking for
if (substr($template, $start - MINX + 1, MINX) ne 'X' x MINX) {
! ${$options{ErrStr}} = "The template must contain at least ".
! MINX . " 'X' characters\n";
return ();
}
***************
*** 371,394 ****
# 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";
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?)";
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?)";
return ();
}
}
--- 400,429 ----
# not a file -- no point returning a name that includes a directory
# that does not exist or is not writable
! 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) {
! my $safeerr;
! unless (_is_safe($parent,\$safeerr)) {
! ${$options{ErrStr}} = "Parent directory ($parent) is not safe ($safeerr)";
return ();
}
} elsif (File::Temp->safe_level == HIGH) {
! my $safeerr;
! unless (_is_verysafe($parent, \$safeerr)) {
! ${$options{ErrStr}} = "Parent directory ($parent) is not safe ($safeerr)";
return ();
}
}
***************
*** 409,415 ****
# 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;
# Store callers umask
my $umask = umask();
--- 444,450 ----
# 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;
# Store callers umask
my $umask = umask();
***************
*** 444,450 ****
# Error opening file - abort with error
# if the reason was anything but EEXIST
unless ($!{EEXIST}) {
! carp "File::Temp: Could not create temp file $path: $!";
return ();
}
--- 479,485 ----
# Error opening file - abort with error
# if the reason was anything but EEXIST
unless ($!{EEXIST}) {
! ${$options{ErrStr}} = "Could not create temp file $path: $!";
return ();
}
***************
*** 474,480 ****
# Abort with error if the reason for failure was anything
# except EEXIST
unless ($!{EEXIST}) {
! carp "File::Temp: Could not create directory $path: $!";
return ();
}
--- 509,515 ----
# Abort with error if the reason for failure was anything
# except EEXIST
unless ($!{EEXIST}) {
! ${$options{ErrStr}} = "Could not create directory $path: $!";
return ();
}
***************
*** 519,533 ****
# 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)";
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";
return ();
--- 554,568 ----
# Check for out of control looping
if ($counter > $MAX_GUESS) {
! ${$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
! ${ $options{ErrStr} } = "Have exceeded the maximum number of attempts ("
! . MAX_TRIES . ") to open temp file/dir";
return ();
***************
*** 588,593 ****
--- 623,629 ----
# 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
***************
*** 600,609 ****
sub _is_safe {
my $path = shift;
# 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
--- 636,649 ----
sub _is_safe {
my $path = shift;
+ my $err_ref = shift;
# Stat path
my @info = stat($path);
! 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
***************
*** 614,620 ****
Carp::cluck(sprintf "uid=$info[4] topuid=%s \$<=$< path='$path'",
File::Temp->top_system_uid());
! carp "Directory owned neither by root nor the current user.";
return 0;
}
--- 654,661 ----
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;
}
***************
*** 625,632 ****
# 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
}
return 1;
--- 666,683 ----
# mode is in info[2]
if (($info[2] & &Fcntl::S_IWGRP) || # Is group writable?
($info[2] & &Fcntl::S_IWOTH) ) { # Is world writable?
! # 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;
***************
*** 640,653 ****
--- 691,709 ----
# 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;
***************
*** 658,664 ****
if (defined $chown_restricted) {
# Return if the current directory is safe
! return _is_safe($path) if POSIX::sysconf( $chown_restricted );
}
--- 714,720 ----
if (defined $chown_restricted) {
# Return if the current directory is safe
! return _is_safe($path,$err_ref) if POSIX::sysconf( $chown_restricted );
}
***************
*** 693,699 ****
print "TESTING DIR $dir\n" if $DEBUG;
# Check the directory
! return 0 unless _is_safe($dir);
}
--- 749,755 ----
print "TESTING DIR $dir\n" if $DEBUG;
# Check the directory
! return 0 unless _is_safe($dir,$err_ref);
}
***************
*** 790,796 ****
}
}
-
}
# This is the sub called to register a file for deferred unlinking
--- 846,851 ----
***************
*** 819,825 ****
push (@dirs_to_unlink, $fname);
} else {
! carp "Request to remove directory $fname could not be completed since it does
not exist!\n";
}
} else {
--- 874,880 ----
push (@dirs_to_unlink, $fname);
} else {
! carp "Request to remove directory $fname could not be completed since it does
not exist!\n" if $^W;
}
} else {
***************
*** 830,836 ****
push(@files_to_unlink, [$fh, $fname]);
} else {
! carp "Request to remove file $fname could not be completed since it is not
there!\n";
}
}
--- 885,891 ----
push(@files_to_unlink, [$fh, $fname]);
} else {
! carp "Request to remove file $fname could not be completed since it is not
there!\n" if $^W;
}
}
***************
*** 902,908 ****
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);
This will return the filename based on the template but
--- 957,962 ----
***************
*** 994,1006 ****
my $unlink_on_close = ( wantarray ? 0 : 1);
# Create the file
! my ($fh, $path);
! croak "Error in tempfile() using $template"
unless (($fh, $path) = _gettemp($template,
"open" => $options{'OPEN'},
"mkdir"=> 0 ,
"unlink_on_close" => $unlink_on_close,
"suffixlen" => length($options{'SUFFIX'}),
) );
# Set up an exit handler that can do whatever is right for the
--- 1048,1061 ----
my $unlink_on_close = ( wantarray ? 0 : 1);
# Create the file
! my ($fh, $path, $errstr);
! croak "Error in tempfile() using $template: $errstr"
unless (($fh, $path) = _gettemp($template,
"open" => $options{'OPEN'},
"mkdir"=> 0 ,
"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
***************
*** 1158,1168 ****
$template =~ m/([\.\]:>]+)$/;
$suffixlen = length($1);
}
! croak "Error in tempdir() using $template"
unless ((undef, $tempdir) = _gettemp($template,
"open" => 0,
"mkdir"=> 1 ,
"suffixlen" => $suffixlen,
) );
# Install exit handler; must be dynamic to get lexical
--- 1213,1226 ----
$template =~ m/([\.\]:>]+)$/;
$suffixlen = length($1);
}
!
! 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
***************
*** 1208,1219 ****
my $template = shift;
! my ($fh, $path);
! croak "Error in mkstemp using $template"
unless (($fh, $path) = _gettemp($template,
"open" => 1,
"mkdir"=> 0 ,
"suffixlen" => 0,
) );
if (wantarray()) {
--- 1266,1278 ----
my $template = shift;
! 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()) {
***************
*** 1250,1261 ****
$template .= $suffix;
! my ($fh, $path);
! croak "Error in mkstemps using $template"
unless (($fh, $path) = _gettemp($template,
! "open" => 1,
"mkdir"=> 0 ,
"suffixlen" => length($suffix),
) );
if (wantarray()) {
--- 1309,1321 ----
$template .= $suffix;
! my ($fh, $path, $errstr);
! croak "Error in mkstemps using $template: $errstr"
unless (($fh, $path) = _gettemp($template,
! "open" => 1,
"mkdir"=> 0 ,
"suffixlen" => length($suffix),
+ "ErrStr" => \$errstr,
) );
if (wantarray()) {
***************
*** 1293,1304 ****
$template =~ m/([\.\]:>]+)$/;
$suffixlen = length($1);
}
! my ($junk, $tmpdir);
! croak "Error creating temp directory from template $template\n"
unless (($junk, $tmpdir) = _gettemp($template,
"open" => 0,
"mkdir"=> 1 ,
"suffixlen" => $suffixlen,
) );
return $tmpdir;
--- 1353,1365 ----
$template =~ m/([\.\]:>]+)$/;
$suffixlen = length($1);
}
! 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;
***************
*** 1323,1334 ****
my $template = shift;
! my ($tmpname, $junk);
! croak "Error getting name to temp file from template $template\n"
unless (($junk, $tmpname) = _gettemp($template,
"open" => 0,
"mkdir"=> 0 ,
"suffixlen" => 0,
) );
return $tmpname;
--- 1384,1396 ----
my $template = shift;
! 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;
***************
*** 1523,1529 ****
my @fh = stat $fh;
if ($fh[3] > 1 && $^W) {
! carp "unlink0: fstat found too many links; SB=@fh";
}
# Stat the path
--- 1585,1591 ----
my @fh = stat $fh;
if ($fh[3] > 1 && $^W) {
! carp "unlink0: fstat found too many links; SB=@fh" if $^W;
}
# Stat the path
***************
*** 1677,1683 ****
if (@_) {
my $level = shift;
if (($level != STANDARD) && ($level != MEDIUM) && ($level != HIGH)) {
! carp "safe_level: Specified level ($level) not STANDARD, MEDIUM or HIGH -
ignoring\n";
} else {
# Dont allow this on perl 5.005 or earlier
if ($] < 5.006 && $level != STANDARD) {
--- 1739,1745 ----
if (@_) {
my $level = shift;
if (($level != STANDARD) && ($level != MEDIUM) && ($level != HIGH)) {
! 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) {
