This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
2dd3102f562a3fc4fe1afc739995f8d8324ab8b5
[perl5.git] / cpan / File-Temp / lib / File / Temp.pm
1 package File::Temp;
2 # ABSTRACT: return name and handle of a temporary file safely
3 our $VERSION = '0.2301'; # VERSION
4
5
6 # 5.6.0 gives us S_IWOTH, S_IWGRP, our and auto-vivifying filehandls
7 # People would like a version on 5.004 so give them what they want :-)
8 use 5.004;
9 use strict;
10 use Carp;
11 use File::Spec 0.8;
12 use Cwd ();
13 use File::Path qw/ rmtree /;
14 use Fcntl 1.03;
15 use IO::Seekable;               # For SEEK_*
16 use Errno;
17 use Scalar::Util 'refaddr';
18 require VMS::Stdio if $^O eq 'VMS';
19
20 # pre-emptively load Carp::Heavy. If we don't when we run out of file
21 # handles and attempt to call croak() we get an error message telling
22 # us that Carp::Heavy won't load rather than an error telling us we
23 # have run out of file handles. We either preload croak() or we
24 # switch the calls to croak from _gettemp() to use die.
25 eval { require Carp::Heavy; };
26
27 # Need the Symbol package if we are running older perl
28 require Symbol if $] < 5.006;
29
30 ### For the OO interface
31 use base qw/ IO::Handle IO::Seekable /;
32 use overload '""' => "STRINGIFY", '0+' => "NUMIFY",
33   fallback => 1;
34
35 # use 'our' on v5.6.0
36 use vars qw(@EXPORT_OK %EXPORT_TAGS $DEBUG $KEEP_ALL);
37
38 $DEBUG = 0;
39 $KEEP_ALL = 0;
40
41 # We are exporting functions
42
43 use base qw/Exporter/;
44
45 # Export list - to allow fine tuning of export table
46
47 @EXPORT_OK = qw{
48                  tempfile
49                  tempdir
50                  tmpnam
51                  tmpfile
52                  mktemp
53                  mkstemp
54                  mkstemps
55                  mkdtemp
56                  unlink0
57                  cleanup
58                  SEEK_SET
59                  SEEK_CUR
60                  SEEK_END
61              };
62
63 # Groups of functions for export
64
65 %EXPORT_TAGS = (
66                 'POSIX' => [qw/ tmpnam tmpfile /],
67                 'mktemp' => [qw/ mktemp mkstemp mkstemps mkdtemp/],
68                 'seekable' => [qw/ SEEK_SET SEEK_CUR SEEK_END /],
69                );
70
71 # add contents of these tags to @EXPORT
72 Exporter::export_tags('POSIX','mktemp','seekable');
73
74 # This is a list of characters that can be used in random filenames
75
76 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
77                  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
78                  0 1 2 3 4 5 6 7 8 9 _
79                /);
80
81 # Maximum number of tries to make a temp file before failing
82
83 use constant MAX_TRIES => 1000;
84
85 # Minimum number of X characters that should be in a template
86 use constant MINX => 4;
87
88 # Default template when no template supplied
89
90 use constant TEMPXXX => 'X' x 10;
91
92 # Constants for the security level
93
94 use constant STANDARD => 0;
95 use constant MEDIUM   => 1;
96 use constant HIGH     => 2;
97
98 # OPENFLAGS. If we defined the flag to use with Sysopen here this gives
99 # us an optimisation when many temporary files are requested
100
101 my $OPENFLAGS = O_CREAT | O_EXCL | O_RDWR;
102 my $LOCKFLAG;
103
104 unless ($^O eq 'MacOS') {
105   for my $oflag (qw/ NOFOLLOW BINARY LARGEFILE NOINHERIT /) {
106     my ($bit, $func) = (0, "Fcntl::O_" . $oflag);
107     no strict 'refs';
108     $OPENFLAGS |= $bit if eval {
109       # Make sure that redefined die handlers do not cause problems
110       # e.g. CGI::Carp
111       local $SIG{__DIE__} = sub {};
112       local $SIG{__WARN__} = sub {};
113       $bit = &$func();
114       1;
115     };
116   }
117   # Special case O_EXLOCK
118   $LOCKFLAG = eval {
119     local $SIG{__DIE__} = sub {};
120     local $SIG{__WARN__} = sub {};
121     &Fcntl::O_EXLOCK();
122   };
123 }
124
125 # On some systems the O_TEMPORARY flag can be used to tell the OS
126 # to automatically remove the file when it is closed. This is fine
127 # in most cases but not if tempfile is called with UNLINK=>0 and
128 # the filename is requested -- in the case where the filename is to
129 # be passed to another routine. This happens on windows. We overcome
130 # this by using a second open flags variable
131
132 my $OPENTEMPFLAGS = $OPENFLAGS;
133 unless ($^O eq 'MacOS') {
134   for my $oflag (qw/ TEMPORARY /) {
135     my ($bit, $func) = (0, "Fcntl::O_" . $oflag);
136     local($@);
137     no strict 'refs';
138     $OPENTEMPFLAGS |= $bit if eval {
139       # Make sure that redefined die handlers do not cause problems
140       # e.g. CGI::Carp
141       local $SIG{__DIE__} = sub {};
142       local $SIG{__WARN__} = sub {};
143       $bit = &$func();
144       1;
145     };
146   }
147 }
148
149 # Private hash tracking which files have been created by each process id via the OO interface
150 my %FILES_CREATED_BY_OBJECT;
151
152 # INTERNAL ROUTINES - not to be used outside of package
153
154 # Generic routine for getting a temporary filename
155 # modelled on OpenBSD _gettemp() in mktemp.c
156
157 # The template must contain X's that are to be replaced
158 # with the random values
159
160 #  Arguments:
161
162 #  TEMPLATE   - string containing the XXXXX's that is converted
163 #           to a random filename and opened if required
164
165 # Optionally, a hash can also be supplied containing specific options
166 #   "open" => if true open the temp file, else just return the name
167 #             default is 0
168 #   "mkdir"=> if true, we are creating a temp directory rather than tempfile
169 #             default is 0
170 #   "suffixlen" => number of characters at end of PATH to be ignored.
171 #                  default is 0.
172 #   "unlink_on_close" => indicates that, if possible,  the OS should remove
173 #                        the file as soon as it is closed. Usually indicates
174 #                        use of the O_TEMPORARY flag to sysopen.
175 #                        Usually irrelevant on unix
176 #   "use_exlock" => Indicates that O_EXLOCK should be used. Default is true.
177
178 # Optionally a reference to a scalar can be passed into the function
179 # On error this will be used to store the reason for the error
180 #   "ErrStr"  => \$errstr
181
182 # "open" and "mkdir" can not both be true
183 # "unlink_on_close" is not used when "mkdir" is true.
184
185 # The default options are equivalent to mktemp().
186
187 # Returns:
188 #   filehandle - open file handle (if called with doopen=1, else undef)
189 #   temp name  - name of the temp file or directory
190
191 # For example:
192 #   ($fh, $name) = _gettemp($template, "open" => 1);
193
194 # for the current version, failures are associated with
195 # stored in an error string and returned to give the reason whilst debugging
196 # This routine is not called by any external function
197 sub _gettemp {
198
199   croak 'Usage: ($fh, $name) = _gettemp($template, OPTIONS);'
200     unless scalar(@_) >= 1;
201
202   # the internal error string - expect it to be overridden
203   # Need this in case the caller decides not to supply us a value
204   # need an anonymous scalar
205   my $tempErrStr;
206
207   # Default options
208   my %options = (
209                  "open" => 0,
210                  "mkdir" => 0,
211                  "suffixlen" => 0,
212                  "unlink_on_close" => 0,
213                  "use_exlock" => 1,
214                  "ErrStr" => \$tempErrStr,
215                 );
216
217   # Read the template
218   my $template = shift;
219   if (ref($template)) {
220     # Use a warning here since we have not yet merged ErrStr
221     carp "File::Temp::_gettemp: template must not be a reference";
222     return ();
223   }
224
225   # Check that the number of entries on stack are even
226   if (scalar(@_) % 2 != 0) {
227     # Use a warning here since we have not yet merged ErrStr
228     carp "File::Temp::_gettemp: Must have even number of options";
229     return ();
230   }
231
232   # Read the options and merge with defaults
233   %options = (%options, @_)  if @_;
234
235   # Make sure the error string is set to undef
236   ${$options{ErrStr}} = undef;
237
238   # Can not open the file and make a directory in a single call
239   if ($options{"open"} && $options{"mkdir"}) {
240     ${$options{ErrStr}} = "doopen and domkdir can not both be true\n";
241     return ();
242   }
243
244   # Find the start of the end of the  Xs (position of last X)
245   # Substr starts from 0
246   my $start = length($template) - 1 - $options{"suffixlen"};
247
248   # Check that we have at least MINX x X (e.g. 'XXXX") at the end of the string
249   # (taking suffixlen into account). Any fewer is insecure.
250
251   # Do it using substr - no reason to use a pattern match since
252   # we know where we are looking and what we are looking for
253
254   if (substr($template, $start - MINX + 1, MINX) ne 'X' x MINX) {
255     ${$options{ErrStr}} = "The template must end with at least ".
256       MINX . " 'X' characters\n";
257     return ();
258   }
259
260   # Replace all the X at the end of the substring with a
261   # random character or just all the XX at the end of a full string.
262   # Do it as an if, since the suffix adjusts which section to replace
263   # and suffixlen=0 returns nothing if used in the substr directly
264   # and generate a full path from the template
265
266   my $path = _replace_XX($template, $options{"suffixlen"});
267
268
269   # Split the path into constituent parts - eventually we need to check
270   # whether the directory exists
271   # We need to know whether we are making a temp directory
272   # or a tempfile
273
274   my ($volume, $directories, $file);
275   my $parent;                   # parent directory
276   if ($options{"mkdir"}) {
277     # There is no filename at the end
278     ($volume, $directories, $file) = File::Spec->splitpath( $path, 1);
279
280     # The parent is then $directories without the last directory
281     # Split the directory and put it back together again
282     my @dirs = File::Spec->splitdir($directories);
283
284     # If @dirs only has one entry (i.e. the directory template) that means
285     # we are in the current directory
286     if ($#dirs == 0) {
287       $parent = File::Spec->curdir;
288     } else {
289
290       if ($^O eq 'VMS') {     # need volume to avoid relative dir spec
291         $parent = File::Spec->catdir($volume, @dirs[0..$#dirs-1]);
292         $parent = 'sys$disk:[]' if $parent eq '';
293       } else {
294
295         # Put it back together without the last one
296         $parent = File::Spec->catdir(@dirs[0..$#dirs-1]);
297
298         # ...and attach the volume (no filename)
299         $parent = File::Spec->catpath($volume, $parent, '');
300       }
301
302     }
303
304   } else {
305
306     # Get rid of the last filename (use File::Basename for this?)
307     ($volume, $directories, $file) = File::Spec->splitpath( $path );
308
309     # Join up without the file part
310     $parent = File::Spec->catpath($volume,$directories,'');
311
312     # If $parent is empty replace with curdir
313     $parent = File::Spec->curdir
314       unless $directories ne '';
315
316   }
317
318   # Check that the parent directories exist
319   # Do this even for the case where we are simply returning a name
320   # not a file -- no point returning a name that includes a directory
321   # that does not exist or is not writable
322
323   unless (-e $parent) {
324     ${$options{ErrStr}} = "Parent directory ($parent) does not exist";
325     return ();
326   }
327   unless (-d $parent) {
328     ${$options{ErrStr}} = "Parent directory ($parent) is not a directory";
329     return ();
330   }
331
332   # Check the stickiness of the directory and chown giveaway if required
333   # If the directory is world writable the sticky bit
334   # must be set
335
336   if (File::Temp->safe_level == MEDIUM) {
337     my $safeerr;
338     unless (_is_safe($parent,\$safeerr)) {
339       ${$options{ErrStr}} = "Parent directory ($parent) is not safe ($safeerr)";
340       return ();
341     }
342   } elsif (File::Temp->safe_level == HIGH) {
343     my $safeerr;
344     unless (_is_verysafe($parent, \$safeerr)) {
345       ${$options{ErrStr}} = "Parent directory ($parent) is not safe ($safeerr)";
346       return ();
347     }
348   }
349
350
351   # Now try MAX_TRIES time to open the file
352   for (my $i = 0; $i < MAX_TRIES; $i++) {
353
354     # Try to open the file if requested
355     if ($options{"open"}) {
356       my $fh;
357
358       # If we are running before perl5.6.0 we can not auto-vivify
359       if ($] < 5.006) {
360         $fh = &Symbol::gensym;
361       }
362
363       # Try to make sure this will be marked close-on-exec
364       # XXX: Win32 doesn't respect this, nor the proper fcntl,
365       #      but may have O_NOINHERIT. This may or may not be in Fcntl.
366       local $^F = 2;
367
368       # Attempt to open the file
369       my $open_success = undef;
370       if ( $^O eq 'VMS' and $options{"unlink_on_close"} && !$KEEP_ALL) {
371         # make it auto delete on close by setting FAB$V_DLT bit
372         $fh = VMS::Stdio::vmssysopen($path, $OPENFLAGS, 0600, 'fop=dlt');
373         $open_success = $fh;
374       } else {
375         my $flags = ( ($options{"unlink_on_close"} && !$KEEP_ALL) ?
376                       $OPENTEMPFLAGS :
377                       $OPENFLAGS );
378         $flags |= $LOCKFLAG if (defined $LOCKFLAG && $options{use_exlock});
379         $open_success = sysopen($fh, $path, $flags, 0600);
380       }
381       if ( $open_success ) {
382
383         # in case of odd umask force rw
384         chmod(0600, $path);
385
386         # Opened successfully - return file handle and name
387         return ($fh, $path);
388
389       } else {
390
391         # Error opening file - abort with error
392         # if the reason was anything but EEXIST
393         unless ($!{EEXIST}) {
394           ${$options{ErrStr}} = "Could not create temp file $path: $!";
395           return ();
396         }
397
398         # Loop round for another try
399
400       }
401     } elsif ($options{"mkdir"}) {
402
403       # Open the temp directory
404       if (mkdir( $path, 0700)) {
405         # in case of odd umask
406         chmod(0700, $path);
407
408         return undef, $path;
409       } else {
410
411         # Abort with error if the reason for failure was anything
412         # except EEXIST
413         unless ($!{EEXIST}) {
414           ${$options{ErrStr}} = "Could not create directory $path: $!";
415           return ();
416         }
417
418         # Loop round for another try
419
420       }
421
422     } else {
423
424       # Return true if the file can not be found
425       # Directory has been checked previously
426
427       return (undef, $path) unless -e $path;
428
429       # Try again until MAX_TRIES
430
431     }
432
433     # Did not successfully open the tempfile/dir
434     # so try again with a different set of random letters
435     # No point in trying to increment unless we have only
436     # 1 X say and the randomness could come up with the same
437     # file MAX_TRIES in a row.
438
439     # Store current attempt - in principal this implies that the
440     # 3rd time around the open attempt that the first temp file
441     # name could be generated again. Probably should store each
442     # attempt and make sure that none are repeated
443
444     my $original = $path;
445     my $counter = 0;            # Stop infinite loop
446     my $MAX_GUESS = 50;
447
448     do {
449
450       # Generate new name from original template
451       $path = _replace_XX($template, $options{"suffixlen"});
452
453       $counter++;
454
455     } until ($path ne $original || $counter > $MAX_GUESS);
456
457     # Check for out of control looping
458     if ($counter > $MAX_GUESS) {
459       ${$options{ErrStr}} = "Tried to get a new temp name different to the previous value $MAX_GUESS times.\nSomething wrong with template?? ($template)";
460       return ();
461     }
462
463   }
464
465   # If we get here, we have run out of tries
466   ${ $options{ErrStr} } = "Have exceeded the maximum number of attempts ("
467     . MAX_TRIES . ") to open temp file/dir";
468
469   return ();
470
471 }
472
473 # Internal routine to replace the XXXX... with random characters
474 # This has to be done by _gettemp() every time it fails to
475 # open a temp file/dir
476
477 # Arguments:  $template (the template with XXX),
478 #             $ignore   (number of characters at end to ignore)
479
480 # Returns:    modified template
481
482 sub _replace_XX {
483
484   croak 'Usage: _replace_XX($template, $ignore)'
485     unless scalar(@_) == 2;
486
487   my ($path, $ignore) = @_;
488
489   # Do it as an if, since the suffix adjusts which section to replace
490   # and suffixlen=0 returns nothing if used in the substr directly
491   # Alternatively, could simply set $ignore to length($path)-1
492   # Don't want to always use substr when not required though.
493   my $end = ( $] >= 5.006 ? "\\z" : "\\Z" );
494
495   if ($ignore) {
496     substr($path, 0, - $ignore) =~ s/X(?=X*$end)/$CHARS[ int( rand( @CHARS ) ) ]/ge;
497   } else {
498     $path =~ s/X(?=X*$end)/$CHARS[ int( rand( @CHARS ) ) ]/ge;
499   }
500   return $path;
501 }
502
503 # Internal routine to force a temp file to be writable after
504 # it is created so that we can unlink it. Windows seems to occasionally
505 # force a file to be readonly when written to certain temp locations
506 sub _force_writable {
507   my $file = shift;
508   chmod 0600, $file;
509 }
510
511
512 # internal routine to check to see if the directory is safe
513 # First checks to see if the directory is not owned by the
514 # current user or root. Then checks to see if anyone else
515 # can write to the directory and if so, checks to see if
516 # it has the sticky bit set
517
518 # Will not work on systems that do not support sticky bit
519
520 #Args:  directory path to check
521 #       Optionally: reference to scalar to contain error message
522 # Returns true if the path is safe and false otherwise.
523 # Returns undef if can not even run stat() on the path
524
525 # This routine based on version written by Tom Christiansen
526
527 # Presumably, by the time we actually attempt to create the
528 # file or directory in this directory, it may not be safe
529 # anymore... Have to run _is_safe directly after the open.
530
531 sub _is_safe {
532
533   my $path = shift;
534   my $err_ref = shift;
535
536   # Stat path
537   my @info = stat($path);
538   unless (scalar(@info)) {
539     $$err_ref = "stat(path) returned no values";
540     return 0;
541   }
542   ;
543   return 1 if $^O eq 'VMS';     # owner delete control at file level
544
545   # Check to see whether owner is neither superuser (or a system uid) nor me
546   # Use the effective uid from the $> variable
547   # UID is in [4]
548   if ($info[4] > File::Temp->top_system_uid() && $info[4] != $>) {
549
550     Carp::cluck(sprintf "uid=$info[4] topuid=%s euid=$> path='$path'",
551                 File::Temp->top_system_uid());
552
553     $$err_ref = "Directory owned neither by root nor the current user"
554       if ref($err_ref);
555     return 0;
556   }
557
558   # check whether group or other can write file
559   # use 066 to detect either reading or writing
560   # use 022 to check writability
561   # Do it with S_IWOTH and S_IWGRP for portability (maybe)
562   # mode is in info[2]
563   if (($info[2] & &Fcntl::S_IWGRP) ||  # Is group writable?
564       ($info[2] & &Fcntl::S_IWOTH) ) { # Is world writable?
565     # Must be a directory
566     unless (-d $path) {
567       $$err_ref = "Path ($path) is not a directory"
568         if ref($err_ref);
569       return 0;
570     }
571     # Must have sticky bit set
572     unless (-k $path) {
573       $$err_ref = "Sticky bit not set on $path when dir is group|world writable"
574         if ref($err_ref);
575       return 0;
576     }
577   }
578
579   return 1;
580 }
581
582 # Internal routine to check whether a directory is safe
583 # for temp files. Safer than _is_safe since it checks for
584 # the possibility of chown giveaway and if that is a possibility
585 # checks each directory in the path to see if it is safe (with _is_safe)
586
587 # If _PC_CHOWN_RESTRICTED is not set, does the full test of each
588 # directory anyway.
589
590 # Takes optional second arg as scalar ref to error reason
591
592 sub _is_verysafe {
593
594   # Need POSIX - but only want to bother if really necessary due to overhead
595   require POSIX;
596
597   my $path = shift;
598   print "_is_verysafe testing $path\n" if $DEBUG;
599   return 1 if $^O eq 'VMS';     # owner delete control at file level
600
601   my $err_ref = shift;
602
603   # Should Get the value of _PC_CHOWN_RESTRICTED if it is defined
604   # and If it is not there do the extensive test
605   local($@);
606   my $chown_restricted;
607   $chown_restricted = &POSIX::_PC_CHOWN_RESTRICTED()
608     if eval { &POSIX::_PC_CHOWN_RESTRICTED(); 1};
609
610   # If chown_resticted is set to some value we should test it
611   if (defined $chown_restricted) {
612
613     # Return if the current directory is safe
614     return _is_safe($path,$err_ref) if POSIX::sysconf( $chown_restricted );
615
616   }
617
618   # To reach this point either, the _PC_CHOWN_RESTRICTED symbol
619   # was not available or the symbol was there but chown giveaway
620   # is allowed. Either way, we now have to test the entire tree for
621   # safety.
622
623   # Convert path to an absolute directory if required
624   unless (File::Spec->file_name_is_absolute($path)) {
625     $path = File::Spec->rel2abs($path);
626   }
627
628   # Split directory into components - assume no file
629   my ($volume, $directories, undef) = File::Spec->splitpath( $path, 1);
630
631   # Slightly less efficient than having a function in File::Spec
632   # to chop off the end of a directory or even a function that
633   # can handle ../ in a directory tree
634   # Sometimes splitdir() returns a blank at the end
635   # so we will probably check the bottom directory twice in some cases
636   my @dirs = File::Spec->splitdir($directories);
637
638   # Concatenate one less directory each time around
639   foreach my $pos (0.. $#dirs) {
640     # Get a directory name
641     my $dir = File::Spec->catpath($volume,
642                                   File::Spec->catdir(@dirs[0.. $#dirs - $pos]),
643                                   ''
644                                  );
645
646     print "TESTING DIR $dir\n" if $DEBUG;
647
648     # Check the directory
649     return 0 unless _is_safe($dir,$err_ref);
650
651   }
652
653   return 1;
654 }
655
656
657
658 # internal routine to determine whether unlink works on this
659 # platform for files that are currently open.
660 # Returns true if we can, false otherwise.
661
662 # Currently WinNT, OS/2 and VMS can not unlink an opened file
663 # On VMS this is because the O_EXCL flag is used to open the
664 # temporary file. Currently I do not know enough about the issues
665 # on VMS to decide whether O_EXCL is a requirement.
666
667 sub _can_unlink_opened_file {
668
669   if (grep { $^O eq $_ } qw/MSWin32 os2 VMS dos MacOS haiku/) {
670     return 0;
671   } else {
672     return 1;
673   }
674
675 }
676
677 # internal routine to decide which security levels are allowed
678 # see safe_level() for more information on this
679
680 # Controls whether the supplied security level is allowed
681
682 #   $cando = _can_do_level( $level )
683
684 sub _can_do_level {
685
686   # Get security level
687   my $level = shift;
688
689   # Always have to be able to do STANDARD
690   return 1 if $level == STANDARD;
691
692   # Currently, the systems that can do HIGH or MEDIUM are identical
693   if ( $^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'cygwin' || $^O eq 'dos' || $^O eq 'MacOS' || $^O eq 'mpeix') {
694     return 0;
695   } else {
696     return 1;
697   }
698
699 }
700
701 # This routine sets up a deferred unlinking of a specified
702 # filename and filehandle. It is used in the following cases:
703 #  - Called by unlink0 if an opened file can not be unlinked
704 #  - Called by tempfile() if files are to be removed on shutdown
705 #  - Called by tempdir() if directories are to be removed on shutdown
706
707 # Arguments:
708 #   _deferred_unlink( $fh, $fname, $isdir );
709 #
710 #   - filehandle (so that it can be explicitly closed if open
711 #   - filename   (the thing we want to remove)
712 #   - isdir      (flag to indicate that we are being given a directory)
713 #                 [and hence no filehandle]
714
715 # Status is not referred to since all the magic is done with an END block
716
717 {
718   # Will set up two lexical variables to contain all the files to be
719   # removed. One array for files, another for directories They will
720   # only exist in this block.
721
722   #  This means we only have to set up a single END block to remove
723   #  all files. 
724
725   # in order to prevent child processes inadvertently deleting the parent
726   # temp files we use a hash to store the temp files and directories
727   # created by a particular process id.
728
729   # %files_to_unlink contains values that are references to an array of
730   # array references containing the filehandle and filename associated with
731   # the temp file.
732   my (%files_to_unlink, %dirs_to_unlink);
733
734   # Set up an end block to use these arrays
735   END {
736     local($., $@, $!, $^E, $?);
737     cleanup(at_exit => 1);
738   }
739
740   # Cleanup function. Always triggered on END (with at_exit => 1) but
741   # can be invoked manually.
742   sub cleanup {
743     my %h = @_;
744     my $at_exit = delete $h{at_exit};
745     $at_exit = 0 if not defined $at_exit;
746     { my @k = sort keys %h; die "unrecognized parameters: @k" if @k }
747
748     if (!$KEEP_ALL) {
749       # Files
750       my @files = (exists $files_to_unlink{$$} ?
751                    @{ $files_to_unlink{$$} } : () );
752       foreach my $file (@files) {
753         # close the filehandle without checking its state
754         # in order to make real sure that this is closed
755         # if its already closed then I dont care about the answer
756         # probably a better way to do this
757         close($file->[0]);      # file handle is [0]
758
759         if (-f $file->[1]) {       # file name is [1]
760           _force_writable( $file->[1] ); # for windows
761           unlink $file->[1] or warn "Error removing ".$file->[1];
762         }
763       }
764       # Dirs
765       my @dirs = (exists $dirs_to_unlink{$$} ?
766                   @{ $dirs_to_unlink{$$} } : () );
767       my ($cwd, $cwd_to_remove);
768       foreach my $dir (@dirs) {
769         if (-d $dir) {
770           # Some versions of rmtree will abort if you attempt to remove
771           # the directory you are sitting in. For automatic cleanup
772           # at program exit, we avoid this by chdir()ing out of the way
773           # first. If not at program exit, it's best not to mess with the
774           # current directory, so just let it fail with a warning.
775           if ($at_exit) {
776             $cwd = Cwd::abs_path(File::Spec->curdir) if not defined $cwd;
777             my $abs = Cwd::abs_path($dir);
778             if ($abs eq $cwd) {
779               $cwd_to_remove = $dir;
780               next;
781             }
782           }
783           eval { rmtree($dir, $DEBUG, 0); };
784           warn $@ if ($@ && $^W);
785         }
786       }
787
788       if (defined $cwd_to_remove) {
789         # We do need to clean up the current directory, and everything
790         # else is done, so get out of there and remove it.
791         chdir $cwd_to_remove or die "cannot chdir to $cwd_to_remove: $!";
792         my $updir = File::Spec->updir;
793         chdir $updir or die "cannot chdir to $updir: $!";
794         eval { rmtree($cwd_to_remove, $DEBUG, 0); };
795         warn $@ if ($@ && $^W);
796       }
797
798       # clear the arrays
799       @{ $files_to_unlink{$$} } = ()
800         if exists $files_to_unlink{$$};
801       @{ $dirs_to_unlink{$$} } = ()
802         if exists $dirs_to_unlink{$$};
803     }
804   }
805
806
807   # This is the sub called to register a file for deferred unlinking
808   # This could simply store the input parameters and defer everything
809   # until the END block. For now we do a bit of checking at this
810   # point in order to make sure that (1) we have a file/dir to delete
811   # and (2) we have been called with the correct arguments.
812   sub _deferred_unlink {
813
814     croak 'Usage:  _deferred_unlink($fh, $fname, $isdir)'
815       unless scalar(@_) == 3;
816
817     my ($fh, $fname, $isdir) = @_;
818
819     warn "Setting up deferred removal of $fname\n"
820       if $DEBUG;
821
822     # make sure we save the absolute path for later cleanup
823     # OK to untaint because we only ever use this internally
824     # as a file path, never interpolating into the shell
825     $fname = Cwd::abs_path($fname);
826     ($fname) = $fname =~ /^(.*)$/;
827
828     # If we have a directory, check that it is a directory
829     if ($isdir) {
830
831       if (-d $fname) {
832
833         # Directory exists so store it
834         # first on VMS turn []foo into [.foo] for rmtree
835         $fname = VMS::Filespec::vmspath($fname) if $^O eq 'VMS';
836         $dirs_to_unlink{$$} = [] 
837           unless exists $dirs_to_unlink{$$};
838         push (@{ $dirs_to_unlink{$$} }, $fname);
839
840       } else {
841         carp "Request to remove directory $fname could not be completed since it does not exist!\n" if $^W;
842       }
843
844     } else {
845
846       if (-f $fname) {
847
848         # file exists so store handle and name for later removal
849         $files_to_unlink{$$} = []
850           unless exists $files_to_unlink{$$};
851         push(@{ $files_to_unlink{$$} }, [$fh, $fname]);
852
853       } else {
854         carp "Request to remove file $fname could not be completed since it is not there!\n" if $^W;
855       }
856
857     }
858
859   }
860
861
862 }
863
864 # normalize argument keys to upper case and do consistent handling
865 # of leading template vs TEMPLATE
866 sub _parse_args {
867   my $leading_template = (scalar(@_) % 2 == 1 ? shift(@_) : '' );
868   my %args = @_;
869   %args = map { uc($_), $args{$_} } keys %args;
870
871   # template (store it in an array so that it will
872   # disappear from the arg list of tempfile)
873   my @template = (
874     exists $args{TEMPLATE}  ? $args{TEMPLATE} :
875     $leading_template       ? $leading_template : ()
876   );
877   delete $args{TEMPLATE};
878
879   return( \@template, \%args );
880 }
881
882
883 sub new {
884   my $proto = shift;
885   my $class = ref($proto) || $proto;
886
887   my ($maybe_template, $args) = _parse_args(@_);
888
889   # see if they are unlinking (defaulting to yes)
890   my $unlink = (exists $args->{UNLINK} ? $args->{UNLINK} : 1 );
891   delete $args->{UNLINK};
892
893   # Protect OPEN
894   delete $args->{OPEN};
895
896   # Open the file and retain file handle and file name
897   my ($fh, $path) = tempfile( @$maybe_template, %$args );
898
899   print "Tmp: $fh - $path\n" if $DEBUG;
900
901   # Store the filename in the scalar slot
902   ${*$fh} = $path;
903
904   # Cache the filename by pid so that the destructor can decide whether to remove it
905   $FILES_CREATED_BY_OBJECT{$$}{$path} = 1;
906
907   # Store unlink information in hash slot (plus other constructor info)
908   %{*$fh} = %$args;
909
910   # create the object
911   bless $fh, $class;
912
913   # final method-based configuration
914   $fh->unlink_on_destroy( $unlink );
915
916   return $fh;
917 }
918
919
920 sub newdir {
921   my $self = shift;
922
923   my ($maybe_template, $args) = _parse_args(@_);
924
925   # handle CLEANUP without passing CLEANUP to tempdir
926   my $cleanup = (exists $args->{CLEANUP} ? $args->{CLEANUP} : 1 );
927   delete $args->{CLEANUP};
928
929   my $tempdir = tempdir( @$maybe_template, %$args);
930
931   # get a safe absolute path for cleanup, just like
932   # happens in _deferred_unlink
933   my $real_dir = Cwd::abs_path( $tempdir );
934   ($real_dir) = $real_dir =~ /^(.*)$/;
935
936   return bless { DIRNAME => $tempdir,
937                  REALNAME => $real_dir,
938                  CLEANUP => $cleanup,
939                  LAUNCHPID => $$,
940                }, "File::Temp::Dir";
941 }
942
943
944 sub filename {
945   my $self = shift;
946   return ${*$self};
947 }
948
949 sub STRINGIFY {
950   my $self = shift;
951   return $self->filename;
952 }
953
954 # For reference, can't use '0+'=>\&Scalar::Util::refaddr directly because
955 # refaddr() demands one parameter only, whereas overload.pm calls with three
956 # even for unary operations like '0+'.
957 sub NUMIFY {
958   return refaddr($_[0]);
959 }
960
961
962 sub unlink_on_destroy {
963   my $self = shift;
964   if (@_) {
965     ${*$self}{UNLINK} = shift;
966   }
967   return ${*$self}{UNLINK};
968 }
969
970
971 sub DESTROY {
972   local($., $@, $!, $^E, $?);
973   my $self = shift;
974
975   # Make sure we always remove the file from the global hash
976   # on destruction. This prevents the hash from growing uncontrollably
977   # and post-destruction there is no reason to know about the file.
978   my $file = $self->filename;
979   my $was_created_by_proc;
980   if (exists $FILES_CREATED_BY_OBJECT{$$}{$file}) {
981     $was_created_by_proc = 1;
982     delete $FILES_CREATED_BY_OBJECT{$$}{$file};
983   }
984
985   if (${*$self}{UNLINK} && !$KEEP_ALL) {
986     print "# --------->   Unlinking $self\n" if $DEBUG;
987
988     # only delete if this process created it
989     return unless $was_created_by_proc;
990
991     # The unlink1 may fail if the file has been closed
992     # by the caller. This leaves us with the decision
993     # of whether to refuse to remove the file or simply
994     # do an unlink without test. Seems to be silly
995     # to do this when we are trying to be careful
996     # about security
997     _force_writable( $file ); # for windows
998     unlink1( $self, $file )
999       or unlink($file);
1000   }
1001 }
1002
1003
1004 sub tempfile {
1005   if ( @_ && $_[0] eq 'File::Temp' ) {
1006       croak "'tempfile' can't be called as a method";
1007   }
1008   # Can not check for argument count since we can have any
1009   # number of args
1010
1011   # Default options
1012   my %options = (
1013                  "DIR"    => undef, # Directory prefix
1014                  "SUFFIX" => '',    # Template suffix
1015                  "UNLINK" => 0,     # Do not unlink file on exit
1016                  "OPEN"   => 1,     # Open file
1017                  "TMPDIR" => 0, # Place tempfile in tempdir if template specified
1018                  "EXLOCK" => 1, # Open file with O_EXLOCK
1019                 );
1020
1021   # Check to see whether we have an odd or even number of arguments
1022   my ($maybe_template, $args) = _parse_args(@_);
1023   my $template = @$maybe_template ? $maybe_template->[0] : undef;
1024
1025   # Read the options and merge with defaults
1026   %options = (%options, %$args);
1027
1028   # First decision is whether or not to open the file
1029   if (! $options{"OPEN"}) {
1030
1031     warn "tempfile(): temporary filename requested but not opened.\nPossibly unsafe, consider using tempfile() with OPEN set to true\n"
1032       if $^W;
1033
1034   }
1035
1036   if ($options{"DIR"} and $^O eq 'VMS') {
1037
1038     # on VMS turn []foo into [.foo] for concatenation
1039     $options{"DIR"} = VMS::Filespec::vmspath($options{"DIR"});
1040   }
1041
1042   # Construct the template
1043
1044   # Have a choice of trying to work around the mkstemp/mktemp/tmpnam etc
1045   # functions or simply constructing a template and using _gettemp()
1046   # explicitly. Go for the latter
1047
1048   # First generate a template if not defined and prefix the directory
1049   # If no template must prefix the temp directory
1050   if (defined $template) {
1051     # End up with current directory if neither DIR not TMPDIR are set
1052     if ($options{"DIR"}) {
1053
1054       $template = File::Spec->catfile($options{"DIR"}, $template);
1055
1056     } elsif ($options{TMPDIR}) {
1057
1058       $template = File::Spec->catfile(File::Spec->tmpdir, $template );
1059
1060     }
1061
1062   } else {
1063
1064     if ($options{"DIR"}) {
1065
1066       $template = File::Spec->catfile($options{"DIR"}, TEMPXXX);
1067
1068     } else {
1069
1070       $template = File::Spec->catfile(File::Spec->tmpdir, TEMPXXX);
1071
1072     }
1073
1074   }
1075
1076   # Now add a suffix
1077   $template .= $options{"SUFFIX"};
1078
1079   # Determine whether we should tell _gettemp to unlink the file
1080   # On unix this is irrelevant and can be worked out after the file is
1081   # opened (simply by unlinking the open filehandle). On Windows or VMS
1082   # we have to indicate temporary-ness when we open the file. In general
1083   # we only want a true temporary file if we are returning just the
1084   # filehandle - if the user wants the filename they probably do not
1085   # want the file to disappear as soon as they close it (which may be
1086   # important if they want a child process to use the file)
1087   # For this reason, tie unlink_on_close to the return context regardless
1088   # of OS.
1089   my $unlink_on_close = ( wantarray ? 0 : 1);
1090
1091   # Create the file
1092   my ($fh, $path, $errstr);
1093   croak "Error in tempfile() using template $template: $errstr"
1094     unless (($fh, $path) = _gettemp($template,
1095                                     "open" => $options{'OPEN'},
1096                                     "mkdir"=> 0 ,
1097                                     "unlink_on_close" => $unlink_on_close,
1098                                     "suffixlen" => length($options{'SUFFIX'}),
1099                                     "ErrStr" => \$errstr,
1100                                     "use_exlock" => $options{EXLOCK},
1101                                    ) );
1102
1103   # Set up an exit handler that can do whatever is right for the
1104   # system. This removes files at exit when requested explicitly or when
1105   # system is asked to unlink_on_close but is unable to do so because
1106   # of OS limitations.
1107   # The latter should be achieved by using a tied filehandle.
1108   # Do not check return status since this is all done with END blocks.
1109   _deferred_unlink($fh, $path, 0) if $options{"UNLINK"};
1110
1111   # Return
1112   if (wantarray()) {
1113
1114     if ($options{'OPEN'}) {
1115       return ($fh, $path);
1116     } else {
1117       return (undef, $path);
1118     }
1119
1120   } else {
1121
1122     # Unlink the file. It is up to unlink0 to decide what to do with
1123     # this (whether to unlink now or to defer until later)
1124     unlink0($fh, $path) or croak "Error unlinking file $path using unlink0";
1125
1126     # Return just the filehandle.
1127     return $fh;
1128   }
1129
1130
1131 }
1132
1133
1134 # '
1135
1136 sub tempdir  {
1137   if ( @_ && $_[0] eq 'File::Temp' ) {
1138       croak "'tempdir' can't be called as a method";
1139   }
1140
1141   # Can not check for argument count since we can have any
1142   # number of args
1143
1144   # Default options
1145   my %options = (
1146                  "CLEANUP"    => 0, # Remove directory on exit
1147                  "DIR"        => '', # Root directory
1148                  "TMPDIR"     => 0,  # Use tempdir with template
1149                 );
1150
1151   # Check to see whether we have an odd or even number of arguments
1152   my ($maybe_template, $args) = _parse_args(@_);
1153   my $template = @$maybe_template ? $maybe_template->[0] : undef;
1154
1155   # Read the options and merge with defaults
1156   %options = (%options, %$args);
1157
1158   # Modify or generate the template
1159
1160   # Deal with the DIR and TMPDIR options
1161   if (defined $template) {
1162
1163     # Need to strip directory path if using DIR or TMPDIR
1164     if ($options{'TMPDIR'} || $options{'DIR'}) {
1165
1166       # Strip parent directory from the filename
1167       #
1168       # There is no filename at the end
1169       $template = VMS::Filespec::vmspath($template) if $^O eq 'VMS';
1170       my ($volume, $directories, undef) = File::Spec->splitpath( $template, 1);
1171
1172       # Last directory is then our template
1173       $template = (File::Spec->splitdir($directories))[-1];
1174
1175       # Prepend the supplied directory or temp dir
1176       if ($options{"DIR"}) {
1177
1178         $template = File::Spec->catdir($options{"DIR"}, $template);
1179
1180       } elsif ($options{TMPDIR}) {
1181
1182         # Prepend tmpdir
1183         $template = File::Spec->catdir(File::Spec->tmpdir, $template);
1184
1185       }
1186
1187     }
1188
1189   } else {
1190
1191     if ($options{"DIR"}) {
1192
1193       $template = File::Spec->catdir($options{"DIR"}, TEMPXXX);
1194
1195     } else {
1196
1197       $template = File::Spec->catdir(File::Spec->tmpdir, TEMPXXX);
1198
1199     }
1200
1201   }
1202
1203   # Create the directory
1204   my $tempdir;
1205   my $suffixlen = 0;
1206   if ($^O eq 'VMS') {           # dir names can end in delimiters
1207     $template =~ m/([\.\]:>]+)$/;
1208     $suffixlen = length($1);
1209   }
1210   if ( ($^O eq 'MacOS') && (substr($template, -1) eq ':') ) {
1211     # dir name has a trailing ':'
1212     ++$suffixlen;
1213   }
1214
1215   my $errstr;
1216   croak "Error in tempdir() using $template: $errstr"
1217     unless ((undef, $tempdir) = _gettemp($template,
1218                                          "open" => 0,
1219                                          "mkdir"=> 1 ,
1220                                          "suffixlen" => $suffixlen,
1221                                          "ErrStr" => \$errstr,
1222                                         ) );
1223
1224   # Install exit handler; must be dynamic to get lexical
1225   if ( $options{'CLEANUP'} && -d $tempdir) {
1226     _deferred_unlink(undef, $tempdir, 1);
1227   }
1228
1229   # Return the dir name
1230   return $tempdir;
1231
1232 }
1233
1234
1235
1236
1237 sub mkstemp {
1238
1239   croak "Usage: mkstemp(template)"
1240     if scalar(@_) != 1;
1241
1242   my $template = shift;
1243
1244   my ($fh, $path, $errstr);
1245   croak "Error in mkstemp using $template: $errstr"
1246     unless (($fh, $path) = _gettemp($template,
1247                                     "open" => 1,
1248                                     "mkdir"=> 0 ,
1249                                     "suffixlen" => 0,
1250                                     "ErrStr" => \$errstr,
1251                                    ) );
1252
1253   if (wantarray()) {
1254     return ($fh, $path);
1255   } else {
1256     return $fh;
1257   }
1258
1259 }
1260
1261
1262
1263 sub mkstemps {
1264
1265   croak "Usage: mkstemps(template, suffix)"
1266     if scalar(@_) != 2;
1267
1268
1269   my $template = shift;
1270   my $suffix   = shift;
1271
1272   $template .= $suffix;
1273
1274   my ($fh, $path, $errstr);
1275   croak "Error in mkstemps using $template: $errstr"
1276     unless (($fh, $path) = _gettemp($template,
1277                                     "open" => 1,
1278                                     "mkdir"=> 0 ,
1279                                     "suffixlen" => length($suffix),
1280                                     "ErrStr" => \$errstr,
1281                                    ) );
1282
1283   if (wantarray()) {
1284     return ($fh, $path);
1285   } else {
1286     return $fh;
1287   }
1288
1289 }
1290
1291
1292 #' # for emacs
1293
1294 sub mkdtemp {
1295
1296   croak "Usage: mkdtemp(template)"
1297     if scalar(@_) != 1;
1298
1299   my $template = shift;
1300   my $suffixlen = 0;
1301   if ($^O eq 'VMS') {           # dir names can end in delimiters
1302     $template =~ m/([\.\]:>]+)$/;
1303     $suffixlen = length($1);
1304   }
1305   if ( ($^O eq 'MacOS') && (substr($template, -1) eq ':') ) {
1306     # dir name has a trailing ':'
1307     ++$suffixlen;
1308   }
1309   my ($junk, $tmpdir, $errstr);
1310   croak "Error creating temp directory from template $template\: $errstr"
1311     unless (($junk, $tmpdir) = _gettemp($template,
1312                                         "open" => 0,
1313                                         "mkdir"=> 1 ,
1314                                         "suffixlen" => $suffixlen,
1315                                         "ErrStr" => \$errstr,
1316                                        ) );
1317
1318   return $tmpdir;
1319
1320 }
1321
1322
1323 sub mktemp {
1324
1325   croak "Usage: mktemp(template)"
1326     if scalar(@_) != 1;
1327
1328   my $template = shift;
1329
1330   my ($tmpname, $junk, $errstr);
1331   croak "Error getting name to temp file from template $template: $errstr"
1332     unless (($junk, $tmpname) = _gettemp($template,
1333                                          "open" => 0,
1334                                          "mkdir"=> 0 ,
1335                                          "suffixlen" => 0,
1336                                          "ErrStr" => \$errstr,
1337                                         ) );
1338
1339   return $tmpname;
1340 }
1341
1342
1343 sub tmpnam {
1344
1345   # Retrieve the temporary directory name
1346   my $tmpdir = File::Spec->tmpdir;
1347
1348   croak "Error temporary directory is not writable"
1349     if $tmpdir eq '';
1350
1351   # Use a ten character template and append to tmpdir
1352   my $template = File::Spec->catfile($tmpdir, TEMPXXX);
1353
1354   if (wantarray() ) {
1355     return mkstemp($template);
1356   } else {
1357     return mktemp($template);
1358   }
1359
1360 }
1361
1362
1363 sub tmpfile {
1364
1365   # Simply call tmpnam() in a list context
1366   my ($fh, $file) = tmpnam();
1367
1368   # Make sure file is removed when filehandle is closed
1369   # This will fail on NFS
1370   unlink0($fh, $file)
1371     or return undef;
1372
1373   return $fh;
1374
1375 }
1376
1377
1378 sub tempnam {
1379
1380   croak 'Usage tempnam($dir, $prefix)' unless scalar(@_) == 2;
1381
1382   my ($dir, $prefix) = @_;
1383
1384   # Add a string to the prefix
1385   $prefix .= 'XXXXXXXX';
1386
1387   # Concatenate the directory to the file
1388   my $template = File::Spec->catfile($dir, $prefix);
1389
1390   return mktemp($template);
1391
1392 }
1393
1394
1395 sub unlink0 {
1396
1397   croak 'Usage: unlink0(filehandle, filename)'
1398     unless scalar(@_) == 2;
1399
1400   # Read args
1401   my ($fh, $path) = @_;
1402
1403   cmpstat($fh, $path) or return 0;
1404
1405   # attempt remove the file (does not work on some platforms)
1406   if (_can_unlink_opened_file()) {
1407
1408     # return early (Without unlink) if we have been instructed to retain files.
1409     return 1 if $KEEP_ALL;
1410
1411     # XXX: do *not* call this on a directory; possible race
1412     #      resulting in recursive removal
1413     croak "unlink0: $path has become a directory!" if -d $path;
1414     unlink($path) or return 0;
1415
1416     # Stat the filehandle
1417     my @fh = stat $fh;
1418
1419     print "Link count = $fh[3] \n" if $DEBUG;
1420
1421     # Make sure that the link count is zero
1422     # - Cygwin provides deferred unlinking, however,
1423     #   on Win9x the link count remains 1
1424     # On NFS the link count may still be 1 but we can't know that
1425     # we are on NFS.  Since we can't be sure, we'll defer it
1426
1427     return 1 if $fh[3] == 0 || $^O eq 'cygwin';
1428   }
1429   # fall-through if we can't unlink now
1430   _deferred_unlink($fh, $path, 0);
1431   return 1;
1432 }
1433
1434
1435 sub cmpstat {
1436
1437   croak 'Usage: cmpstat(filehandle, filename)'
1438     unless scalar(@_) == 2;
1439
1440   # Read args
1441   my ($fh, $path) = @_;
1442
1443   warn "Comparing stat\n"
1444     if $DEBUG;
1445
1446   # Stat the filehandle - which may be closed if someone has manually
1447   # closed the file. Can not turn off warnings without using $^W
1448   # unless we upgrade to 5.006 minimum requirement
1449   my @fh;
1450   {
1451     local ($^W) = 0;
1452     @fh = stat $fh;
1453   }
1454   return unless @fh;
1455
1456   if ($fh[3] > 1 && $^W) {
1457     carp "unlink0: fstat found too many links; SB=@fh" if $^W;
1458   }
1459
1460   # Stat the path
1461   my @path = stat $path;
1462
1463   unless (@path) {
1464     carp "unlink0: $path is gone already" if $^W;
1465     return;
1466   }
1467
1468   # this is no longer a file, but may be a directory, or worse
1469   unless (-f $path) {
1470     confess "panic: $path is no longer a file: SB=@fh";
1471   }
1472
1473   # Do comparison of each member of the array
1474   # On WinNT dev and rdev seem to be different
1475   # depending on whether it is a file or a handle.
1476   # Cannot simply compare all members of the stat return
1477   # Select the ones we can use
1478   my @okstat = (0..$#fh);       # Use all by default
1479   if ($^O eq 'MSWin32') {
1480     @okstat = (1,2,3,4,5,7,8,9,10);
1481   } elsif ($^O eq 'os2') {
1482     @okstat = (0, 2..$#fh);
1483   } elsif ($^O eq 'VMS') {      # device and file ID are sufficient
1484     @okstat = (0, 1);
1485   } elsif ($^O eq 'dos') {
1486     @okstat = (0,2..7,11..$#fh);
1487   } elsif ($^O eq 'mpeix') {
1488     @okstat = (0..4,8..10);
1489   }
1490
1491   # Now compare each entry explicitly by number
1492   for (@okstat) {
1493     print "Comparing: $_ : $fh[$_] and $path[$_]\n" if $DEBUG;
1494     # Use eq rather than == since rdev, blksize, and blocks (6, 11,
1495     # and 12) will be '' on platforms that do not support them.  This
1496     # is fine since we are only comparing integers.
1497     unless ($fh[$_] eq $path[$_]) {
1498       warn "Did not match $_ element of stat\n" if $DEBUG;
1499       return 0;
1500     }
1501   }
1502
1503   return 1;
1504 }
1505
1506
1507 sub unlink1 {
1508   croak 'Usage: unlink1(filehandle, filename)'
1509     unless scalar(@_) == 2;
1510
1511   # Read args
1512   my ($fh, $path) = @_;
1513
1514   cmpstat($fh, $path) or return 0;
1515
1516   # Close the file
1517   close( $fh ) or return 0;
1518
1519   # Make sure the file is writable (for windows)
1520   _force_writable( $path );
1521
1522   # return early (without unlink) if we have been instructed to retain files.
1523   return 1 if $KEEP_ALL;
1524
1525   # remove the file
1526   return unlink($path);
1527 }
1528
1529
1530 {
1531   # protect from using the variable itself
1532   my $LEVEL = STANDARD;
1533   sub safe_level {
1534     my $self = shift;
1535     if (@_) {
1536       my $level = shift;
1537       if (($level != STANDARD) && ($level != MEDIUM) && ($level != HIGH)) {
1538         carp "safe_level: Specified level ($level) not STANDARD, MEDIUM or HIGH - ignoring\n" if $^W;
1539       } else {
1540         # Don't allow this on perl 5.005 or earlier
1541         if ($] < 5.006 && $level != STANDARD) {
1542           # Cant do MEDIUM or HIGH checks
1543           croak "Currently requires perl 5.006 or newer to do the safe checks";
1544         }
1545         # Check that we are allowed to change level
1546         # Silently ignore if we can not.
1547         $LEVEL = $level if _can_do_level($level);
1548       }
1549     }
1550     return $LEVEL;
1551   }
1552 }
1553
1554
1555 {
1556   my $TopSystemUID = 10;
1557   $TopSystemUID = 197108 if $^O eq 'interix'; # "Administrator"
1558   sub top_system_uid {
1559     my $self = shift;
1560     if (@_) {
1561       my $newuid = shift;
1562       croak "top_system_uid: UIDs should be numeric"
1563         unless $newuid =~ /^\d+$/s;
1564       $TopSystemUID = $newuid;
1565     }
1566     return $TopSystemUID;
1567   }
1568 }
1569
1570
1571 package File::Temp::Dir;
1572
1573 use File::Path qw/ rmtree /;
1574 use strict;
1575 use overload '""' => "STRINGIFY",
1576   '0+' => \&File::Temp::NUMIFY,
1577   fallback => 1;
1578
1579 # private class specifically to support tempdir objects
1580 # created by File::Temp->newdir
1581
1582 # ostensibly the same method interface as File::Temp but without
1583 # inheriting all the IO::Seekable methods and other cruft
1584
1585 # Read-only - returns the name of the temp directory
1586
1587 sub dirname {
1588   my $self = shift;
1589   return $self->{DIRNAME};
1590 }
1591
1592 sub STRINGIFY {
1593   my $self = shift;
1594   return $self->dirname;
1595 }
1596
1597 sub unlink_on_destroy {
1598   my $self = shift;
1599   if (@_) {
1600     $self->{CLEANUP} = shift;
1601   }
1602   return $self->{CLEANUP};
1603 }
1604
1605 sub DESTROY {
1606   my $self = shift;
1607   local($., $@, $!, $^E, $?);
1608   if ($self->unlink_on_destroy && 
1609       $$ == $self->{LAUNCHPID} && !$File::Temp::KEEP_ALL) {
1610     if (-d $self->{REALNAME}) {
1611       # Some versions of rmtree will abort if you attempt to remove
1612       # the directory you are sitting in. We protect that and turn it
1613       # into a warning. We do this because this occurs during object
1614       # destruction and so can not be caught by the user.
1615       eval { rmtree($self->{REALNAME}, $File::Temp::DEBUG, 0); };
1616       warn $@ if ($@ && $^W);
1617     }
1618   }
1619 }
1620
1621 1;
1622
1623 __END__
1624
1625 =pod
1626
1627 =encoding utf-8
1628
1629 =head1 NAME
1630
1631 File::Temp - return name and handle of a temporary file safely
1632
1633 =head1 VERSION
1634
1635 version 0.2301
1636
1637 =head1 SYNOPSIS
1638
1639   use File::Temp qw/ tempfile tempdir /;
1640
1641   $fh = tempfile();
1642   ($fh, $filename) = tempfile();
1643
1644   ($fh, $filename) = tempfile( $template, DIR => $dir);
1645   ($fh, $filename) = tempfile( $template, SUFFIX => '.dat');
1646   ($fh, $filename) = tempfile( $template, TMPDIR => 1 );
1647
1648   binmode( $fh, ":utf8" );
1649
1650   $dir = tempdir( CLEANUP => 1 );
1651   ($fh, $filename) = tempfile( DIR => $dir );
1652
1653 Object interface:
1654
1655   require File::Temp;
1656   use File::Temp ();
1657   use File::Temp qw/ :seekable /;
1658
1659   $fh = File::Temp->new();
1660   $fname = $fh->filename;
1661
1662   $fh = File::Temp->new(TEMPLATE => $template);
1663   $fname = $fh->filename;
1664
1665   $tmp = File::Temp->new( UNLINK => 0, SUFFIX => '.dat' );
1666   print $tmp "Some data\n";
1667   print "Filename is $tmp\n";
1668   $tmp->seek( 0, SEEK_END );
1669
1670 The following interfaces are provided for compatibility with
1671 existing APIs. They should not be used in new code.
1672
1673 MkTemp family:
1674
1675   use File::Temp qw/ :mktemp  /;
1676
1677   ($fh, $file) = mkstemp( "tmpfileXXXXX" );
1678   ($fh, $file) = mkstemps( "tmpfileXXXXXX", $suffix);
1679
1680   $tmpdir = mkdtemp( $template );
1681
1682   $unopened_file = mktemp( $template );
1683
1684 POSIX functions:
1685
1686   use File::Temp qw/ :POSIX /;
1687
1688   $file = tmpnam();
1689   $fh = tmpfile();
1690
1691   ($fh, $file) = tmpnam();
1692
1693 Compatibility functions:
1694
1695   $unopened_file = File::Temp::tempnam( $dir, $pfx );
1696
1697 =head1 DESCRIPTION
1698
1699 C<File::Temp> can be used to create and open temporary files in a safe
1700 way.  There is both a function interface and an object-oriented
1701 interface.  The File::Temp constructor or the tempfile() function can
1702 be used to return the name and the open filehandle of a temporary
1703 file.  The tempdir() function can be used to create a temporary
1704 directory.
1705
1706 The security aspect of temporary file creation is emphasized such that
1707 a filehandle and filename are returned together.  This helps guarantee
1708 that a race condition can not occur where the temporary file is
1709 created by another process between checking for the existence of the
1710 file and its opening.  Additional security levels are provided to
1711 check, for example, that the sticky bit is set on world writable
1712 directories.  See L<"safe_level"> for more information.
1713
1714 For compatibility with popular C library functions, Perl implementations of
1715 the mkstemp() family of functions are provided. These are, mkstemp(),
1716 mkstemps(), mkdtemp() and mktemp().
1717
1718 Additionally, implementations of the standard L<POSIX|POSIX>
1719 tmpnam() and tmpfile() functions are provided if required.
1720
1721 Implementations of mktemp(), tmpnam(), and tempnam() are provided,
1722 but should be used with caution since they return only a filename
1723 that was valid when function was called, so cannot guarantee
1724 that the file will not exist by the time the caller opens the filename.
1725
1726 Filehandles returned by these functions support the seekable methods.
1727
1728 =begin __INTERNALS
1729
1730 =head1 PORTABILITY
1731
1732 This section is at the top in order to provide easier access to
1733 porters.  It is not expected to be rendered by a standard pod
1734 formatting tool. Please skip straight to the SYNOPSIS section if you
1735 are not trying to port this module to a new platform.
1736
1737 This module is designed to be portable across operating systems and it
1738 currently supports Unix, VMS, DOS, OS/2, Windows and Mac OS
1739 (Classic). When porting to a new OS there are generally three main
1740 issues that have to be solved:
1741 =over 4
1742
1743 =item *
1744
1745 Can the OS unlink an open file? If it can not then the
1746 C<_can_unlink_opened_file> method should be modified.
1747
1748 =item *
1749
1750 Are the return values from C<stat> reliable? By default all the
1751 return values from C<stat> are compared when unlinking a temporary
1752 file using the filename and the handle. Operating systems other than
1753 unix do not always have valid entries in all fields. If utility function
1754 C<File::Temp::unlink0> fails then the C<stat> comparison should be
1755 modified accordingly.
1756
1757 =item *
1758
1759 Security. Systems that can not support a test for the sticky bit
1760 on a directory can not use the MEDIUM and HIGH security tests.
1761 The C<_can_do_level> method should be modified accordingly.
1762
1763 =back
1764
1765 =end __INTERNALS
1766
1767 =head1 OBJECT-ORIENTED INTERFACE
1768
1769 This is the primary interface for interacting with
1770 C<File::Temp>. Using the OO interface a temporary file can be created
1771 when the object is constructed and the file can be removed when the
1772 object is no longer required.
1773
1774 Note that there is no method to obtain the filehandle from the
1775 C<File::Temp> object. The object itself acts as a filehandle.  The object
1776 isa C<IO::Handle> and isa C<IO::Seekable> so all those methods are
1777 available.
1778
1779 Also, the object is configured such that it stringifies to the name of the
1780 temporary file and so can be compared to a filename directly.  It numifies
1781 to the C<refaddr> the same as other handles and so can be compared to other
1782 handles with C<==>.
1783
1784     $fh eq $filename       # as a string
1785     $fh != \*STDOUT        # as a number
1786
1787 =over 4
1788
1789 =item B<new>
1790
1791 Create a temporary file object.
1792
1793   my $tmp = File::Temp->new();
1794
1795 by default the object is constructed as if C<tempfile>
1796 was called without options, but with the additional behaviour
1797 that the temporary file is removed by the object destructor
1798 if UNLINK is set to true (the default).
1799
1800 Supported arguments are the same as for C<tempfile>: UNLINK
1801 (defaulting to true), DIR, EXLOCK and SUFFIX. Additionally, the filename
1802 template is specified using the TEMPLATE option. The OPEN option
1803 is not supported (the file is always opened).
1804
1805  $tmp = File::Temp->new( TEMPLATE => 'tempXXXXX',
1806                         DIR => 'mydir',
1807                         SUFFIX => '.dat');
1808
1809 Arguments are case insensitive.
1810
1811 Can call croak() if an error occurs.
1812
1813 =item B<newdir>
1814
1815 Create a temporary directory using an object oriented interface.
1816
1817   $dir = File::Temp->newdir();
1818
1819 By default the directory is deleted when the object goes out of scope.
1820
1821 Supports the same options as the C<tempdir> function. Note that directories
1822 created with this method default to CLEANUP => 1.
1823
1824   $dir = File::Temp->newdir( $template, %options );
1825
1826 A template may be specified either with a leading template or
1827 with a TEMPLATE argument.
1828
1829 =item B<filename>
1830
1831 Return the name of the temporary file associated with this object
1832 (if the object was created using the "new" constructor).
1833
1834   $filename = $tmp->filename;
1835
1836 This method is called automatically when the object is used as
1837 a string.
1838
1839 =item B<dirname>
1840
1841 Return the name of the temporary directory associated with this
1842 object (if the object was created using the "newdir" constructor).
1843
1844   $dirname = $tmpdir->dirname;
1845
1846 This method is called automatically when the object is used in string context.
1847
1848 =item B<unlink_on_destroy>
1849
1850 Control whether the file is unlinked when the object goes out of scope.
1851 The file is removed if this value is true and $KEEP_ALL is not.
1852
1853  $fh->unlink_on_destroy( 1 );
1854
1855 Default is for the file to be removed.
1856
1857 =item B<DESTROY>
1858
1859 When the object goes out of scope, the destructor is called. This
1860 destructor will attempt to unlink the file (using L<unlink1|"unlink1">)
1861 if the constructor was called with UNLINK set to 1 (the default state
1862 if UNLINK is not specified).
1863
1864 No error is given if the unlink fails.
1865
1866 If the object has been passed to a child process during a fork, the
1867 file will be deleted when the object goes out of scope in the parent.
1868
1869 For a temporary directory object the directory will be removed unless
1870 the CLEANUP argument was used in the constructor (and set to false) or
1871 C<unlink_on_destroy> was modified after creation.  Note that if a temp
1872 directory is your current directory, it cannot be removed - a warning
1873 will be given in this case.  C<chdir()> out of the directory before
1874 letting the object go out of scope.
1875
1876 If the global variable $KEEP_ALL is true, the file or directory
1877 will not be removed.
1878
1879 =back
1880
1881 =head1 FUNCTIONS
1882
1883 This section describes the recommended interface for generating
1884 temporary files and directories.
1885
1886 =over 4
1887
1888 =item B<tempfile>
1889
1890 This is the basic function to generate temporary files.
1891 The behaviour of the file can be changed using various options:
1892
1893   $fh = tempfile();
1894   ($fh, $filename) = tempfile();
1895
1896 Create a temporary file in  the directory specified for temporary
1897 files, as specified by the tmpdir() function in L<File::Spec>.
1898
1899   ($fh, $filename) = tempfile($template);
1900
1901 Create a temporary file in the current directory using the supplied
1902 template.  Trailing `X' characters are replaced with random letters to
1903 generate the filename.  At least four `X' characters must be present
1904 at the end of the template.
1905
1906   ($fh, $filename) = tempfile($template, SUFFIX => $suffix)
1907
1908 Same as previously, except that a suffix is added to the template
1909 after the `X' translation.  Useful for ensuring that a temporary
1910 filename has a particular extension when needed by other applications.
1911 But see the WARNING at the end.
1912
1913   ($fh, $filename) = tempfile($template, DIR => $dir);
1914
1915 Translates the template as before except that a directory name
1916 is specified.
1917
1918   ($fh, $filename) = tempfile($template, TMPDIR => 1);
1919
1920 Equivalent to specifying a DIR of "File::Spec->tmpdir", writing the file
1921 into the same temporary directory as would be used if no template was
1922 specified at all.
1923
1924   ($fh, $filename) = tempfile($template, UNLINK => 1);
1925
1926 Return the filename and filehandle as before except that the file is
1927 automatically removed when the program exits (dependent on
1928 $KEEP_ALL). Default is for the file to be removed if a file handle is
1929 requested and to be kept if the filename is requested. In a scalar
1930 context (where no filename is returned) the file is always deleted
1931 either (depending on the operating system) on exit or when it is
1932 closed (unless $KEEP_ALL is true when the temp file is created).
1933
1934 Use the object-oriented interface if fine-grained control of when
1935 a file is removed is required.
1936
1937 If the template is not specified, a template is always
1938 automatically generated. This temporary file is placed in tmpdir()
1939 (L<File::Spec>) unless a directory is specified explicitly with the
1940 DIR option.
1941
1942   $fh = tempfile( DIR => $dir );
1943
1944 If called in scalar context, only the filehandle is returned and the
1945 file will automatically be deleted when closed on operating systems
1946 that support this (see the description of tmpfile() elsewhere in this
1947 document).  This is the preferred mode of operation, as if you only
1948 have a filehandle, you can never create a race condition by fumbling
1949 with the filename. On systems that can not unlink an open file or can
1950 not mark a file as temporary when it is opened (for example, Windows
1951 NT uses the C<O_TEMPORARY> flag) the file is marked for deletion when
1952 the program ends (equivalent to setting UNLINK to 1). The C<UNLINK>
1953 flag is ignored if present.
1954
1955   (undef, $filename) = tempfile($template, OPEN => 0);
1956
1957 This will return the filename based on the template but
1958 will not open this file.  Cannot be used in conjunction with
1959 UNLINK set to true. Default is to always open the file
1960 to protect from possible race conditions. A warning is issued
1961 if warnings are turned on. Consider using the tmpnam()
1962 and mktemp() functions described elsewhere in this document
1963 if opening the file is not required.
1964
1965 If the operating system supports it (for example BSD derived systems), the 
1966 filehandle will be opened with O_EXLOCK (open with exclusive file lock). 
1967 This can sometimes cause problems if the intention is to pass the filename 
1968 to another system that expects to take an exclusive lock itself (such as 
1969 DBD::SQLite) whilst ensuring that the tempfile is not reused. In this 
1970 situation the "EXLOCK" option can be passed to tempfile. By default EXLOCK 
1971 will be true (this retains compatibility with earlier releases).
1972
1973   ($fh, $filename) = tempfile($template, EXLOCK => 0);
1974
1975 Options can be combined as required.
1976
1977 Will croak() if there is an error.
1978
1979 =item B<tempdir>
1980
1981 This is the recommended interface for creation of temporary
1982 directories.  By default the directory will not be removed on exit
1983 (that is, it won't be temporary; this behaviour can not be changed
1984 because of issues with backwards compatibility). To enable removal
1985 either use the CLEANUP option which will trigger removal on program
1986 exit, or consider using the "newdir" method in the object interface which
1987 will allow the directory to be cleaned up when the object goes out of
1988 scope.
1989
1990 The behaviour of the function depends on the arguments:
1991
1992   $tempdir = tempdir();
1993
1994 Create a directory in tmpdir() (see L<File::Spec|File::Spec>).
1995
1996   $tempdir = tempdir( $template );
1997
1998 Create a directory from the supplied template. This template is
1999 similar to that described for tempfile(). `X' characters at the end
2000 of the template are replaced with random letters to construct the
2001 directory name. At least four `X' characters must be in the template.
2002
2003   $tempdir = tempdir ( DIR => $dir );
2004
2005 Specifies the directory to use for the temporary directory.
2006 The temporary directory name is derived from an internal template.
2007
2008   $tempdir = tempdir ( $template, DIR => $dir );
2009
2010 Prepend the supplied directory name to the template. The template
2011 should not include parent directory specifications itself. Any parent
2012 directory specifications are removed from the template before
2013 prepending the supplied directory.
2014
2015   $tempdir = tempdir ( $template, TMPDIR => 1 );
2016
2017 Using the supplied template, create the temporary directory in
2018 a standard location for temporary files. Equivalent to doing
2019
2020   $tempdir = tempdir ( $template, DIR => File::Spec->tmpdir);
2021
2022 but shorter. Parent directory specifications are stripped from the
2023 template itself. The C<TMPDIR> option is ignored if C<DIR> is set
2024 explicitly.  Additionally, C<TMPDIR> is implied if neither a template
2025 nor a directory are supplied.
2026
2027   $tempdir = tempdir( $template, CLEANUP => 1);
2028
2029 Create a temporary directory using the supplied template, but
2030 attempt to remove it (and all files inside it) when the program
2031 exits. Note that an attempt will be made to remove all files from
2032 the directory even if they were not created by this module (otherwise
2033 why ask to clean it up?). The directory removal is made with
2034 the rmtree() function from the L<File::Path|File::Path> module.
2035 Of course, if the template is not specified, the temporary directory
2036 will be created in tmpdir() and will also be removed at program exit.
2037
2038 Will croak() if there is an error.
2039
2040 =back
2041
2042 =head1 MKTEMP FUNCTIONS
2043
2044 The following functions are Perl implementations of the
2045 mktemp() family of temp file generation system calls.
2046
2047 =over 4
2048
2049 =item B<mkstemp>
2050
2051 Given a template, returns a filehandle to the temporary file and the name
2052 of the file.
2053
2054   ($fh, $name) = mkstemp( $template );
2055
2056 In scalar context, just the filehandle is returned.
2057
2058 The template may be any filename with some number of X's appended
2059 to it, for example F</tmp/temp.XXXX>. The trailing X's are replaced
2060 with unique alphanumeric combinations.
2061
2062 Will croak() if there is an error.
2063
2064 =item B<mkstemps>
2065
2066 Similar to mkstemp(), except that an extra argument can be supplied
2067 with a suffix to be appended to the template.
2068
2069   ($fh, $name) = mkstemps( $template, $suffix );
2070
2071 For example a template of C<testXXXXXX> and suffix of C<.dat>
2072 would generate a file similar to F<testhGji_w.dat>.
2073
2074 Returns just the filehandle alone when called in scalar context.
2075
2076 Will croak() if there is an error.
2077
2078 =item B<mkdtemp>
2079
2080 Create a directory from a template. The template must end in
2081 X's that are replaced by the routine.
2082
2083   $tmpdir_name = mkdtemp($template);
2084
2085 Returns the name of the temporary directory created.
2086
2087 Directory must be removed by the caller.
2088
2089 Will croak() if there is an error.
2090
2091 =item B<mktemp>
2092
2093 Returns a valid temporary filename but does not guarantee
2094 that the file will not be opened by someone else.
2095
2096   $unopened_file = mktemp($template);
2097
2098 Template is the same as that required by mkstemp().
2099
2100 Will croak() if there is an error.
2101
2102 =back
2103
2104 =head1 POSIX FUNCTIONS
2105
2106 This section describes the re-implementation of the tmpnam()
2107 and tmpfile() functions described in L<POSIX>
2108 using the mkstemp() from this module.
2109
2110 Unlike the L<POSIX|POSIX> implementations, the directory used
2111 for the temporary file is not specified in a system include
2112 file (C<P_tmpdir>) but simply depends on the choice of tmpdir()
2113 returned by L<File::Spec|File::Spec>. On some implementations this
2114 location can be set using the C<TMPDIR> environment variable, which
2115 may not be secure.
2116 If this is a problem, simply use mkstemp() and specify a template.
2117
2118 =over 4
2119
2120 =item B<tmpnam>
2121
2122 When called in scalar context, returns the full name (including path)
2123 of a temporary file (uses mktemp()). The only check is that the file does
2124 not already exist, but there is no guarantee that that condition will
2125 continue to apply.
2126
2127   $file = tmpnam();
2128
2129 When called in list context, a filehandle to the open file and
2130 a filename are returned. This is achieved by calling mkstemp()
2131 after constructing a suitable template.
2132
2133   ($fh, $file) = tmpnam();
2134
2135 If possible, this form should be used to prevent possible
2136 race conditions.
2137
2138 See L<File::Spec/tmpdir> for information on the choice of temporary
2139 directory for a particular operating system.
2140
2141 Will croak() if there is an error.
2142
2143 =item B<tmpfile>
2144
2145 Returns the filehandle of a temporary file.
2146
2147   $fh = tmpfile();
2148
2149 The file is removed when the filehandle is closed or when the program
2150 exits. No access to the filename is provided.
2151
2152 If the temporary file can not be created undef is returned.
2153 Currently this command will probably not work when the temporary
2154 directory is on an NFS file system.
2155
2156 Will croak() if there is an error.
2157
2158 =back
2159
2160 =head1 ADDITIONAL FUNCTIONS
2161
2162 These functions are provided for backwards compatibility
2163 with common tempfile generation C library functions.
2164
2165 They are not exported and must be addressed using the full package
2166 name.
2167
2168 =over 4
2169
2170 =item B<tempnam>
2171
2172 Return the name of a temporary file in the specified directory
2173 using a prefix. The file is guaranteed not to exist at the time
2174 the function was called, but such guarantees are good for one
2175 clock tick only.  Always use the proper form of C<sysopen>
2176 with C<O_CREAT | O_EXCL> if you must open such a filename.
2177
2178   $filename = File::Temp::tempnam( $dir, $prefix );
2179
2180 Equivalent to running mktemp() with $dir/$prefixXXXXXXXX
2181 (using unix file convention as an example)
2182
2183 Because this function uses mktemp(), it can suffer from race conditions.
2184
2185 Will croak() if there is an error.
2186
2187 =back
2188
2189 =head1 UTILITY FUNCTIONS
2190
2191 Useful functions for dealing with the filehandle and filename.
2192
2193 =over 4
2194
2195 =item B<unlink0>
2196
2197 Given an open filehandle and the associated filename, make a safe
2198 unlink. This is achieved by first checking that the filename and
2199 filehandle initially point to the same file and that the number of
2200 links to the file is 1 (all fields returned by stat() are compared).
2201 Then the filename is unlinked and the filehandle checked once again to
2202 verify that the number of links on that file is now 0.  This is the
2203 closest you can come to making sure that the filename unlinked was the
2204 same as the file whose descriptor you hold.
2205
2206   unlink0($fh, $path)
2207      or die "Error unlinking file $path safely";
2208
2209 Returns false on error but croaks() if there is a security
2210 anomaly. The filehandle is not closed since on some occasions this is
2211 not required.
2212
2213 On some platforms, for example Windows NT, it is not possible to
2214 unlink an open file (the file must be closed first). On those
2215 platforms, the actual unlinking is deferred until the program ends and
2216 good status is returned. A check is still performed to make sure that
2217 the filehandle and filename are pointing to the same thing (but not at
2218 the time the end block is executed since the deferred removal may not
2219 have access to the filehandle).
2220
2221 Additionally, on Windows NT not all the fields returned by stat() can
2222 be compared. For example, the C<dev> and C<rdev> fields seem to be
2223 different.  Also, it seems that the size of the file returned by stat()
2224 does not always agree, with C<stat(FH)> being more accurate than
2225 C<stat(filename)>, presumably because of caching issues even when
2226 using autoflush (this is usually overcome by waiting a while after
2227 writing to the tempfile before attempting to C<unlink0> it).
2228
2229 Finally, on NFS file systems the link count of the file handle does
2230 not always go to zero immediately after unlinking. Currently, this
2231 command is expected to fail on NFS disks.
2232
2233 This function is disabled if the global variable $KEEP_ALL is true
2234 and an unlink on open file is supported. If the unlink is to be deferred
2235 to the END block, the file is still registered for removal.
2236
2237 This function should not be called if you are using the object oriented
2238 interface since the it will interfere with the object destructor deleting
2239 the file.
2240
2241 =item B<cmpstat>
2242
2243 Compare C<stat> of filehandle with C<stat> of provided filename.  This
2244 can be used to check that the filename and filehandle initially point
2245 to the same file and that the number of links to the file is 1 (all
2246 fields returned by stat() are compared).
2247
2248   cmpstat($fh, $path)
2249      or die "Error comparing handle with file";
2250
2251 Returns false if the stat information differs or if the link count is
2252 greater than 1. Calls croak if there is a security anomaly.
2253
2254 On certain platforms, for example Windows, not all the fields returned by stat()
2255 can be compared. For example, the C<dev> and C<rdev> fields seem to be
2256 different in Windows.  Also, it seems that the size of the file
2257 returned by stat() does not always agree, with C<stat(FH)> being more
2258 accurate than C<stat(filename)>, presumably because of caching issues
2259 even when using autoflush (this is usually overcome by waiting a while
2260 after writing to the tempfile before attempting to C<unlink0> it).
2261
2262 Not exported by default.
2263
2264 =item B<unlink1>
2265
2266 Similar to C<unlink0> except after file comparison using cmpstat, the
2267 filehandle is closed prior to attempting to unlink the file. This
2268 allows the file to be removed without using an END block, but does
2269 mean that the post-unlink comparison of the filehandle state provided
2270 by C<unlink0> is not available.
2271
2272   unlink1($fh, $path)
2273      or die "Error closing and unlinking file";
2274
2275 Usually called from the object destructor when using the OO interface.
2276
2277 Not exported by default.
2278
2279 This function is disabled if the global variable $KEEP_ALL is true.
2280
2281 Can call croak() if there is a security anomaly during the stat()
2282 comparison.
2283
2284 =item B<cleanup>
2285
2286 Calling this function will cause any temp files or temp directories
2287 that are registered for removal to be removed. This happens automatically
2288 when the process exits but can be triggered manually if the caller is sure
2289 that none of the temp files are required. This method can be registered as
2290 an Apache callback.
2291
2292 Note that if a temp directory is your current directory, it cannot be
2293 removed.  C<chdir()> out of the directory first before calling
2294 C<cleanup()>. (For the cleanup at program exit when the CLEANUP flag
2295 is set, this happens automatically.)
2296
2297 On OSes where temp files are automatically removed when the temp file
2298 is closed, calling this function will have no effect other than to remove
2299 temporary directories (which may include temporary files).
2300
2301   File::Temp::cleanup();
2302
2303 Not exported by default.
2304
2305 =back
2306
2307 =head1 PACKAGE VARIABLES
2308
2309 These functions control the global state of the package.
2310
2311 =over 4
2312
2313 =item B<safe_level>
2314
2315 Controls the lengths to which the module will go to check the safety of the
2316 temporary file or directory before proceeding.
2317 Options are:
2318
2319 =over 8
2320
2321 =item STANDARD
2322
2323 Do the basic security measures to ensure the directory exists and is
2324 writable, that temporary files are opened only if they do not already
2325 exist, and that possible race conditions are avoided.  Finally the
2326 L<unlink0|"unlink0"> function is used to remove files safely.
2327
2328 =item MEDIUM
2329
2330 In addition to the STANDARD security, the output directory is checked
2331 to make sure that it is owned either by root or the user running the
2332 program. If the directory is writable by group or by other, it is then
2333 checked to make sure that the sticky bit is set.
2334
2335 Will not work on platforms that do not support the C<-k> test
2336 for sticky bit.
2337
2338 =item HIGH
2339
2340 In addition to the MEDIUM security checks, also check for the
2341 possibility of ``chown() giveaway'' using the L<POSIX|POSIX>
2342 sysconf() function. If this is a possibility, each directory in the
2343 path is checked in turn for safeness, recursively walking back to the
2344 root directory.
2345
2346 For platforms that do not support the L<POSIX|POSIX>
2347 C<_PC_CHOWN_RESTRICTED> symbol (for example, Windows NT) it is
2348 assumed that ``chown() giveaway'' is possible and the recursive test
2349 is performed.
2350
2351 =back
2352
2353 The level can be changed as follows:
2354
2355   File::Temp->safe_level( File::Temp::HIGH );
2356
2357 The level constants are not exported by the module.
2358
2359 Currently, you must be running at least perl v5.6.0 in order to
2360 run with MEDIUM or HIGH security. This is simply because the
2361 safety tests use functions from L<Fcntl|Fcntl> that are not
2362 available in older versions of perl. The problem is that the version
2363 number for Fcntl is the same in perl 5.6.0 and in 5.005_03 even though
2364 they are different versions.
2365
2366 On systems that do not support the HIGH or MEDIUM safety levels
2367 (for example Win NT or OS/2) any attempt to change the level will
2368 be ignored. The decision to ignore rather than raise an exception
2369 allows portable programs to be written with high security in mind
2370 for the systems that can support this without those programs failing
2371 on systems where the extra tests are irrelevant.
2372
2373 If you really need to see whether the change has been accepted
2374 simply examine the return value of C<safe_level>.
2375
2376   $newlevel = File::Temp->safe_level( File::Temp::HIGH );
2377   die "Could not change to high security"
2378       if $newlevel != File::Temp::HIGH;
2379
2380 =item TopSystemUID
2381
2382 This is the highest UID on the current system that refers to a root
2383 UID. This is used to make sure that the temporary directory is
2384 owned by a system UID (C<root>, C<bin>, C<sys> etc) rather than
2385 simply by root.
2386
2387 This is required since on many unix systems C</tmp> is not owned
2388 by root.
2389
2390 Default is to assume that any UID less than or equal to 10 is a root
2391 UID.
2392
2393   File::Temp->top_system_uid(10);
2394   my $topid = File::Temp->top_system_uid;
2395
2396 This value can be adjusted to reduce security checking if required.
2397 The value is only relevant when C<safe_level> is set to MEDIUM or higher.
2398
2399 =item B<$KEEP_ALL>
2400
2401 Controls whether temporary files and directories should be retained
2402 regardless of any instructions in the program to remove them
2403 automatically.  This is useful for debugging but should not be used in
2404 production code.
2405
2406   $File::Temp::KEEP_ALL = 1;
2407
2408 Default is for files to be removed as requested by the caller.
2409
2410 In some cases, files will only be retained if this variable is true
2411 when the file is created. This means that you can not create a temporary
2412 file, set this variable and expect the temp file to still be around
2413 when the program exits.
2414
2415 =item B<$DEBUG>
2416
2417 Controls whether debugging messages should be enabled.
2418
2419   $File::Temp::DEBUG = 1;
2420
2421 Default is for debugging mode to be disabled.
2422
2423 =back
2424
2425 =head1 WARNING
2426
2427 For maximum security, endeavour always to avoid ever looking at,
2428 touching, or even imputing the existence of the filename.  You do not
2429 know that that filename is connected to the same file as the handle
2430 you have, and attempts to check this can only trigger more race
2431 conditions.  It's far more secure to use the filehandle alone and
2432 dispense with the filename altogether.
2433
2434 If you need to pass the handle to something that expects a filename
2435 then on a unix system you can use C<"/dev/fd/" . fileno($fh)> for
2436 arbitrary programs. Perl code that uses the 2-argument version of
2437 C<< open >> can be passed C<< "+<=&" . fileno($fh) >>. Otherwise you
2438 will need to pass the filename. You will have to clear the
2439 close-on-exec bit on that file descriptor before passing it to another
2440 process.
2441
2442     use Fcntl qw/F_SETFD F_GETFD/;
2443     fcntl($tmpfh, F_SETFD, 0)
2444         or die "Can't clear close-on-exec flag on temp fh: $!\n";
2445
2446 =head2 Temporary files and NFS
2447
2448 Some problems are associated with using temporary files that reside
2449 on NFS file systems and it is recommended that a local filesystem
2450 is used whenever possible. Some of the security tests will most probably
2451 fail when the temp file is not local. Additionally, be aware that
2452 the performance of I/O operations over NFS will not be as good as for
2453 a local disk.
2454
2455 =head2 Forking
2456
2457 In some cases files created by File::Temp are removed from within an
2458 END block. Since END blocks are triggered when a child process exits
2459 (unless C<POSIX::_exit()> is used by the child) File::Temp takes care
2460 to only remove those temp files created by a particular process ID. This
2461 means that a child will not attempt to remove temp files created by the
2462 parent process.
2463
2464 If you are forking many processes in parallel that are all creating
2465 temporary files, you may need to reset the random number seed using
2466 srand(EXPR) in each child else all the children will attempt to walk
2467 through the same set of random file names and may well cause
2468 themselves to give up if they exceed the number of retry attempts.
2469
2470 =head2 Directory removal
2471
2472 Note that if you have chdir'ed into the temporary directory and it is
2473 subsequently cleaned up (either in the END block or as part of object
2474 destruction), then you will get a warning from File::Path::rmtree().
2475
2476 =head2 Taint mode
2477
2478 If you need to run code under taint mode, updating to the latest
2479 L<File::Spec> is highly recommended.
2480
2481 =head2 BINMODE
2482
2483 The file returned by File::Temp will have been opened in binary mode
2484 if such a mode is available. If that is not correct, use the C<binmode()>
2485 function to change the mode of the filehandle.
2486
2487 Note that you can modify the encoding of a file opened by File::Temp
2488 also by using C<binmode()>.
2489
2490 =head1 HISTORY
2491
2492 Originally began life in May 1999 as an XS interface to the system
2493 mkstemp() function. In March 2000, the OpenBSD mkstemp() code was
2494 translated to Perl for total control of the code's
2495 security checking, to ensure the presence of the function regardless of
2496 operating system and to help with portability. The module was shipped
2497 as a standard part of perl from v5.6.1.
2498
2499 Thanks to Tom Christiansen for suggesting that this module
2500 should be written and providing ideas for code improvements and
2501 security enhancements.
2502
2503 =head1 SEE ALSO
2504
2505 L<POSIX/tmpnam>, L<POSIX/tmpfile>, L<File::Spec>, L<File::Path>
2506
2507 See L<IO::File> and L<File::MkTemp>, L<Apache::TempFile> for
2508 different implementations of temporary file handling.
2509
2510 See L<File::Tempdir> for an alternative object-oriented wrapper for
2511 the C<tempdir> function.
2512
2513 =for Pod::Coverage STRINGIFY NUMIFY top_system_uid
2514
2515 # vim: ts=2 sts=2 sw=2 et:
2516
2517 =for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
2518
2519 =head1 SUPPORT
2520
2521 =head2 Bugs / Feature Requests
2522
2523 Please report any bugs or feature requests through the issue tracker
2524 at L<https://rt.cpan.org/Public/Dist/Display.html?Name=File-Temp>.
2525 You will be notified automatically of any progress on your issue.
2526
2527 =head2 Source Code
2528
2529 This is open source software.  The code repository is available for
2530 public review and contribution under the terms of the license.
2531
2532 L<http://github.com/Perl-Toolchain-Gang/File-Temp>
2533
2534   git clone git://github.com/Perl-Toolchain-Gang/File-Temp.git
2535
2536 =head1 AUTHOR
2537
2538 Tim Jenness <tjenness@cpan.org>
2539
2540 =head1 CONTRIBUTORS
2541
2542 =over 4
2543
2544 =item *
2545
2546 Ben Tilly <btilly@gmail.com>
2547
2548 =item *
2549
2550 David Golden <dagolden@cpan.org>
2551
2552 =item *
2553
2554 Ed Avis <eda@linux01.wcl.local>
2555
2556 =item *
2557
2558 James E. Keenan <jkeen@verizon.net>
2559
2560 =item *
2561
2562 Kevin Ryde <user42@zip.com.au>
2563
2564 =item *
2565
2566 Peter John Acklam <pjacklam@online.no>
2567
2568 =back
2569
2570 =head1 COPYRIGHT AND LICENSE
2571
2572 This software is copyright (c) 2013 by Tim Jenness and the UK Particle Physics and Astronomy Research Council.
2573
2574 This is free software; you can redistribute it and/or modify it under
2575 the same terms as the Perl 5 programming language system itself.
2576
2577 =cut