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