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