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