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