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