This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
dd0ee9c7ebb839f68145efd7ebd93d2e410c79a7
[perl5.git] / lib / File / Temp.pm
1 package File::Temp;
2
3 =head1 NAME
4
5 File::Temp - return name and handle of a temporary file safely
6
7 =head1 SYNOPSIS
8
9   use File::Temp qw/ tempfile tempdir /; 
10
11   $dir = tempdir( CLEANUP => 1 );
12   ($fh, $filename) = tempfile( DIR => $dir );
13
14   ($fh, $filename) = tempfile( $template, DIR => $dir);
15   ($fh, $filename) = tempfile( $template, SUFFIX => '.dat');
16
17   $fh = tempfile();
18
19 MkTemp family:
20
21   use File::Temp qw/ :mktemp  /;
22
23   ($fh, $file) = mkstemp( "tmpfileXXXXX" );
24   ($fh, $file) = mkstemps( "tmpfileXXXXXX", $suffix);
25
26   $tmpdir = mkdtemp( $template );
27
28   $unopened_file = mktemp( $template );
29
30 POSIX functions:
31
32   use File::Temp qw/ :POSIX /;
33
34   $file = tmpnam();
35   $fh = tmpfile();
36
37   ($fh, $file) = tmpnam();
38   ($fh, $file) = tmpfile();
39
40
41 Compatibility functions:
42
43   $unopened_file = File::Temp::tempnam( $dir, $pfx );
44
45 =begin later
46
47 Objects (NOT YET IMPLEMENTED):
48
49   require File::Temp;
50
51   $fh = new File::Temp($template);
52   $fname = $fh->filename;
53
54 =end later
55
56 =head1 DESCRIPTION
57
58 C<File::Temp> can be used to create and open temporary files in a safe way.
59 The tempfile() function can be used to return the name and the open
60 filehandle of a temporary file.  The tempdir() function can 
61 be used to create a temporary directory.
62
63 The security aspect of temporary file creation is emphasized such that
64 a filehandle and filename are returned together.  This helps guarantee that 
65 a race condition can not occur where the temporary file is created by another process 
66 between checking for the existence of the file and its
67 opening.  Additional security levels are provided to check, for 
68 example, that the sticky bit is set on world writable directories.
69 See L<"safe_level"> for more information.
70
71 For compatibility with popular C library functions, Perl implementations of
72 the mkstemp() family of functions are provided. These are, mkstemp(),
73 mkstemps(), mkdtemp() and mktemp().
74
75 Additionally, implementations of the standard L<POSIX|POSIX>
76 tmpnam() and tmpfile() functions are provided if required.
77
78 Implementations of mktemp(), tmpnam(), and tempnam() are provided,
79 but should be used with caution since they return only a filename
80 that was valid when function was called, so cannot guarantee
81 that the file will not exist by the time the caller opens the filename.
82
83 =cut
84
85 # 5.6.0 gives us S_IWOTH, S_IWGRP, our and auto-vivifying filehandls
86 # People would like a version on 5.005 so give them what they want :-)
87 use 5.005;
88 use strict;
89 use Carp;
90 use File::Spec 0.8;
91 use File::Path qw/ rmtree /;
92 use Fcntl 1.03;
93 use Errno qw( EEXIST ENOENT ENOTDIR EINVAL );
94
95 # Need the Symbol package if we are running older perl 
96 require Symbol if $] < 5.006;
97
98
99 # use 'our' on v5.6.0
100 use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS $DEBUG);
101
102 $DEBUG = 0;
103
104 # We are exporting functions
105
106 use base qw/Exporter/;
107
108 # Export list - to allow fine tuning of export table
109
110 @EXPORT_OK = qw{
111               tempfile
112               tempdir
113               tmpnam
114               tmpfile
115               mktemp
116               mkstemp
117               mkstemps
118               mkdtemp
119               unlink0
120                 };
121
122 # Groups of functions for export
123
124 %EXPORT_TAGS = (
125                 'POSIX' => [qw/ tmpnam tmpfile /],
126                 'mktemp' => [qw/ mktemp mkstemp mkstemps mkdtemp/],
127                );
128
129 # add contents of these tags to @EXPORT
130 Exporter::export_tags('POSIX','mktemp');
131
132 # Version number 
133
134 $VERSION = '0.09';
135
136 # This is a list of characters that can be used in random filenames
137
138 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
139                  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
140                  0 1 2 3 4 5 6 7 8 9 _
141              /);
142
143 # Maximum number of tries to make a temp file before failing
144
145 use constant MAX_TRIES => 10;
146
147 # Minimum number of X characters that should be in a template
148 use constant MINX => 4;
149
150 # Default template when no template supplied
151
152 use constant TEMPXXX => 'X' x 10;
153
154 # Constants for the security level
155
156 use constant STANDARD => 0;
157 use constant MEDIUM   => 1;
158 use constant HIGH     => 2;
159
160 # OPENFLAGS. If we defined the flag to use with Sysopen here this gives
161 # us an optimisation when many temporary files are requested
162
163 my $OPENFLAGS = O_CREAT | O_EXCL | O_RDWR;
164
165 for my $oflag (qw/FOLLOW BINARY LARGEFILE EXLOCK NOINHERIT TEMPORARY/) {
166   my ($bit, $func) = (0, "Fcntl::O_" . $oflag);
167   no strict 'refs';
168   $OPENFLAGS |= $bit if eval { $bit = &$func(); 1 };
169 }
170
171
172
173 # INTERNAL ROUTINES - not to be used outside of package
174
175 # Generic routine for getting a temporary filename
176 # modelled on OpenBSD _gettemp() in mktemp.c
177
178 # The template must contain X's that are to be replaced
179 # with the random values
180
181 #  Arguments:
182
183 #  TEMPLATE   - string containing the XXXXX's that is converted
184 #           to a random filename and opened if required
185
186 # Optionally, a hash can also be supplied containing specific options
187 #   "open" => if true open the temp file, else just return the name
188 #             default is 0
189 #   "mkdir"=> if true, we are creating a temp directory rather than tempfile
190 #             default is 0
191 #   "suffixlen" => number of characters at end of PATH to be ignored.
192 #                  default is 0.
193 # "open" and "mkdir" can not both be true
194
195 # The default options are equivalent to mktemp().
196
197 # Returns:
198 #   filehandle - open file handle (if called with doopen=1, else undef)
199 #   temp name  - name of the temp file or directory
200
201 # For example:
202 #   ($fh, $name) = _gettemp($template, "open" => 1);
203
204 # for the current version, failures are associated with
205 # a carp to give the reason whilst debugging
206
207 sub _gettemp {
208
209   croak 'Usage: ($fh, $name) = _gettemp($template, OPTIONS);'
210     unless scalar(@_) >= 1;
211
212   # Default options
213   my %options = (
214                  "open" => 0,
215                  "mkdir" => 0,
216                  "suffixlen" => 0,
217                 );
218
219   # Read the template
220   my $template = shift;
221   if (ref($template)) {
222     carp "File::Temp::_gettemp: template must not be a reference";
223     return ();
224   }
225
226   # Check that the number of entries on stack are even
227   if (scalar(@_) % 2 != 0) {
228     carp "File::Temp::_gettemp: Must have even number of options";
229     return ();
230   }
231
232   # Read the options and merge with defaults
233   %options = (%options, @_)  if @_;
234
235   # Can not open the file and make a directory in a single call
236   if ($options{"open"} && $options{"mkdir"}) {
237     carp "File::Temp::_gettemp: doopen and domkdir can not both be true\n";
238     return ();
239   }
240
241   # Find the start of the end of the  Xs (position of last X)
242   # Substr starts from 0
243   my $start = length($template) - 1 - $options{"suffixlen"};
244
245   # Check that we have at least MINX x X (eg 'XXXX") at the end of the string
246   # (taking suffixlen into account). Any fewer is insecure.
247
248   # Do it using substr - no reason to use a pattern match since
249   # we know where we are looking and what we are looking for
250
251   if (substr($template, $start - MINX + 1, MINX) ne 'X' x MINX) {
252     carp "File::Temp::_gettemp: The template must contain at least ". MINX ." 'X' characters\n";
253     return ();
254   }
255
256   # Replace all the X at the end of the substring with a
257   # random character or just all the XX at the end of a full string.
258   # Do it as an if, since the suffix adjusts which section to replace
259   # and suffixlen=0 returns nothing if used in the substr directly
260   # and generate a full path from the template
261
262   my $path = _replace_XX($template, $options{"suffixlen"});
263
264
265   # Split the path into constituent parts - eventually we need to check
266   # whether the directory exists
267   # We need to know whether we are making a temp directory
268   # or a tempfile
269
270   my ($volume, $directories, $file);
271   my $parent; # parent directory
272   if ($options{"mkdir"}) {
273     # There is no filename at the end
274     ($volume, $directories, $file) = File::Spec->splitpath( $path, 1);
275
276     # The parent is then $directories without the last directory
277     # Split the directory and put it back together again
278     my @dirs = File::Spec->splitdir($directories);
279
280     # If @dirs only has one entry that means we are in the current
281     # directory
282     if ($#dirs == 0) {
283       $parent = File::Spec->curdir;
284     } else {
285
286       if ($^O eq 'VMS') {  # need volume to avoid relative dir spec
287         $parent = File::Spec->catdir($volume, @dirs[0..$#dirs-1]);
288       } else {
289
290         # Put it back together without the last one
291         $parent = File::Spec->catdir(@dirs[0..$#dirs-1]);
292
293         # ...and attach the volume (no filename)
294         $parent = File::Spec->catpath($volume, $parent, '');
295       }
296
297     }
298
299   } else {
300
301     # Get rid of the last filename (use File::Basename for this?)
302     ($volume, $directories, $file) = File::Spec->splitpath( $path );
303
304     # Join up without the file part
305     $parent = File::Spec->catpath($volume,$directories,'');
306
307     # If $parent is empty replace with curdir
308     $parent = File::Spec->curdir
309       unless $directories ne '';
310
311   }
312
313   # Check that the parent directories exist 
314   # Do this even for the case where we are simply returning a name
315   # not a file -- no point returning a name that includes a directory
316   # that does not exist or is not writable
317
318   unless (-d $parent && -w _) {
319     carp "File::Temp::_gettemp: Parent directory ($parent) is not a directory"
320       . " or is not writable\n";
321       return ();
322   }
323
324   # Check the stickiness of the directory and chown giveaway if required
325   # If the directory is world writable the sticky bit
326   # must be set
327
328   if (File::Temp->safe_level == MEDIUM) {
329     unless (_is_safe($parent)) {
330       carp "File::Temp::_gettemp: Parent directory ($parent) is not safe (sticky bit not set when world writable?)";
331       return ();
332     }
333   } elsif (File::Temp->safe_level == HIGH) {
334     unless (_is_verysafe($parent)) {
335       carp "File::Temp::_gettemp: Parent directory ($parent) is not safe (sticky bit not set when world writable?)";
336       return ();
337     }
338   }
339
340
341   # Calculate the flags that we wish to use for the sysopen
342   # Some of these are not always available
343 #  my $openflags;
344 #  if ($options{"open"}) {
345     # Default set
346 #    $openflags = O_CREAT | O_EXCL | O_RDWR;
347
348 #    for my $oflag (qw/FOLLOW BINARY LARGEFILE EXLOCK NOINHERIT TEMPORARY/) {
349 #        my ($bit, $func) = (0, "Fcntl::O_" . $oflag);
350 #        no strict 'refs';
351 #        $openflags |= $bit if eval { $bit = &$func(); 1 };
352 #    }
353
354 #  }
355
356   # Now try MAX_TRIES time to open the file
357   for (my $i = 0; $i < MAX_TRIES; $i++) {
358
359     # Try to open the file if requested
360     if ($options{"open"}) {
361       my $fh;
362
363       # If we are running before perl5.6.0 we can not auto-vivify
364       if ($] < 5.006) {
365         $fh = &Symbol::gensym;
366       }
367
368       # Try to make sure this will be marked close-on-exec
369       # XXX: Win32 doesn't respect this, nor the proper fcntl,
370       #      but may have O_NOINHERIT. This may or may not be in Fcntl.
371       local $^F = 2; 
372
373       # Store callers umask
374       my $umask = umask();
375
376       # Set a known umask
377       umask(066);
378
379       # Attempt to open the file
380       if ( sysopen($fh, $path, $OPENFLAGS, 0600) ) {
381
382         # Reset umask
383         umask($umask);
384         
385         # Opened successfully - return file handle and name
386         return ($fh, $path);
387
388       } else {
389         # Reset umask
390         umask($umask);
391
392         # Error opening file - abort with error
393         # if the reason was anything but EEXIST
394         unless ($! == EEXIST) {
395           carp "File::Temp: Could not create temp file $path: $!";
396           return ();
397         }
398
399         # Loop round for another try
400         
401       }
402     } elsif ($options{"mkdir"}) {
403
404       # Store callers umask
405       my $umask = umask();
406
407       # Set a known umask
408       umask(066);
409
410       # Open the temp directory
411       if (mkdir( $path, 0700)) {
412         # created okay
413         # Reset umask
414         umask($umask);
415
416         return undef, $path;
417       } else {
418
419         # Reset umask
420         umask($umask);
421
422         # Abort with error if the reason for failure was anything
423         # except EEXIST
424         unless ($! == EEXIST) {
425           carp "File::Temp: Could not create directory $path: $!";
426           return ();
427         }
428
429         # Loop round for another try
430
431       }
432
433     } else {
434
435       # Return true if the file can not be found
436       # Directory has been checked previously
437
438       return (undef, $path) unless -e $path;
439
440       # Try again until MAX_TRIES
441
442     }
443
444     # Did not successfully open the tempfile/dir
445     # so try again with a different set of random letters
446     # No point in trying to increment unless we have only
447     # 1 X say and the randomness could come up with the same
448     # file MAX_TRIES in a row.
449
450     # Store current attempt - in principal this implies that the
451     # 3rd time around the open attempt that the first temp file
452     # name could be generated again. Probably should store each
453     # attempt and make sure that none are repeated
454
455     my $original = $path;
456     my $counter = 0;  # Stop infinite loop
457     my $MAX_GUESS = 50;
458
459     do {
460
461       # Generate new name from original template
462       $path = _replace_XX($template, $options{"suffixlen"});
463
464       $counter++;
465
466     } until ($path ne $original || $counter > $MAX_GUESS);
467
468     # Check for out of control looping
469     if ($counter > $MAX_GUESS) {
470       carp "Tried to get a new temp name different to the previous value $MAX_GUESS times.\nSomething wrong with template?? ($template)";
471       return ();
472     }
473
474   }
475
476   # If we get here, we have run out of tries
477   carp "Have exceeded the maximum number of attempts (".MAX_TRIES .
478     ") to open temp file/dir";
479
480   return ();
481
482 }
483
484 # Internal routine to return a random character from the
485 # character list. Does not do an srand() since rand()
486 # will do one automatically
487
488 # No arguments. Return value is the random character
489
490 # No longer called since _replace_XX runs a few percent faster if
491 # I inline the code. This is important if we are creating thousands of
492 # temporary files.
493
494 sub _randchar {
495
496   $CHARS[ int( rand( $#CHARS ) ) ];
497
498 }
499
500 # Internal routine to replace the XXXX... with random characters
501 # This has to be done by _gettemp() every time it fails to 
502 # open a temp file/dir
503
504 # Arguments:  $template (the template with XXX), 
505 #             $ignore   (number of characters at end to ignore)
506
507 # Returns:    modified template
508
509 sub _replace_XX {
510
511   croak 'Usage: _replace_XX($template, $ignore)'
512     unless scalar(@_) == 2;
513
514   my ($path, $ignore) = @_;
515
516   # Do it as an if, since the suffix adjusts which section to replace
517   # and suffixlen=0 returns nothing if used in the substr directly
518   # Alternatively, could simply set $ignore to length($path)-1
519   # Don't want to always use substr when not required though.
520
521   if ($ignore) {
522     substr($path, 0, - $ignore) =~ s/X(?=X*\z)/$CHARS[ int( rand( $#CHARS ) ) ]/ge;
523   } else {
524     $path =~ s/X(?=X*\z)/$CHARS[ int( rand( $#CHARS ) ) ]/ge;
525   }
526
527   return $path;
528 }
529
530 # internal routine to check to see if the directory is safe
531 # First checks to see if the directory is not owned by the
532 # current user or root. Then checks to see if anyone else
533 # can write to the directory and if so, checks to see if
534 # it has the sticky bit set
535
536 # Will not work on systems that do not support sticky bit
537
538 #Args:  directory path to check
539 # Returns true if the path is safe and false otherwise.
540 # Returns undef if can not even run stat() on the path
541
542 # This routine based on version written by Tom Christiansen
543
544 # Presumably, by the time we actually attempt to create the
545 # file or directory in this directory, it may not be safe
546 # anymore... Have to run _is_safe directly after the open.
547
548 sub _is_safe {
549
550   my $path = shift;
551
552   # Stat path
553   my @info = stat($path);
554   return 0 unless scalar(@info);
555   return 1 if $^O eq 'VMS';  # owner delete control at file level
556
557   # Check to see whether owner is neither superuser (or a system uid) nor me
558   # Use the real uid from the $< variable
559   # UID is in [4]
560   if ( $info[4] > File::Temp->top_system_uid() && $info[4] != $<) {
561     carp "Directory owned neither by root nor the current user";
562     return 0;
563   }
564
565   # check whether group or other can write file
566   # use 066 to detect either reading or writing
567   # use 022 to check writability
568   # Do it with S_IWOTH and S_IWGRP for portability (maybe)
569   # mode is in info[2]
570   if (($info[2] & &Fcntl::S_IWGRP) ||   # Is group writable?
571       ($info[2] & &Fcntl::S_IWOTH) ) {  # Is world writable?
572     return 0 unless -d _;       # Must be a directory
573     return 0 unless -k _;       # Must be sticky
574   }
575
576   return 1;
577 }
578
579 # Internal routine to check whether a directory is safe
580 # for temp files. Safer than _is_safe since it checks for 
581 # the possibility of chown giveaway and if that is a possibility
582 # checks each directory in the path to see if it is safe (with _is_safe)
583
584 # If _PC_CHOWN_RESTRICTED is not set, does the full test of each
585 # directory anyway.
586
587 sub _is_verysafe {
588
589   # Need POSIX - but only want to bother if really necessary due to overhead
590   require POSIX;
591
592   my $path = shift;
593   return 1 if $^O eq 'VMS';  # owner delete control at file level
594
595   # Should Get the value of _PC_CHOWN_RESTRICTED if it is defined
596   # and If it is not there do the extensive test
597   my $chown_restricted;
598   $chown_restricted = &POSIX::_PC_CHOWN_RESTRICTED()
599     if eval { &POSIX::_PC_CHOWN_RESTRICTED(); 1};
600
601   # If chown_resticted is set to some value we should test it
602   if (defined $chown_restricted) {
603
604     # Return if the current directory is safe
605     return _is_safe($path) if POSIX::sysconf( $chown_restricted );
606
607   }
608
609   # To reach this point either, the _PC_CHOWN_RESTRICTED symbol
610   # was not avialable or the symbol was there but chown giveaway
611   # is allowed. Either way, we now have to test the entire tree for
612   # safety.
613
614   # Convert path to an absolute directory if required
615   unless (File::Spec->file_name_is_absolute($path)) {
616     $path = File::Spec->rel2abs($path);
617   }
618
619   # Split directory into components - assume no file
620   my ($volume, $directories, undef) = File::Spec->splitpath( $path, 1);
621
622   # Slightly less efficient than having a a function in File::Spec
623   # to chop off the end of a directory or even a function that
624   # can handle ../ in a directory tree
625   # Sometimes splitdir() returns a blank at the end
626   # so we will probably check the bottom directory twice in some cases
627   my @dirs = File::Spec->splitdir($directories);
628
629   # Concatenate one less directory each time around
630   foreach my $pos (0.. $#dirs) {
631     # Get a directory name
632     my $dir = File::Spec->catpath($volume,
633                                   File::Spec->catdir(@dirs[0.. $#dirs - $pos]),
634                                   ''
635                                   );
636
637     print "TESTING DIR $dir\n" if $DEBUG;
638
639     # Check the directory
640     return 0 unless _is_safe($dir);
641
642   }
643
644   return 1;
645 }
646
647
648
649 # internal routine to determine whether unlink works on this
650 # platform for files that are currently open.
651 # Returns true if we can, false otherwise.
652
653 # Currently WinNT, OS/2 and VMS can not unlink an opened file
654 # On VMS this is because the O_EXCL flag is used to open the
655 # temporary file. Currently I do not know enough about the issues
656 # on VMS to decide whether O_EXCL is a requirement.
657
658 sub _can_unlink_opened_file {
659
660   if ($^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'VMS') {
661     return 0;
662   } else {
663     return 1;
664   }
665
666 }
667
668 # internal routine to decide which security levels are allowed
669 # see safe_level() for more information on this
670
671 # Controls whether the supplied security level is allowed
672
673 #   $cando = _can_do_level( $level )
674
675 sub _can_do_level {
676
677   # Get security level
678   my $level = shift;
679
680   # Always have to be able to do STANDARD
681   return 1 if $level == STANDARD;
682
683   # Currently, the systems that can do HIGH or MEDIUM are identical
684   if ( $^O eq 'MSWin32' || $^O eq 'os2') {
685     return 0;
686   } else {
687     return 1;
688   }
689
690 }
691
692 # This routine sets up a deferred unlinking of a specified
693 # filename and filehandle. It is used in the following cases:
694 #  - Called by unlink0 if an opened file can not be unlinked
695 #  - Called by tempfile() if files are to be removed on shutdown
696 #  - Called by tempdir() if directories are to be removed on shutdown
697
698 # Arguments:
699 #   _deferred_unlink( $fh, $fname, $isdir );
700 #
701 #   - filehandle (so that it can be expclicitly closed if open
702 #   - filename   (the thing we want to remove)
703 #   - isdir      (flag to indicate that we are being given a directory)
704 #                 [and hence no filehandle]
705
706 # Status is not referred to since all the magic is done with and END block
707
708 {
709   # Will set up two lexical variables to contain all the files to be
710   # removed. One array for files, another for directories
711   # They will only exist in this block
712   # This means we only have to set up a single END block to remove all files
713   # @files_to_unlink contains an array ref with the filehandle and filename
714   my (@files_to_unlink, @dirs_to_unlink);
715
716   # Set up an end block to use these arrays
717   END {
718     # Files
719     foreach my $file (@files_to_unlink) {
720       # close the filehandle without checking its state
721       # in order to make real sure that this is closed
722       # if its already closed then I dont care about the answer
723       # probably a better way to do this
724       close($file->[0]);  # file handle is [0]
725
726       if (-f $file->[1]) {  # file name is [1]
727         unlink $file->[1] or warn "Error removing ".$file->[1];
728       }
729     }
730     # Dirs
731     foreach my $dir (@dirs_to_unlink) {
732       if (-d $dir) {
733         rmtree($dir, $DEBUG, 1);
734       }
735     }
736
737
738   }
739
740   # This is the sub called to register a file for deferred unlinking
741   # This could simply store the input parameters and defer everything
742   # until the END block. For now we do a bit of checking at this
743   # point in order to make sure that (1) we have a file/dir to delete
744   # and (2) we have been called with the correct arguments.
745   sub _deferred_unlink {
746
747     croak 'Usage:  _deferred_unlink($fh, $fname, $isdir)'
748       unless scalar(@_) == 3;
749
750     my ($fh, $fname, $isdir) = @_;
751
752     warn "Setting up deferred removal of $fname\n"
753       if $DEBUG;
754
755     # If we have a directory, check that it is a directory
756     if ($isdir) {
757
758       if (-d $fname) {
759
760         # Directory exists so store it
761         push (@dirs_to_unlink, $fname);
762
763       } else {
764         carp "Request to remove directory $fname could not be completed since it does not exists!\n";
765       }
766
767     } else {
768
769       if (-f $fname) {
770
771         # file exists so store handle and name for later removal
772         push(@files_to_unlink, [$fh, $fname]);
773
774       } else {
775         carp "Request to remove file $fname could not be completed since it is not there!\n";
776       }
777
778     }
779
780   }
781
782
783 }
784
785 =head1 FUNCTIONS
786
787 This section describes the recommended interface for generating
788 temporary files and directories.
789
790 =over 4
791
792 =item B<tempfile>
793
794 This is the basic function to generate temporary files.
795 The behaviour of the file can be changed using various options:
796
797   ($fh, $filename) = tempfile();
798
799 Create a temporary file in  the directory specified for temporary
800 files, as specified by the tmpdir() function in L<File::Spec>.
801
802   ($fh, $filename) = tempfile($template);
803
804 Create a temporary file in the current directory using the supplied
805 template.  Trailing `X' characters are replaced with random letters to
806 generate the filename.  At least four `X' characters must be present
807 in the template.
808
809   ($fh, $filename) = tempfile($template, SUFFIX => $suffix)
810
811 Same as previously, except that a suffix is added to the template
812 after the `X' translation.  Useful for ensuring that a temporary
813 filename has a particular extension when needed by other applications.
814 But see the WARNING at the end.
815
816   ($fh, $filename) = tempfile($template, DIR => $dir);
817
818 Translates the template as before except that a directory name
819 is specified.
820
821 If the template is not specified, a template is always
822 automatically generated. This temporary file is placed in tmpdir()
823 (L<File::Spec>) unless a directory is specified explicitly with the 
824 DIR option.
825
826   $fh = tempfile( $template, DIR => $dir );
827
828 If called in scalar context, only the filehandle is returned
829 and the file will automatically be deleted when closed (see 
830 the description of tmpfile() elsewhere in this document).
831 This is the preferred mode of operation, as if you only 
832 have a filehandle, you can never create a race condition
833 by fumbling with the filename. On systems that can not unlink
834 an open file (for example, Windows NT) the file is marked for
835 deletion when the program ends (equivalent to setting UNLINK to 1).
836
837   (undef, $filename) = tempfile($template, OPEN => 0);
838
839 This will return the filename based on the template but
840 will not open this file.  Cannot be used in conjunction with
841 UNLINK set to true. Default is to always open the file 
842 to protect from possible race conditions. A warning is issued
843 if warnings are turned on. Consider using the tmpnam()
844 and mktemp() functions described elsewhere in this document
845 if opening the file is not required.
846
847 =cut
848
849 sub tempfile {
850
851   # Can not check for argument count since we can have any
852   # number of args
853
854   # Default options
855   my %options = (
856                  "DIR"    => undef,  # Directory prefix
857                  "SUFFIX" => '',      # Template suffix
858                  "UNLINK" => 0,      # Unlink file on exit
859                  "OPEN"   => 1,      # Do not open file
860                 );
861
862   # Check to see whether we have an odd or even number of arguments
863   my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef);
864
865   # Read the options and merge with defaults
866   %options = (%options, @_)  if @_;
867
868   # First decision is whether or not to open the file
869   if (! $options{"OPEN"}) {
870
871     warn "tempfile(): temporary filename requested but not opened.\nPossibly unsafe, consider using tempfile() with OPEN set to true\n"
872       if $^W;
873
874   }
875
876   # Construct the template
877
878   # Have a choice of trying to work around the mkstemp/mktemp/tmpnam etc
879   # functions or simply constructing a template and using _gettemp()
880   # explicitly. Go for the latter
881
882   # First generate a template if not defined and prefix the directory
883   # If no template must prefix the temp directory
884   if (defined $template) {
885     if ($options{"DIR"}) {
886
887       $template = File::Spec->catfile($options{"DIR"}, $template);
888
889     }
890
891   } else {
892
893     if ($options{"DIR"}) {
894
895       $template = File::Spec->catfile($options{"DIR"}, TEMPXXX);
896
897     } else {
898
899       $template = File::Spec->catfile(File::Spec->tmpdir, TEMPXXX);
900
901     }
902
903   }
904
905   # Now add a suffix
906   $template .= $options{"SUFFIX"};
907
908   # Create the file
909   my ($fh, $path);
910   croak "Error in tempfile() using $template"
911     unless (($fh, $path) = _gettemp($template,
912                                     "open" => $options{'OPEN'}, 
913                                     "mkdir"=> 0 ,
914                                     "suffixlen" => length($options{'SUFFIX'}),
915                                    ) );
916
917   # Set up an exit handler that can do whatever is right for the
918   # system. Do not check return status since this is all done with
919   # END blocks
920   _deferred_unlink($fh, $path, 0) if $options{"UNLINK"};
921
922   # Return
923   if (wantarray()) {
924
925     if ($options{'OPEN'}) {
926       return ($fh, $path);
927     } else {
928       return (undef, $path);
929     }
930
931   } else {
932
933     # Unlink the file. It is up to unlink0 to decide what to do with
934     # this (whether to unlink now or to defer until later)
935     unlink0($fh, $path) or croak "Error unlinking file $path using unlink0";
936
937     # Return just the filehandle.
938     return $fh;
939   }
940
941
942 }
943
944 =item B<tempdir>
945
946 This is the recommended interface for creation of temporary directories.
947 The behaviour of the function depends on the arguments:
948
949   $tempdir = tempdir();
950
951 Create a directory in tmpdir() (see L<File::Spec|File::Spec>).
952
953   $tempdir = tempdir( $template );
954
955 Create a directory from the supplied template. This template is
956 similar to that described for tempfile(). `X' characters at the end
957 of the template are replaced with random letters to construct the
958 directory name. At least four `X' characters must be in the template.
959
960   $tempdir = tempdir ( DIR => $dir );
961
962 Specifies the directory to use for the temporary directory.
963 The temporary directory name is derived from an internal template.
964
965   $tempdir = tempdir ( $template, DIR => $dir );
966
967 Prepend the supplied directory name to the template. The template
968 should not include parent directory specifications itself. Any parent
969 directory specifications are removed from the template before
970 prepending the supplied directory.
971
972   $tempdir = tempdir ( $template, TMPDIR => 1 );
973
974 Using the supplied template, creat the temporary directory in 
975 a standard location for temporary files. Equivalent to doing
976
977   $tempdir = tempdir ( $template, DIR => File::Spec->tmpdir);
978
979 but shorter. Parent directory specifications are stripped from the
980 template itself. The C<TMPDIR> option is ignored if C<DIR> is set
981 explicitly.  Additionally, C<TMPDIR> is implied if neither a template
982 nor a directory are supplied.
983
984   $tempdir = tempdir( $template, CLEANUP => 1);
985
986 Create a temporary directory using the supplied template, but 
987 attempt to remove it (and all files inside it) when the program
988 exits. Note that an attempt will be made to remove all files from
989 the directory even if they were not created by this module (otherwise
990 why ask to clean it up?). The directory removal is made with
991 the rmtree() function from the L<File::Path|File::Path> module.
992 Of course, if the template is not specified, the temporary directory
993 will be created in tmpdir() and will also be removed at program exit.
994
995 =cut
996
997 # '
998
999 sub tempdir  {
1000
1001   # Can not check for argument count since we can have any
1002   # number of args
1003
1004   # Default options
1005   my %options = (
1006                  "CLEANUP"    => 0,  # Remove directory on exit
1007                  "DIR"        => '', # Root directory
1008                  "TMPDIR"     => 0,  # Use tempdir with template
1009                 );
1010
1011   # Check to see whether we have an odd or even number of arguments
1012   my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef );
1013
1014   # Read the options and merge with defaults
1015   %options = (%options, @_)  if @_;
1016
1017   # Modify or generate the template
1018
1019   # Deal with the DIR and TMPDIR options
1020   if (defined $template) {
1021
1022     # Need to strip directory path if using DIR or TMPDIR
1023     if ($options{'TMPDIR'} || $options{'DIR'}) {
1024
1025       # Strip parent directory from the filename
1026       # 
1027       # There is no filename at the end
1028       my ($volume, $directories, undef) = File::Spec->splitpath( $template, 1);
1029
1030       # Last directory is then our template
1031       $template = (File::Spec->splitdir($directories))[-1];
1032
1033       # Prepend the supplied directory or temp dir
1034       if ($options{"DIR"}) {
1035
1036         $template = File::Spec->catfile($options{"DIR"}, $template);
1037
1038       } elsif ($options{TMPDIR}) {
1039
1040         # Prepend tmpdir
1041         $template = File::Spec->catdir(File::Spec->tmpdir, $template);
1042
1043       }
1044
1045     }
1046
1047   } else {
1048
1049     if ($options{"DIR"}) {
1050
1051       $template = File::Spec->catdir($options{"DIR"}, TEMPXXX);
1052
1053     } else {
1054
1055       $template = File::Spec->catdir(File::Spec->tmpdir, TEMPXXX);
1056
1057     }
1058
1059   }
1060
1061   # Create the directory
1062   my $tempdir;
1063   my $suffixlen = 0;
1064   if ($^O eq 'VMS') {  # dir names can end in delimiters
1065     $template =~ m/([\.\]:>]+)$/;
1066     $suffixlen = length($1);
1067   }
1068   croak "Error in tempdir() using $template"
1069     unless ((undef, $tempdir) = _gettemp($template,
1070                                     "open" => 0,
1071                                     "mkdir"=> 1 ,
1072                                     "suffixlen" => $suffixlen,
1073                                    ) );
1074
1075   # Install exit handler; must be dynamic to get lexical
1076   if ( $options{'CLEANUP'} && -d $tempdir) {
1077     _deferred_unlink(undef, $tempdir, 1);
1078   }
1079
1080   # Return the dir name
1081   return $tempdir;
1082
1083 }
1084
1085 =back
1086
1087 =head1 MKTEMP FUNCTIONS
1088
1089 The following functions are Perl implementations of the 
1090 mktemp() family of temp file generation system calls.
1091
1092 =over 4
1093
1094 =item B<mkstemp>
1095
1096 Given a template, returns a filehandle to the temporary file and the name
1097 of the file.
1098
1099   ($fh, $name) = mkstemp( $template );
1100
1101 In scalar context, just the filehandle is returned.
1102
1103 The template may be any filename with some number of X's appended
1104 to it, for example F</tmp/temp.XXXX>. The trailing X's are replaced
1105 with unique alphanumeric combinations.
1106
1107 =cut
1108
1109
1110
1111 sub mkstemp {
1112
1113   croak "Usage: mkstemp(template)"
1114     if scalar(@_) != 1;
1115
1116   my $template = shift;
1117
1118   my ($fh, $path);
1119   croak "Error in mkstemp using $template"
1120     unless (($fh, $path) = _gettemp($template,
1121                                     "open" => 1,
1122                                     "mkdir"=> 0 ,
1123                                     "suffixlen" => 0,
1124                                    ) );
1125
1126   if (wantarray()) {
1127     return ($fh, $path);
1128   } else {
1129     return $fh;
1130   }
1131
1132 }
1133
1134
1135 =item B<mkstemps>
1136
1137 Similar to mkstemp(), except that an extra argument can be supplied
1138 with a suffix to be appended to the template.
1139
1140   ($fh, $name) = mkstemps( $template, $suffix );
1141
1142 For example a template of C<testXXXXXX> and suffix of C<.dat>
1143 would generate a file similar to F<testhGji_w.dat>.
1144
1145 Returns just the filehandle alone when called in scalar context.
1146
1147 =cut
1148
1149 sub mkstemps {
1150
1151   croak "Usage: mkstemps(template, suffix)"
1152     if scalar(@_) != 2;
1153
1154
1155   my $template = shift;
1156   my $suffix   = shift;
1157
1158   $template .= $suffix;
1159
1160   my ($fh, $path);
1161   croak "Error in mkstemps using $template"
1162     unless (($fh, $path) = _gettemp($template,
1163                                     "open" => 1, 
1164                                     "mkdir"=> 0 ,
1165                                     "suffixlen" => length($suffix),
1166                                    ) );
1167
1168   if (wantarray()) {
1169     return ($fh, $path);
1170   } else {
1171     return $fh;
1172   }
1173
1174 }
1175
1176 =item B<mkdtemp>
1177
1178 Create a directory from a template. The template must end in
1179 X's that are replaced by the routine.
1180
1181   $tmpdir_name = mkdtemp($template);
1182
1183 Returns the name of the temporary directory created.
1184 Returns undef on failure.
1185
1186 Directory must be removed by the caller.
1187
1188 =cut
1189
1190 #' # for emacs
1191
1192 sub mkdtemp {
1193
1194   croak "Usage: mkdtemp(template)"
1195     if scalar(@_) != 1;
1196
1197   my $template = shift;
1198   my $suffixlen = 0;
1199   if ($^O eq 'VMS') {  # dir names can end in delimiters
1200     $template =~ m/([\.\]:>]+)$/;
1201     $suffixlen = length($1);
1202   }
1203   my ($junk, $tmpdir);
1204   croak "Error creating temp directory from template $template\n"
1205     unless (($junk, $tmpdir) = _gettemp($template,
1206                                         "open" => 0,
1207                                         "mkdir"=> 1 ,
1208                                         "suffixlen" => $suffixlen,
1209                                        ) );
1210
1211   return $tmpdir;
1212
1213 }
1214
1215 =item B<mktemp>
1216
1217 Returns a valid temporary filename but does not guarantee
1218 that the file will not be opened by someone else.
1219
1220   $unopened_file = mktemp($template);
1221
1222 Template is the same as that required by mkstemp().
1223
1224 =cut
1225
1226 sub mktemp {
1227
1228   croak "Usage: mktemp(template)"
1229     if scalar(@_) != 1;
1230
1231   my $template = shift;
1232
1233   my ($tmpname, $junk);
1234   croak "Error getting name to temp file from template $template\n"
1235     unless (($junk, $tmpname) = _gettemp($template,
1236                                          "open" => 0,
1237                                          "mkdir"=> 0 ,
1238                                          "suffixlen" => 0,
1239                                          ) );
1240
1241   return $tmpname;
1242 }
1243
1244 =back
1245
1246 =head1 POSIX FUNCTIONS
1247
1248 This section describes the re-implementation of the tmpnam()
1249 and tmpfile() functions described in L<POSIX> 
1250 using the mkstemp() from this module.
1251
1252 Unlike the L<POSIX|POSIX> implementations, the directory used
1253 for the temporary file is not specified in a system include
1254 file (C<P_tmpdir>) but simply depends on the choice of tmpdir()
1255 returned by L<File::Spec|File::Spec>. On some implementations this
1256 location can be set using the C<TMPDIR> environment variable, which
1257 may not be secure.
1258 If this is a problem, simply use mkstemp() and specify a template.
1259
1260 =over 4
1261
1262 =item B<tmpnam>
1263
1264 When called in scalar context, returns the full name (including path)
1265 of a temporary file (uses mktemp()). The only check is that the file does
1266 not already exist, but there is no guarantee that that condition will
1267 continue to apply.
1268
1269   $file = tmpnam();
1270
1271 When called in list context, a filehandle to the open file and
1272 a filename are returned. This is achieved by calling mkstemp()
1273 after constructing a suitable template.
1274
1275   ($fh, $file) = tmpnam();
1276
1277 If possible, this form should be used to prevent possible
1278 race conditions.
1279
1280 See L<File::Spec/tmpdir> for information on the choice of temporary
1281 directory for a particular operating system.
1282
1283 =cut
1284
1285 sub tmpnam {
1286
1287    # Retrieve the temporary directory name
1288    my $tmpdir = File::Spec->tmpdir;
1289
1290    croak "Error temporary directory is not writable"
1291      if $tmpdir eq '';
1292
1293    # Use a ten character template and append to tmpdir
1294    my $template = File::Spec->catfile($tmpdir, TEMPXXX);
1295
1296    if (wantarray() ) {
1297        return mkstemp($template);
1298    } else {
1299        return mktemp($template);
1300    }
1301
1302 }
1303
1304 =item B<tmpfile>
1305
1306 In scalar context, returns the filehandle of a temporary file.
1307
1308   $fh = tmpfile();
1309
1310 The file is removed when the filehandle is closed or when the program
1311 exits. No access to the filename is provided.
1312
1313 =cut
1314
1315 sub tmpfile {
1316
1317   # Simply call tmpnam() in an array context
1318   my ($fh, $file) = tmpnam();
1319
1320   # Make sure file is removed when filehandle is closed
1321   unlink0($fh, $file) or croak "Unable to unlink temporary file: $!";
1322
1323   return $fh;
1324
1325 }
1326
1327 =back
1328
1329 =head1 ADDITIONAL FUNCTIONS
1330
1331 These functions are provided for backwards compatibility
1332 with common tempfile generation C library functions.
1333
1334 They are not exported and must be addressed using the full package
1335 name. 
1336
1337 =over 4
1338
1339 =item B<tempnam>
1340
1341 Return the name of a temporary file in the specified directory
1342 using a prefix. The file is guaranteed not to exist at the time
1343 the function was called, but such guarantees are good for one 
1344 clock tick only.  Always use the proper form of C<sysopen>
1345 with C<O_CREAT | O_EXCL> if you must open such a filename.
1346
1347   $filename = File::Temp::tempnam( $dir, $prefix );
1348
1349 Equivalent to running mktemp() with $dir/$prefixXXXXXXXX
1350 (using unix file convention as an example) 
1351
1352 Because this function uses mktemp(), it can suffer from race conditions.
1353
1354 =cut
1355
1356 sub tempnam {
1357
1358   croak 'Usage tempnam($dir, $prefix)' unless scalar(@_) == 2;
1359
1360   my ($dir, $prefix) = @_;
1361
1362   # Add a string to the prefix
1363   $prefix .= 'XXXXXXXX';
1364
1365   # Concatenate the directory to the file
1366   my $template = File::Spec->catfile($dir, $prefix);
1367
1368   return mktemp($template);
1369
1370 }
1371
1372 =back
1373
1374 =head1 UTILITY FUNCTIONS
1375
1376 Useful functions for dealing with the filehandle and filename.
1377
1378 =over 4
1379
1380 =item B<unlink0>
1381
1382 Given an open filehandle and the associated filename, make a safe
1383 unlink. This is achieved by first checking that the filename and
1384 filehandle initially point to the same file and that the number of
1385 links to the file is 1 (all fields returned by stat() are compared).
1386 Then the filename is unlinked and the filehandle checked once again to
1387 verify that the number of links on that file is now 0.  This is the
1388 closest you can come to making sure that the filename unlinked was the
1389 same as the file whose descriptor you hold.
1390
1391   unlink0($fh, $path) or die "Error unlinking file $path safely";
1392
1393 Returns false on error. The filehandle is not closed since on some
1394 occasions this is not required.
1395
1396 On some platforms, for example Windows NT, it is not possible to
1397 unlink an open file (the file must be closed first). On those
1398 platforms, the actual unlinking is deferred until the program ends and
1399 good status is returned. A check is still performed to make sure that
1400 the filehandle and filename are pointing to the same thing (but not at
1401 the time the end block is executed since the deferred removal may not
1402 have access to the filehandle).
1403
1404 Additionally, on Windows NT not all the fields returned by stat() can
1405 be compared. For example, the C<dev> and C<rdev> fields seem to be different
1406 and also. Also, it seems that the size of the file returned by stat()
1407 does not always agree, with C<stat(FH)> being more accurate than
1408 C<stat(filename)>, presumably because of caching issues even when
1409 using autoflush (this is usually overcome by waiting a while after
1410 writing to the tempfile before attempting to C<unlink0> it).
1411
1412 Finally, on NFS file systems the link count of the file handle does
1413 not always go to zero immediately after unlinking. Currently, this
1414 command is expected to fail on NFS disks.
1415
1416 =cut
1417
1418 sub unlink0 {
1419
1420   croak 'Usage: unlink0(filehandle, filename)'
1421     unless scalar(@_) == 2;
1422
1423   # Read args
1424   my ($fh, $path) = @_;
1425
1426   warn "Unlinking $path using unlink0\n"
1427     if $DEBUG;
1428
1429   # Stat the filehandle
1430   my @fh = stat $fh;
1431
1432   if ($fh[3] > 1 && $^W) {
1433     carp "unlink0: fstat found too many links; SB=@fh";
1434   }
1435
1436   # Stat the path
1437   my @path = stat $path;
1438
1439   unless (@path) {
1440     carp "unlink0: $path is gone already" if $^W;
1441     return;
1442   }
1443
1444   # this is no longer a file, but may be a directory, or worse
1445   unless (-f _) {
1446     confess "panic: $path is no longer a file: SB=@fh";
1447   }
1448
1449   # Do comparison of each member of the array
1450   # On WinNT dev and rdev seem to be different
1451   # depending on whether it is a file or a handle.
1452   # Cannot simply compare all members of the stat return
1453   # Select the ones we can use
1454   my @okstat = (0..$#fh);  # Use all by default
1455   if ($^O eq 'MSWin32') {
1456     @okstat = (1,2,3,4,5,7,8,9,10);
1457   }  elsif ($^O eq 'VMS') {
1458     @okstat = (0,1,2,3,4,5,7,8,9,10);
1459   } elsif ($^O eq 'os2') {
1460     @okstat = (0, 2..10, 13..$#fh);
1461   }
1462
1463   # Now compare each entry explicitly by number
1464   for (@okstat) {
1465     print "Comparing: $_ : $fh[$_] and $path[$_]\n" if $DEBUG;
1466     # Use eq rather than == since on OS/2 elements 11 and 12 return
1467     # the empty string rather than a null. This is fine since we
1468     # are only comparing integers.
1469     unless ($fh[$_] eq $path[$_]) {
1470       warn "Did not match $_ element of stat\n" if $DEBUG;
1471       return 0;
1472     }
1473   }
1474
1475   # attempt remove the file (does not work on some platforms)
1476   if (_can_unlink_opened_file()) {
1477     # XXX: do *not* call this on a directory; possible race
1478     #      resulting in recursive removal
1479     croak "unlink0: $path has become a directory!" if -d $path;
1480     unlink($path) or return 0;
1481
1482     # Stat the filehandle
1483     @fh = stat $fh;
1484
1485     print "Link count = $fh[3] \n" if $DEBUG;
1486
1487     # Make sure that the link count is zero
1488     return ( $fh[3] == 0 ? 1 : 0);
1489
1490   } else {
1491     _deferred_unlink($fh, $path, 0);
1492     return 1;
1493   }
1494
1495 }
1496
1497 =back
1498
1499 =head1 PACKAGE VARIABLES
1500
1501 These functions control the global state of the package.
1502
1503 =over 4
1504
1505 =item B<safe_level>
1506
1507 Controls the lengths to which the module will go to check the safety of the
1508 temporary file or directory before proceeding.
1509 Options are:
1510
1511 =over 8
1512
1513 =item STANDARD
1514
1515 Do the basic security measures to ensure the directory exists and
1516 is writable, that the umask() is fixed before opening of the file,
1517 that temporary files are opened only if they do not already exist, and
1518 that possible race conditions are avoided.  Finally the L<unlink0|"unlink0">
1519 function is used to remove files safely.
1520
1521 =item MEDIUM
1522
1523 In addition to the STANDARD security, the output directory is checked
1524 to make sure that it is owned either by root or the user running the
1525 program. If the directory is writable by group or by other, it is then
1526 checked to make sure that the sticky bit is set.
1527
1528 Will not work on platforms that do not support the C<-k> test
1529 for sticky bit.
1530
1531 =item HIGH
1532
1533 In addition to the MEDIUM security checks, also check for the
1534 possibility of ``chown() giveaway'' using the L<POSIX|POSIX>
1535 sysconf() function. If this is a possibility, each directory in the
1536 path is checked in turn for safeness, recursively walking back to the 
1537 root directory.
1538
1539 For platforms that do not support the L<POSIX|POSIX>
1540 C<_PC_CHOWN_RESTRICTED> symbol (for example, Windows NT) it is 
1541 assumed that ``chown() giveaway'' is possible and the recursive test
1542 is performed.
1543
1544 =back
1545
1546 The level can be changed as follows:
1547
1548   File::Temp->safe_level( File::Temp::HIGH );
1549
1550 The level constants are not exported by the module.
1551
1552 Currently, you must be running at least perl v5.6.0 in order to
1553 run with MEDIUM or HIGH security. This is simply because the 
1554 safety tests use functions from L<Fcntl|Fcntl> that are not
1555 available in older versions of perl. The problem is that the version
1556 number for Fcntl is the same in perl 5.6.0 and in 5.005_03 even though
1557 they are different versions.
1558
1559 On systems that do not support the HIGH or MEDIUM safety levels
1560 (for example Win NT or OS/2) any attempt to change the level will
1561 be ignored. The decision to ignore rather than raise an exception
1562 allows portable programs to be written with high security in mind
1563 for the systems that can support this without those programs failing
1564 on systems where the extra tests are irrelevant.
1565
1566 If you really need to see whether the change has been accepted
1567 simply examine the return value of C<safe_level>.
1568
1569   $newlevel = File::Temp->safe_level( File::Temp::HIGH );
1570   die "Could not change to high security" 
1571       if $newlevel != File::Temp::HIGH;
1572
1573 =cut
1574
1575 {
1576   # protect from using the variable itself
1577   my $LEVEL = STANDARD;
1578   sub safe_level {
1579     my $self = shift;
1580     if (@_) { 
1581       my $level = shift;
1582       if (($level != STANDARD) && ($level != MEDIUM) && ($level != HIGH)) {
1583         carp "safe_level: Specified level ($level) not STANDARD, MEDIUM or HIGH - ignoring\n";
1584       } else {
1585         # Dont allow this on perl 5.005 or earlier
1586         if ($] < 5.006 && $level != STANDARD) {
1587           # Cant do MEDIUM or HIGH checks
1588           croak "Currently requires perl 5.006 or newer to do the safe checks";
1589         }
1590         # Check that we are allowed to change level
1591         # Silently ignore if we can not.
1592         $LEVEL = $level if _can_do_level($level);
1593       }
1594     }
1595     return $LEVEL;
1596   }
1597 }
1598
1599 =item TopSystemUID
1600
1601 This is the highest UID on the current system that refers to a root
1602 UID. This is used to make sure that the temporary directory is 
1603 owned by a system UID (C<root>, C<bin>, C<sys> etc) rather than 
1604 simply by root.
1605
1606 This is required since on many unix systems C</tmp> is not owned
1607 by root.
1608
1609 Default is to assume that any UID less than or equal to 10 is a root
1610 UID.
1611
1612   File::Temp->top_system_uid(10);
1613   my $topid = File::Temp->top_system_uid;
1614
1615 This value can be adjusted to reduce security checking if required.
1616 The value is only relevant when C<safe_level> is set to MEDIUM or higher.
1617
1618 =back
1619
1620 =cut
1621
1622 {
1623   my $TopSystemUID = 10;
1624   sub top_system_uid {
1625     my $self = shift;
1626     if (@_) {
1627       my $newuid = shift;
1628       croak "top_system_uid: UIDs should be numeric"
1629         unless $newuid =~ /^\d+$/s;
1630       $TopSystemUID = $newuid;
1631     }
1632     return $TopSystemUID;
1633   }
1634 }
1635
1636 =head1 WARNING
1637
1638 For maximum security, endeavour always to avoid ever looking at,
1639 touching, or even imputing the existence of the filename.  You do not
1640 know that that filename is connected to the same file as the handle
1641 you have, and attempts to check this can only trigger more race
1642 conditions.  It's far more secure to use the filehandle alone and
1643 dispense with the filename altogether.
1644
1645 If you need to pass the handle to something that expects a filename
1646 then, on a unix system, use C<"/dev/fd/" . fileno($fh)> for arbitrary
1647 programs, or more generally C<< "+<=&" . fileno($fh) >> for Perl
1648 programs.  You will have to clear the close-on-exec bit on that file
1649 descriptor before passing it to another process.
1650
1651     use Fcntl qw/F_SETFD F_GETFD/;
1652     fcntl($tmpfh, F_SETFD, 0)
1653         or die "Can't clear close-on-exec flag on temp fh: $!\n";
1654
1655 =head1 HISTORY
1656
1657 Originally began life in May 1999 as an XS interface to the system
1658 mkstemp() function. In March 2000, the mkstemp() code was
1659 translated to Perl for total control of the code's
1660 security checking, to ensure the presence of the function regardless of
1661 operating system and to help with portability.
1662
1663 =head1 SEE ALSO
1664
1665 L<POSIX/tmpnam>, L<POSIX/tmpfile>, L<File::Spec>, L<File::Path>
1666
1667 See L<File::MkTemp> for a different implementation of temporary
1668 file handling.
1669
1670 =head1 AUTHOR
1671
1672 Tim Jenness E<lt>t.jenness@jach.hawaii.eduE<gt>
1673
1674 Copyright (C) 1999, 2000 Tim Jenness and the UK Particle Physics and
1675 Astronomy Research Council. All Rights Reserved.  This program is free
1676 software; you can redistribute it and/or modify it under the same
1677 terms as Perl itself.
1678
1679 Original Perl implementation loosely based on the OpenBSD C code for 
1680 mkstemp(). Thanks to Tom Christiansen for suggesting that this module
1681 should be written and providing ideas for code improvements and
1682 security enhancements.
1683
1684 =cut
1685
1686
1687 1;