diff options
Diffstat (limited to 'linux-x86/lib/perl-base/File/Temp.pm')
| -rw-r--r-- | linux-x86/lib/perl-base/File/Temp.pm | 1592 |
1 files changed, 0 insertions, 1592 deletions
diff --git a/linux-x86/lib/perl-base/File/Temp.pm b/linux-x86/lib/perl-base/File/Temp.pm deleted file mode 100644 index 308d9eb..0000000 --- a/linux-x86/lib/perl-base/File/Temp.pm +++ /dev/null @@ -1,1592 +0,0 @@ -package File::Temp; -# ABSTRACT: return name and handle of a temporary file safely -our $VERSION = '0.2304'; # VERSION - -# Toolchain targets v5.8.1, but we'll try to support back to v5.6 anyway. -# It might be possible to make this v5.5, but many v5.6isms are creeping -# into the code and tests. -use 5.006; -use strict; -use Carp; -use File::Spec 0.8; -use Cwd (); -use File::Path 2.06 qw/ rmtree /; -use Fcntl 1.03; -use IO::Seekable; # For SEEK_* -use Errno; -use Scalar::Util 'refaddr'; -require VMS::Stdio if $^O eq 'VMS'; - -# pre-emptively load Carp::Heavy. If we don't when we run out of file -# handles and attempt to call croak() we get an error message telling -# us that Carp::Heavy won't load rather than an error telling us we -# have run out of file handles. We either preload croak() or we -# switch the calls to croak from _gettemp() to use die. -eval { require Carp::Heavy; }; - -# Need the Symbol package if we are running older perl -require Symbol if $] < 5.006; - -### For the OO interface -use parent 0.221 qw/ IO::Handle IO::Seekable /; -use overload '""' => "STRINGIFY", '0+' => "NUMIFY", - fallback => 1; - -# use 'our' on v5.6.0 -use vars qw(@EXPORT_OK %EXPORT_TAGS $DEBUG $KEEP_ALL); - -$DEBUG = 0; -$KEEP_ALL = 0; - -# We are exporting functions - -use Exporter 5.57 'import'; # 5.57 lets us import 'import' - -# Export list - to allow fine tuning of export table - -@EXPORT_OK = qw{ - tempfile - tempdir - tmpnam - tmpfile - mktemp - mkstemp - mkstemps - mkdtemp - unlink0 - cleanup - SEEK_SET - SEEK_CUR - SEEK_END - }; - -# Groups of functions for export - -%EXPORT_TAGS = ( - 'POSIX' => [qw/ tmpnam tmpfile /], - 'mktemp' => [qw/ mktemp mkstemp mkstemps mkdtemp/], - 'seekable' => [qw/ SEEK_SET SEEK_CUR SEEK_END /], - ); - -# add contents of these tags to @EXPORT -Exporter::export_tags('POSIX','mktemp','seekable'); - -# 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 _ - /); - -# Maximum number of tries to make a temp file before failing - -use constant MAX_TRIES => 1000; - -# Minimum number of X characters that should be in a template -use constant MINX => 4; - -# Default template when no template supplied - -use constant TEMPXXX => 'X' x 10; - -# Constants for the security level - -use constant STANDARD => 0; -use constant MEDIUM => 1; -use constant HIGH => 2; - -# OPENFLAGS. If we defined the flag to use with Sysopen here this gives -# us an optimisation when many temporary files are requested - -my $OPENFLAGS = O_CREAT | O_EXCL | O_RDWR; -my $LOCKFLAG; - -unless ($^O eq 'MacOS') { - for my $oflag (qw/ NOFOLLOW BINARY LARGEFILE 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 - # e.g. CGI::Carp - local $SIG{__DIE__} = sub {}; - local $SIG{__WARN__} = sub {}; - $bit = &$func(); - 1; - }; - } - # Special case O_EXLOCK - $LOCKFLAG = eval { - local $SIG{__DIE__} = sub {}; - local $SIG{__WARN__} = sub {}; - &Fcntl::O_EXLOCK(); - }; -} - -# On some systems the O_TEMPORARY flag can be used to tell the OS -# to automatically remove the file when it is closed. This is fine -# in most cases but not if tempfile is called with UNLINK=>0 and -# the filename is requested -- in the case where the filename is to -# be passed to another routine. This happens on windows. We overcome -# this by using a second open flags variable - -my $OPENTEMPFLAGS = $OPENFLAGS; -unless ($^O eq 'MacOS') { - for my $oflag (qw/ TEMPORARY /) { - my ($bit, $func) = (0, "Fcntl::O_" . $oflag); - local($@); - no strict 'refs'; - $OPENTEMPFLAGS |= $bit if eval { - # Make sure that redefined die handlers do not cause problems - # e.g. CGI::Carp - local $SIG{__DIE__} = sub {}; - local $SIG{__WARN__} = sub {}; - $bit = &$func(); - 1; - }; - } -} - -# Private hash tracking which files have been created by each process id via the OO interface -my %FILES_CREATED_BY_OBJECT; - -# INTERNAL ROUTINES - not to be used outside of package - -# 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 -# with the random values - -# Arguments: - -# TEMPLATE - string containing the XXXXX's that is converted -# to a random filename and opened if required - -# Optionally, a hash can also be supplied containing specific options -# "open" => if true open the temp file, else just return the name -# default is 0 -# "mkdir"=> if true, we are creating a temp directory rather than tempfile -# default is 0 -# "suffixlen" => number of characters at end of PATH to be ignored. -# default is 0. -# "unlink_on_close" => indicates that, if possible, the OS should remove -# the file as soon as it is closed. Usually indicates -# use of the O_TEMPORARY flag to sysopen. -# Usually irrelevant on unix -# "use_exlock" => Indicates that O_EXLOCK should be used. Default is true. - -# 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. - -# The default options are equivalent to mktemp(). - -# Returns: -# filehandle - open file handle (if called with doopen=1, else undef) -# temp name - name of the temp file or directory - -# For example: -# ($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, - "use_exlock" => 1, - "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"}) { - ${$options{ErrStr}} = "doopen and domkdir can not both be true\n"; - return (); - } - - # Find the start of the end of the Xs (position of last X) - # Substr starts from 0 - my $start = length($template) - 1 - $options{"suffixlen"}; - - # Check that we have at least MINX x X (e.g. 'XXXX") at the end of the string - # (taking suffixlen into account). Any fewer is insecure. - - # Do it using substr - no reason to use a pattern match since - # 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 end with at least ". - MINX . " 'X' characters\n"; - return (); - } - - # Replace all the X at the end of the substring with a - # random character or just all the XX at the end of a full string. - # Do it as an if, since the suffix adjusts which section to replace - # and suffixlen=0 returns nothing if used in the substr directly - # and generate a full path from the template - - my $path = _replace_XX($template, $options{"suffixlen"}); - - # Split the path into constituent parts - eventually we need to check - # whether the directory exists - # We need to know whether we are making a temp directory - # or a tempfile - - my ($volume, $directories, $file); - my $parent; # parent directory - if ($options{"mkdir"}) { - # There is no filename at the end - ($volume, $directories, $file) = File::Spec->splitpath( $path, 1); - - # The parent is then $directories without the last directory - # Split the directory and put it back together again - my @dirs = File::Spec->splitdir($directories); - - # If @dirs only has one entry (i.e. the directory template) that means - # we are in the current directory - if ($#dirs == 0) { - $parent = File::Spec->curdir; - } else { - - 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 - $parent = File::Spec->catdir(@dirs[0..$#dirs-1]); - - # ...and attach the volume (no filename) - $parent = File::Spec->catpath($volume, $parent, ''); - } - - } - - } else { - - # Get rid of the last filename (use File::Basename for this?) - ($volume, $directories, $file) = File::Spec->splitpath( $path ); - - # Join up without the file part - $parent = File::Spec->catpath($volume,$directories,''); - - # If $parent is empty replace with curdir - $parent = File::Spec->curdir - unless $directories ne ''; - - } - - # Check that the parent directories exist - # Do this even for the case where we are simply returning a name - # not a file -- no point returning a name that includes a directory - # that does not exist or is not writable - - unless (-e $parent) { - ${$options{ErrStr}} = "Parent directory ($parent) does not exist"; - return (); - } - unless (-d $parent) { - ${$options{ErrStr}} = "Parent directory ($parent) is not a directory"; - 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 (); - } - } - - # Now try MAX_TRIES time to open the file - for (my $i = 0; $i < MAX_TRIES; $i++) { - - # Try to open the file if requested - if ($options{"open"}) { - my $fh; - - # If we are running before perl5.6.0 we can not auto-vivify - if ($] < 5.006) { - $fh = &Symbol::gensym; - } - - # 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; - - # Attempt to open the file - my $open_success = undef; - if ( $^O eq 'VMS' and $options{"unlink_on_close"} && !$KEEP_ALL) { - # make it auto delete on close by setting FAB$V_DLT bit - $fh = VMS::Stdio::vmssysopen($path, $OPENFLAGS, 0600, 'fop=dlt'); - $open_success = $fh; - } else { - my $flags = ( ($options{"unlink_on_close"} && !$KEEP_ALL) ? - $OPENTEMPFLAGS : - $OPENFLAGS ); - $flags |= $LOCKFLAG if (defined $LOCKFLAG && $options{use_exlock}); - $open_success = sysopen($fh, $path, $flags, 0600); - } - if ( $open_success ) { - - # in case of odd umask force rw - chmod(0600, $path); - - # Opened successfully - return file handle and name - return ($fh, $path); - - } else { - - # Error opening file - abort with error - # if the reason was anything but EEXIST - unless ($!{EEXIST}) { - ${$options{ErrStr}} = "Could not create temp file $path: $!"; - return (); - } - - # Loop round for another try - - } - } elsif ($options{"mkdir"}) { - - # Open the temp directory - if (mkdir( $path, 0700)) { - # in case of odd umask - chmod(0700, $path); - - return undef, $path; - } else { - - # Abort with error if the reason for failure was anything - # except EEXIST - unless ($!{EEXIST}) { - ${$options{ErrStr}} = "Could not create directory $path: $!"; - return (); - } - - # Loop round for another try - - } - - } else { - - # Return true if the file can not be found - # Directory has been checked previously - - return (undef, $path) unless -e $path; - - # 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 - # 1 X say and the randomness could come up with the same - # file MAX_TRIES in a row. - - # Store current attempt - in principal this implies that the - # 3rd time around the open attempt that the first temp file - # name could be generated again. Probably should store each - # attempt and make sure that none are repeated - - my $original = $path; - my $counter = 0; # Stop infinite loop - my $MAX_GUESS = 50; - - do { - - # Generate new name from original template - $path = _replace_XX($template, $options{"suffixlen"}); - - $counter++; - - } until ($path ne $original || $counter > $MAX_GUESS); - - # 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 (); - -} - -# Internal routine to replace the XXXX... with random characters -# This has to be done by _gettemp() every time it fails to -# open a temp file/dir - -# Arguments: $template (the template with XXX), -# $ignore (number of characters at end to ignore) - -# Returns: modified template - -sub _replace_XX { - - croak 'Usage: _replace_XX($template, $ignore)' - unless scalar(@_) == 2; - - my ($path, $ignore) = @_; - - # Do it as an if, since the suffix adjusts which section to replace - # and suffixlen=0 returns nothing if used in the substr directly - # Alternatively, could simply set $ignore to length($path)-1 - # Don't want to always use substr when not required though. - my $end = ( $] >= 5.006 ? "\\z" : "\\Z" ); - - if ($ignore) { - substr($path, 0, - $ignore) =~ s/X(?=X*$end)/$CHARS[ int( rand( @CHARS ) ) ]/ge; - } else { - $path =~ s/X(?=X*$end)/$CHARS[ int( rand( @CHARS ) ) ]/ge; - } - return $path; -} - -# Internal routine to force a temp file to be writable after -# it is created so that we can unlink it. Windows seems to occasionally -# force a file to be readonly when written to certain temp locations -sub _force_writable { - my $file = shift; - chmod 0600, $file; -} - -# internal routine to check to see if the directory is safe -# 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 -# it has the sticky bit set - -# 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 - -# This routine based on version written by Tom Christiansen - -# Presumably, by the time we actually attempt to create the -# file or directory in this directory, it may not be safe -# anymore... Have to run _is_safe directly after the open. - -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 - # Use the effective uid from the $> variable - # UID is in [4] - if ($info[4] > File::Temp->top_system_uid() && $info[4] != $>) { - - Carp::cluck(sprintf "uid=$info[4] topuid=%s euid=$> path='$path'", - File::Temp->top_system_uid()); - - $$err_ref = "Directory owned neither by root nor the current user" - if ref($err_ref); - return 0; - } - - # check whether group or other can write file - # use 066 to detect either reading or writing - # use 022 to check writability - # Do it with S_IWOTH and S_IWGRP for portability (maybe) - # 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 $path) { - $$err_ref = "Path ($path) is not a directory" - if ref($err_ref); - return 0; - } - # Must have sticky bit set - unless (-k $path) { - $$err_ref = "Sticky bit not set on $path when dir is group|world writable" - if ref($err_ref); - return 0; - } - } - - return 1; -} - -# Internal routine to check whether a directory is safe -# for temp files. Safer than _is_safe since it checks for -# the possibility of chown giveaway and if that is a possibility -# checks each directory in the path to see if it is safe (with _is_safe) - -# 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 - local($@); - my $chown_restricted; - $chown_restricted = &POSIX::_PC_CHOWN_RESTRICTED() - if eval { &POSIX::_PC_CHOWN_RESTRICTED(); 1}; - - # If chown_resticted is set to some value we should test it - if (defined $chown_restricted) { - - # Return if the current directory is safe - return _is_safe($path,$err_ref) if POSIX::sysconf( $chown_restricted ); - - } - - # To reach this point either, the _PC_CHOWN_RESTRICTED symbol - # was not available or the symbol was there but chown giveaway - # is allowed. Either way, we now have to test the entire tree for - # safety. - - # Convert path to an absolute directory if required - unless (File::Spec->file_name_is_absolute($path)) { - $path = File::Spec->rel2abs($path); - } - - # Split directory into components - assume no file - my ($volume, $directories, undef) = File::Spec->splitpath( $path, 1); - - # Slightly less efficient than having a function in File::Spec - # to chop off the end of a directory or even a function that - # can handle ../ in a directory tree - # Sometimes splitdir() returns a blank at the end - # so we will probably check the bottom directory twice in some cases - my @dirs = File::Spec->splitdir($directories); - - # Concatenate one less directory each time around - foreach my $pos (0.. $#dirs) { - # Get a directory name - my $dir = File::Spec->catpath($volume, - File::Spec->catdir(@dirs[0.. $#dirs - $pos]), - '' - ); - - print "TESTING DIR $dir\n" if $DEBUG; - - # Check the directory - return 0 unless _is_safe($dir,$err_ref); - - } - - return 1; -} - -# internal routine to determine whether unlink works on this -# platform for files that are currently open. -# Returns true if we can, false otherwise. - -# 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 (grep { $^O eq $_ } qw/MSWin32 os2 VMS dos MacOS haiku/) { - return 0; - } else { - return 1; - } - -} - -# internal routine to decide which security levels are allowed -# see safe_level() for more information on this - -# Controls whether the supplied security level is allowed - -# $cando = _can_do_level( $level ) - -sub _can_do_level { - - # Get security level - my $level = shift; - - # Always have to be able to do STANDARD - return 1 if $level == STANDARD; - - # Currently, the systems that can do HIGH or MEDIUM are identical - if ( $^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'cygwin' || $^O eq 'dos' || $^O eq 'MacOS' || $^O eq 'mpeix') { - 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 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 - -# Arguments: -# _deferred_unlink( $fh, $fname, $isdir ); -# -# - filehandle (so that it can be explicitly closed if open -# - filename (the thing we want to remove) -# - isdir (flag to indicate that we are being given a directory) -# [and hence no filehandle] - -# Status is not referred to since all the magic is done with an END block - -{ - # Will set up two lexical variables to contain all the files to be - # removed. One array for files, another for directories They will - # only exist in this block. - - # This means we only have to set up a single END block to remove - # all files. - - # in order to prevent child processes inadvertently deleting the parent - # temp files we use a hash to store the temp files and directories - # created by a particular process id. - - # %files_to_unlink contains values that are references to an array of - # array references containing the filehandle and filename associated with - # the temp file. - my (%files_to_unlink, %dirs_to_unlink); - - # Set up an end block to use these arrays - END { - local($., $@, $!, $^E, $?); - cleanup(at_exit => 1); - } - - # Cleanup function. Always triggered on END (with at_exit => 1) but - # can be invoked manually. - sub cleanup { - my %h = @_; - my $at_exit = delete $h{at_exit}; - $at_exit = 0 if not defined $at_exit; - { my @k = sort keys %h; die "unrecognized parameters: @k" if @k } - - if (!$KEEP_ALL) { - # Files - my @files = (exists $files_to_unlink{$$} ? - @{ $files_to_unlink{$$} } : () ); - foreach my $file (@files) { - # close the filehandle without checking its state - # in order to make real sure that this is closed - # if its already closed then I don't care about the answer - # probably a better way to do this - close($file->[0]); # file handle is [0] - - if (-f $file->[1]) { # file name is [1] - _force_writable( $file->[1] ); # for windows - unlink $file->[1] or warn "Error removing ".$file->[1]; - } - } - # Dirs - my @dirs = (exists $dirs_to_unlink{$$} ? - @{ $dirs_to_unlink{$$} } : () ); - my ($cwd, $cwd_to_remove); - foreach my $dir (@dirs) { - if (-d $dir) { - # Some versions of rmtree will abort if you attempt to remove - # the directory you are sitting in. For automatic cleanup - # at program exit, we avoid this by chdir()ing out of the way - # first. If not at program exit, it's best not to mess with the - # current directory, so just let it fail with a warning. - if ($at_exit) { - $cwd = Cwd::abs_path(File::Spec->curdir) if not defined $cwd; - my $abs = Cwd::abs_path($dir); - if ($abs eq $cwd) { - $cwd_to_remove = $dir; - next; - } - } - eval { rmtree($dir, $DEBUG, 0); }; - warn $@ if ($@ && $^W); - } - } - - if (defined $cwd_to_remove) { - # We do need to clean up the current directory, and everything - # else is done, so get out of there and remove it. - chdir $cwd_to_remove or die "cannot chdir to $cwd_to_remove: $!"; - my $updir = File::Spec->updir; - chdir $updir or die "cannot chdir to $updir: $!"; - eval { rmtree($cwd_to_remove, $DEBUG, 0); }; - warn $@ if ($@ && $^W); - } - - # clear the arrays - @{ $files_to_unlink{$$} } = () - if exists $files_to_unlink{$$}; - @{ $dirs_to_unlink{$$} } = () - if exists $dirs_to_unlink{$$}; - } - } - - # This is the sub called to register a file for deferred unlinking - # This could simply store the input parameters and defer everything - # until the END block. For now we do a bit of checking at this - # point in order to make sure that (1) we have a file/dir to delete - # and (2) we have been called with the correct arguments. - sub _deferred_unlink { - - croak 'Usage: _deferred_unlink($fh, $fname, $isdir)' - unless scalar(@_) == 3; - - my ($fh, $fname, $isdir) = @_; - - warn "Setting up deferred removal of $fname\n" - if $DEBUG; - - # make sure we save the absolute path for later cleanup - # OK to untaint because we only ever use this internally - # as a file path, never interpolating into the shell - $fname = Cwd::abs_path($fname); - ($fname) = $fname =~ /^(.*)$/; - - # If we have a directory, check that it is a directory - if ($isdir) { - - if (-d $fname) { - - # Directory exists so store it - # first on VMS turn []foo into [.foo] for rmtree - $fname = VMS::Filespec::vmspath($fname) if $^O eq 'VMS'; - $dirs_to_unlink{$$} = [] - unless exists $dirs_to_unlink{$$}; - 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 { - - if (-f $fname) { - - # file exists so store handle and name for later removal - $files_to_unlink{$$} = [] - unless exists $files_to_unlink{$$}; - 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; - } - - } - - } - -} - -# normalize argument keys to upper case and do consistent handling -# of leading template vs TEMPLATE -sub _parse_args { - my $leading_template = (scalar(@_) % 2 == 1 ? shift(@_) : '' ); - my %args = @_; - %args = map { uc($_), $args{$_} } keys %args; - - # template (store it in an array so that it will - # disappear from the arg list of tempfile) - my @template = ( - exists $args{TEMPLATE} ? $args{TEMPLATE} : - $leading_template ? $leading_template : () - ); - delete $args{TEMPLATE}; - - return( \@template, \%args ); -} - -sub new { - my $proto = shift; - my $class = ref($proto) || $proto; - - my ($maybe_template, $args) = _parse_args(@_); - - # see if they are unlinking (defaulting to yes) - my $unlink = (exists $args->{UNLINK} ? $args->{UNLINK} : 1 ); - delete $args->{UNLINK}; - - # Protect OPEN - delete $args->{OPEN}; - - # Open the file and retain file handle and file name - my ($fh, $path) = tempfile( @$maybe_template, %$args ); - - print "Tmp: $fh - $path\n" if $DEBUG; - - # Store the filename in the scalar slot - ${*$fh} = $path; - - # Cache the filename by pid so that the destructor can decide whether to remove it - $FILES_CREATED_BY_OBJECT{$$}{$path} = 1; - - # Store unlink information in hash slot (plus other constructor info) - %{*$fh} = %$args; - - # create the object - bless $fh, $class; - - # final method-based configuration - $fh->unlink_on_destroy( $unlink ); - - return $fh; -} - -sub newdir { - my $self = shift; - - my ($maybe_template, $args) = _parse_args(@_); - - # handle CLEANUP without passing CLEANUP to tempdir - my $cleanup = (exists $args->{CLEANUP} ? $args->{CLEANUP} : 1 ); - delete $args->{CLEANUP}; - - my $tempdir = tempdir( @$maybe_template, %$args); - - # get a safe absolute path for cleanup, just like - # happens in _deferred_unlink - my $real_dir = Cwd::abs_path( $tempdir ); - ($real_dir) = $real_dir =~ /^(.*)$/; - - return bless { DIRNAME => $tempdir, - REALNAME => $real_dir, - CLEANUP => $cleanup, - LAUNCHPID => $$, - }, "File::Temp::Dir"; -} - -sub filename { - my $self = shift; - return ${*$self}; -} - -sub STRINGIFY { - my $self = shift; - return $self->filename; -} - -# For reference, can't use '0+'=>\&Scalar::Util::refaddr directly because -# refaddr() demands one parameter only, whereas overload.pm calls with three -# even for unary operations like '0+'. -sub NUMIFY { - return refaddr($_[0]); -} - -sub unlink_on_destroy { - my $self = shift; - if (@_) { - ${*$self}{UNLINK} = shift; - } - return ${*$self}{UNLINK}; -} - -sub DESTROY { - local($., $@, $!, $^E, $?); - my $self = shift; - - # Make sure we always remove the file from the global hash - # on destruction. This prevents the hash from growing uncontrollably - # and post-destruction there is no reason to know about the file. - my $file = $self->filename; - my $was_created_by_proc; - if (exists $FILES_CREATED_BY_OBJECT{$$}{$file}) { - $was_created_by_proc = 1; - delete $FILES_CREATED_BY_OBJECT{$$}{$file}; - } - - if (${*$self}{UNLINK} && !$KEEP_ALL) { - print "# ---------> Unlinking $self\n" if $DEBUG; - - # only delete if this process created it - return unless $was_created_by_proc; - - # The unlink1 may fail if the file has been closed - # by the caller. This leaves us with the decision - # of whether to refuse to remove the file or simply - # do an unlink without test. Seems to be silly - # to do this when we are trying to be careful - # about security - _force_writable( $file ); # for windows - unlink1( $self, $file ) - or unlink($file); - } -} - -sub tempfile { - if ( @_ && $_[0] eq 'File::Temp' ) { - croak "'tempfile' can't be called as a method"; - } - # Can not check for argument count since we can have any - # number of args - - # Default options - my %options = ( - "DIR" => undef, # Directory prefix - "SUFFIX" => '', # Template suffix - "UNLINK" => 0, # Do not unlink file on exit - "OPEN" => 1, # Open file - "TMPDIR" => 0, # Place tempfile in tempdir if template specified - "EXLOCK" => 1, # Open file with O_EXLOCK - ); - - # Check to see whether we have an odd or even number of arguments - my ($maybe_template, $args) = _parse_args(@_); - my $template = @$maybe_template ? $maybe_template->[0] : undef; - - # Read the options and merge with defaults - %options = (%options, %$args); - - # First decision is whether or not to open the file - if (! $options{"OPEN"}) { - - warn "tempfile(): temporary filename requested but not opened.\nPossibly unsafe, consider using tempfile() with OPEN set to true\n" - if $^W; - - } - - if ($options{"DIR"} and $^O eq 'VMS') { - - # on VMS turn []foo into [.foo] for concatenation - $options{"DIR"} = VMS::Filespec::vmspath($options{"DIR"}); - } - - # 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() - # explicitly. Go for the latter - - # First generate a template if not defined and prefix the directory - # If no template must prefix the temp directory - if (defined $template) { - # End up with current directory if neither DIR not TMPDIR are set - if ($options{"DIR"}) { - - $template = File::Spec->catfile($options{"DIR"}, $template); - - } elsif ($options{TMPDIR}) { - - $template = File::Spec->catfile(File::Spec->tmpdir, $template ); - - } - - } else { - - if ($options{"DIR"}) { - - $template = File::Spec->catfile($options{"DIR"}, TEMPXXX); - - } else { - - $template = File::Spec->catfile(File::Spec->tmpdir, TEMPXXX); - - } - - } - - # 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 (which may be - # important if they want a child process to use the file) - # 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, $errstr); - croak "Error in tempfile() using template $template: $errstr" - unless (($fh, $path) = _gettemp($template, - "open" => $options{'OPEN'}, - "mkdir"=> 0 , - "unlink_on_close" => $unlink_on_close, - "suffixlen" => length($options{'SUFFIX'}), - "ErrStr" => \$errstr, - "use_exlock" => $options{EXLOCK}, - ) ); - - # Set up an exit handler that can do whatever is right for the - # 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 - if (wantarray()) { - - if ($options{'OPEN'}) { - return ($fh, $path); - } else { - return (undef, $path); - } - - } else { - - # 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; - } - -} - -# ' - -sub tempdir { - if ( @_ && $_[0] eq 'File::Temp' ) { - croak "'tempdir' can't be called as a method"; - } - - # Can not check for argument count since we can have any - # number of args - - # Default options - my %options = ( - "CLEANUP" => 0, # Remove directory on exit - "DIR" => '', # Root directory - "TMPDIR" => 0, # Use tempdir with template - ); - - # Check to see whether we have an odd or even number of arguments - my ($maybe_template, $args) = _parse_args(@_); - my $template = @$maybe_template ? $maybe_template->[0] : undef; - - # Read the options and merge with defaults - %options = (%options, %$args); - - # Modify or generate the template - - # Deal with the DIR and TMPDIR options - if (defined $template) { - - # Need to strip directory path if using DIR or TMPDIR - if ($options{'TMPDIR'} || $options{'DIR'}) { - - # Strip parent directory from the filename - # - # There is no filename at the end - $template = VMS::Filespec::vmspath($template) if $^O eq 'VMS'; - my ($volume, $directories, undef) = File::Spec->splitpath( $template, 1); - - # Last directory is then our template - $template = (File::Spec->splitdir($directories))[-1]; - - # Prepend the supplied directory or temp dir - if ($options{"DIR"}) { - - $template = File::Spec->catdir($options{"DIR"}, $template); - - } elsif ($options{TMPDIR}) { - - # Prepend tmpdir - $template = File::Spec->catdir(File::Spec->tmpdir, $template); - - } - - } - - } else { - - if ($options{"DIR"}) { - - $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); - } - if ( ($^O eq 'MacOS') && (substr($template, -1) eq ':') ) { - # dir name has a trailing ':' - ++$suffixlen; - } - - 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 - if ( $options{'CLEANUP'} && -d $tempdir) { - _deferred_unlink(undef, $tempdir, 1); - } - - # Return the dir name - return $tempdir; - -} - -sub mkstemp { - - croak "Usage: mkstemp(template)" - if scalar(@_) != 1; - - 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()) { - return ($fh, $path); - } else { - return $fh; - } - -} - -sub mkstemps { - - croak "Usage: mkstemps(template, suffix)" - if scalar(@_) != 2; - - my $template = shift; - my $suffix = shift; - - $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()) { - return ($fh, $path); - } else { - return $fh; - } - -} - -#' # for emacs - -sub mkdtemp { - - croak "Usage: mkdtemp(template)" - if scalar(@_) != 1; - - my $template = shift; - my $suffixlen = 0; - if ($^O eq 'VMS') { # dir names can end in delimiters - $template =~ m/([\.\]:>]+)$/; - $suffixlen = length($1); - } - if ( ($^O eq 'MacOS') && (substr($template, -1) eq ':') ) { - # dir name has a trailing ':' - ++$suffixlen; - } - 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; - -} - -sub mktemp { - - croak "Usage: mktemp(template)" - if scalar(@_) != 1; - - 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; -} - -sub tmpnam { - - # Retrieve the temporary directory name - my $tmpdir = File::Spec->tmpdir; - - croak "Error temporary directory is not writable" - if $tmpdir eq ''; - - # Use a ten character template and append to tmpdir - my $template = File::Spec->catfile($tmpdir, TEMPXXX); - - if (wantarray() ) { - return mkstemp($template); - } else { - return mktemp($template); - } - -} - -sub tmpfile { - - # Simply call tmpnam() in a list context - my ($fh, $file) = tmpnam(); - - # Make sure file is removed when filehandle is closed - # This will fail on NFS - unlink0($fh, $file) - or return undef; - - return $fh; - -} - -sub tempnam { - - croak 'Usage tempnam($dir, $prefix)' unless scalar(@_) == 2; - - my ($dir, $prefix) = @_; - - # Add a string to the prefix - $prefix .= 'XXXXXXXX'; - - # Concatenate the directory to the file - my $template = File::Spec->catfile($dir, $prefix); - - return mktemp($template); - -} - -sub unlink0 { - - croak 'Usage: unlink0(filehandle, filename)' - unless scalar(@_) == 2; - - # Read args - my ($fh, $path) = @_; - - cmpstat($fh, $path) or return 0; - - # attempt remove the file (does not work on some platforms) - if (_can_unlink_opened_file()) { - - # return early (Without unlink) if we have been instructed to retain files. - return 1 if $KEEP_ALL; - - # XXX: do *not* call this on a directory; possible race - # resulting in recursive removal - croak "unlink0: $path has become a directory!" if -d $path; - unlink($path) or return 0; - - # Stat the filehandle - my @fh = stat $fh; - - print "Link count = $fh[3] \n" if $DEBUG; - - # 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 can't know that - # we are on NFS. Since we can't be sure, we'll defer it - - return 1 if $fh[3] == 0 || $^O eq 'cygwin'; - } - # fall-through if we can't unlink now - _deferred_unlink($fh, $path, 0); - return 1; -} - -sub cmpstat { - - croak 'Usage: cmpstat(filehandle, filename)' - unless scalar(@_) == 2; - - # Read args - my ($fh, $path) = @_; - - warn "Comparing stat\n" - if $DEBUG; - - # Stat the filehandle - which may be closed if someone has manually - # closed the file. Can not turn off warnings without using $^W - # unless we upgrade to 5.006 minimum requirement - my @fh; - { - local ($^W) = 0; - @fh = stat $fh; - } - return unless @fh; - - if ($fh[3] > 1 && $^W) { - carp "unlink0: fstat found too many links; SB=@fh" if $^W; - } - - # 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 $path) { - 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 - # depending on whether it is a file or a handle. - # Cannot simply compare all members of the stat return - # Select the ones we can use - 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 'os2') { - @okstat = (0, 2..$#fh); - } elsif ($^O eq 'VMS') { # device and file ID are sufficient - @okstat = (0, 1); - } elsif ($^O eq 'dos') { - @okstat = (0,2..7,11..$#fh); - } elsif ($^O eq 'mpeix') { - @okstat = (0..4,8..10); - } - - # Now compare each entry explicitly by number - for (@okstat) { - print "Comparing: $_ : $fh[$_] and $path[$_]\n" if $DEBUG; - # Use eq rather than == since rdev, blksize, and blocks (6, 11, - # and 12) will be '' on platforms that do not support them. 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; - } - } - - return 1; -} - -sub unlink1 { - croak 'Usage: unlink1(filehandle, filename)' - unless scalar(@_) == 2; - - # Read args - my ($fh, $path) = @_; - - cmpstat($fh, $path) or return 0; - - # Close the file - close( $fh ) or return 0; - - # Make sure the file is writable (for windows) - _force_writable( $path ); - - # return early (without unlink) if we have been instructed to retain files. - return 1 if $KEEP_ALL; - - # remove the file - return unlink($path); -} - -{ - # protect from using the variable itself - my $LEVEL = STANDARD; - sub safe_level { - my $self = shift; - 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 { - # Don't allow this on perl 5.005 or earlier - if ($] < 5.006 && $level != STANDARD) { - # Cant do MEDIUM or HIGH checks - croak "Currently requires perl 5.006 or newer to do the safe checks"; - } - # Check that we are allowed to change level - # Silently ignore if we can not. - $LEVEL = $level if _can_do_level($level); - } - } - return $LEVEL; - } -} - -{ - my $TopSystemUID = 10; - $TopSystemUID = 197108 if $^O eq 'interix'; # "Administrator" - sub top_system_uid { - my $self = shift; - if (@_) { - my $newuid = shift; - croak "top_system_uid: UIDs should be numeric" - unless $newuid =~ /^\d+$/s; - $TopSystemUID = $newuid; - } - return $TopSystemUID; - } -} - -package File::Temp::Dir; - -use File::Path qw/ rmtree /; -use strict; -use overload '""' => "STRINGIFY", - '0+' => \&File::Temp::NUMIFY, - fallback => 1; - -# private class specifically to support tempdir objects -# created by File::Temp->newdir - -# ostensibly the same method interface as File::Temp but without -# inheriting all the IO::Seekable methods and other cruft - -# Read-only - returns the name of the temp directory - -sub dirname { - my $self = shift; - return $self->{DIRNAME}; -} - -sub STRINGIFY { - my $self = shift; - return $self->dirname; -} - -sub unlink_on_destroy { - my $self = shift; - if (@_) { - $self->{CLEANUP} = shift; - } - return $self->{CLEANUP}; -} - -sub DESTROY { - my $self = shift; - local($., $@, $!, $^E, $?); - if ($self->unlink_on_destroy && - $$ == $self->{LAUNCHPID} && !$File::Temp::KEEP_ALL) { - if (-d $self->{REALNAME}) { - # Some versions of rmtree will abort if you attempt to remove - # the directory you are sitting in. We protect that and turn it - # into a warning. We do this because this occurs during object - # destruction and so can not be caught by the user. - eval { rmtree($self->{REALNAME}, $File::Temp::DEBUG, 0); }; - warn $@ if ($@ && $^W); - } - } -} - -1; - -__END__ - |