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