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