lib/File/Temp.pm

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