tmpnam
tmpfile
mktemp
- mkstemp
+ mkstemp
mkstemps
mkdtemp
unlink0
# 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
# 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:
# 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";
$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, '');
+ }
}
# 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 ();
}
# }
# }
-
# Now try MAX_TRIES time to open the file
for (my $i = 0; $i < MAX_TRIES; $i++) {
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
}
# 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
# 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
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
# 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;
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;
# 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
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) {
carp "Request to remove directory $fname could not be completed since it does not exists!\n";
}
-
} else {
if (-f $fname) {
}
- # 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()
$template = File::Spec->catfile($options{"DIR"}, TEMPXXX);
} else {
-
+
$template = File::Spec->catfile(File::Spec->tmpdir, TEMPXXX);
}
-
+
}
# Now add a suffix
"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()) {
# 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;
}
$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;
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,
) );
my $suffix = shift;
$template .= $suffix;
-
+
my ($fh, $path);
croak "Error in mkstemps using $template"
unless (($fh, $path) = _gettemp($template,
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;
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,
) );
# Use a ten character template and append to tmpdir
my $template = File::Spec->catfile($tmpdir, TEMPXXX);
-
+
if (wantarray() ) {
return mkstemp($template);
} else {
if ($fh[3] > 1 && $^W) {
carp "unlink0: fstat found too many links; SB=@fh";
- }
+ }
# Stat the path
my @path = stat $path;
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
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
projects / p5sagit/p5-mst-13.2.git / commitdiff