diff options
author | Nicholas Clark <nick@ccl4.org> | 2009-10-01 16:22:48 +0100 |
---|---|---|
committer | Nicholas Clark <nick@ccl4.org> | 2009-10-01 16:22:48 +0100 |
commit | 724f9809fd0c24b3761f70b6b5972a9ce37db3c6 (patch) | |
tree | 5a3e324c29d14973a99149d61182b1651d025baa /ext | |
parent | cb9d5b3a2566a2a88f1a861bc6c9a0bee5e7d768 (diff) | |
download | perl-724f9809fd0c24b3761f70b6b5972a9ce37db3c6.tar.gz |
Move File::Temp from ext/ to cpan/
Diffstat (limited to 'ext')
-rw-r--r-- | ext/File-Temp/Temp.pm | 2452 | ||||
-rw-r--r-- | ext/File-Temp/t/cmp.t | 11 | ||||
-rw-r--r-- | ext/File-Temp/t/fork.t | 103 | ||||
-rw-r--r-- | ext/File-Temp/t/lock.t | 60 | ||||
-rw-r--r-- | ext/File-Temp/t/mktemp.t | 110 | ||||
-rw-r--r-- | ext/File-Temp/t/object.t | 138 | ||||
-rw-r--r-- | ext/File-Temp/t/posix.t | 77 | ||||
-rw-r--r-- | ext/File-Temp/t/security.t | 140 | ||||
-rw-r--r-- | ext/File-Temp/t/seekable.t | 43 | ||||
-rw-r--r-- | ext/File-Temp/t/tempfile.t | 150 |
10 files changed, 0 insertions, 3284 deletions
diff --git a/ext/File-Temp/Temp.pm b/ext/File-Temp/Temp.pm deleted file mode 100644 index a2d4ae0759..0000000000 --- a/ext/File-Temp/Temp.pm +++ /dev/null @@ -1,2452 +0,0 @@ -package File::Temp; - -=head1 NAME - -File::Temp - return name and handle of a temporary file safely - -=begin __INTERNALS - -=head1 PORTABILITY - -This section is at the top in order to provide easier access to -porters. It is not expected to be rendered by a standard pod -formatting tool. Please skip straight to the SYNOPSIS section if you -are not trying to port this module to a new platform. - -This module is designed to be portable across operating systems and it -currently supports Unix, VMS, DOS, OS/2, Windows and Mac OS -(Classic). When porting to a new OS there are generally three main -issues that have to be solved: - -=over 4 - -=item * - -Can the OS unlink an open file? If it can not then the -C<_can_unlink_opened_file> method should be modified. - -=item * - -Are the return values from C<stat> reliable? By default all the -return values from C<stat> are compared when unlinking a temporary -file using the filename and the handle. Operating systems other than -unix do not always have valid entries in all fields. If C<unlink0> fails -then the C<stat> comparison should be modified accordingly. - -=item * - -Security. Systems that can not support a test for the sticky bit -on a directory can not use the MEDIUM and HIGH security tests. -The C<_can_do_level> method should be modified accordingly. - -=back - -=end __INTERNALS - -=head1 SYNOPSIS - - use File::Temp qw/ tempfile tempdir /; - - $fh = tempfile(); - ($fh, $filename) = tempfile(); - - ($fh, $filename) = tempfile( $template, DIR => $dir); - ($fh, $filename) = tempfile( $template, SUFFIX => '.dat'); - ($fh, $filename) = tempfile( $template, TMPDIR => 1 ); - - binmode( $fh, ":utf8" ); - - $dir = tempdir( CLEANUP => 1 ); - ($fh, $filename) = tempfile( DIR => $dir ); - -Object interface: - - require File::Temp; - use File::Temp (); - use File::Temp qw/ :seekable /; - - $fh = File::Temp->new(); - $fname = $fh->filename; - - $fh = File::Temp->new(TEMPLATE => $template); - $fname = $fh->filename; - - $tmp = File::Temp->new( UNLINK => 0, SUFFIX => '.dat' ); - print $tmp "Some data\n"; - print "Filename is $tmp\n"; - $tmp->seek( 0, SEEK_END ); - -The following interfaces are provided for compatibility with -existing APIs. They should not be used in new code. - -MkTemp family: - - use File::Temp qw/ :mktemp /; - - ($fh, $file) = mkstemp( "tmpfileXXXXX" ); - ($fh, $file) = mkstemps( "tmpfileXXXXXX", $suffix); - - $tmpdir = mkdtemp( $template ); - - $unopened_file = mktemp( $template ); - -POSIX functions: - - use File::Temp qw/ :POSIX /; - - $file = tmpnam(); - $fh = tmpfile(); - - ($fh, $file) = tmpnam(); - -Compatibility functions: - - $unopened_file = File::Temp::tempnam( $dir, $pfx ); - -=head1 DESCRIPTION - -C<File::Temp> can be used to create and open temporary files in a safe -way. There is both a function interface and an object-oriented -interface. The File::Temp constructor or the tempfile() function can -be used to return the name and the open filehandle of a temporary -file. The tempdir() function can be used to create a temporary -directory. - -The security aspect of temporary file creation is emphasized such that -a filehandle and filename are returned together. This helps guarantee -that a race condition can not occur where the temporary file is -created by another process between checking for the existence of the -file and its opening. Additional security levels are provided to -check, for example, that the sticky bit is set on world writable -directories. See L<"safe_level"> for more information. - -For compatibility with popular C library functions, Perl implementations of -the mkstemp() family of functions are provided. These are, mkstemp(), -mkstemps(), mkdtemp() and mktemp(). - -Additionally, implementations of the standard L<POSIX|POSIX> -tmpnam() and tmpfile() functions are provided if required. - -Implementations of mktemp(), tmpnam(), and tempnam() are provided, -but should be used with caution since they return only a filename -that was valid when function was called, so cannot guarantee -that the file will not exist by the time the caller opens the filename. - -Filehandles returned by these functions support the seekable methods. - -=cut - -# 5.6.0 gives us S_IWOTH, S_IWGRP, our and auto-vivifying filehandls -# People would like a version on 5.004 so give them what they want :-) -use 5.004; -use strict; -use Carp; -use File::Spec 0.8; -use File::Path qw/ rmtree /; -use Fcntl 1.03; -use IO::Seekable; # For SEEK_* -use Errno; -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 base qw/ IO::Handle IO::Seekable /; -use overload '""' => "STRINGIFY", fallback => 1; - -# use 'our' on v5.6.0 -use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS $DEBUG $KEEP_ALL); - -$DEBUG = 0; -$KEEP_ALL = 0; - -# We are exporting functions - -use base qw/Exporter/; - -# 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'); - -# Version number - -$VERSION = '0.22'; - -# 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 occassionally -# 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 avialable 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 ($^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'VMS' || $^O eq 'dos' || $^O eq 'MacOS') { - 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 expclicitly 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(); - } - - # Cleanup function. Always triggered on END but can be invoked - # manually. - sub cleanup { - 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 dont 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{$$} } : () ); - foreach my $dir (@dirs) { - if (-d $dir) { - # 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 - # cleanup and so can not be caught by the user. - eval { rmtree($dir, $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; - - # 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; - } - - } - - } - - -} - -=head1 OBJECT-ORIENTED INTERFACE - -This is the primary interface for interacting with -C<File::Temp>. Using the OO interface a temporary file can be created -when the object is constructed and the file can be removed when the -object is no longer required. - -Note that there is no method to obtain the filehandle from the -C<File::Temp> object. The object itself acts as a filehandle. Also, -the object is configured such that it stringifies to the name of the -temporary file, and can be compared to a filename directly. The object -isa C<IO::Handle> and isa C<IO::Seekable> so all those methods are -available. - -=over 4 - -=item B<new> - -Create a temporary file object. - - my $tmp = File::Temp->new(); - -by default the object is constructed as if C<tempfile> -was called without options, but with the additional behaviour -that the temporary file is removed by the object destructor -if UNLINK is set to true (the default). - -Supported arguments are the same as for C<tempfile>: UNLINK -(defaulting to true), DIR, EXLOCK and SUFFIX. Additionally, the filename -template is specified using the TEMPLATE option. The OPEN option -is not supported (the file is always opened). - - $tmp = File::Temp->new( TEMPLATE => 'tempXXXXX', - DIR => 'mydir', - SUFFIX => '.dat'); - -Arguments are case insensitive. - -Can call croak() if an error occurs. - -=cut - -sub new { - my $proto = shift; - my $class = ref($proto) || $proto; - - # read arguments and convert keys to upper case - my %args = @_; - %args = map { uc($_), $args{$_} } keys %args; - - # see if they are unlinking (defaulting to yes) - my $unlink = (exists $args{UNLINK} ? $args{UNLINK} : 1 ); - delete $args{UNLINK}; - - # template (store it in an array so that it will - # disappear from the arg list of tempfile) - my @template = ( exists $args{TEMPLATE} ? $args{TEMPLATE} : () ); - delete $args{TEMPLATE}; - - # Protect OPEN - delete $args{OPEN}; - - # Open the file and retain file handle and file name - my ($fh, $path) = tempfile( @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; -} - -=item B<newdir> - -Create a temporary directory using an object oriented interface. - - $dir = File::Temp->newdir(); - -By default the directory is deleted when the object goes out of scope. - -Supports the same options as the C<tempdir> function. Note that directories -created with this method default to CLEANUP => 1. - - $dir = File::Temp->newdir( $template, %options ); - -=cut - -sub newdir { - my $self = shift; - - # need to handle args as in tempdir because we have to force CLEANUP - # default without passing CLEANUP to tempdir - my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef ); - my %options = @_; - my $cleanup = (exists $options{CLEANUP} ? $options{CLEANUP} : 1 ); - - delete $options{CLEANUP}; - - my $tempdir; - if (defined $template) { - $tempdir = tempdir( $template, %options ); - } else { - $tempdir = tempdir( %options ); - } - return bless { DIRNAME => $tempdir, - CLEANUP => $cleanup, - LAUNCHPID => $$, - }, "File::Temp::Dir"; -} - -=item B<filename> - -Return the name of the temporary file associated with this object -(if the object was created using the "new" constructor). - - $filename = $tmp->filename; - -This method is called automatically when the object is used as -a string. - -=cut - -sub filename { - my $self = shift; - return ${*$self}; -} - -sub STRINGIFY { - my $self = shift; - return $self->filename; -} - -=item B<dirname> - -Return the name of the temporary directory associated with this -object (if the object was created using the "newdir" constructor). - - $dirname = $tmpdir->dirname; - -This method is called automatically when the object is used in string context. - -=item B<unlink_on_destroy> - -Control whether the file is unlinked when the object goes out of scope. -The file is removed if this value is true and $KEEP_ALL is not. - - $fh->unlink_on_destroy( 1 ); - -Default is for the file to be removed. - -=cut - -sub unlink_on_destroy { - my $self = shift; - if (@_) { - ${*$self}{UNLINK} = shift; - } - return ${*$self}{UNLINK}; -} - -=item B<DESTROY> - -When the object goes out of scope, the destructor is called. This -destructor will attempt to unlink the file (using C<unlink1>) -if the constructor was called with UNLINK set to 1 (the default state -if UNLINK is not specified). - -No error is given if the unlink fails. - -If the object has been passed to a child process during a fork, the -file will be deleted when the object goes out of scope in the parent. - -For a temporary directory object the directory will be removed -unless the CLEANUP argument was used in the constructor (and set to -false) or C<unlink_on_destroy> was modified after creation. - -If the global variable $KEEP_ALL is true, the file or directory -will not be removed. - -=cut - -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); - } -} - -=back - -=head1 FUNCTIONS - -This section describes the recommended interface for generating -temporary files and directories. - -=over 4 - -=item B<tempfile> - -This is the basic function to generate temporary files. -The behaviour of the file can be changed using various options: - - $fh = tempfile(); - ($fh, $filename) = tempfile(); - -Create a temporary file in the directory specified for temporary -files, as specified by the tmpdir() function in L<File::Spec>. - - ($fh, $filename) = tempfile($template); - -Create a temporary file in the current directory using the supplied -template. Trailing `X' characters are replaced with random letters to -generate the filename. At least four `X' characters must be present -at the end of the template. - - ($fh, $filename) = tempfile($template, SUFFIX => $suffix) - -Same as previously, except that a suffix is added to the template -after the `X' translation. Useful for ensuring that a temporary -filename has a particular extension when needed by other applications. -But see the WARNING at the end. - - ($fh, $filename) = tempfile($template, DIR => $dir); - -Translates the template as before except that a directory name -is specified. - - ($fh, $filename) = tempfile($template, TMPDIR => 1); - -Equivalent to specifying a DIR of "File::Spec->tmpdir", writing the file -into the same temporary directory as would be used if no template was -specified at all. - - ($fh, $filename) = tempfile($template, UNLINK => 1); - -Return the filename and filehandle as before except that the file is -automatically removed when the program exits (dependent on -$KEEP_ALL). Default is for the file to be removed if a file handle is -requested and to be kept if the filename is requested. In a scalar -context (where no filename is returned) the file is always deleted -either (depending on the operating system) on exit or when it is -closed (unless $KEEP_ALL is true when the temp file is created). - -Use the object-oriented interface if fine-grained control of when -a file is removed is required. - -If the template is not specified, a template is always -automatically generated. This temporary file is placed in tmpdir() -(L<File::Spec>) unless a directory is specified explicitly with the -DIR option. - - $fh = tempfile( DIR => $dir ); - -If called in scalar context, only the filehandle is returned and the -file will automatically be deleted when closed on operating systems -that support this (see the description of tmpfile() elsewhere in this -document). 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 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); - -This will return the filename based on the template but -will not open this file. Cannot be used in conjunction with -UNLINK set to true. Default is to always open the file -to protect from possible race conditions. A warning is issued -if warnings are turned on. Consider using the tmpnam() -and mktemp() functions described elsewhere in this document -if opening the file is not required. - -If the operating system supports it (for example BSD derived systems), the -filehandle will be opened with O_EXLOCK (open with exclusive file lock). -This can sometimes cause problems if the intention is to pass the filename -to another system that expects to take an exclusive lock itself (such as -DBD::SQLite) whilst ensuring that the tempfile is not reused. In this -situation the "EXLOCK" option can be passed to tempfile. By default EXLOCK -will be true (this retains compatibility with earlier releases). - - ($fh, $filename) = tempfile($template, EXLOCK => 0); - -Options can be combined as required. - -Will croak() if there is an error. - -=cut - -sub tempfile { - - # 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 $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef); - - # Read the options and merge with defaults - %options = (%options, @_) if @_; - - # 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: $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; - } - - -} - -=item B<tempdir> - -This is the recommended interface for creation of temporary -directories. By default the directory will not be removed on exit -(that is, it won't be temporary; this behaviour can not be changed -because of issues with backwards compatibility). To enable removal -either use the CLEANUP option which will trigger removal on program -exit, or consider using the "newdir" method in the object interface which -will allow the directory to be cleaned up when the object goes out of -scope. - -The behaviour of the function depends on the arguments: - - $tempdir = tempdir(); - -Create a directory in tmpdir() (see L<File::Spec|File::Spec>). - - $tempdir = tempdir( $template ); - -Create a directory from the supplied template. This template is -similar to that described for tempfile(). `X' characters at the end -of the template are replaced with random letters to construct the -directory name. At least four `X' characters must be in the template. - - $tempdir = tempdir ( DIR => $dir ); - -Specifies the directory to use for the temporary directory. -The temporary directory name is derived from an internal template. - - $tempdir = tempdir ( $template, DIR => $dir ); - -Prepend the supplied directory name to the template. The template -should not include parent directory specifications itself. Any parent -directory specifications are removed from the template before -prepending the supplied directory. - - $tempdir = tempdir ( $template, TMPDIR => 1 ); - -Using the supplied template, create the temporary directory in -a standard location for temporary files. Equivalent to doing - - $tempdir = tempdir ( $template, DIR => File::Spec->tmpdir); - -but shorter. Parent directory specifications are stripped from the -template itself. The C<TMPDIR> option is ignored if C<DIR> is set -explicitly. Additionally, C<TMPDIR> is implied if neither a template -nor a directory are supplied. - - $tempdir = tempdir( $template, CLEANUP => 1); - -Create a temporary directory using the supplied template, but -attempt to remove it (and all files inside it) when the program -exits. Note that an attempt will be made to remove all files from -the directory even if they were not created by this module (otherwise -why ask to clean it up?). The directory removal is made with -the rmtree() function from the L<File::Path|File::Path> module. -Of course, if the template is not specified, the temporary directory -will be created in tmpdir() and will also be removed at program exit. - -Will croak() if there is an error. - -=cut - -# ' - -sub tempdir { - - # 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 $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef ); - - # Read the options and merge with defaults - %options = (%options, @_) if @_; - - # 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; - -} - -=back - -=head1 MKTEMP FUNCTIONS - -The following functions are Perl implementations of the -mktemp() family of temp file generation system calls. - -=over 4 - -=item B<mkstemp> - -Given a template, returns a filehandle to the temporary file and the name -of the file. - - ($fh, $name) = mkstemp( $template ); - -In scalar context, just the filehandle is returned. - -The template may be any filename with some number of X's appended -to it, for example F</tmp/temp.XXXX>. The trailing X's are replaced -with unique alphanumeric combinations. - -Will croak() if there is an error. - -=cut - - - -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; - } - -} - - -=item B<mkstemps> - -Similar to mkstemp(), except that an extra argument can be supplied -with a suffix to be appended to the template. - - ($fh, $name) = mkstemps( $template, $suffix ); - -For example a template of C<testXXXXXX> and suffix of C<.dat> -would generate a file similar to F<testhGji_w.dat>. - -Returns just the filehandle alone when called in scalar context. - -Will croak() if there is an error. - -=cut - -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; - } - -} - -=item B<mkdtemp> - -Create a directory from a template. The template must end in -X's that are replaced by the routine. - - $tmpdir_name = mkdtemp($template); - -Returns the name of the temporary directory created. - -Directory must be removed by the caller. - -Will croak() if there is an error. - -=cut - -#' # 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; - -} - -=item B<mktemp> - -Returns a valid temporary filename but does not guarantee -that the file will not be opened by someone else. - - $unopened_file = mktemp($template); - -Template is the same as that required by mkstemp(). - -Will croak() if there is an error. - -=cut - -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; -} - -=back - -=head1 POSIX FUNCTIONS - -This section describes the re-implementation of the tmpnam() -and tmpfile() functions described in L<POSIX> -using the mkstemp() from this module. - -Unlike the L<POSIX|POSIX> implementations, the directory used -for the temporary file is not specified in a system include -file (C<P_tmpdir>) but simply depends on the choice of tmpdir() -returned by L<File::Spec|File::Spec>. On some implementations this -location can be set using the C<TMPDIR> environment variable, which -may not be secure. -If this is a problem, simply use mkstemp() and specify a template. - -=over 4 - -=item B<tmpnam> - -When called in scalar context, returns the full name (including path) -of a temporary file (uses mktemp()). The only check is that the file does -not already exist, but there is no guarantee that that condition will -continue to apply. - - $file = tmpnam(); - -When called in list context, a filehandle to the open file and -a filename are returned. This is achieved by calling mkstemp() -after constructing a suitable template. - - ($fh, $file) = tmpnam(); - -If possible, this form should be used to prevent possible -race conditions. - -See L<File::Spec/tmpdir> for information on the choice of temporary -directory for a particular operating system. - -Will croak() if there is an error. - -=cut - -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); - } - -} - -=item B<tmpfile> - -Returns the filehandle of a temporary file. - - $fh = tmpfile(); - -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. - -Will croak() if there is an error. - -=cut - -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; - -} - -=back - -=head1 ADDITIONAL FUNCTIONS - -These functions are provided for backwards compatibility -with common tempfile generation C library functions. - -They are not exported and must be addressed using the full package -name. - -=over 4 - -=item B<tempnam> - -Return the name of a temporary file in the specified directory -using a prefix. The file is guaranteed not to exist at the time -the function was called, but such guarantees are good for one -clock tick only. Always use the proper form of C<sysopen> -with C<O_CREAT | O_EXCL> if you must open such a filename. - - $filename = File::Temp::tempnam( $dir, $prefix ); - -Equivalent to running mktemp() with $dir/$prefixXXXXXXXX -(using unix file convention as an example) - -Because this function uses mktemp(), it can suffer from race conditions. - -Will croak() if there is an error. - -=cut - -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); - -} - -=back - -=head1 UTILITY FUNCTIONS - -Useful functions for dealing with the filehandle and filename. - -=over 4 - -=item B<unlink0> - -Given an open filehandle and the associated filename, make a safe -unlink. This is achieved by first checking that the filename and -filehandle initially point to the same file and that the number of -links to the file is 1 (all fields returned by stat() are compared). -Then the filename is unlinked and the filehandle checked once again to -verify that the number of links on that file is now 0. This is the -closest you can come to making sure that the filename unlinked was the -same as the file whose descriptor you hold. - - unlink0($fh, $path) - or die "Error unlinking file $path safely"; - -Returns false on error but croaks() if there is a security -anomaly. The filehandle is not closed since on some occasions this is -not required. - -On some platforms, for example Windows NT, it is not possible to -unlink an open file (the file must be closed first). On those -platforms, the actual unlinking is deferred until the program ends and -good status is returned. A check is still performed to make sure that -the filehandle and filename are pointing to the same thing (but not at -the time the end block is executed since the deferred removal may not -have access to the filehandle). - -Additionally, on Windows NT not all the fields returned by stat() can -be compared. For example, the C<dev> and C<rdev> fields seem to be -different. Also, it seems that the size of the file returned by stat() -does not always agree, with C<stat(FH)> being more accurate than -C<stat(filename)>, presumably because of caching issues even when -using autoflush (this is usually overcome by waiting a while after -writing to the tempfile before attempting to C<unlink0> it). - -Finally, on NFS file systems the link count of the file handle does -not always go to zero immediately after unlinking. Currently, this -command is expected to fail on NFS disks. - -This function is disabled if the global variable $KEEP_ALL is true -and an unlink on open file is supported. If the unlink is to be deferred -to the END block, the file is still registered for removal. - -This function should not be called if you are using the object oriented -interface since the it will interfere with the object destructor deleting -the file. - -=cut - -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 cant know that - # we are on NFS - return ( $fh[3] == 0 or $^O eq 'cygwin' ? 1 : 0); - - } else { - _deferred_unlink($fh, $path, 0); - return 1; - } - -} - -=item B<cmpstat> - -Compare C<stat> of filehandle with C<stat> of provided filename. This -can be used to check that the filename and filehandle initially point -to the same file and that the number of links to the file is 1 (all -fields returned by stat() are compared). - - cmpstat($fh, $path) - or die "Error comparing handle with file"; - -Returns false if the stat information differs or if the link count is -greater than 1. Calls croak if there is a security anomaly. - -On certain platforms, for example Windows, not all the fields returned by stat() -can be compared. For example, the C<dev> and C<rdev> fields seem to be -different in Windows. Also, it seems that the size of the file -returned by stat() does not always agree, with C<stat(FH)> being more -accurate than C<stat(filename)>, presumably because of caching issues -even when using autoflush (this is usually overcome by waiting a while -after writing to the tempfile before attempting to C<unlink0> it). - -Not exported by default. - -=cut - -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; -} - -=item B<unlink1> - -Similar to C<unlink0> except after file comparison using cmpstat, the -filehandle is closed prior to attempting to unlink the file. This -allows the file to be removed without using an END block, but does -mean that the post-unlink comparison of the filehandle state provided -by C<unlink0> is not available. - - unlink1($fh, $path) - or die "Error closing and unlinking file"; - -Usually called from the object destructor when using the OO interface. - -Not exported by default. - -This function is disabled if the global variable $KEEP_ALL is true. - -Can call croak() if there is a security anomaly during the stat() -comparison. - -=cut - -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); -} - -=item B<cleanup> - -Calling this function will cause any temp files or temp directories -that are registered for removal to be removed. This happens automatically -when the process exits but can be triggered manually if the caller is sure -that none of the temp files are required. This method can be registered as -an Apache callback. - -On OSes where temp files are automatically removed when the temp file -is closed, calling this function will have no effect other than to remove -temporary directories (which may include temporary files). - - File::Temp::cleanup(); - -Not exported by default. - -=back - -=head1 PACKAGE VARIABLES - -These functions control the global state of the package. - -=over 4 - -=item B<safe_level> - -Controls the lengths to which the module will go to check the safety of the -temporary file or directory before proceeding. -Options are: - -=over 8 - -=item STANDARD - -Do the basic security measures to ensure the directory exists and is -writable, that temporary files are opened only if they do not already -exist, and that possible race conditions are avoided. Finally the -L<unlink0|"unlink0"> function is used to remove files safely. - -=item MEDIUM - -In addition to the STANDARD security, the output directory is checked -to make sure that it is owned either by root or the user running the -program. If the directory is writable by group or by other, it is then -checked to make sure that the sticky bit is set. - -Will not work on platforms that do not support the C<-k> test -for sticky bit. - -=item HIGH - -In addition to the MEDIUM security checks, also check for the -possibility of ``chown() giveaway'' using the L<POSIX|POSIX> -sysconf() function. If this is a possibility, each directory in the -path is checked in turn for safeness, recursively walking back to the -root directory. - -For platforms that do not support the L<POSIX|POSIX> -C<_PC_CHOWN_RESTRICTED> symbol (for example, Windows NT) it is -assumed that ``chown() giveaway'' is possible and the recursive test -is performed. - -=back - -The level can be changed as follows: - - File::Temp->safe_level( File::Temp::HIGH ); - -The level constants are not exported by the module. - -Currently, you must be running at least perl v5.6.0 in order to -run with MEDIUM or HIGH security. This is simply because the -safety tests use functions from L<Fcntl|Fcntl> that are not -available in older versions of perl. The problem is that the version -number for Fcntl is the same in perl 5.6.0 and in 5.005_03 even though -they are different versions. - -On systems that do not support the HIGH or MEDIUM safety levels -(for example Win NT or OS/2) any attempt to change the level will -be ignored. The decision to ignore rather than raise an exception -allows portable programs to be written with high security in mind -for the systems that can support this without those programs failing -on systems where the extra tests are irrelevant. - -If you really need to see whether the change has been accepted -simply examine the return value of C<safe_level>. - - $newlevel = File::Temp->safe_level( File::Temp::HIGH ); - die "Could not change to high security" - if $newlevel != File::Temp::HIGH; - -=cut - -{ - # 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 { - # Dont 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; - } -} - -=item TopSystemUID - -This is the highest UID on the current system that refers to a root -UID. This is used to make sure that the temporary directory is -owned by a system UID (C<root>, C<bin>, C<sys> etc) rather than -simply by root. - -This is required since on many unix systems C</tmp> is not owned -by root. - -Default is to assume that any UID less than or equal to 10 is a root -UID. - - File::Temp->top_system_uid(10); - my $topid = File::Temp->top_system_uid; - -This value can be adjusted to reduce security checking if required. -The value is only relevant when C<safe_level> is set to MEDIUM or higher. - -=cut - -{ - 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; - } -} - -=item B<$KEEP_ALL> - -Controls whether temporary files and directories should be retained -regardless of any instructions in the program to remove them -automatically. This is useful for debugging but should not be used in -production code. - - $File::Temp::KEEP_ALL = 1; - -Default is for files to be removed as requested by the caller. - -In some cases, files will only be retained if this variable is true -when the file is created. This means that you can not create a temporary -file, set this variable and expect the temp file to still be around -when the program exits. - -=item B<$DEBUG> - -Controls whether debugging messages should be enabled. - - $File::Temp::DEBUG = 1; - -Default is for debugging mode to be disabled. - -=back - -=head1 WARNING - -For maximum security, endeavour always to avoid ever looking at, -touching, or even imputing the existence of the filename. You do not -know that that filename is connected to the same file as the handle -you have, and attempts to check this can only trigger more race -conditions. It's far more secure to use the filehandle alone and -dispense with the filename altogether. - -If you need to pass the handle to something that expects a filename -then, on a unix system, use C<"/dev/fd/" . fileno($fh)> for arbitrary -programs, or more generally C<< "+<=&" . fileno($fh) >> for Perl -programs. You will have to clear the close-on-exec bit on that file -descriptor before passing it to another process. - - use Fcntl qw/F_SETFD F_GETFD/; - 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. - -=head2 Forking - -In some cases files created by File::Temp are removed from within an -END block. Since END blocks are triggered when a child process exits -(unless C<POSIX::_exit()> is used by the child) File::Temp takes care -to only remove those temp files created by a particular process ID. This -means that a child will not attempt to remove temp files created by the -parent process. - -If you are forking many processes in parallel that are all creating -temporary files, you may need to reset the random number seed using -srand(EXPR) in each child else all the children will attempt to walk -through the same set of random file names and may well cause -themselves to give up if they exceed the number of retry attempts. - -=head2 Directory removal - -Note that if you have chdir'ed into the temporary directory and it is -subsequently cleaned up (either in the END block or as part of object -destruction), then you will get a warning from File::Path::rmtree(). - -=head2 BINMODE - -The file returned by File::Temp will have been opened in binary mode -if such a mode is available. If that is not correct, use the C<binmode()> -function to change the mode of the filehandle. - -Note that you can modify the encoding of a file opened by File::Temp -also by using C<binmode()>. - -=head1 HISTORY - -Originally began life in May 1999 as an XS interface to the system -mkstemp() function. In March 2000, the OpenBSD mkstemp() code was -translated to Perl for total control of the code's -security checking, to ensure the presence of the function regardless of -operating system and to help with portability. The module was shipped -as a standard part of perl from v5.6.1. - -=head1 SEE ALSO - -L<POSIX/tmpnam>, L<POSIX/tmpfile>, L<File::Spec>, L<File::Path> - -See L<IO::File> and L<File::MkTemp>, L<Apache::TempFile> for -different implementations of temporary file handling. - -See L<File::Tempdir> for an alternative object-oriented wrapper for -the C<tempdir> function. - -=head1 AUTHOR - -Tim Jenness E<lt>tjenness@cpan.orgE<gt> - -Copyright (C) 2007-2009 Tim Jenness. -Copyright (C) 1999-2007 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. - -Original Perl implementation loosely based on the OpenBSD C code for -mkstemp(). Thanks to Tom Christiansen for suggesting that this module -should be written and providing ideas for code improvements and -security enhancements. - -=cut - -package File::Temp::Dir; - -use File::Path qw/ rmtree /; -use strict; -use overload '""' => "STRINGIFY", 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->{DIRNAME}) { - # 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->{DIRNAME}, $File::Temp::DEBUG, 0); }; - warn $@ if ($@ && $^W); - } - } -} - - -1; diff --git a/ext/File-Temp/t/cmp.t b/ext/File-Temp/t/cmp.t deleted file mode 100644 index db94e44ccc..0000000000 --- a/ext/File-Temp/t/cmp.t +++ /dev/null @@ -1,11 +0,0 @@ -#!perl -w -# Test overloading - -use Test::More tests => 3; -use strict; - -BEGIN {use_ok( "File::Temp" ); } - -my $fh = new File::Temp(); -ok( "$fh" ne "foo", "compare stringified object with string"); -ok( $fh ne "foo", "compare object with string");
\ No newline at end of file diff --git a/ext/File-Temp/t/fork.t b/ext/File-Temp/t/fork.t deleted file mode 100644 index fd3f5a6f3c..0000000000 --- a/ext/File-Temp/t/fork.t +++ /dev/null @@ -1,103 +0,0 @@ -#!/usr/bin/perl -$| = 1; - -# Note that because fork loses test count we do not use Test::More - -use strict; - -BEGIN { - require Config; - my $can_fork = $Config::Config{d_fork} || - (($^O eq 'MSWin32' || $^O eq 'NetWare') and - $Config::Config{useithreads} and - $Config::Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/ - ); - if ( $can_fork ) { - print "1..8\n"; - } else { - print "1..0 # Skip No fork available\n"; - exit; - } -} - -use File::Temp; - -# OO interface - -my $file = File::Temp->new(); - -myok( 1, -f $file->filename, "OO File exists" ); - -my $children = 2; -for my $i (1 .. $children) { - my $pid = fork; - die "Can't fork: $!" unless defined $pid; - if ($pid) { - # parent process - next; - } else { - # in a child we can't keep the count properly so we do it manually - # make sure that child 1 dies first - srand(); - my $time = (($i-1) * 5) +int(rand(5)); - print "# child $i sleeping for $time seconds\n"; - sleep($time); - my $count = $i + 1; - myok( $count, -f $file->filename(), "OO file present in child $i" ); - print "# child $i exiting\n"; - exit; - } -} - -while ($children) { - wait; - $children--; -} - - - -myok( 4, -f $file->filename(), "OO File exists in parent" ); - -# non-OO interface - -my ($fh, $filename) = File::Temp::tempfile( UNLINK => 1 ); - -myok( 5, -f $filename, "non-OO File exists" ); - -$children = 2; -for my $i (1 .. $children) { - my $pid = fork; - die "Can't fork: $!" unless defined $pid; - if ($pid) { - # parent process - next; - } else { - srand(); - my $time = (($i-1) * 5) +int(rand(5)); - print "# child $i sleeping for $time seconds\n"; - sleep($time); - my $count = 5 + $i; - myok( $count, -f $filename, "non-OO File present in child $i" ); - print "# child $i exiting\n"; - exit; - } -} - -while ($children) { - wait; - $children--; -} -myok(8, -f $filename, "non-OO File exists in parent" ); - - -# Local ok sub handles explicit number -sub myok { - my ($count, $test, $msg) = @_; - - if ($test) { - print "ok $count - $msg\n"; - } else { - print "not ok $count - $msg\n"; - } - return $test; -} diff --git a/ext/File-Temp/t/lock.t b/ext/File-Temp/t/lock.t deleted file mode 100644 index ff8c7f954d..0000000000 --- a/ext/File-Temp/t/lock.t +++ /dev/null @@ -1,60 +0,0 @@ -#!perl -w -# Test O_EXLOCK - -use Test::More; -use strict; -use Fcntl; - -BEGIN { -# see if we have O_EXLOCK - eval { &Fcntl::O_EXLOCK; }; - if ($@) { - plan skip_all => 'Do not seem to have O_EXLOCK'; - } else { - plan tests => 4; - use_ok( "File::Temp" ); - } -} - -# Need Symbol package for lexical filehandle on older perls -require Symbol if $] < 5.006; - -# Get a tempfile with O_EXLOCK -my $fh = new File::Temp(); -ok( -e "$fh", "temp file is present" ); - -# try to open it with a lock -my $flags = O_CREAT | O_RDWR | O_EXLOCK; - -my $timeout = 5; -my $status; -eval { - local $SIG{ALRM} = sub { die "alarm\n" }; # NB: \n required - alarm $timeout; - my $newfh; - $newfh = &Symbol::gensym if $] < 5.006; - $status = sysopen($newfh, "$fh", $flags, 0600); - alarm 0; -}; -if ($@) { - die unless $@ eq "alarm\n"; # propagate unexpected errors - # timed out -} -ok( !$status, "File $fh is locked" ); - -# Now get a tempfile with locking disabled -$fh = new File::Temp( EXLOCK => 0 ); - -eval { - local $SIG{ALRM} = sub { die "alarm\n" }; # NB: \n required - alarm $timeout; - my $newfh; - $newfh = &Symbol::gensym if $] < 5.006; - $status = sysopen($newfh, "$fh", $flags, 0600); - alarm 0; -}; -if ($@) { - die unless $@ eq "alarm\n"; # propagate unexpected errors - # timed out -} -ok( $status, "File $fh is not locked"); diff --git a/ext/File-Temp/t/mktemp.t b/ext/File-Temp/t/mktemp.t deleted file mode 100644 index 2014e30717..0000000000 --- a/ext/File-Temp/t/mktemp.t +++ /dev/null @@ -1,110 +0,0 @@ -#!/usr/local/bin/perl -w - -# Test for mktemp family of commands in File::Temp -# Use STANDARD safe level for these tests - -use strict; -use Test; -BEGIN { plan tests => 9 } - -use File::Spec; -use File::Path; -use File::Temp qw/ :mktemp unlink0 /; -use FileHandle; - -ok(1); - -# MKSTEMP - test - -# Create file in temp directory -my $template = File::Spec->catfile(File::Spec->tmpdir, 'wowserXXXX'); - -(my $fh, $template) = mkstemp($template); - -print "# MKSTEMP: FH is $fh File is $template fileno=".fileno($fh)."\n"; -# Check if the file exists -ok( (-e $template) ); - -# Autoflush -$fh->autoflush(1) if $] >= 5.006; - -# Try printing something to the file -my $string = "woohoo\n"; -print $fh $string; - -# rewind the file -ok(seek( $fh, 0, 0)); - -# Read from the file -my $line = <$fh>; - -# compare with previous string -ok($string, $line); - -# Tidy up -# This test fails on Windows NT since it seems that the size returned by -# stat(filehandle) does not always equal the size of the stat(filename) -# This must be due to caching. In particular this test writes 7 bytes -# to the file which are not recognised by stat(filename) -# Simply waiting 3 seconds seems to be enough for the system to update - -if ($^O eq 'MSWin32') { - sleep 3; -} -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 so -# may be problematic on NFS - -$template = "suffixXXXXXX"; -my $suffix = ".dat"; - -($fh, my $fname) = mkstemps($template, $suffix); - -print "# MKSTEMPS: File is $template -> $fname fileno=".fileno($fh)."\n"; -# Check if the file exists -ok( (-e $fname) ); - -# This fails if you are running on NFS -# If this test fails simply skip it rather than doing a hard failure -$status = unlink0($fh, $fname); - -if ($status) { - ok($status); -} else { - skip("Skip test failed probably due to cwd being on NFS",1) -} - -# MKDTEMP -# Temp directory - -$template = File::Spec->catdir(File::Spec->tmpdir, 'tmpdirXXXXXX'); - -my $tmpdir = mkdtemp($template); - -print "# MKDTEMP: Name is $tmpdir from template $template\n"; - -ok( (-d $tmpdir ) ); - -# Need to tidy up after myself -rmtree($tmpdir); - -# MKTEMP -# Just a filename, not opened - -$template = File::Spec->catfile(File::Spec->tmpdir, 'mytestXXXXXX'); - -my $tmpfile = mktemp($template); - -print "# MKTEMP: Tempfile is $template -> $tmpfile\n"; - -# Okay if template no longer has XXXXX in - - -ok( ($tmpfile !~ /XXXXX$/) ); diff --git a/ext/File-Temp/t/object.t b/ext/File-Temp/t/object.t deleted file mode 100644 index 8cf37858cc..0000000000 --- a/ext/File-Temp/t/object.t +++ /dev/null @@ -1,138 +0,0 @@ -#!/usr/local/bin/perl -w -# Test for File::Temp - OO interface - -use strict; -use Test::More tests => 30; -use File::Spec; - -# Will need to check that all files were unlinked correctly -# Set up an END block here to do it - -# Arrays containing list of dirs/files to test -my (@files, @dirs, @still_there); - -# And a test for files that should still be around -# These are tidied up -END { - foreach (@still_there) { - ok( -f $_, "Check $_ exists" ); - ok( unlink( $_ ), "Unlinked $_" ); - ok( !(-f $_), "$_ no longer there"); - } -} - -# Loop over an array hoping that the files dont exist -END { foreach (@files) { ok( !(-e $_), "File $_ should not be there" )} } - -# And a test for directories -END { foreach (@dirs) { ok( !(-d $_), "Directory $_ should not be there" ) } } - -# Need to make sure that the END blocks are setup before -# the ones that File::Temp configures since END blocks are evaluated -# in reverse order and we need to check the files *after* File::Temp -# removes them -BEGIN {use_ok( "File::Temp" ); } - -# Tempfile -# Open tempfile in some directory, unlink at end -my $fh = new File::Temp( SUFFIX => '.txt' ); - -ok( (-f "$fh"), "File $fh exists" ); -# Should still be around after closing -ok( close( $fh ), "Close file $fh" ); -ok( (-f "$fh"), "File $fh still exists after close" ); -# Check again at exit -push(@files, "$fh"); - -# OO tempdir -my $tdir = File::Temp->newdir(); -my $dirname = "$tdir"; # Stringify overload -ok( -d $dirname, "Directory $tdir exists"); -undef $tdir; -ok( !-d $dirname, "Directory should now be gone"); - -# Quick basic tempfile test -my $qfh = File::Temp->new(); -my $qfname = "$qfh"; -ok (-f $qfname, "temp file exists"); -undef $qfh; -ok( !-f $qfname, "temp file now gone"); - - -# TEMPDIR test as somewhere to put the temp files -# Create temp directory in current dir -my $template = 'tmpdirXXXXXX'; -print "# Template: $template\n"; -my $tempdir = File::Temp::tempdir( $template , - DIR => File::Spec->curdir, - CLEANUP => 1, - ); - -print "# TEMPDIR: $tempdir\n"; - -ok( (-d $tempdir), "Does $tempdir directory exist" ); -push(@dirs, $tempdir); - -# Create file in the temp dir -$fh = new File::Temp( - DIR => $tempdir, - SUFFIX => '.dat', - ); - -ok( $fh->unlink_on_destroy, "should unlink"); -print "# TEMPFILE: Created $fh\n"; - -ok( (-f "$fh"), "File $fh exists in tempdir?"); -push(@files, "$fh"); - -# Test tempfile -# ..and again (without unlinking it) -$fh = new File::Temp( DIR => $tempdir, UNLINK => 0 ); - -print "# TEMPFILE: Created $fh\n"; -ok( (-f "$fh" ), "Second file $fh exists in tempdir [nounlink]?"); -push(@files, "$fh"); - -# and another (with template) - -$fh = new File::Temp( TEMPLATE => 'helloXXXXXXX', - DIR => $tempdir, - SUFFIX => '.dat', - ); - -print "# TEMPFILE: Created $fh\n"; - -ok( (-f "$fh"), "File $fh exists? [from template]" ); -push(@files, "$fh"); - - -# Create a temporary file that should stay around after -# it has been closed -$fh = new File::Temp( TEMPLATE => 'permXXXXXXX', UNLINK => 0); - -print "# TEMPFILE: Created $fh\n"; -ok( -f "$fh", "File $fh exists?" ); -ok( close( $fh ), "Close file $fh" ); -ok( ! $fh->unlink_on_destroy, "should not unlink"); -push( @still_there, "$fh"); # check at END - -# Now create a temp file that will remain when the object -# goes out of scope because of $KEEP_ALL -$fh = new File::Temp( TEMPLATE => 'permXXXXXXX', UNLINK => 1); - -print "# TEMPFILE: Created $fh\n"; -ok( -f "$fh", "File $fh exists?" ); -ok( close( $fh ), "Close file $fh" ); -ok( $fh->unlink_on_destroy, "should unlink (in principal)"); -push( @still_there, "$fh"); # check at END -$File::Temp::KEEP_ALL = 1; - -# Make sure destructors run -undef $fh; - -# allow end blocks to run -$File::Temp::KEEP_ALL = 0; - -# Now END block will execute to test the removal of directories -print "# End of tests. Execute END blocks\n"; - diff --git a/ext/File-Temp/t/posix.t b/ext/File-Temp/t/posix.t deleted file mode 100644 index b63fb29140..0000000000 --- a/ext/File-Temp/t/posix.t +++ /dev/null @@ -1,77 +0,0 @@ -#!/usr/local/bin/perl -w -# Test for File::Temp - POSIX functions - -use strict; -use Test; -BEGIN { plan tests => 7} - -use File::Temp qw/ :POSIX unlink0 /; -use FileHandle; -ok(1); - -# TMPNAM - scalar - -print "# TMPNAM: in a scalar context: \n"; -my $tmpnam = tmpnam(); - -# simply check that the file does not exist -# Not a 100% water tight test though if another program -# has managed to create one in the meantime. -ok( !(-e $tmpnam )); - -print "# TMPNAM file name: $tmpnam\n"; - -# TMPNAM list context -# Not strict posix behaviour -(my $fh, $tmpnam) = tmpnam(); - -print "# TMPNAM: in list context: $fh $tmpnam\n"; - -# File is opened - make sure it exists -ok( (-e $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(); - -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"; - - # rewind it - ok( seek($fh,0,0) ); - - # Read from it - my $line = <$fh>; - - 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); - } -} - - - - diff --git a/ext/File-Temp/t/security.t b/ext/File-Temp/t/security.t deleted file mode 100644 index 736854f054..0000000000 --- a/ext/File-Temp/t/security.t +++ /dev/null @@ -1,140 +0,0 @@ -#!/usr/bin/perl -w -# Test for File::Temp - Security levels - -# Some of the security checking will not work on all platforms -# Test a simple open in the cwd and tmpdir foreach of the -# security levels - -use Test; -BEGIN { plan tests => 13 } - -use strict; -use File::Spec; - -# Set up END block - this needs to happen before we load -# File::Temp since this END block must be evaluated after the -# END block configured by File::Temp -my @files; # list of files to remove -END { foreach (@files) { ok( !(-e $_) )} } - -use File::Temp qw/ tempfile unlink0 /; -ok(1); - -# The high security tests must currently be skipped on some platforms -my $skipplat = ( ( - # No sticky bits. - $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'os2' || $^O eq 'dos' || $^O eq 'mpeix' || $^O eq 'MacOS' - ) ? 1 : 0 ); - -# Can not run high security tests in perls before 5.6.0 -my $skipperl = ($] < 5.006 ? 1 : 0 ); - -# Determine whether we need to skip things and why -my $skip = 0; -if ($skipplat) { - $skip = "Skip Not supported on this platform"; -} elsif ($skipperl) { - $skip = "Skip Perl version must be v5.6.0 for these tests"; - -} - -print "# We will be skipping some tests : $skip\n" if $skip; - -# start off with basic checking - -File::Temp->safe_level( File::Temp::STANDARD ); - -print "# Testing with STANDARD security...\n"; - -&test_security(0); - -# Try medium - -File::Temp->safe_level( File::Temp::MEDIUM ) - unless $skip; - -print "# Testing with MEDIUM security...\n"; - -# Now we need to start skipping tests -&test_security($skip); - -# Try HIGH - -File::Temp->safe_level( File::Temp::HIGH ) - unless $skip; - -print "# Testing with HIGH security...\n"; - -&test_security($skip); - -exit; - -# Subroutine to open two temporary files. -# one is opened in the current dir and the other in the temp dir - -sub test_security { - - # Read in the skip flag - my $skip = shift; - - # If we are skipping we need to simply fake the correct number - # of tests -- we dont use skip since the tempfile() commands will - # fail with MEDIUM/HIGH security before the skip() command would be run - if ($skip) { - - skip($skip,1); - skip($skip,1); - - # plus we need an end block so the tests come out in the right order - eval q{ END { skip($skip,1); skip($skip,1) } 1; } || die; - - return; - } - - # Create the tempfile - my $template = "tmpXXXXX"; - my ($fh1, $fname1) = eval { tempfile ( $template, - DIR => File::Spec->tmpdir, - UNLINK => 1, - ); - }; - - if (defined $fname1) { - print "# fname1 = $fname1\n"; - ok( (-e $fname1) ); - push(@files, $fname1); # store for end block - } elsif (File::Temp->safe_level() != File::Temp::STANDARD) { - chomp($@); - my $skip2 = "Skip: " . File::Spec->tmpdir() . " possibly insecure: $@. " . - "See INSTALL under 'make test'"; - skip($skip2, 1); - # plus we need an end block so the tests come out in the right order - eval q{ END { skip($skip2,1); } 1; } || die; - } else { - ok(0); - } - - # Explicitly - if ( $< < File::Temp->top_system_uid() ){ - skip("Skip Test inappropriate for root", 1); - eval q{ END { skip($skip,1); } 1; } || die; - return; - } - my ($fh2, $fname2) = eval { tempfile ($template, UNLINK => 1 ); }; - if (defined $fname2) { - print "# fname2 = $fname2\n"; - ok( (-e $fname2) ); - push(@files, $fname2); # store for end block - close($fh2); - } elsif (File::Temp->safe_level() != File::Temp::STANDARD) { - chomp($@); - my $skip2 = "Skip: current directory possibly insecure: $@. " . - "See INSTALL under 'make test'"; - skip($skip2, 1); - # plus we need an end block so the tests come out in the right order - eval q{ END { skip($skip2,1); } 1; } || die; - } else { - ok(0); - } - -} diff --git a/ext/File-Temp/t/seekable.t b/ext/File-Temp/t/seekable.t deleted file mode 100644 index 5f07beb171..0000000000 --- a/ext/File-Temp/t/seekable.t +++ /dev/null @@ -1,43 +0,0 @@ -# -*- perl -*- -# Before `make install' is performed this script should be runnable with -# `make test'. After `make install' it should work as `perl File-Temp.t' - -######################### - -# change 'tests => 1' to 'tests => last_test_to_print'; - -use Test::More tests => 10; -BEGIN { use_ok('File::Temp') }; - -######################### - -# Insert your test code below, the Test::More module is use()ed here so read -# its man page ( perldoc Test::More ) for help writing this test script. - -# make sure we can create a tmp file... -$tmp = File::Temp->new; -isa_ok( $tmp, 'File::Temp' ); -isa_ok( $tmp, 'IO::Handle' ); -SKIP: { - skip "->isa is broken on 5.6.0", 1 if $] == 5.006000; - isa_ok( $tmp, 'IO::Seekable' ); -} - -# make sure the seek method is available... -# Note that we need a reasonably modern IO::Seekable -SKIP: { - skip "IO::Seekable is too old", 1 if IO::Seekable->VERSION <= 1.06; - ok( File::Temp->can('seek'), 'tmp can seek' ); -} - -# make sure IO::Handle methods are still there... -ok( File::Temp->can('print'), 'tmp can print' ); - -# let's see what we're exporting... -$c = scalar @File::Temp::EXPORT; -$l = join ' ', @File::Temp::EXPORT; -ok( $c == 9, "really exporting $c: $l" ); - -ok(defined eval { SEEK_SET() }, 'SEEK_SET defined by File::Temp') or diag $@; -ok(defined eval { SEEK_END() }, 'SEEK_END defined by File::Temp') or diag $@; -ok(defined eval { SEEK_CUR() }, 'SEEK_CUR defined by File::Temp') or diag $@; diff --git a/ext/File-Temp/t/tempfile.t b/ext/File-Temp/t/tempfile.t deleted file mode 100644 index 7021645704..0000000000 --- a/ext/File-Temp/t/tempfile.t +++ /dev/null @@ -1,150 +0,0 @@ -#!/usr/local/bin/perl -w -# Test for File::Temp - tempfile function - -use strict; -use Test; -BEGIN { plan tests => 22} -use File::Spec; - -# Will need to check that all files were unlinked correctly -# Set up an END block here to do it - -# Arrays containing list of dirs/files to test -my (@files, @dirs, @still_there); - -# And a test for files that should still be around -# These are tidied up -END { - foreach (@still_there) { - ok( -f $_ ); - ok( unlink( $_ ) ); - ok( !(-f $_) ); - } -} - -# Loop over an array hoping that the files dont exist -END { foreach (@files) { ok( !(-e $_) )} } - -# And a test for directories -END { foreach (@dirs) { ok( !(-d $_) )} } - -# Need to make sure that the END blocks are setup before -# the ones that File::Temp configures since END blocks are evaluated -# in revers order and we need to check the files *after* File::Temp -# removes them -use File::Temp qw/ tempfile tempdir/; - -# Now we start the tests properly -ok(1); - - -# Tempfile -# Open tempfile in some directory, unlink at end -my ($fh, $tempfile) = tempfile( - UNLINK => 1, - SUFFIX => '.txt', - ); - -ok( (-f $tempfile) ); -# Should still be around after closing -ok( close( $fh ) ); -ok( (-f $tempfile) ); -# Check again at exit -push(@files, $tempfile); - -# TEMPDIR test -# Create temp directory in current dir -my $template = 'tmpdirXXXXXX'; -print "# Template: $template\n"; -my $tempdir = tempdir( $template , - DIR => File::Spec->curdir, - CLEANUP => 1, - ); - -print "# TEMPDIR: $tempdir\n"; - -ok( (-d $tempdir) ); -push(@dirs, $tempdir); - -# Create file in the temp dir -($fh, $tempfile) = tempfile( - DIR => $tempdir, - UNLINK => 1, - SUFFIX => '.dat', - ); - -print "# TEMPFILE: Created $tempfile\n"; - -ok( (-f $tempfile)); -push(@files, $tempfile); - -# Test tempfile -# ..and again -($fh, $tempfile) = tempfile( - DIR => $tempdir, - ); - - -ok( (-f $tempfile )); -push(@files, $tempfile); - -# Test tempfile -# ..and another with changed permissions (read-only) -($fh, $tempfile) = tempfile( - DIR => $tempdir, - ); -chmod 0444, $tempfile; - -ok( (-f $tempfile )); -push(@files, $tempfile); - -print "# TEMPFILE: Created $tempfile\n"; - -# and another (with template) - -($fh, $tempfile) = tempfile( 'helloXXXXXXX', - DIR => $tempdir, - UNLINK => 1, - SUFFIX => '.dat', - ); - -print "# TEMPFILE: Created $tempfile\n"; - -ok( (-f $tempfile) ); -push(@files, $tempfile); - - -# Create a temporary file that should stay around after -# it has been closed -($fh, $tempfile) = tempfile( 'permXXXXXXX', UNLINK => 0 ); -print "# TEMPFILE: Created $tempfile\n"; -ok( -f $tempfile ); -ok( close( $fh ) ); -push( @still_there, $tempfile); # check at END - -# Would like to create a temp file and just retrieve the handle -# but the test is problematic since: -# - We dont know the filename so we cant check that it is tidied -# correctly -# - The unlink0 required on unix for tempfile creation will fail -# on NFS -# Try to do what we can. -# Tempfile croaks on error so we need an eval -$fh = eval { tempfile( 'ftmpXXXXX', DIR => File::Spec->tmpdir ) }; - -if ($fh) { - - # print something to it to make sure something is there - ok( print $fh "Test\n" ); - - # Close it - can not check it is gone since we dont know the name - ok( close($fh) ); - -} else { - skip "Skip Failed probably due to NFS", 1; - skip "Skip Failed probably due to NFS", 1; -} - -# Now END block will execute to test the removal of directories -print "# End of tests. Execute END blocks\n"; - |