temp.pm

1. 记录每个帖子的访问人情况

package File::Temp;

=head1 NAME

File::Temp - return name and handle of a temporary file safely

=begin __INTERNALS

=head1 PORTABILITY

This module is designed to be portable across operating systems
and it currently supports Unix, VMS, DOS, OS/2 and Windows. When
porting to a new OS there are generally three main issues
that have to be solved:

=over 4

=item *

Can the OS unlink an open file? If it can not then the
C<_can_unlink_opened_file> method should be modified.

=item *

Are the return values from C<stat> reliable? By default all the
return values from C<stat> are compared when unlinking a temporary
file using the filename and the handle. Operating systems other than
unix do not always have valid entries in all fields. If C<unlink0> fails
then the C<stat> comparison should be modified accordingly.

=item *

Security. Systems that can not support a test for the sticky bit
on a directory can not use the MEDIUM and HIGH security tests.
The C<_can_do_level> method should be modified accordingly.

=back

=end __INTERNALS

=head1 SYNOPSIS

  use File::Temp qw/ tempfile tempdir /; 

  $dir = tempdir( CLEANUP => 1 );
  ($fh, $filename) = tempfile( DIR => $dir );

  ($fh, $filename) = tempfile( $template, DIR => $dir);
  ($fh, $filename) = tempfile( $template, SUFFIX => '.dat');

  $fh = tempfile();

MkTemp family:

  use File::Temp qw/ :mktemp  /;

  ($fh, $file) = mkstemp( "tmpfileXXXXX" );
  ($fh, $file) = mkstemps( "tmpfileXXXXXX", $suffix);

  $tmpdir = mkdtemp( $template );

  $unopened_file = mktemp( $template );

POSIX functions:

  use File::Temp qw/ :POSIX /;

  $file = tmpnam();
  $fh = tmpfile();

  ($fh, $file) = tmpnam();
  ($fh, $file) = tmpfile();


Compatibility functions:

  $unopened_file = File::Temp::tempnam( $dir, $pfx );

=begin later

Objects (NOT YET IMPLEMENTED):

  require File::Temp;

  $fh = new File::Temp($template);
  $fname = $fh->filename;

=end later

=head1 DESCRIPTION

C<File::Temp> can be used to create and open temporary files in a safe way.
The tempfile() function can be used to return the name and the open
filehandle of a temporary file.  The tempdir() function can 
be used to create a temporary directory.

The security aspect of temporary file creation is emphasized such that
a filehandle and filename are returned together.  This helps guarantee
that a race condition can not occur where the temporary file is
created by another process between checking for the existence of the
file and its opening.  Additional security levels are provided to
check, for example, that the sticky bit is set on world writable
directories.  See L<"safe_level"> for more information.

For compatibility with popular C library functions, Perl implementations of
the mkstemp() family of functions are provided. These are, mkstemp(),
mkstemps(), mkdtemp() and mktemp().

Additionally, implementations of the standard L<POSIX|POSIX>
tmpnam() and tmpfile() functions are provided if required.

Implementations of mktemp(), tmpnam(), and tempnam() are provided,
but should be used with caution since they return only a filename
that was valid when function was called, so cannot guarantee
that the file will not exist by the time the caller opens the filename.

=cut

# 5.6.0 gives us S_IWOTH, S_IWGRP, our and auto-vivifying filehandls
# People would like a version on 5.005 so give them what they want :-)
use 5.005;
use strict;
use Carp;
use File::Spec 0.8;
use File::Path qw/ rmtree /;
use Fcntl 1.03;
use Errno;
require VMS::Stdio if $^O eq 'VMS';

# Need the Symbol package if we are running older perl
require Symbol if $] < 5.006;


# use 'our' on v5.6.0
use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS $DEBUG);

$DEBUG = 0;

# We are exporting functions

use base qw/Exporter/;

# Export list - to allow fine tuning of export table

@EXPORT_OK = qw{
	      tempfile
	      tempdir
	      tmpnam
	      tmpfile
	      mktemp
	      mkstemp
	      mkstemps
	      mkdtemp
	      unlink0
		};

# Groups of functions for export

%EXPORT_TAGS = (
		'POSIX' => [qw/ tmpnam tmpfile /],
		'mktemp' => [qw/ mktemp mkstemp mkstemps mkdtemp/],
	       );

# add contents of these tags to @EXPORT
Exporter::export_tags('POSIX','mktemp');

# Version number 

$VERSION = '0.12';

# This is a list of characters that can be used in random filenames

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
	         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
	         0 1 2 3 4 5 6 7 8 9 _
	     /);

# Maximum number of tries to make a temp file before failing

use constant MAX_TRIES => 10;

# Minimum number of X characters that should be in a template
use constant MINX => 4;

# Default template when no template supplied

use constant TEMPXXX => 'X' x 10;

# Constants for the security level

use constant STANDARD => 0;
use constant MEDIUM   => 1;
use constant HIGH     => 2;

# OPENFLAGS. If we defined the flag to use with Sysopen here this gives
# us an optimisation when many temporary files are requested

my $OPENFLAGS = O_CREAT | O_EXCL | O_RDWR;

for my $oflag (qw/ FOLLOW BINARY LARGEFILE EXLOCK NOINHERIT /) {
  my ($bit, $func) = (0, "Fcntl::O_" . $oflag);
  no strict 'refs';
  $OPENFLAGS |= $bit if eval {
    # Make sure that redefined die handlers do not cause problems
    # eg CGI::Carp
    local $SIG{__DIE__} = sub {};
    local $SIG{__WARN__} = sub {};
    $bit = &$func();
    1;
  };
}

# On some systems the O_TEMPORARY flag can be used to tell the OS
# to automatically remove the file when it is closed. This is fine
# in most cases but not if tempfile is called with UNLINK=>0 and
# the filename is requested -- in the case where the filename is to
# be passed to another routine. This happens on windows. We overcome
# this by using a second open flags variable

my $OPENTEMPFLAGS = $OPENFLAGS;
for my $oflag (qw/ TEMPORARY /) {
  my ($bit, $func) = (0, "Fcntl::O_" . $oflag);
  no strict 'refs';
  $OPENTEMPFLAGS |= $bit if eval {
    # Make sure that redefined die handlers do not cause problems
    # eg CGI::Carp
    local $SIG{__DIE__} = sub {};
    local $SIG{__WARN__} = sub {};
    $bit = &$func();
    1;
  };
}

# INTERNAL ROUTINES - not to be used outside of package

# Generic routine for getting a temporary filename
# modelled on OpenBSD _gettemp() in mktemp.c

# The template must contain X's that are to be replaced
# with the random values

#  Arguments:

#  TEMPLATE   - string containing the XXXXX's that is converted
#           to a random filename and opened if required

# Optionally, a hash can also be supplied containing specific options
#   "open" => if true open the temp file, else just return the name
#             default is 0
#   "mkdir"=> if true, we are creating a temp directory rather than tempfile
#             default is 0
#   "suffixlen" => number of characters at end of PATH to be ignored.
#                  default is 0.
#   "unlink_on_close" => indicates that, if possible,  the OS should remove
#                        the file as soon as it is closed. Usually indicates
#                        use of the O_TEMPORARY flag to sysopen. 
#                        Usually irrelevant on unix

# Optionally a reference to a scalar can be passed into the function
# On error this will be used to store the reason for the error
#   "ErrStr"  => \$errstr

# "open" and "mkdir" can not both be true
# "unlink_on_close" is not used when "mkdir" is true.

# The default options are equivalent to mktemp().

# Returns:
#   filehandle - open file handle (if called with doopen=1, else undef)
#   temp name  - name of the temp file or directory

# For example:
#   ($fh, $name) = _gettemp($template, "open" => 1);

# for the current version, failures are associated with
# stored in an error string and returned to give the reason whilst debugging
# This routine is not called by any external function
sub _gettemp {

  croak 'Usage: ($fh, $name) = _gettemp($template, OPTIONS);'
    unless scalar(@_) >= 1;

  # the internal error string - expect it to be overridden
  # Need this in case the caller decides not to supply us a value
  # need an anonymous scalar
  my $tempErrStr;

  # Default options
  my %options = (
		 "open" => 0,
		 "mkdir" => 0,
		 "suffixlen" => 0,
		 "unlink_on_close" => 0,
		 "ErrStr" => \$tempErrStr,
		);

  # Read the template
  my $template = shift;
  if (ref($template)) {
    # Use a warning here since we have not yet merged ErrStr
    carp "File::Temp::_gettemp: template must not be a reference";
    return ();
  }

  # Check that the number of entries on stack are even
  if (scalar(@_) % 2 != 0) {
    # Use a warning here since we have not yet merged ErrStr
    carp "File::Temp::_gettemp: Must have even number of options";
    return ();
  }

  # Read the options and merge with defaults
  %options = (%options, @_)  if @_;

  # Make sure the error string is set to undef
  ${$options{ErrStr}} = undef;

  # Can not open the file and make a directory in a single call
  if ($options{"open"} && $options{"mkdir"}) {
    ${$options{ErrStr}} = "doopen and domkdir can not both be true\n";
    return ();
  }

  # Find the start of the end of the  Xs (position of last X)
  # Substr starts from 0
  my $start = length($template) - 1 - $options{"suffixlen"};

  # Check that we have at least MINX x X (eg 'XXXX") at the end of the string
  # (taking suffixlen into account). Any fewer is insecure.

  # Do it using substr - no reason to use a pattern match since
  # we know where we are looking and what we are looking for

  if (substr($template, $start - MINX + 1, MINX) ne 'X' x MINX) {
    ${$options{ErrStr}} = "The template must contain at least ".
      MINX . " 'X' characters\n";
    return ();
  }

  # Replace all the X at the end of the substring with a
  # random character or just all the XX at the end of a full string.
  # Do it as an if, since the suffix adjusts which section to replace
  # and suffixlen=0 returns nothing if used in the substr directly
  # and generate a full path from the template

  my $path = _replace_XX($template, $options{"suffixlen"});


  # Split the path into constituent parts - eventually we need to check
  # whether the directory exists
  # We need to know whether we are making a temp directory
  # or a tempfile

  my ($volume, $directories, $file);
  my $parent; # parent directory
  if ($options{"mkdir"}) {
    # There is no filename at the end
    ($volume, $directories, $file) = File::Spec->splitpath( $path, 1);

    # The parent is then $directories without the last directory
    # Split the directory and put it back together again
    my @dirs = File::Spec->splitdir($directories);

    # If @dirs only has one entry that means we are in the current
    # directory
    if ($#dirs == 0) {
      $parent = File::Spec->curdir;
    } else {

      if ($^O eq 'VMS') {  # need volume to avoid relative dir spec
        $parent = File::Spec->catdir($volume, @dirs[0..$#dirs-1]);
        $parent = 'sys$disk:[]' if $parent eq '';
      } else {

	# Put it back together without the last one
	$parent = File::Spec->catdir(@dirs[0..$#dirs-1]);

	# ...and attach the volume (no filename)
	$parent = File::Spec->catpath($volume, $parent, '');
      }

    }

  } else {

    # Get rid of the last filename (use File::Basename for this?)
    ($volume, $directories, $file) = File::Spec->splitpath( $path );

    # Join up without the file part
    $parent = File::Spec->catpath($volume,$directories,'');

    # If $parent is empty replace with curdir
    $parent = File::Spec->curdir
      unless $directories ne '';

  }

  # Check that the parent directories exist 
  # Do this even for the case where we are simply returning a name
  # not a file -- no point returning a name that includes a directory
  # that does not exist or is not writable

  unless (-d $parent) {
    ${$options{ErrStr}} = "Parent directory ($parent) is not a directory";
    return ();
  }
  unless (-w _) {
    ${$options{ErrStr}} = "Parent directory ($parent) is not writable\n";
      return ();
  }


  # Check the stickiness of the directory and chown giveaway if required
  # If the directory is world writable the sticky bit
  # must be set

  if (File::Temp->safe_level == MEDIUM) {
    my $safeerr;
    unless (_is_safe($parent,\$safeerr)) {
      ${$options{ErrStr}} = "Parent directory ($parent) is not safe ($safeerr)";
      return ();
    }
  } elsif (File::Temp->safe_level == HIGH) {
    my $safeerr;
    unless (_is_verysafe($parent, \$safeerr)) {
      ${$options{ErrStr}} = "Parent directory ($parent) is not safe ($safeerr)";
      return ();
    }
  }


  # Now try MAX_TRIES time to open the file
  for (my $i = 0; $i < MAX_TRIES; $i++) {

    # Try to open the file if requested
    if ($options{"open"}) {
      my $fh;

      # If we are running before perl5.6.0 we can not auto-vivify
      if ($] < 5.006) {
	$fh = &Symbol::gensym;
      }

      # Try to make sure this will be marked close-on-exec
      # XXX: Win32 doesn't respect this, nor the proper fcntl,
      #      but may have O_NOINHERIT. This may or may not be in Fcntl.
      local $^F = 2;

      # Store callers umask
      my $umask = umask();

      # Set a known umask
      umask(066);

      # Attempt to open the file
      my $open_success = undef;
      if ( $^O eq 'VMS' and $options{"unlink_on_close"} ) {
        # make it auto delete on close by setting FAB$V_DLT bit
	$fh = VMS::Stdio::vmssysopen($path, $OPENFLAGS, 0600, 'fop=dlt');
	$open_success = $fh;
      } else {
	my $flags = ( $options{"unlink_on_close"} ?
		      $OPENTEMPFLAGS :
		      $OPENFLAGS );
	$open_success = sysopen($fh, $path, $flags, 0600);
      }