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