[ Index ]

PHP Cross Reference of Unnamed Project

title

Body

[close]

/se3-unattended/var/se3/unattended/install/linuxaux/opt/perl/lib/5.10.0/File/ -> Temp.pm (source)

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


Generated: Tue Mar 17 22:47:18 2015 Cross-referenced by PHPXref 0.7.1