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