Merge branch 'master' of http://repo.or.cz/r/msysgit into devel
[msysgit/historical-msysgit.git] / lib / perl5 / 5.6.1 / File / Temp.pm
blobacbc1b4fe1363091d7770cf78f1512a907c243ce
1 package File::Temp;
3 =head1 NAME
5 File::Temp - return name and handle of a temporary file safely
7 =begin __INTERNALS
9 =head1 PORTABILITY
11 This module is designed to be portable across operating systems
12 and it currently supports Unix, VMS, DOS, OS/2 and Windows. When
13 porting to a new OS there are generally three main issues
14 that have to be solved:
16 =over 4
18 =item *
20 Can the OS unlink an open file? If it can not then the
21 C<_can_unlink_opened_file> method should be modified.
23 =item *
25 Are the return values from C<stat> reliable? By default all the
26 return values from C<stat> are compared when unlinking a temporary
27 file using the filename and the handle. Operating systems other than
28 unix do not always have valid entries in all fields. If C<unlink0> fails
29 then the C<stat> comparison should be modified accordingly.
31 =item *
33 Security. Systems that can not support a test for the sticky bit
34 on a directory can not use the MEDIUM and HIGH security tests.
35 The C<_can_do_level> method should be modified accordingly.
37 =back
39 =end __INTERNALS
41 =head1 SYNOPSIS
43 use File::Temp qw/ tempfile tempdir /;
45 $dir = tempdir( CLEANUP => 1 );
46 ($fh, $filename) = tempfile( DIR => $dir );
48 ($fh, $filename) = tempfile( $template, DIR => $dir);
49 ($fh, $filename) = tempfile( $template, SUFFIX => '.dat');
51 $fh = tempfile();
53 MkTemp family:
55 use File::Temp qw/ :mktemp /;
57 ($fh, $file) = mkstemp( "tmpfileXXXXX" );
58 ($fh, $file) = mkstemps( "tmpfileXXXXXX", $suffix);
60 $tmpdir = mkdtemp( $template );
62 $unopened_file = mktemp( $template );
64 POSIX functions:
66 use File::Temp qw/ :POSIX /;
68 $file = tmpnam();
69 $fh = tmpfile();
71 ($fh, $file) = tmpnam();
72 ($fh, $file) = tmpfile();
75 Compatibility functions:
77 $unopened_file = File::Temp::tempnam( $dir, $pfx );
79 =begin later
81 Objects (NOT YET IMPLEMENTED):
83 require File::Temp;
85 $fh = new File::Temp($template);
86 $fname = $fh->filename;
88 =end later
90 =head1 DESCRIPTION
92 C<File::Temp> can be used to create and open temporary files in a safe way.
93 The tempfile() function can be used to return the name and the open
94 filehandle of a temporary file. The tempdir() function can
95 be used to create a temporary directory.
97 The security aspect of temporary file creation is emphasized such that
98 a filehandle and filename are returned together. This helps guarantee
99 that a race condition can not occur where the temporary file is
100 created by another process between checking for the existence of the
101 file and its opening. Additional security levels are provided to
102 check, for example, that the sticky bit is set on world writable
103 directories. See L<"safe_level"> for more information.
105 For compatibility with popular C library functions, Perl implementations of
106 the mkstemp() family of functions are provided. These are, mkstemp(),
107 mkstemps(), mkdtemp() and mktemp().
109 Additionally, implementations of the standard L<POSIX|POSIX>
110 tmpnam() and tmpfile() functions are provided if required.
112 Implementations of mktemp(), tmpnam(), and tempnam() are provided,
113 but should be used with caution since they return only a filename
114 that was valid when function was called, so cannot guarantee
115 that the file will not exist by the time the caller opens the filename.
117 =cut
119 # 5.6.0 gives us S_IWOTH, S_IWGRP, our and auto-vivifying filehandls
120 # People would like a version on 5.005 so give them what they want :-)
121 use 5.005;
122 use strict;
123 use Carp;
124 use File::Spec 0.8;
125 use File::Path qw/ rmtree /;
126 use Fcntl 1.03;
127 use Errno;
128 require VMS::Stdio if $^O eq 'VMS';
130 # Need the Symbol package if we are running older perl
131 require Symbol if $] < 5.006;
134 # use 'our' on v5.6.0
135 use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS $DEBUG);
137 $DEBUG = 0;
139 # We are exporting functions
141 use base qw/Exporter/;
143 # Export list - to allow fine tuning of export table
145 @EXPORT_OK = qw{
146 tempfile
147 tempdir
148 tmpnam
149 tmpfile
150 mktemp
151 mkstemp
152 mkstemps
153 mkdtemp
154 unlink0
157 # Groups of functions for export
159 %EXPORT_TAGS = (
160 'POSIX' => [qw/ tmpnam tmpfile /],
161 'mktemp' => [qw/ mktemp mkstemp mkstemps mkdtemp/],
164 # add contents of these tags to @EXPORT
165 Exporter::export_tags('POSIX','mktemp');
167 # Version number
169 $VERSION = '0.12';
171 # This is a list of characters that can be used in random filenames
173 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
174 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
175 0 1 2 3 4 5 6 7 8 9 _
178 # Maximum number of tries to make a temp file before failing
180 use constant MAX_TRIES => 10;
182 # Minimum number of X characters that should be in a template
183 use constant MINX => 4;
185 # Default template when no template supplied
187 use constant TEMPXXX => 'X' x 10;
189 # Constants for the security level
191 use constant STANDARD => 0;
192 use constant MEDIUM => 1;
193 use constant HIGH => 2;
195 # OPENFLAGS. If we defined the flag to use with Sysopen here this gives
196 # us an optimisation when many temporary files are requested
198 my $OPENFLAGS = O_CREAT | O_EXCL | O_RDWR;
200 for my $oflag (qw/ FOLLOW BINARY LARGEFILE EXLOCK NOINHERIT /) {
201 my ($bit, $func) = (0, "Fcntl::O_" . $oflag);
202 no strict 'refs';
203 $OPENFLAGS |= $bit if eval {
204 # Make sure that redefined die handlers do not cause problems
205 # eg CGI::Carp
206 local $SIG{__DIE__} = sub {};
207 local $SIG{__WARN__} = sub {};
208 $bit = &$func();
213 # On some systems the O_TEMPORARY flag can be used to tell the OS
214 # to automatically remove the file when it is closed. This is fine
215 # in most cases but not if tempfile is called with UNLINK=>0 and
216 # the filename is requested -- in the case where the filename is to
217 # be passed to another routine. This happens on windows. We overcome
218 # this by using a second open flags variable
220 my $OPENTEMPFLAGS = $OPENFLAGS;
221 for my $oflag (qw/ TEMPORARY /) {
222 my ($bit, $func) = (0, "Fcntl::O_" . $oflag);
223 no strict 'refs';
224 $OPENTEMPFLAGS |= $bit if eval {
225 # Make sure that redefined die handlers do not cause problems
226 # eg CGI::Carp
227 local $SIG{__DIE__} = sub {};
228 local $SIG{__WARN__} = sub {};
229 $bit = &$func();
234 # INTERNAL ROUTINES - not to be used outside of package
236 # Generic routine for getting a temporary filename
237 # modelled on OpenBSD _gettemp() in mktemp.c
239 # The template must contain X's that are to be replaced
240 # with the random values
242 # Arguments:
244 # TEMPLATE - string containing the XXXXX's that is converted
245 # to a random filename and opened if required
247 # Optionally, a hash can also be supplied containing specific options
248 # "open" => if true open the temp file, else just return the name
249 # default is 0
250 # "mkdir"=> if true, we are creating a temp directory rather than tempfile
251 # default is 0
252 # "suffixlen" => number of characters at end of PATH to be ignored.
253 # default is 0.
254 # "unlink_on_close" => indicates that, if possible, the OS should remove
255 # the file as soon as it is closed. Usually indicates
256 # use of the O_TEMPORARY flag to sysopen.
257 # Usually irrelevant on unix
259 # Optionally a reference to a scalar can be passed into the function
260 # On error this will be used to store the reason for the error
261 # "ErrStr" => \$errstr
263 # "open" and "mkdir" can not both be true
264 # "unlink_on_close" is not used when "mkdir" is true.
266 # The default options are equivalent to mktemp().
268 # Returns:
269 # filehandle - open file handle (if called with doopen=1, else undef)
270 # temp name - name of the temp file or directory
272 # For example:
273 # ($fh, $name) = _gettemp($template, "open" => 1);
275 # for the current version, failures are associated with
276 # stored in an error string and returned to give the reason whilst debugging
277 # This routine is not called by any external function
278 sub _gettemp {
280 croak 'Usage: ($fh, $name) = _gettemp($template, OPTIONS);'
281 unless scalar(@_) >= 1;
283 # the internal error string - expect it to be overridden
284 # Need this in case the caller decides not to supply us a value
285 # need an anonymous scalar
286 my $tempErrStr;
288 # Default options
289 my %options = (
290 "open" => 0,
291 "mkdir" => 0,
292 "suffixlen" => 0,
293 "unlink_on_close" => 0,
294 "ErrStr" => \$tempErrStr,
297 # Read the template
298 my $template = shift;
299 if (ref($template)) {
300 # Use a warning here since we have not yet merged ErrStr
301 carp "File::Temp::_gettemp: template must not be a reference";
302 return ();
305 # Check that the number of entries on stack are even
306 if (scalar(@_) % 2 != 0) {
307 # Use a warning here since we have not yet merged ErrStr
308 carp "File::Temp::_gettemp: Must have even number of options";
309 return ();
312 # Read the options and merge with defaults
313 %options = (%options, @_) if @_;
315 # Make sure the error string is set to undef
316 ${$options{ErrStr}} = undef;
318 # Can not open the file and make a directory in a single call
319 if ($options{"open"} && $options{"mkdir"}) {
320 ${$options{ErrStr}} = "doopen and domkdir can not both be true\n";
321 return ();
324 # Find the start of the end of the Xs (position of last X)
325 # Substr starts from 0
326 my $start = length($template) - 1 - $options{"suffixlen"};
328 # Check that we have at least MINX x X (eg 'XXXX") at the end of the string
329 # (taking suffixlen into account). Any fewer is insecure.
331 # Do it using substr - no reason to use a pattern match since
332 # we know where we are looking and what we are looking for
334 if (substr($template, $start - MINX + 1, MINX) ne 'X' x MINX) {
335 ${$options{ErrStr}} = "The template must contain at least ".
336 MINX . " 'X' characters\n";
337 return ();
340 # Replace all the X at the end of the substring with a
341 # random character or just all the XX at the end of a full string.
342 # Do it as an if, since the suffix adjusts which section to replace
343 # and suffixlen=0 returns nothing if used in the substr directly
344 # and generate a full path from the template
346 my $path = _replace_XX($template, $options{"suffixlen"});
349 # Split the path into constituent parts - eventually we need to check
350 # whether the directory exists
351 # We need to know whether we are making a temp directory
352 # or a tempfile
354 my ($volume, $directories, $file);
355 my $parent; # parent directory
356 if ($options{"mkdir"}) {
357 # There is no filename at the end
358 ($volume, $directories, $file) = File::Spec->splitpath( $path, 1);
360 # The parent is then $directories without the last directory
361 # Split the directory and put it back together again
362 my @dirs = File::Spec->splitdir($directories);
364 # If @dirs only has one entry that means we are in the current
365 # directory
366 if ($#dirs == 0) {
367 $parent = File::Spec->curdir;
368 } else {
370 if ($^O eq 'VMS') { # need volume to avoid relative dir spec
371 $parent = File::Spec->catdir($volume, @dirs[0..$#dirs-1]);
372 $parent = 'sys$disk:[]' if $parent eq '';
373 } else {
375 # Put it back together without the last one
376 $parent = File::Spec->catdir(@dirs[0..$#dirs-1]);
378 # ...and attach the volume (no filename)
379 $parent = File::Spec->catpath($volume, $parent, '');
384 } else {
386 # Get rid of the last filename (use File::Basename for this?)
387 ($volume, $directories, $file) = File::Spec->splitpath( $path );
389 # Join up without the file part
390 $parent = File::Spec->catpath($volume,$directories,'');
392 # If $parent is empty replace with curdir
393 $parent = File::Spec->curdir
394 unless $directories ne '';
398 # Check that the parent directories exist
399 # Do this even for the case where we are simply returning a name
400 # not a file -- no point returning a name that includes a directory
401 # that does not exist or is not writable
403 unless (-d $parent) {
404 ${$options{ErrStr}} = "Parent directory ($parent) is not a directory";
405 return ();
407 unless (-w _) {
408 ${$options{ErrStr}} = "Parent directory ($parent) is not writable\n";
409 return ();
413 # Check the stickiness of the directory and chown giveaway if required
414 # If the directory is world writable the sticky bit
415 # must be set
417 if (File::Temp->safe_level == MEDIUM) {
418 my $safeerr;
419 unless (_is_safe($parent,\$safeerr)) {
420 ${$options{ErrStr}} = "Parent directory ($parent) is not safe ($safeerr)";
421 return ();
423 } elsif (File::Temp->safe_level == HIGH) {
424 my $safeerr;
425 unless (_is_verysafe($parent, \$safeerr)) {
426 ${$options{ErrStr}} = "Parent directory ($parent) is not safe ($safeerr)";
427 return ();
432 # Now try MAX_TRIES time to open the file
433 for (my $i = 0; $i < MAX_TRIES; $i++) {
435 # Try to open the file if requested
436 if ($options{"open"}) {
437 my $fh;
439 # If we are running before perl5.6.0 we can not auto-vivify
440 if ($] < 5.006) {
441 $fh = &Symbol::gensym;
444 # Try to make sure this will be marked close-on-exec
445 # XXX: Win32 doesn't respect this, nor the proper fcntl,
446 # but may have O_NOINHERIT. This may or may not be in Fcntl.
447 local $^F = 2;
449 # Store callers umask
450 my $umask = umask();
452 # Set a known umask
453 umask(066);
455 # Attempt to open the file
456 my $open_success = undef;
457 if ( $^O eq 'VMS' and $options{"unlink_on_close"} ) {
458 # make it auto delete on close by setting FAB$V_DLT bit
459 $fh = VMS::Stdio::vmssysopen($path, $OPENFLAGS, 0600, 'fop=dlt');
460 $open_success = $fh;
461 } else {
462 my $flags = ( $options{"unlink_on_close"} ?
463 $OPENTEMPFLAGS :
464 $OPENFLAGS );
465 $open_success = sysopen($fh, $path, $flags, 0600);
467 if ( $open_success ) {
469 # Reset umask
470 umask($umask);
472 # Opened successfully - return file handle and name
473 return ($fh, $path);
475 } else {
476 # Reset umask
477 umask($umask);
479 # Error opening file - abort with error
480 # if the reason was anything but EEXIST
481 unless ($!{EEXIST}) {
482 ${$options{ErrStr}} = "Could not create temp file $path: $!";
483 return ();
486 # Loop round for another try
489 } elsif ($options{"mkdir"}) {
491 # Store callers umask
492 my $umask = umask();
494 # Set a known umask
495 umask(066);
497 # Open the temp directory
498 if (mkdir( $path, 0700)) {
499 # created okay
500 # Reset umask
501 umask($umask);
503 return undef, $path;
504 } else {
506 # Reset umask
507 umask($umask);
509 # Abort with error if the reason for failure was anything
510 # except EEXIST
511 unless ($!{EEXIST}) {
512 ${$options{ErrStr}} = "Could not create directory $path: $!";
513 return ();
516 # Loop round for another try
520 } else {
522 # Return true if the file can not be found
523 # Directory has been checked previously
525 return (undef, $path) unless -e $path;
527 # Try again until MAX_TRIES
531 # Did not successfully open the tempfile/dir
532 # so try again with a different set of random letters
533 # No point in trying to increment unless we have only
534 # 1 X say and the randomness could come up with the same
535 # file MAX_TRIES in a row.
537 # Store current attempt - in principal this implies that the
538 # 3rd time around the open attempt that the first temp file
539 # name could be generated again. Probably should store each
540 # attempt and make sure that none are repeated
542 my $original = $path;
543 my $counter = 0; # Stop infinite loop
544 my $MAX_GUESS = 50;
546 do {
548 # Generate new name from original template
549 $path = _replace_XX($template, $options{"suffixlen"});
551 $counter++;
553 } until ($path ne $original || $counter > $MAX_GUESS);
555 # Check for out of control looping
556 if ($counter > $MAX_GUESS) {
557 ${$options{ErrStr}} = "Tried to get a new temp name different to the previous value $MAX_GUESS times.\nSomething wrong with template?? ($template)";
558 return ();
563 # If we get here, we have run out of tries
564 ${ $options{ErrStr} } = "Have exceeded the maximum number of attempts ("
565 . MAX_TRIES . ") to open temp file/dir";
567 return ();
571 # Internal routine to return a random character from the
572 # character list. Does not do an srand() since rand()
573 # will do one automatically
575 # No arguments. Return value is the random character
577 # No longer called since _replace_XX runs a few percent faster if
578 # I inline the code. This is important if we are creating thousands of
579 # temporary files.
581 sub _randchar {
583 $CHARS[ int( rand( $#CHARS ) ) ];
587 # Internal routine to replace the XXXX... with random characters
588 # This has to be done by _gettemp() every time it fails to
589 # open a temp file/dir
591 # Arguments: $template (the template with XXX),
592 # $ignore (number of characters at end to ignore)
594 # Returns: modified template
596 sub _replace_XX {
598 croak 'Usage: _replace_XX($template, $ignore)'
599 unless scalar(@_) == 2;
601 my ($path, $ignore) = @_;
603 # Do it as an if, since the suffix adjusts which section to replace
604 # and suffixlen=0 returns nothing if used in the substr directly
605 # Alternatively, could simply set $ignore to length($path)-1
606 # Don't want to always use substr when not required though.
608 if ($ignore) {
609 substr($path, 0, - $ignore) =~ s/X(?=X*\z)/$CHARS[ int( rand( $#CHARS ) ) ]/ge;
610 } else {
611 $path =~ s/X(?=X*\z)/$CHARS[ int( rand( $#CHARS ) ) ]/ge;
614 return $path;
617 # internal routine to check to see if the directory is safe
618 # First checks to see if the directory is not owned by the
619 # current user or root. Then checks to see if anyone else
620 # can write to the directory and if so, checks to see if
621 # it has the sticky bit set
623 # Will not work on systems that do not support sticky bit
625 #Args: directory path to check
626 # Optionally: reference to scalar to contain error message
627 # Returns true if the path is safe and false otherwise.
628 # Returns undef if can not even run stat() on the path
630 # This routine based on version written by Tom Christiansen
632 # Presumably, by the time we actually attempt to create the
633 # file or directory in this directory, it may not be safe
634 # anymore... Have to run _is_safe directly after the open.
636 sub _is_safe {
638 my $path = shift;
639 my $err_ref = shift;
641 # Stat path
642 my @info = stat($path);
643 unless (scalar(@info)) {
644 $$err_ref = "stat(path) returned no values";
645 return 0;
647 return 1 if $^O eq 'VMS'; # owner delete control at file level
649 # Check to see whether owner is neither superuser (or a system uid) nor me
650 # Use the real uid from the $< variable
651 # UID is in [4]
652 if ($info[4] > File::Temp->top_system_uid() && $info[4] != $<) {
654 Carp::cluck(sprintf "uid=$info[4] topuid=%s \$<=$< path='$path'",
655 File::Temp->top_system_uid());
657 $$err_ref = "Directory owned neither by root nor the current user"
658 if ref($err_ref);
659 return 0;
662 # check whether group or other can write file
663 # use 066 to detect either reading or writing
664 # use 022 to check writability
665 # Do it with S_IWOTH and S_IWGRP for portability (maybe)
666 # mode is in info[2]
667 if (($info[2] & &Fcntl::S_IWGRP) || # Is group writable?
668 ($info[2] & &Fcntl::S_IWOTH) ) { # Is world writable?
669 # Must be a directory
670 unless (-d _) {
671 $$err_ref = "Path ($path) is not a directory"
672 if ref($err_ref);
673 return 0;
675 # Must have sticky bit set
676 unless (-k _) {
677 $$err_ref = "Sticky bit not set on $path when dir is group|world writable"
678 if ref($err_ref);
679 return 0;
683 return 1;
686 # Internal routine to check whether a directory is safe
687 # for temp files. Safer than _is_safe since it checks for
688 # the possibility of chown giveaway and if that is a possibility
689 # checks each directory in the path to see if it is safe (with _is_safe)
691 # If _PC_CHOWN_RESTRICTED is not set, does the full test of each
692 # directory anyway.
694 # Takes optional second arg as scalar ref to error reason
696 sub _is_verysafe {
698 # Need POSIX - but only want to bother if really necessary due to overhead
699 require POSIX;
701 my $path = shift;
702 print "_is_verysafe testing $path\n" if $DEBUG;
703 return 1 if $^O eq 'VMS'; # owner delete control at file level
705 my $err_ref = shift;
707 # Should Get the value of _PC_CHOWN_RESTRICTED if it is defined
708 # and If it is not there do the extensive test
709 my $chown_restricted;
710 $chown_restricted = &POSIX::_PC_CHOWN_RESTRICTED()
711 if eval { &POSIX::_PC_CHOWN_RESTRICTED(); 1};
713 # If chown_resticted is set to some value we should test it
714 if (defined $chown_restricted) {
716 # Return if the current directory is safe
717 return _is_safe($path,$err_ref) if POSIX::sysconf( $chown_restricted );
721 # To reach this point either, the _PC_CHOWN_RESTRICTED symbol
722 # was not avialable or the symbol was there but chown giveaway
723 # is allowed. Either way, we now have to test the entire tree for
724 # safety.
726 # Convert path to an absolute directory if required
727 unless (File::Spec->file_name_is_absolute($path)) {
728 $path = File::Spec->rel2abs($path);
731 # Split directory into components - assume no file
732 my ($volume, $directories, undef) = File::Spec->splitpath( $path, 1);
734 # Slightly less efficient than having a a function in File::Spec
735 # to chop off the end of a directory or even a function that
736 # can handle ../ in a directory tree
737 # Sometimes splitdir() returns a blank at the end
738 # so we will probably check the bottom directory twice in some cases
739 my @dirs = File::Spec->splitdir($directories);
741 # Concatenate one less directory each time around
742 foreach my $pos (0.. $#dirs) {
743 # Get a directory name
744 my $dir = File::Spec->catpath($volume,
745 File::Spec->catdir(@dirs[0.. $#dirs - $pos]),
749 print "TESTING DIR $dir\n" if $DEBUG;
751 # Check the directory
752 return 0 unless _is_safe($dir,$err_ref);
756 return 1;
761 # internal routine to determine whether unlink works on this
762 # platform for files that are currently open.
763 # Returns true if we can, false otherwise.
765 # Currently WinNT, OS/2 and VMS can not unlink an opened file
766 # On VMS this is because the O_EXCL flag is used to open the
767 # temporary file. Currently I do not know enough about the issues
768 # on VMS to decide whether O_EXCL is a requirement.
770 sub _can_unlink_opened_file {
772 if ($^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'VMS' || $^O eq 'dos') {
773 return 0;
774 } else {
775 return 1;
780 # internal routine to decide which security levels are allowed
781 # see safe_level() for more information on this
783 # Controls whether the supplied security level is allowed
785 # $cando = _can_do_level( $level )
787 sub _can_do_level {
789 # Get security level
790 my $level = shift;
792 # Always have to be able to do STANDARD
793 return 1 if $level == STANDARD;
795 # Currently, the systems that can do HIGH or MEDIUM are identical
796 if ( $^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'cygwin' || $^O eq 'dos' || $^O eq 'msys') {
797 return 0;
798 } else {
799 return 1;
804 # This routine sets up a deferred unlinking of a specified
805 # filename and filehandle. It is used in the following cases:
806 # - Called by unlink0 if an opened file can not be unlinked
807 # - Called by tempfile() if files are to be removed on shutdown
808 # - Called by tempdir() if directories are to be removed on shutdown
810 # Arguments:
811 # _deferred_unlink( $fh, $fname, $isdir );
813 # - filehandle (so that it can be expclicitly closed if open
814 # - filename (the thing we want to remove)
815 # - isdir (flag to indicate that we are being given a directory)
816 # [and hence no filehandle]
818 # Status is not referred to since all the magic is done with an END block
821 # Will set up two lexical variables to contain all the files to be
822 # removed. One array for files, another for directories
823 # They will only exist in this block
824 # This means we only have to set up a single END block to remove all files
825 # @files_to_unlink contains an array ref with the filehandle and filename
826 my (@files_to_unlink, @dirs_to_unlink);
828 # Set up an end block to use these arrays
829 END {
830 # Files
831 foreach my $file (@files_to_unlink) {
832 # close the filehandle without checking its state
833 # in order to make real sure that this is closed
834 # if its already closed then I dont care about the answer
835 # probably a better way to do this
836 close($file->[0]); # file handle is [0]
838 if (-f $file->[1]) { # file name is [1]
839 unlink $file->[1] or warn "Error removing ".$file->[1];
842 # Dirs
843 foreach my $dir (@dirs_to_unlink) {
844 if (-d $dir) {
845 rmtree($dir, $DEBUG, 1);
851 # This is the sub called to register a file for deferred unlinking
852 # This could simply store the input parameters and defer everything
853 # until the END block. For now we do a bit of checking at this
854 # point in order to make sure that (1) we have a file/dir to delete
855 # and (2) we have been called with the correct arguments.
856 sub _deferred_unlink {
858 croak 'Usage: _deferred_unlink($fh, $fname, $isdir)'
859 unless scalar(@_) == 3;
861 my ($fh, $fname, $isdir) = @_;
863 warn "Setting up deferred removal of $fname\n"
864 if $DEBUG;
866 # If we have a directory, check that it is a directory
867 if ($isdir) {
869 if (-d $fname) {
871 # Directory exists so store it
872 # first on VMS turn []foo into [.foo] for rmtree
873 $fname = VMS::Filespec::vmspath($fname) if $^O eq 'VMS';
874 push (@dirs_to_unlink, $fname);
876 } else {
877 carp "Request to remove directory $fname could not be completed since it does not exist!\n" if $^W;
880 } else {
882 if (-f $fname) {
884 # file exists so store handle and name for later removal
885 push(@files_to_unlink, [$fh, $fname]);
887 } else {
888 carp "Request to remove file $fname could not be completed since it is not there!\n" if $^W;
898 =head1 FUNCTIONS
900 This section describes the recommended interface for generating
901 temporary files and directories.
903 =over 4
905 =item B<tempfile>
907 This is the basic function to generate temporary files.
908 The behaviour of the file can be changed using various options:
910 ($fh, $filename) = tempfile();
912 Create a temporary file in the directory specified for temporary
913 files, as specified by the tmpdir() function in L<File::Spec>.
915 ($fh, $filename) = tempfile($template);
917 Create a temporary file in the current directory using the supplied
918 template. Trailing `X' characters are replaced with random letters to
919 generate the filename. At least four `X' characters must be present
920 in the template.
922 ($fh, $filename) = tempfile($template, SUFFIX => $suffix)
924 Same as previously, except that a suffix is added to the template
925 after the `X' translation. Useful for ensuring that a temporary
926 filename has a particular extension when needed by other applications.
927 But see the WARNING at the end.
929 ($fh, $filename) = tempfile($template, DIR => $dir);
931 Translates the template as before except that a directory name
932 is specified.
934 ($fh, $filename) = tempfile($template, UNLINK => 1);
936 Return the filename and filehandle as before except that the file is
937 automatically removed when the program exits. Default is for the file
938 to be removed if a file handle is requested and to be kept if the
939 filename is requested. In a scalar context (where no filename is
940 returned) the file is always deleted either on exit or when it is closed.
942 If the template is not specified, a template is always
943 automatically generated. This temporary file is placed in tmpdir()
944 (L<File::Spec>) unless a directory is specified explicitly with the
945 DIR option.
947 $fh = tempfile( $template, DIR => $dir );
949 If called in scalar context, only the filehandle is returned
950 and the file will automatically be deleted when closed (see
951 the description of tmpfile() elsewhere in this document).
952 This is the preferred mode of operation, as if you only
953 have a filehandle, you can never create a race condition
954 by fumbling with the filename. On systems that can not unlink
955 an open file or can not mark a file as temporary when it is opened
956 (for example, Windows NT uses the C<O_TEMPORARY> flag))
957 the file is marked for deletion when the program ends (equivalent
958 to setting UNLINK to 1). The C<UNLINK> flag is ignored if present.
960 (undef, $filename) = tempfile($template, OPEN => 0);
962 This will return the filename based on the template but
963 will not open this file. Cannot be used in conjunction with
964 UNLINK set to true. Default is to always open the file
965 to protect from possible race conditions. A warning is issued
966 if warnings are turned on. Consider using the tmpnam()
967 and mktemp() functions described elsewhere in this document
968 if opening the file is not required.
970 Options can be combined as required.
972 =cut
974 sub tempfile {
976 # Can not check for argument count since we can have any
977 # number of args
979 # Default options
980 my %options = (
981 "DIR" => undef, # Directory prefix
982 "SUFFIX" => '', # Template suffix
983 "UNLINK" => 0, # Do not unlink file on exit
984 "OPEN" => 1, # Open file
987 # Check to see whether we have an odd or even number of arguments
988 my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef);
990 # Read the options and merge with defaults
991 %options = (%options, @_) if @_;
993 # First decision is whether or not to open the file
994 if (! $options{"OPEN"}) {
996 warn "tempfile(): temporary filename requested but not opened.\nPossibly unsafe, consider using tempfile() with OPEN set to true\n"
997 if $^W;
1001 if ($options{"DIR"} and $^O eq 'VMS') {
1003 # on VMS turn []foo into [.foo] for concatenation
1004 $options{"DIR"} = VMS::Filespec::vmspath($options{"DIR"});
1007 # Construct the template
1009 # Have a choice of trying to work around the mkstemp/mktemp/tmpnam etc
1010 # functions or simply constructing a template and using _gettemp()
1011 # explicitly. Go for the latter
1013 # First generate a template if not defined and prefix the directory
1014 # If no template must prefix the temp directory
1015 if (defined $template) {
1016 if ($options{"DIR"}) {
1018 $template = File::Spec->catfile($options{"DIR"}, $template);
1022 } else {
1024 if ($options{"DIR"}) {
1026 $template = File::Spec->catfile($options{"DIR"}, TEMPXXX);
1028 } else {
1030 $template = File::Spec->catfile(File::Spec->tmpdir, TEMPXXX);
1036 # Now add a suffix
1037 $template .= $options{"SUFFIX"};
1039 # Determine whether we should tell _gettemp to unlink the file
1040 # On unix this is irrelevant and can be worked out after the file is
1041 # opened (simply by unlinking the open filehandle). On Windows or VMS
1042 # we have to indicate temporary-ness when we open the file. In general
1043 # we only want a true temporary file if we are returning just the
1044 # filehandle - if the user wants the filename they probably do not
1045 # want the file to disappear as soon as they close it.
1046 # For this reason, tie unlink_on_close to the return context regardless
1047 # of OS.
1048 my $unlink_on_close = ( wantarray ? 0 : 1);
1050 # Create the file
1051 my ($fh, $path, $errstr);
1052 croak "Error in tempfile() using $template: $errstr"
1053 unless (($fh, $path) = _gettemp($template,
1054 "open" => $options{'OPEN'},
1055 "mkdir"=> 0 ,
1056 "unlink_on_close" => $unlink_on_close,
1057 "suffixlen" => length($options{'SUFFIX'}),
1058 "ErrStr" => \$errstr,
1059 ) );
1061 # Set up an exit handler that can do whatever is right for the
1062 # system. This removes files at exit when requested explicitly or when
1063 # system is asked to unlink_on_close but is unable to do so because
1064 # of OS limitations.
1065 # The latter should be achieved by using a tied filehandle.
1066 # Do not check return status since this is all done with END blocks.
1067 _deferred_unlink($fh, $path, 0) if $options{"UNLINK"};
1069 # Return
1070 if (wantarray()) {
1072 if ($options{'OPEN'}) {
1073 return ($fh, $path);
1074 } else {
1075 return (undef, $path);
1078 } else {
1080 # Unlink the file. It is up to unlink0 to decide what to do with
1081 # this (whether to unlink now or to defer until later)
1082 unlink0($fh, $path) or croak "Error unlinking file $path using unlink0";
1084 # Return just the filehandle.
1085 return $fh;
1091 =item B<tempdir>
1093 This is the recommended interface for creation of temporary directories.
1094 The behaviour of the function depends on the arguments:
1096 $tempdir = tempdir();
1098 Create a directory in tmpdir() (see L<File::Spec|File::Spec>).
1100 $tempdir = tempdir( $template );
1102 Create a directory from the supplied template. This template is
1103 similar to that described for tempfile(). `X' characters at the end
1104 of the template are replaced with random letters to construct the
1105 directory name. At least four `X' characters must be in the template.
1107 $tempdir = tempdir ( DIR => $dir );
1109 Specifies the directory to use for the temporary directory.
1110 The temporary directory name is derived from an internal template.
1112 $tempdir = tempdir ( $template, DIR => $dir );
1114 Prepend the supplied directory name to the template. The template
1115 should not include parent directory specifications itself. Any parent
1116 directory specifications are removed from the template before
1117 prepending the supplied directory.
1119 $tempdir = tempdir ( $template, TMPDIR => 1 );
1121 Using the supplied template, creat the temporary directory in
1122 a standard location for temporary files. Equivalent to doing
1124 $tempdir = tempdir ( $template, DIR => File::Spec->tmpdir);
1126 but shorter. Parent directory specifications are stripped from the
1127 template itself. The C<TMPDIR> option is ignored if C<DIR> is set
1128 explicitly. Additionally, C<TMPDIR> is implied if neither a template
1129 nor a directory are supplied.
1131 $tempdir = tempdir( $template, CLEANUP => 1);
1133 Create a temporary directory using the supplied template, but
1134 attempt to remove it (and all files inside it) when the program
1135 exits. Note that an attempt will be made to remove all files from
1136 the directory even if they were not created by this module (otherwise
1137 why ask to clean it up?). The directory removal is made with
1138 the rmtree() function from the L<File::Path|File::Path> module.
1139 Of course, if the template is not specified, the temporary directory
1140 will be created in tmpdir() and will also be removed at program exit.
1142 =cut
1146 sub tempdir {
1148 # Can not check for argument count since we can have any
1149 # number of args
1151 # Default options
1152 my %options = (
1153 "CLEANUP" => 0, # Remove directory on exit
1154 "DIR" => '', # Root directory
1155 "TMPDIR" => 0, # Use tempdir with template
1158 # Check to see whether we have an odd or even number of arguments
1159 my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef );
1161 # Read the options and merge with defaults
1162 %options = (%options, @_) if @_;
1164 # Modify or generate the template
1166 # Deal with the DIR and TMPDIR options
1167 if (defined $template) {
1169 # Need to strip directory path if using DIR or TMPDIR
1170 if ($options{'TMPDIR'} || $options{'DIR'}) {
1172 # Strip parent directory from the filename
1174 # There is no filename at the end
1175 $template = VMS::Filespec::vmspath($template) if $^O eq 'VMS';
1176 my ($volume, $directories, undef) = File::Spec->splitpath( $template, 1);
1178 # Last directory is then our template
1179 $template = (File::Spec->splitdir($directories))[-1];
1181 # Prepend the supplied directory or temp dir
1182 if ($options{"DIR"}) {
1184 $template = File::Spec->catdir($options{"DIR"}, $template);
1186 } elsif ($options{TMPDIR}) {
1188 # Prepend tmpdir
1189 $template = File::Spec->catdir(File::Spec->tmpdir, $template);
1195 } else {
1197 if ($options{"DIR"}) {
1199 $template = File::Spec->catdir($options{"DIR"}, TEMPXXX);
1201 } else {
1203 $template = File::Spec->catdir(File::Spec->tmpdir, TEMPXXX);
1209 # Create the directory
1210 my $tempdir;
1211 my $suffixlen = 0;
1212 if ($^O eq 'VMS') { # dir names can end in delimiters
1213 $template =~ m/([\.\]:>]+)$/;
1214 $suffixlen = length($1);
1217 my $errstr;
1218 croak "Error in tempdir() using $template: $errstr"
1219 unless ((undef, $tempdir) = _gettemp($template,
1220 "open" => 0,
1221 "mkdir"=> 1 ,
1222 "suffixlen" => $suffixlen,
1223 "ErrStr" => \$errstr,
1224 ) );
1226 # Install exit handler; must be dynamic to get lexical
1227 if ( $options{'CLEANUP'} && -d $tempdir) {
1228 _deferred_unlink(undef, $tempdir, 1);
1231 # Return the dir name
1232 return $tempdir;
1236 =back
1238 =head1 MKTEMP FUNCTIONS
1240 The following functions are Perl implementations of the
1241 mktemp() family of temp file generation system calls.
1243 =over 4
1245 =item B<mkstemp>
1247 Given a template, returns a filehandle to the temporary file and the name
1248 of the file.
1250 ($fh, $name) = mkstemp( $template );
1252 In scalar context, just the filehandle is returned.
1254 The template may be any filename with some number of X's appended
1255 to it, for example F</tmp/temp.XXXX>. The trailing X's are replaced
1256 with unique alphanumeric combinations.
1258 =cut
1262 sub mkstemp {
1264 croak "Usage: mkstemp(template)"
1265 if scalar(@_) != 1;
1267 my $template = shift;
1269 my ($fh, $path, $errstr);
1270 croak "Error in mkstemp using $template: $errstr"
1271 unless (($fh, $path) = _gettemp($template,
1272 "open" => 1,
1273 "mkdir"=> 0 ,
1274 "suffixlen" => 0,
1275 "ErrStr" => \$errstr,
1276 ) );
1278 if (wantarray()) {
1279 return ($fh, $path);
1280 } else {
1281 return $fh;
1287 =item B<mkstemps>
1289 Similar to mkstemp(), except that an extra argument can be supplied
1290 with a suffix to be appended to the template.
1292 ($fh, $name) = mkstemps( $template, $suffix );
1294 For example a template of C<testXXXXXX> and suffix of C<.dat>
1295 would generate a file similar to F<testhGji_w.dat>.
1297 Returns just the filehandle alone when called in scalar context.
1299 =cut
1301 sub mkstemps {
1303 croak "Usage: mkstemps(template, suffix)"
1304 if scalar(@_) != 2;
1307 my $template = shift;
1308 my $suffix = shift;
1310 $template .= $suffix;
1312 my ($fh, $path, $errstr);
1313 croak "Error in mkstemps using $template: $errstr"
1314 unless (($fh, $path) = _gettemp($template,
1315 "open" => 1,
1316 "mkdir"=> 0 ,
1317 "suffixlen" => length($suffix),
1318 "ErrStr" => \$errstr,
1319 ) );
1321 if (wantarray()) {
1322 return ($fh, $path);
1323 } else {
1324 return $fh;
1329 =item B<mkdtemp>
1331 Create a directory from a template. The template must end in
1332 X's that are replaced by the routine.
1334 $tmpdir_name = mkdtemp($template);
1336 Returns the name of the temporary directory created.
1337 Returns undef on failure.
1339 Directory must be removed by the caller.
1341 =cut
1343 #' # for emacs
1345 sub mkdtemp {
1347 croak "Usage: mkdtemp(template)"
1348 if scalar(@_) != 1;
1350 my $template = shift;
1351 my $suffixlen = 0;
1352 if ($^O eq 'VMS') { # dir names can end in delimiters
1353 $template =~ m/([\.\]:>]+)$/;
1354 $suffixlen = length($1);
1356 my ($junk, $tmpdir, $errstr);
1357 croak "Error creating temp directory from template $template\: $errstr"
1358 unless (($junk, $tmpdir) = _gettemp($template,
1359 "open" => 0,
1360 "mkdir"=> 1 ,
1361 "suffixlen" => $suffixlen,
1362 "ErrStr" => \$errstr,
1363 ) );
1365 return $tmpdir;
1369 =item B<mktemp>
1371 Returns a valid temporary filename but does not guarantee
1372 that the file will not be opened by someone else.
1374 $unopened_file = mktemp($template);
1376 Template is the same as that required by mkstemp().
1378 =cut
1380 sub mktemp {
1382 croak "Usage: mktemp(template)"
1383 if scalar(@_) != 1;
1385 my $template = shift;
1387 my ($tmpname, $junk, $errstr);
1388 croak "Error getting name to temp file from template $template: $errstr"
1389 unless (($junk, $tmpname) = _gettemp($template,
1390 "open" => 0,
1391 "mkdir"=> 0 ,
1392 "suffixlen" => 0,
1393 "ErrStr" => \$errstr,
1394 ) );
1396 return $tmpname;
1399 =back
1401 =head1 POSIX FUNCTIONS
1403 This section describes the re-implementation of the tmpnam()
1404 and tmpfile() functions described in L<POSIX>
1405 using the mkstemp() from this module.
1407 Unlike the L<POSIX|POSIX> implementations, the directory used
1408 for the temporary file is not specified in a system include
1409 file (C<P_tmpdir>) but simply depends on the choice of tmpdir()
1410 returned by L<File::Spec|File::Spec>. On some implementations this
1411 location can be set using the C<TMPDIR> environment variable, which
1412 may not be secure.
1413 If this is a problem, simply use mkstemp() and specify a template.
1415 =over 4
1417 =item B<tmpnam>
1419 When called in scalar context, returns the full name (including path)
1420 of a temporary file (uses mktemp()). The only check is that the file does
1421 not already exist, but there is no guarantee that that condition will
1422 continue to apply.
1424 $file = tmpnam();
1426 When called in list context, a filehandle to the open file and
1427 a filename are returned. This is achieved by calling mkstemp()
1428 after constructing a suitable template.
1430 ($fh, $file) = tmpnam();
1432 If possible, this form should be used to prevent possible
1433 race conditions.
1435 See L<File::Spec/tmpdir> for information on the choice of temporary
1436 directory for a particular operating system.
1438 =cut
1440 sub tmpnam {
1442 # Retrieve the temporary directory name
1443 my $tmpdir = File::Spec->tmpdir;
1445 croak "Error temporary directory is not writable"
1446 if $tmpdir eq '';
1448 # Use a ten character template and append to tmpdir
1449 my $template = File::Spec->catfile($tmpdir, TEMPXXX);
1451 if (wantarray() ) {
1452 return mkstemp($template);
1453 } else {
1454 return mktemp($template);
1459 =item B<tmpfile>
1461 In scalar context, returns the filehandle of a temporary file.
1463 $fh = tmpfile();
1465 The file is removed when the filehandle is closed or when the program
1466 exits. No access to the filename is provided.
1468 If the temporary file can not be created undef is returned.
1469 Currently this command will probably not work when the temporary
1470 directory is on an NFS file system.
1472 =cut
1474 sub tmpfile {
1476 # Simply call tmpnam() in a list context
1477 my ($fh, $file) = tmpnam();
1479 # Make sure file is removed when filehandle is closed
1480 # This will fail on NFS
1481 unlink0($fh, $file)
1482 or return undef;
1484 return $fh;
1488 =back
1490 =head1 ADDITIONAL FUNCTIONS
1492 These functions are provided for backwards compatibility
1493 with common tempfile generation C library functions.
1495 They are not exported and must be addressed using the full package
1496 name.
1498 =over 4
1500 =item B<tempnam>
1502 Return the name of a temporary file in the specified directory
1503 using a prefix. The file is guaranteed not to exist at the time
1504 the function was called, but such guarantees are good for one
1505 clock tick only. Always use the proper form of C<sysopen>
1506 with C<O_CREAT | O_EXCL> if you must open such a filename.
1508 $filename = File::Temp::tempnam( $dir, $prefix );
1510 Equivalent to running mktemp() with $dir/$prefixXXXXXXXX
1511 (using unix file convention as an example)
1513 Because this function uses mktemp(), it can suffer from race conditions.
1515 =cut
1517 sub tempnam {
1519 croak 'Usage tempnam($dir, $prefix)' unless scalar(@_) == 2;
1521 my ($dir, $prefix) = @_;
1523 # Add a string to the prefix
1524 $prefix .= 'XXXXXXXX';
1526 # Concatenate the directory to the file
1527 my $template = File::Spec->catfile($dir, $prefix);
1529 return mktemp($template);
1533 =back
1535 =head1 UTILITY FUNCTIONS
1537 Useful functions for dealing with the filehandle and filename.
1539 =over 4
1541 =item B<unlink0>
1543 Given an open filehandle and the associated filename, make a safe
1544 unlink. This is achieved by first checking that the filename and
1545 filehandle initially point to the same file and that the number of
1546 links to the file is 1 (all fields returned by stat() are compared).
1547 Then the filename is unlinked and the filehandle checked once again to
1548 verify that the number of links on that file is now 0. This is the
1549 closest you can come to making sure that the filename unlinked was the
1550 same as the file whose descriptor you hold.
1552 unlink0($fh, $path) or die "Error unlinking file $path safely";
1554 Returns false on error. The filehandle is not closed since on some
1555 occasions this is not required.
1557 On some platforms, for example Windows NT, it is not possible to
1558 unlink an open file (the file must be closed first). On those
1559 platforms, the actual unlinking is deferred until the program ends and
1560 good status is returned. A check is still performed to make sure that
1561 the filehandle and filename are pointing to the same thing (but not at
1562 the time the end block is executed since the deferred removal may not
1563 have access to the filehandle).
1565 Additionally, on Windows NT not all the fields returned by stat() can
1566 be compared. For example, the C<dev> and C<rdev> fields seem to be
1567 different. Also, it seems that the size of the file returned by stat()
1568 does not always agree, with C<stat(FH)> being more accurate than
1569 C<stat(filename)>, presumably because of caching issues even when
1570 using autoflush (this is usually overcome by waiting a while after
1571 writing to the tempfile before attempting to C<unlink0> it).
1573 Finally, on NFS file systems the link count of the file handle does
1574 not always go to zero immediately after unlinking. Currently, this
1575 command is expected to fail on NFS disks.
1577 =cut
1579 sub unlink0 {
1581 croak 'Usage: unlink0(filehandle, filename)'
1582 unless scalar(@_) == 2;
1584 # Read args
1585 my ($fh, $path) = @_;
1587 warn "Unlinking $path using unlink0\n"
1588 if $DEBUG;
1590 # Stat the filehandle
1591 my @fh = stat $fh;
1593 if ($fh[3] > 1 && $^W) {
1594 carp "unlink0: fstat found too many links; SB=@fh" if $^W;
1597 # Stat the path
1598 my @path = stat $path;
1600 unless (@path) {
1601 carp "unlink0: $path is gone already" if $^W;
1602 return;
1605 # this is no longer a file, but may be a directory, or worse
1606 unless (-f _) {
1607 confess "panic: $path is no longer a file: SB=@fh";
1610 # Do comparison of each member of the array
1611 # On WinNT dev and rdev seem to be different
1612 # depending on whether it is a file or a handle.
1613 # Cannot simply compare all members of the stat return
1614 # Select the ones we can use
1615 my @okstat = (0..$#fh); # Use all by default
1616 if ($^O eq 'MSWin32') {
1617 @okstat = (1,2,3,4,5,7,8,9,10);
1618 } elsif ($^O eq 'os2') {
1619 @okstat = (0, 2..$#fh);
1620 } elsif ($^O eq 'VMS') { # device and file ID are sufficient
1621 @okstat = (0, 1);
1622 } elsif ($^O eq 'dos') {
1623 @okstat = (0,2..7,11..$#fh);
1626 # Now compare each entry explicitly by number
1627 for (@okstat) {
1628 print "Comparing: $_ : $fh[$_] and $path[$_]\n" if $DEBUG;
1629 # Use eq rather than == since rdev, blksize, and blocks (6, 11,
1630 # and 12) will be '' on platforms that do not support them. This
1631 # is fine since we are only comparing integers.
1632 unless ($fh[$_] eq $path[$_]) {
1633 warn "Did not match $_ element of stat\n" if $DEBUG;
1634 return 0;
1638 # attempt remove the file (does not work on some platforms)
1639 if (_can_unlink_opened_file()) {
1640 # XXX: do *not* call this on a directory; possible race
1641 # resulting in recursive removal
1642 croak "unlink0: $path has become a directory!" if -d $path;
1643 unlink($path) or return 0;
1645 # Stat the filehandle
1646 @fh = stat $fh;
1648 print "Link count = $fh[3] \n" if $DEBUG;
1650 # Make sure that the link count is zero
1651 # - Cygwin provides deferred unlinking, however,
1652 # on Win9x the link count remains 1
1653 # On NFS the link count may still be 1 but we cant know that
1654 # we are on NFS
1655 return ( $fh[3] == 0 or $^O eq 'cygwin' or $^O eq 'msys' ? 1 : 0);
1657 } else {
1658 _deferred_unlink($fh, $path, 0);
1659 return 1;
1664 =back
1666 =head1 PACKAGE VARIABLES
1668 These functions control the global state of the package.
1670 =over 4
1672 =item B<safe_level>
1674 Controls the lengths to which the module will go to check the safety of the
1675 temporary file or directory before proceeding.
1676 Options are:
1678 =over 8
1680 =item STANDARD
1682 Do the basic security measures to ensure the directory exists and
1683 is writable, that the umask() is fixed before opening of the file,
1684 that temporary files are opened only if they do not already exist, and
1685 that possible race conditions are avoided. Finally the L<unlink0|"unlink0">
1686 function is used to remove files safely.
1688 =item MEDIUM
1690 In addition to the STANDARD security, the output directory is checked
1691 to make sure that it is owned either by root or the user running the
1692 program. If the directory is writable by group or by other, it is then
1693 checked to make sure that the sticky bit is set.
1695 Will not work on platforms that do not support the C<-k> test
1696 for sticky bit.
1698 =item HIGH
1700 In addition to the MEDIUM security checks, also check for the
1701 possibility of ``chown() giveaway'' using the L<POSIX|POSIX>
1702 sysconf() function. If this is a possibility, each directory in the
1703 path is checked in turn for safeness, recursively walking back to the
1704 root directory.
1706 For platforms that do not support the L<POSIX|POSIX>
1707 C<_PC_CHOWN_RESTRICTED> symbol (for example, Windows NT) it is
1708 assumed that ``chown() giveaway'' is possible and the recursive test
1709 is performed.
1711 =back
1713 The level can be changed as follows:
1715 File::Temp->safe_level( File::Temp::HIGH );
1717 The level constants are not exported by the module.
1719 Currently, you must be running at least perl v5.6.0 in order to
1720 run with MEDIUM or HIGH security. This is simply because the
1721 safety tests use functions from L<Fcntl|Fcntl> that are not
1722 available in older versions of perl. The problem is that the version
1723 number for Fcntl is the same in perl 5.6.0 and in 5.005_03 even though
1724 they are different versions.
1726 On systems that do not support the HIGH or MEDIUM safety levels
1727 (for example Win NT or OS/2) any attempt to change the level will
1728 be ignored. The decision to ignore rather than raise an exception
1729 allows portable programs to be written with high security in mind
1730 for the systems that can support this without those programs failing
1731 on systems where the extra tests are irrelevant.
1733 If you really need to see whether the change has been accepted
1734 simply examine the return value of C<safe_level>.
1736 $newlevel = File::Temp->safe_level( File::Temp::HIGH );
1737 die "Could not change to high security"
1738 if $newlevel != File::Temp::HIGH;
1740 =cut
1743 # protect from using the variable itself
1744 my $LEVEL = STANDARD;
1745 sub safe_level {
1746 my $self = shift;
1747 if (@_) {
1748 my $level = shift;
1749 if (($level != STANDARD) && ($level != MEDIUM) && ($level != HIGH)) {
1750 carp "safe_level: Specified level ($level) not STANDARD, MEDIUM or HIGH - ignoring\n" if $^W;
1751 } else {
1752 # Dont allow this on perl 5.005 or earlier
1753 if ($] < 5.006 && $level != STANDARD) {
1754 # Cant do MEDIUM or HIGH checks
1755 croak "Currently requires perl 5.006 or newer to do the safe checks";
1757 # Check that we are allowed to change level
1758 # Silently ignore if we can not.
1759 $LEVEL = $level if _can_do_level($level);
1762 return $LEVEL;
1766 =item TopSystemUID
1768 This is the highest UID on the current system that refers to a root
1769 UID. This is used to make sure that the temporary directory is
1770 owned by a system UID (C<root>, C<bin>, C<sys> etc) rather than
1771 simply by root.
1773 This is required since on many unix systems C</tmp> is not owned
1774 by root.
1776 Default is to assume that any UID less than or equal to 10 is a root
1777 UID.
1779 File::Temp->top_system_uid(10);
1780 my $topid = File::Temp->top_system_uid;
1782 This value can be adjusted to reduce security checking if required.
1783 The value is only relevant when C<safe_level> is set to MEDIUM or higher.
1785 =back
1787 =cut
1790 my $TopSystemUID = 10;
1791 sub top_system_uid {
1792 my $self = shift;
1793 if (@_) {
1794 my $newuid = shift;
1795 croak "top_system_uid: UIDs should be numeric"
1796 unless $newuid =~ /^\d+$/s;
1797 $TopSystemUID = $newuid;
1799 return $TopSystemUID;
1803 =head1 WARNING
1805 For maximum security, endeavour always to avoid ever looking at,
1806 touching, or even imputing the existence of the filename. You do not
1807 know that that filename is connected to the same file as the handle
1808 you have, and attempts to check this can only trigger more race
1809 conditions. It's far more secure to use the filehandle alone and
1810 dispense with the filename altogether.
1812 If you need to pass the handle to something that expects a filename
1813 then, on a unix system, use C<"/dev/fd/" . fileno($fh)> for arbitrary
1814 programs, or more generally C<< "+<=&" . fileno($fh) >> for Perl
1815 programs. You will have to clear the close-on-exec bit on that file
1816 descriptor before passing it to another process.
1818 use Fcntl qw/F_SETFD F_GETFD/;
1819 fcntl($tmpfh, F_SETFD, 0)
1820 or die "Can't clear close-on-exec flag on temp fh: $!\n";
1822 =head2 Temporary files and NFS
1824 Some problems are associated with using temporary files that reside
1825 on NFS file systems and it is recommended that a local filesystem
1826 is used whenever possible. Some of the security tests will most probably
1827 fail when the temp file is not local. Additionally, be aware that
1828 the performance of I/O operations over NFS will not be as good as for
1829 a local disk.
1831 =head1 HISTORY
1833 Originally began life in May 1999 as an XS interface to the system
1834 mkstemp() function. In March 2000, the OpenBSD mkstemp() code was
1835 translated to Perl for total control of the code's
1836 security checking, to ensure the presence of the function regardless of
1837 operating system and to help with portability.
1839 =head1 SEE ALSO
1841 L<POSIX/tmpnam>, L<POSIX/tmpfile>, L<File::Spec>, L<File::Path>
1843 See L<IO::File> and L<File::MkTemp> for different implementations of
1844 temporary file handling.
1846 =head1 AUTHOR
1848 Tim Jenness E<lt>t.jenness@jach.hawaii.eduE<gt>
1850 Copyright (C) 1999-2001 Tim Jenness and the UK Particle Physics and
1851 Astronomy Research Council. All Rights Reserved. This program is free
1852 software; you can redistribute it and/or modify it under the same
1853 terms as Perl itself.
1855 Original Perl implementation loosely based on the OpenBSD C code for
1856 mkstemp(). Thanks to Tom Christiansen for suggesting that this module
1857 should be written and providing ideas for code improvements and
1858 security enhancements.
1860 =cut