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