diff options
| -rw-r--r-- | AUTHORS | 1 | ||||
| -rw-r--r-- | MAINTAIN | 2 | ||||
| -rw-r--r-- | MANIFEST | 5 | ||||
| -rw-r--r-- | iperlsys.h | 2 | ||||
| -rw-r--r-- | lib/Carp/Heavy.pm | 12 | ||||
| -rw-r--r-- | lib/File/Temp.pm | 1584 | ||||
| -rwxr-xr-x | lib/diagnostics.pm | 6 | ||||
| -rw-r--r-- | pod/perlfunc.pod | 3 | ||||
| -rw-r--r-- | pod/perlrun.pod | 12 | ||||
| -rw-r--r-- | pod/perltie.pod | 7 | ||||
| -rw-r--r-- | pp.c | 17 | ||||
| -rwxr-xr-x | t/lib/ftmp-mktemp.t | 101 | ||||
| -rwxr-xr-x | t/lib/ftmp-posix.t | 66 | ||||
| -rwxr-xr-x | t/lib/ftmp-security.t | 119 | ||||
| -rwxr-xr-x | t/lib/ftmp-tempfile.t | 92 | ||||
| -rw-r--r-- | t/lib/peek.t | 20 | ||||
| -rwxr-xr-x | t/op/substr.t | 15 | ||||
| -rw-r--r-- | utils/perlbug.PL | 62 | ||||
| -rw-r--r-- | vms/vms.c | 24 | ||||
| -rw-r--r-- | vms/vmsish.h | 5 |
20 files changed, 2092 insertions, 63 deletions
@@ -68,6 +68,7 @@ sugalskd Dan Sugalski sugalskd@osshe.edu sundstrom David Sundstrom sunds@asictest.sc.ti.com tchrist Tom Christiansen tchrist@perl.com thomas.dorner Dorner Thomas Thomas.Dorner@start.de +tjenness Tim Jenness t.jenness@jach.hawaii.edu timb Tim Bunce Tim.Bunce@ig.co.uk tom.horsley Tom Horsley Tom.Horsley@mail.ccur.com tye Tye McQueen tye@metronet.com @@ -412,6 +412,7 @@ lib/File/Spec/Mac.pm schinder lib/File/Spec/OS2.pm ilya lib/File/Spec/VMS.pm vms lib/File/Spec/Win32.pm win32 +lib/File/Temp.pm tjenness lib/File/stat.pm tchrist lib/FileCache.pm lib/FileHandle.pm @@ -707,6 +708,7 @@ t/lib/filehand.t t/lib/filepath.t t/lib/filespec.t kjahds t/lib/findbin.t +t/lib/ftmp-*.t tjenness t/lib/gdbm.t t/lib/getopt.t jvromans t/lib/h2ph* kstar @@ -618,6 +618,7 @@ lib/File/Spec/OS2.pm portable operations on OS2 file names lib/File/Spec/Unix.pm portable operations on Unix file names lib/File/Spec/VMS.pm portable operations on VMS file names lib/File/Spec/Win32.pm portable operations on Win32 file names +lib/File/Temp.pm create safe temporary files and file handles lib/File/stat.pm By-name interface to Perl's builtin stat lib/FileCache.pm Keep more files open than the system permits lib/FileHandle.pm Backward-compatible front end to IO extension @@ -1285,6 +1286,10 @@ t/lib/filehand.t See if FileHandle works t/lib/filepath.t See if File::Path works t/lib/filespec.t See if File::Spec works t/lib/findbin.t See if FindBin works +t/lib/ftmp-mktemp.t See if File::Temp works +t/lib/ftmp-posix.t See if File::Temp works +t/lib/ftmp-security.t See if File::Temp works +t/lib/ftmp-tempfile.t See if File::Temp works t/lib/gdbm.t See if GDBM_File works t/lib/getopt.t See if Getopt::Std and Getopt::Long work t/lib/glob-basic.t See if File::Glob works diff --git a/iperlsys.h b/iperlsys.h index f36dcd5f32..59da4748cb 100644 --- a/iperlsys.h +++ b/iperlsys.h @@ -551,7 +551,7 @@ struct IPerlDirInfo #define PerlDir_mkdir(name, mode) Mkdir((name), (mode)) #ifdef VMS -# define PerlDir_chdir(n) chdir(((n) && *(n)) ? (n) : "SYS$LOGIN") +# define PerlDir_chdir(n) Chdir(((n) && *(n)) ? (n) : "SYS$LOGIN") #else # define PerlDir_chdir(name) chdir((name)) #endif diff --git a/lib/Carp/Heavy.pm b/lib/Carp/Heavy.pm index 5e3de49418..8cfdcb48f0 100644 --- a/lib/Carp/Heavy.pm +++ b/lib/Carp/Heavy.pm @@ -42,7 +42,7 @@ sub longmess_heavy { # # if the $error error string is newline terminated then it # is copied into $mess. Otherwise, $mess gets set (at the end of - # the 'else {' section below) to one of two things. The first time + # the 'else' section below) to one of two things. The first time # through, it is set to the "$error at $file line $line" message. # $error is then set to 'called' which triggers subsequent loop # iterations to append $sub to $mess before appending the "$error @@ -121,10 +121,7 @@ sub longmess_heavy { # $line" makes sense as "called at $file line $line". $error = "called"; } - # this kludge circumvents die's incorrect handling of NUL - my $msg = \($mess || $error); - $$msg =~ tr/\0//d; - $$msg; + $mess || $error; } @@ -227,9 +224,7 @@ CALLER: } else { # OK! We've got a candidate package. Time to construct the - # relevant error message and return it. die() doesn't like - # to be given NUL characters (which $msg may contain) so we - # remove them first. + # relevant error message and return it. my $msg; $msg = "$error at $file line $line"; if (defined &Thread::tid) { @@ -237,7 +232,6 @@ CALLER: $mess .= " thread $tid" if $tid; } $msg .= "\n"; - $msg =~ tr/\0//d; return $msg; } } diff --git a/lib/File/Temp.pm b/lib/File/Temp.pm new file mode 100644 index 0000000000..736ef3fdb3 --- /dev/null +++ b/lib/File/Temp.pm @@ -0,0 +1,1584 @@ +package File::Temp; + +=head1 NAME + +File::Temp - return name and handle of a temporary file safely + +=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 qw( EEXIST ENOENT ENOTDIR EINVAL ); + +# use 'our' on v5.6.0 +use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS $DEBUG); + +$DEBUG = 0; + +# We are exporting functions + +#require Exporter; +#@ISA = qw/Exporter/; +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.07'; + +# 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; + +# 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. +# "open" and "mkdir" can not both be 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 +# a carp to give the reason whilst debugging + +sub _gettemp { + + croak 'Usage: ($fh, $name) = _gettemp($template, OPTIONS);' + unless scalar(@_) >= 1; + + # Default options + my %options = ( + "open" => 0, + "mkdir" => 0, + "suffixlen" => 0, + ); + + # Read the template + my $template = shift; + if (ref($template)) { + 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) { + carp "File::Temp::_gettemp: Must have even number of options"; + return (); + } + + # Read the options and merge with defaults + %options = (%options, @_) if @_; + + # Can not open the file and make a directory in a single call + if ($options{"open"} && $options{"mkdir"}) { + carp "File::Temp::_gettemp: 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) { + carp "File::Temp::_gettemp: 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 { + + # 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 && -w _) { + carp "File::Temp::_gettemp: Parent directory ($parent) is not a directory" + . " or 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) { + unless (_is_safe($parent)) { + carp "File::Temp::_gettemp: Parent directory ($parent) is not safe (sticky bit not set when world writable?)"; + return (); + } + } elsif (File::Temp->safe_level == HIGH) { + unless (_is_verysafe($parent)) { + carp "File::Temp::_gettemp: Parent directory ($parent) is not safe (sticky bit not set when world writable?)"; + return (); + } + } + + + # Calculate the flags that we wish to use for the sysopen + # Some of these are not always available + my $openflags; + if ($options{"open"}) { + # Default set + $openflags = O_CREAT | O_EXCL | O_RDWR; + + for my $oflag (qw/FOLLOW BINARY LARGEFILE EXLOCK NOINHERIT TEMPORARY/) { + my ($bit, $func) = (0, "Fcntl::O_" . $oflag); + no strict 'refs'; + $openflags |= $bit if eval { $bit = &$func(); 1 }; + } + + } + + + # 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) { + require Symbol; + $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 + if ( sysopen($fh, $path, $openflags, 0600) ) { + + # Reset umask + umask($umask); + + # Opened successfully - return file handle and name + return ($fh, $path); + + } else { + # Reset umask + umask($umask); + + # Error opening file - abort with error + # if the reason was anything but EEXIST + unless ($! == EEXIST) { + carp "File::Temp: Could not create temp file $path: $!"; + return (); + } + + # Loop round for another try + + } + } elsif ($options{"mkdir"}) { + + # Store callers umask + my $umask = umask(); + + # Set a known umask + umask(066); + + # Open the temp directory + if (mkdir( $path, 0700)) { + # created okay + # Reset umask + umask($umask); + + return undef, $path; + } else { + + # Reset umask + umask($umask); + + # Abort with error if the reason for failure was anything + # except EEXIST + unless ($! == EEXIST) { + carp "File::Temp: Could not create directory $path: $!"; + return (); + } + + # Loop round for another try + + } + + } else { + + # Return true if the file can not be found + # Directory has been checked previously + + return (undef, $path) unless -e $path; + + # Try again until MAX_TRIES + + } + + # Did not successfully open the tempfile/dir + # so try again with a different set of random letters + # No point in trying to increment unless we have only + # 1 X say and the randomness could come up with the same + # file MAX_TRIES in a row. + + # Store current attempt - in principal this implies that the + # 3rd time around the open attempt that the first temp file + # name could be generated again. Probably should store each + # attempt and make sure that none are repeated + + my $original = $path; + my $counter = 0; # Stop infinite loop + my $MAX_GUESS = 50; + + do { + + # Generate new name from original template + $path = _replace_XX($template, $options{"suffixlen"}); + + $counter++; + + } until ($path ne $original || $counter > $MAX_GUESS); + + # Check for out of control looping + if ($counter > $MAX_GUESS) { + carp "Tried to get a new temp name different to the previous value$MAX_GUESS times.\nSomething wrong with template?? ($template)"; + return (); + } + + } + + # If we get here, we have run out of tries + carp "Have exceeded the maximum number of attempts (".MAX_TRIES . + ") to open temp file/dir"; + + return (); + +} + +# Internal routine to return a random character from the +# character list. Does not do an srand() since rand() +# will do one automatically + +# No arguments. Return value is the random character + +sub _randchar { + + $CHARS[ int( rand( $#CHARS ) ) ]; + +} + +# Internal routine to replace the XXXX... with random characters +# This has to be done by _gettemp() every time it fails to +# open a temp file/dir + +# Arguments: $template (the template with XXX), +# $ignore (number of characters at end to ignore) + +# Returns: modified template + +sub _replace_XX { + + croak 'Usage: _replace_XX($template, $ignore)' + unless scalar(@_) == 2; + + my ($path, $ignore) = @_; + + # Do it as an if, since the suffix adjusts which section to replace + # and suffixlen=0 returns nothing if used in the substr directly + # Alternatively, could simply set $ignore to length($path)-1 + # Don't want to always use substr when not required though. + + if ($ignore) { + substr($path, 0, - $ignore) =~ s/X(?=X*\z)/_randchar()/ge; + } else { + $path =~ s/X(?=X*\z)/_randchar()/ge; + } + + return $path; +} + +# internal routine to check to see if the directory is safe +# First checks to see if the directory is not owned by the +# current user or root. Then checks to see if anyone else +# can write to the directory and if so, checks to see if +# it has the sticky bit set + +# Will not work on systems that do not support sticky bit + +#Args: directory path to check +# Returns true if the path is safe and false otherwise. +# Returns undef if can not even run stat() on the path + +# This routine based on version written by Tom Christiansen + +# Presumably, by the time we actually attempt to create the +# file or directory in this directory, it may not be safe +# anymore... Have to run _is_safe directly after the open. + +sub _is_safe { + + my $path = shift; + + # Stat path + my @info = stat($path); + return 0 unless scalar(@info); + + # Check to see whether owner is neither superuser (or a system uid) nor me + # Use the real uid from the $< variable + # UID is in [4] + if ( $info[4] > File::Temp->top_system_uid() && $info[4] != $<) { + carp "Directory owned neither by root nor the current user"; + return 0; + } + + # check whether group or other can write file + # use 066 to detect either reading or writing + # use 022 to check writability + # Do it with S_IWOTH and S_IWGRP for portability (maybe) + # mode is in info[2] + if (($info[2] & &Fcntl::S_IWGRP) || # Is group writable? + ($info[2] & &Fcntl::S_IWOTH) ) { # Is world writable? + return 0 unless -d _; # Must be a directory + return 0 unless -k _; # Must be sticky + } + + return 1; +} + +# Internal routine to check whether a directory is safe +# for temp files. Safer than _is_safe since it checks for +# the possibility of chown giveaway and if that is a possibility +# checks each directory in the path to see if it is safe (with _is_safe) + +# If _PC_CHOWN_RESTRICTED is not set, does the full test of each +# directory anyway. + +sub _is_verysafe { + + # Need POSIX - but only want to bother if really necessary due to overhead + require POSIX; + + my $path = shift; + + # Should Get the value of _PC_CHOWN_RESTRICTED if it is defined + # and If it is not there do the extensive test + my $chown_restricted; + $chown_restricted = &POSIX::_PC_CHOWN_RESTRICTED() + if eval { &POSIX::_PC_CHOWN_RESTRICTED(); 1}; + + # If chown_resticted is set to some value we should test it + if (defined $chown_restricted) { + + # Return if the current directory is safe + return _is_safe($path) if POSIX::sysconf( $chown_restricted ); + + } + + # To reach this point either, the _PC_CHOWN_RESTRICTED symbol + # was not avialable or the symbol was there but chown giveaway + # is allowed. Either way, we now have to test the entire tree for + # safety. + + # Convert path to an absolute directory if required + unless (File::Spec->file_name_is_absolute($path)) { + $path = File::Spec->rel2abs($path); + } + + # Split directory into components - assume no file + my ($volume, $directories, undef) = File::Spec->splitpath( $path, 1); + + # Slightly less efficient than having a a function in File::Spec + # to chop off the end of a directory or even a function that + # can handle ../ in a directory tree + # Sometimes splitdir() returns a blank at the end + # so we will probably check the bottom directory twice in some cases + my @dirs = File::Spec->splitdir($directories); + + # Concatenate one less directory each time around + foreach my $pos (0.. $#dirs) { + # Get a directory name + my $dir = File::Spec->catpath($volume, + File::Spec->catdir(@dirs[0.. $#dirs - $pos]), + '' + ); + + print "TESTING DIR $dir\n" if $DEBUG; + + # Check the directory + return 0 unless _is_safe($dir); + + } + + return 1; +} + + + +# internal routine to determine whether unlink works on this +# platform for files that are currently open. +# Returns true if we can, false otherwise. + +# Currently WinNT can not unlink an opened file + +sub _can_unlink_opened_file { + + + $^O ne 'MSWin32' ? 1 : 0; + +} + + +# This routine sets up a deferred unlinking of a specified +# filename and filehandle. It is used in the following cases: +# - Called by unlink0 if an opend file can not be unlinked +# - Called by tempfile() if files are to be removed on shutdown +# - Called by tempdir() if directories are to be removed on shutdown + +# Arguments: +# _deferred_unlink( $fh, $fname, $isdir ); +# +# - filehandle (so that it can be expclicitly closed if open +# - filename (the thing we want to remove) +# - isdir (flag to indicate that we are being given a directory) +# [and hence no filehandle] + +# Status is not referred since all the magic is done with END blocks + +sub _deferred_unlink { + + croak 'Usage: _deferred_unlink($fh, $fname, $isdir)' + unless scalar(@_) == 3; + + my ($fh, $fname, $isdir) = @_; + + warn "Setting up deferred removal of $fname\n" + if $DEBUG; + + # If we have a directory, check that it is a directory + if ($isdir) { + + if (-d $fname) { + + # Directory exists so set up END block + # (quoted to preserve lexical variables) + eval q{ + END { + if (-d $fname) { + rmtree($fname, $DEBUG, 1); + } + } + 1; + } || die; + + } else { + carp "Request to remove directory $fname could not be completed since it does not exists!\n"; + } + + + } else { + + if (-f $fname) { + + # dile exists so set up END block + # (quoted to preserve lexical variables) + eval q{ + END { + # close the filehandle without checking its state + # in order to make real sure that this is closed + # if its already closed then I dont care about the answer + # probably a better way to do this + close($fh); + + if (-f $fname) { + unlink $fname + || warn "Error removing $fname"; + } + } + 1; + } || die; + + } else { + carp "Request to remove file $fname could not be completed since it is not there!\n"; + } + + + + } + +} + + +=head1 FUNCTIONS + +This section describes the recommended interface for generating +temporary files and directories. + +=over 4 + +=item B<tempfile> + +This is the basic function to generate temporary files. +The behaviour of the file can be changed using various options: + + ($fh, $filename) = tempfile(); + +Create a temporary file in the directory specified for temporary +files, as specified by the tmpdir() function in L<File::Spec>. + + ($fh, $filename) = tempfile($template); + +Create a temporary file in the current directory using the supplied +template. Trailing `X' characters are replaced with random letters to +generate the filename. At least four `X' characters must be present +in the template. + + ($fh, $filename) = tempfile($template, SUFFIX => $suffix) + +Same as previously, except that a suffix is added to the template +after the `X' translation. Useful for ensuring that a temporary +filename has a particular extension when needed by other applications. +But see the WARNING at the end. + + ($fh, $filename) = tempfile($template, DIR => $dir); + +Translates the template as before except that a directory name +is specified. + +If the template is not specified, a template is always +automatically generated. This temporary file is placed in tmpdir() +(L<File::Spec>) unless a directory is specified explicitly with the +DIR option. + + $fh = tempfile( $template, DIR => $dir ); + +If called in scalar context, only the filehandle is returned +and the file will automatically be deleted when closed (see +the description of tmpfile() elsewhere in this document). +This is the preferred mode of operation, as if you only +have a filehandle, you can never create a race condition +by fumbling with the filename. On systems that can not unlink +an open file (for example, Windows NT) the file is marked for +deletion when the program ends (equivalent to setting UNLINK to 1). + + (undef, $filename) = tempfile($template, OPEN => 0); + +This will return the filename based on the template but +will not open this file. Cannot be used in conjunction with +UNLINK set to true. Default is to always open the file +to protect from possible race conditions. A warning is issued +if warnings are turned on. Consider using the tmpnam() +and mktemp() functions described elsewhere in this document +if opening the file is not required. + +=cut + +sub tempfile { + + # Can not check for argument count since we can have any + # number of args + + # Default options + my %options = ( + "DIR" => undef, # Directory prefix + "SUFFIX" => '', # Template suffix + "UNLINK" => 0, # Unlink file on exit + "OPEN" => 1, # Do not open file + ); + + # Check to see whether we have an odd or even number of arguments + my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef); + + # Read the options and merge with defaults + %options = (%options, @_) if @_; + + # First decision is whether or not to open the file + if (! $options{"OPEN"}) { + + warn "tempfile(): temporary filename requested but not opened.\nPossibly unsafe, consider using tempfile() with OPEN set to true\n" + if $^W; + + } + + # Construct the template + + # Have a choice of trying to work around the mkstemp/mktemp/tmpnam etc + # functions or simply constructing a template and using _gettemp() + # explicitly. Go for the latter + + # First generate a template if not defined and prefix the directory + # If no template must prefix the temp directory + if (defined $template) { + if ($options{"DIR"}) { + + $template = File::Spec->catfile($options{"DIR"}, $template); + + } + + } else { + + if ($options{"DIR"}) { + + $template = File::Spec->catfile($options{"DIR"}, TEMPXXX); + + } else { + + $template = File::Spec->catfile(File::Spec->tmpdir, TEMPXXX); + + } + + } + + # Now add a suffix + $template .= $options{"SUFFIX"}; + + # Create the file + my ($fh, $path); + croak "Error in tempfile() using $template" + unless (($fh, $path) = _gettemp($template, + "open" => $options{'OPEN'}, + "mkdir"=> 0 , + "suffixlen" => length($options{'SUFFIX'}), + ) ); + + # Set up an exit handler that can do whatever is right for the + # system. Do not check return status since this is all done with + # END blocks + _deferred_unlink($fh, $path, 0) if $options{"UNLINK"}; + + # Return + if (wantarray()) { + + if ($options{'OPEN'}) { + return ($fh, $path); + } else { + return (undef, $path); + } + + } else { + + # Unlink the file. It is up to unlink0 to decide what to do with + # this (whether to unlink now or to defer until later) + unlink0($fh, $path) or croak "Error unlinking file $path using unlink0"; + + # Return just the filehandle. + return $fh; + } + + +} + +=item B<tempdir> + +This is the recommended interface for creation of temporary directories. +The behaviour of the function depends on the arguments: + + $tempdir = tempdir(); + +Create a directory in tmpdir() (see L<File::Spec|File::Spec>). + + $tempdir = tempdir( $template ); + +Create a directory from the supplied template. This template is +similar to that described for tempfile(). `X' characters at the end +of the template are replaced with random letters to construct the +directory name. At least four `X' characters must be in the template. + + $tempdir = tempdir ( DIR => $dir ); + +Specifies the directory to use for the temporary directory. +The temporary directory name is derived from an internal template. + + $tempdir = tempdir ( $template, DIR => $dir ); + +Prepend the supplied directory name to the template. The template +should not include parent directory specifications itself. Any parent +directory specifications are removed from the template before +prepending the supplied directory. + + $tempdir = tempdir ( $template, TMPDIR => 1 ); + +Using the supplied template, creat the temporary directory in +a standard location for temporary files. Equivalent to doing + + $tempdir = tempdir ( $template, DIR => File::Spec->tmpdir); + +but shorter. Parent directory specifications are stripped from the +template itself. The C<TMPDIR> option is ignored if C<DIR> is set +explicitly. Additionally, C<TMPDIR> is implied if neither a template +nor a directory are supplied. + + $tempdir = tempdir( $template, CLEANUP => 1); + +Create a temporary directory using the supplied template, but +attempt to remove it (and all files inside it) when the program +exits. Note that an attempt will be made to remove all files from +the directory even if they were not created by this module (otherwise +why ask to clean it up?). The directory removal is made with +the rmtree() function from the L<File::Path|File::Path> module. +Of course, if the template is not specified, the temporary directory +will be created in tmpdir() and will also be removed at program exit. + +=cut + +# ' + +sub tempdir { + + # Can not check for argument count since we can have any + # number of args + + # Default options + my %options = ( + "CLEANUP" => 0, # Remove directory on exit + "DIR" => '', # Root directory + "TMPDIR" => 0, # Use tempdir with template + ); + + # Check to see whether we have an odd or even number of arguments + my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef ); + + # Read the options and merge with defaults + %options = (%options, @_) if @_; + + # Modify or generate the template + + # Deal with the DIR and TMPDIR options + if (defined $template) { + + # Need to strip directory path if using DIR or TMPDIR + if ($options{'TMPDIR'} || $options{'DIR'}) { + + # Strip parent directory from the filename + # + # There is no filename at the end + my ($volume, $directories, undef) = File::Spec->splitpath( $template, 1); + + # Last directory is then our template + $template = (File::Spec->splitdir($directories))[-1]; + + # Prepend the supplied directory or temp dir + if ($options{"DIR"}) { + + $template = File::Spec->catfile($options{"DIR"}, $template); + + } elsif ($options{TMPDIR}) { + + # Prepend tmpdir + $template = File::Spec->catdir(File::Spec->tmpdir, $template); + + } + + } + + } else { + + if ($options{"DIR"}) { + + $template = File::Spec->catdir($options{"DIR"}, TEMPXXX); + + } else { + + $template = File::Spec->catdir(File::Spec->tmpdir, TEMPXXX); + + } + + } + + # Create the directory + my $tempdir; + croak "Error in tempdir() using $template" + unless ((undef, $tempdir) = _gettemp($template, + "open" => 0, + "mkdir"=> 1 , + "suffixlen" => 0, + ) ); + + # Install exit handler; must be dynamic to get lexical + if ( $options{'CLEANUP'} && -d $tempdir) { + _deferred_unlink(undef, $tempdir, 1); + } + + # Return the dir name + return $tempdir; + +} + +=back + +=head1 MKTEMP FUNCTIONS + +The following functions are Perl implementations of the +mktemp() family of temp file generation system calls. + +=over 4 + +=item B<mkstemp> + +Given a template, returns a filehandle to the temporary file and the name +of the file. + + ($fh, $name) = mkstemp( $template ); + +In scalar context, just the filehandle is returned. + +The template may be any filename with some number of X's appended +to it, for example F</tmp/temp.XXXX>. The trailing X's are replaced +with unique alphanumeric combinations. + +=cut + + + +sub mkstemp { + + croak "Usage: mkstemp(template)" + if scalar(@_) != 1; + + my $template = shift; + + my ($fh, $path); + croak "Error in mkstemp using $template" + unless (($fh, $path) = _gettemp($template, + "open" => 1, + "mkdir"=> 0 , + "suffixlen" => 0, + ) ); + + if (wantarray()) { + return ($fh, $path); + } else { + return $fh; + } + +} + + +=item B<mkstemps> + +Similar to mkstemp(), except that an extra argument can be supplied +with a suffix to be appended to the template. + + ($fh, $name) = mkstemps( $template, $suffix ); + +For example a template of C<testXXXXXX> and suffix of C<.dat> +would generate a file similar to F<testhGji_w.dat>. + +Returns just the filehandle alone when called in scalar context. + +=cut + +sub mkstemps { + + croak "Usage: mkstemps(template, suffix)" + if scalar(@_) != 2; + + + my $template = shift; + my $suffix = shift; + + $template .= $suffix; + + my ($fh, $path); + croak "Error in mkstemps using $template" + unless (($fh, $path) = _gettemp($template, + "open" => 1, + "mkdir"=> 0 , + "suffixlen" => length($suffix), + ) ); + + if (wantarray()) { + return ($fh, $path); + } else { + return $fh; + } + +} + +=item B<mkdtemp> + +Create a directory from a template. The template must end in +X's that are replaced by the routine. + + $tmpdir_name = mkdtemp($template); + +Returns the name of the temporary directory created. +Returns undef on failure. + +Directory must be removed by the caller. + +=cut + +#' # for emacs + +sub mkdtemp { + + croak "Usage: mkdtemp(template)" + if scalar(@_) != 1; + + my $template = shift; + + my ($junk, $tmpdir); + croak "Error creating temp directory from template $template\n" + unless (($junk, $tmpdir) = _gettemp($template, + "open" => 0, + "mkdir"=> 1 , + "suffixlen" => 0, + ) ); + + return $tmpdir; + +} + +=item B<mktemp> + +Returns a valid temporary filename but does not guarantee +that the file will not be opened by someone else. + + $unopened_file = mktemp($template); + +Template is the same as that required by mkstemp(). + +=cut + +sub mktemp { + + croak "Usage: mktemp(template)" + if scalar(@_) != 1; + + my $template = shift; + + my ($tmpname, $junk); + croak "Error getting name to temp file from template $template\n" + unless (($junk, $tmpname) = _gettemp($template, + "open" => 0, + "mkdir"=> 0 , + "suffixlen" => 0, + ) ); + + return $tmpname; +} + +=back + +=head1 POSIX FUNCTIONS + +This section describes the re-implementation of the tmpnam() +and tmpfile() functions described in L<POSIX> +using the mkstemp() from this module. + +Unlike the L<POSIX|POSIX> implementations, the directory used +for the temporary file is not specified in a system include +file (C<P_tmpdir>) but simply depends on the choice of tmpdir() +returned by L<File::Spec|File::Spec>. On some implementations this +location can be set using the C<TMPDIR> environment variable, which +may not be secure. +If this is a problem, simply use mkstemp() and specify a template. + +=over 4 + +=item B<tmpnam> + +When called in scalar context, returns the full name (including path) +of a temporary file (uses mktemp()). The only check is that the file does +not already exist, but there is no guarantee that that condition will +continue to apply. + + $file = tmpnam(); + +When called in list context, a filehandle to the open file and +a filename are returned. This is achieved by calling mkstemp() +after constructing a suitable template. + + ($fh, $file) = tmpnam(); + +If possible, this form should be used to prevent possible +race conditions. + +See L<File::Spec/tmpdir> for information on the choice of temporary +directory for a particular operating system. + +=cut + +sub tmpnam { + + # Retrieve the temporary directory name + my $tmpdir = File::Spec->tmpdir; + + croak "Error temporary directory is not writable" + if $tmpdir eq ''; + + # Use a ten character template and append to tmpdir + my $template = File::Spec->catfile($tmpdir, TEMPXXX); + + if (wantarray() ) { + return mkstemp($template); + } else { + return mktemp($template); + } + +} + +=item B<tmpfile> + +In scalar context, returns the filehandle of a temporary file. + + $fh = tmpfile(); + +The file is removed when the filehandle is closed or when the program +exits. No access to the filename is provided. + +=cut + +sub tmpfile { + + # Simply call tmpnam() in an array context + my ($fh, $file) = tmpnam(); + + # Make sure file is removed when filehandle is closed + unlink0($fh, $file) or croak "Unable to unlink temporary file: $!"; + + return $fh; + +} + +=back + +=head1 ADDITIONAL FUNCTIONS + +These functions are provided for backwards compatibility +with common tempfile generation C library functions. + +They are not exported and must be addressed using the full package +name. + +=over 4 + +=item B<tempnam> + +Return the name of a temporary file in the specified directory +using a prefix. The file is guaranteed not to exist at the time +the function was called, but such guarantees are good for one +clock tick only. Always use the proper form of C<sysopen> +with C<O_CREAT | O_EXCL> if you must open such a filename. + + $filename = File::Temp::tempnam( $dir, $prefix ); + +Equivalent to running mktemp() with $dir/$prefixXXXXXXXX +(using unix file convention as an example) + +Because this function uses mktemp(), it can suffer from race conditions. + +=cut + +sub tempnam { + + croak 'Usage tempnam($dir, $prefix)' unless scalar(@_) == 2; + + my ($dir, $prefix) = @_; + + # Add a string to the prefix + $prefix .= 'XXXXXXXX'; + + # Concatenate the directory to the file + my $template = File::Spec->catfile($dir, $prefix); + + return mktemp($template); + +} + +=back + +=head1 UTILITY FUNCTIONS + +Useful functions for dealing with the filehandle and filename. + +=over 4 + +=item B<unlink0> + +Given an open filehandle and the associated filename, make a safe +unlink. This is achieved by first checking that the filename and +filehandle initially point to the same file and that the number of +links to the file is 1 (all fields returned by stat() are compared). +Then the filename is unlinked and the filehandle checked once again to +verify that the number of links on that file is now 0. This is the +closest you can come to making sure that the filename unlinked was the +same as the file whose descriptor you hold. + + unlink0($fh, $path) or die "Error unlinking file $path safely"; + +Returns false on error. The filehandle is not closed since on some +occasions this is not required. + +On some platforms, for example Windows NT, it is not possible to +unlink an open file (the file must be closed first). On those +platforms, the actual unlinking is deferred until the program ends +and good status is returned. A check is still performed to make sure that +the filehandle and filename are pointing to the same thing (but not at the time +the end block is executed since the deferred removal may not have access to +the filehandle). + +Additionally, on Windows NT not all the fields returned by stat() can +be compared. For example, the C<dev> and C<rdev> fields seem to be different +and also. Also, it seems that the size of the file returned by stat() +does not always agree, with C<stat(FH)> being more accurate than +C<stat(filename)>, presumably because of caching issues even when +using autoflush (this is usually overcome by waiting a while after +writing to the tempfile before attempting to C<unlink0> it). + +=cut + +sub unlink0 { + + croak 'Usage: unlink0(filehandle, filename)' + unless scalar(@_) == 2; + + # Read args + my ($fh, $path) = @_; + + warn "Unlinking $path using unlink0\n" + if $DEBUG; + + # Stat the filehandle + my @fh = stat $fh; + + if ($fh[3] > 1 && $^W) { + carp "unlink0: fstat found too many links; SB=@fh"; + } + + # Stat the path + my @path = stat $path; + + unless (@path) { + carp "unlink0: $path is gone already" if $^W; + return; + } + + # this is no longer a file, but may be a directory, or worse + unless (-f _) { + confess "panic: $path is no longer a file: SB=@fh"; + } + + # Do comparison of each member of the array + # On WinNT dev and rdev seem to be different + # depending on whether it is a file or a handle. + # Cannot simply compare all members of the stat return + # Select the ones we can use + my @okstat = (0..$#fh); # Use all by default + if ($^O eq 'MSWin32') { + @okstat = (1,2,3,4,5,7,8,9,10); + } + + # Now compare each entry explicitly by number + for (@okstat) { + print "Comparing: $_ : $fh[$_] and $path[$_]\n" if $DEBUG; + unless ($fh[$_] == $path[$_]) { + warn "Did not match $_ element of stat\n" if $DEBUG; + return 0; + } + } + + # attempt remove the file (does not work on some platforms) + if (_can_unlink_opened_file()) { + # XXX: do *not* call this on a directory; possible race + # resulting in recursive removal + croak "unlink0: $path has become a directory!" if -d $path; + unlink($path) or return 0; + + # Stat the filehandle + @fh = stat $fh; + + print "Link count = $fh[3] \n" if $DEBUG; + + # Make sure that the link count is zero + return ( $fh[3] == 0 ? 1 : 0); + + } else { + _deferred_unlink($fh, $path, 0); + return 1; + } + +} + +=back + +=head1 PACKAGE VARIABLES + +These functions control the global state of the package. + +=over 4 + +=item B<safe_level> + +Controls the lengths to which the module will go to check the safety of the +temporary file or directory before proceeding. +Options are: + +=over 8 + +=item STANDARD + +Do the basic security measures to ensure the directory exists and +is writable, that the umask() is fixed before opening of the file, +that temporary files are opened only if they do not already exist, and +that possible race conditions are avoided. Finally the L<unlink0|"unlink0"> +function is used to remove files safely. + +=item MEDIUM + +In addition to the STANDARD security, the output directory is checked +to make sure that it is owned either by root or the user running the +program. If the directory is writable by group or by other, it is then +checked to make sure that the sticky bit is set. + +Will not work on platforms that do not support the C<-k> test +for sticky bit. + +=item HIGH + +In addition to the MEDIUM security checks, also check for the +possibility of ``chown() giveaway'' using the L<POSIX|POSIX> +sysconf() function. If this is a possibility, each directory in the +path is checked in turn for safeness, recursively walking back to the +root directory. + +For platforms that do not support the L<POSIX|POSIX> +C<_PC_CHOWN_RESTRICTED> symbol (for example, Windows NT) it is +assumed that ``chown() giveaway'' is possible and the recursive test +is performed. + +=back + +The level can be changed as follows: + + File::Temp->safe_level( File::Temp::HIGH ); + +The level constants are not exported by the module. + +Currently, you must be running at least perl v5.6.0 in order to +run with MEDIUM or HIGH security. This is simply because the +safety tests use functions from L<Fcntl|Fcntl> that are not +available in older versions of perl. The problem is that the version +number for Fcntl is the same in perl 5.6.0 and in 5.005_03 even though +they are different versions..... + +=cut + +{ + # protect from using the variable itself + my $LEVEL = STANDARD; + sub safe_level { + my $self = shift; + if (@_) { + my $level = shift; + if (($level != STANDARD) && ($level != MEDIUM) && ($level != HIGH)) { + carp "safe_level: Specified level ($level) not STANDARD, MEDIUM or HIGH - ignoring\n"; + } else { + if ($] < 5.006 && $level != STANDARD) { + # Cant do MEDIUM or HIGH checks + croak "Currently requires perl 5.006 or newer to do the safe checks"; + } + $LEVEL = $level; + } + } + return $LEVEL; + } +} + +=item TopSystemUID + +This is the highest UID on the current system that refers to a root +UID. This is used to make sure that the temporary directory is +owned by a system UID (C<root>, C<bin>, C<sys> etc) rather than +simply by root. + +This is required since on many unix systems C</tmp> is not owned +by root. + +Default is to assume that any UID less than or equal to 10 is a root +UID. + + File::Temp->top_system_uid(10); + my $topid = File::Temp->top_system_uid; + +This value can be adjusted to reduce security checking if required. +The value is only relevant when C<safe_level> is set to MEDIUM or higher. + +=back + +=cut + +{ + my $TopSystemUID = 10; + sub top_system_uid { + my $self = shift; + if (@_) { + my $newuid = shift; + croak "top_system_uid: UIDs should be numeric" + unless $newuid =~ /^\d+$/s; + $TopSystemUID = $newuid; + } + return $TopSystemUID; + } +} + +=head1 WARNING + +For maximum security, endeavour always to avoid ever looking at, +touching, or even imputing the existence of the filename. You do not +know that that filename is connected to the same file as the handle +you have, and attempts to check this can only trigger more race +conditions. It's far more secure to use the filehandle alone and +dispense with the filename altogether. + +If you need to pass the handle to something that expects a filename +then, on a unix system, use C<"/dev/fd/" . fileno($fh)> for arbitrary +programs, or more generally C<< "+<=&" . fileno($fh) >> for Perl +programs. You will have to clear the close-on-exec bit on that file +descriptor before passing it to another process. + + use Fcntl qw/F_SETFD F_GETFD/; + fcntl($tmpfh, F_SETFD, 0) + or die "Can't clear close-on-exec flag on temp fh: $!\n"; + +=head1 HISTORY + +Originally began life in May 1999 as an XS interface to the system +mkstemp() function. In March 2000, the mkstemp() code was +translated to Perl for total control of the code's +security checking, to ensure the presence of the function regardless of +operating system and to help with portability. + +=head1 SEE ALSO + +L<POSIX/tmpnam>, L<POSIX/tmpfile>, L<File::Spec>, L<File::Path> + +See L<File::MkTemp> for a different implementation of temporary +file handling. + +=head1 AUTHOR + +Tim Jenness E<lt>t.jenness@jach.hawaii.eduE<gt> + +Copyright (C) 1999, 2000 Tim Jenness and the UK Particle Physics and +Astronomy Research Council. All Rights Reserved. This program is free +software; you can redistribute it and/or modify it under the same +terms as Perl itself. + +Original Perl implementation loosely based on the OpenBSD C code for +mkstemp(). Thanks to Tom Christiansen for suggesting that this module +should be written and providing ideas for code improvements and +security enhancements. + +=cut + + +1; diff --git a/lib/diagnostics.pm b/lib/diagnostics.pm index 8c7aedc09a..884ea3ca65 100755 --- a/lib/diagnostics.pm +++ b/lib/diagnostics.pm @@ -44,7 +44,7 @@ These still go out B<STDERR>. Due to the interaction between runtime and compiletime issues, and because it's probably not a very good idea anyway, you may not use C<no diagnostics> to turn them off at compiletime. -However, you may control there behaviour at runtime using the +However, you may control their behaviour at runtime using the disable() and enable() methods to turn them off and on respectively. The B<-verbose> flag first prints out the L<perldiag> introduction before @@ -432,8 +432,8 @@ sub enable { &import } sub disable { shift; return unless $SIG{__WARN__} eq \&warn_trap; - $SIG{__WARN__} = $oldwarn; - $SIG{__DIE__} = $olddie; + $SIG{__WARN__} = $oldwarn || ''; + $SIG{__DIE__} = $olddie || ''; } sub warn_trap { diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index 8e66e1b5f8..4e67506e26 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -539,9 +539,10 @@ Here $subroutine may be C<(eval)> if the frame is not a subroutine call, but an C<eval>. In such a case additional elements $evaltext and C<$is_require> are set: C<$is_require> is true if the frame is created by a C<require> or C<use> statement, $evaltext contains the text of the -C<eval EXPR> statement. In particular, for a C<eval BLOCK> statement, +C<eval EXPR> statement. In particular, for an C<eval BLOCK> statement, $filename is C<(eval)>, but $evaltext is undefined. (Note also that each C<use> statement creates a C<require> frame inside an C<eval EXPR>) +frame. C<$hasargs> is true if a new instance of C<@_> was set up for the frame. C<$hints> and C<$bitmask> contain pragmatic hints that the caller was compiled with. The C<$hints> and C<$bitmask> values are subject to change between versions of Perl, and are not meant for external use. diff --git a/pod/perlrun.pod b/pod/perlrun.pod index f1e2c9a62e..e105b00a7a 100644 --- a/pod/perlrun.pod +++ b/pod/perlrun.pod @@ -809,6 +809,18 @@ Relevant only if your perl executable was built with B<-DDEBUGGING>, this controls the behavior of global destruction of objects and other references. +=item PERL_ROOT (specific to the VMS port) + +A translation concealed rooted logical name that contains perl and the +logical device for the @INC path on VMS only. Other logical names that +affect perl on VMS include PERLSHR, PERL_ENV_TABLES, and +SYS$TIMEZONE_DIFFERENTIAL but are optional and discussed further in +L<perlvms> and in F<README.vms> in the Perl source distribution. + +=item SYS$LOGIN (specific to the VMS port) + +Used if chdir has no argument and HOME and LOGDIR are not set. + =back Perl also has environment variables that control how Perl handles data diff --git a/pod/perltie.pod b/pod/perltie.pod index c835738573..95de3bb928 100644 --- a/pod/perltie.pod +++ b/pod/perltie.pod @@ -862,14 +862,11 @@ called: =head1 SEE ALSO See L<DB_File> or L<Config> for some interesting tie() implementations. +A good starting point for many tie() implementations is with one of the +modules L<Tie::Scalar>, L<Tie::Array>, L<Tie::Hash>, or L<Tie::Handle>. =head1 BUGS -Tied arrays are I<incomplete>. They are also distinctly lacking something -for the C<$#ARRAY> access (which is hard, as it's an lvalue), as well as -the other obvious array functions, like push(), pop(), shift(), unshift(), -and splice(). - You cannot easily tie a multilevel data structure (such as a hash of hashes) to a dbm file. The first problem is that all but GDBM and Berkeley DB have size limitations, but beyond that, you also have problems @@ -1076,10 +1076,10 @@ PP(pp_repeat) SP -= items; } else { /* Note: mark already snarfed by pp_list */ - SV *tmpstr; + SV *tmpstr = POPs; STRLEN len; + bool isutf = SvUTF8(tmpstr) ? TRUE : FALSE; - tmpstr = POPs; SvSetSV(TARG, tmpstr); SvPV_force(TARG, len); if (count != 1) { @@ -1092,7 +1092,10 @@ PP(pp_repeat) } *SvEND(TARG) = '\0'; } - (void)SvPOK_only(TARG); + if (isutf) + (void)SvPOK_only_UTF8(TARG); + else + (void)SvPOK_only(TARG); PUSHTARG; } RETURN; @@ -2008,12 +2011,12 @@ PP(pp_substr) RETPUSHUNDEF; } else { - if (utfcurlen) { + if (utfcurlen) sv_pos_u2b(sv, &pos, &rem); - SvUTF8_on(TARG); - } tmps += pos; sv_setpvn(TARG, tmps, rem); + if (utfcurlen) + SvUTF8_on(TARG); if (repl) sv_insert(sv, pos, rem, repl, repl_len); else if (lvalue) { /* it's an lvalue! */ @@ -2026,7 +2029,7 @@ PP(pp_substr) "Attempt to use reference as lvalue in substr"); } if (SvOK(sv)) /* is it defined ? */ - (void)SvPOK_only(sv); + (void)SvPOK_only_UTF8(sv); else sv_setpvn(sv,"",0); /* avoid lexical reincarnation */ } diff --git a/t/lib/ftmp-mktemp.t b/t/lib/ftmp-mktemp.t new file mode 100755 index 0000000000..c660475709 --- /dev/null +++ b/t/lib/ftmp-mktemp.t @@ -0,0 +1,101 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +# Test for mktemp family of commands in File::Temp +# Use STANDARD safe level for these tests + +use strict; +use Test; +BEGIN { plan tests => 9 } + +use File::Spec; +use File::Path; +use File::Temp qw/ :mktemp unlink0 /; + +ok(1); + +# MKSTEMP - test + +# Create file in temp directory +my $template = File::Spec->catfile(File::Spec->tmpdir, 'wowserXXXX'); + +(my $fh, $template) = mkstemp($template); + +print "# MKSTEMP: FH is $fh File is $template fileno=".fileno($fh)."\n"; +# Check if the file exists +ok( (-e $template) ); + +# Autoflush +$fh->autoflush(1) if $] >= 5.006; + +# Try printing something to the file +my $string = "woohoo\n"; +print $fh $string; + +# rewind the file +ok(seek( $fh, 0, 0)); + +# Read from the file +my $line = <$fh>; + +# compare with previous string +ok($string, $line); + +# Tidy up +# This test fails on Windows NT since it seems that the size returned by +# stat(filehandle) does not always equal the size of the stat(filename) +# This must be due to caching. In particular this test writes 7 bytes +# to the file which are not recognised by stat(filename) + +if ($^O eq 'MSWin32') { + sleep 3; +} +ok( unlink0($fh, $template) ); + + +# MKSTEMPS +# File with suffix. This is created in the current directory + +$template = "suffixXXXXXX"; +my $suffix = ".dat"; + +($fh, my $fname) = mkstemps($template, $suffix); + +print "# MKSTEMPS: File is $template -> $fname fileno=".fileno($fh)."\n"; +# Check if the file exists +ok( (-e $fname) ); + +ok( unlink0($fh, $fname) ); + + +# MKDTEMP +# Temp directory + +$template = File::Spec->catdir(File::Spec->tmpdir, 'tmpdirXXXXXX'); + +my $tmpdir = mkdtemp($template); + +print "# MKDTEMP: Name is $tmpdir from template $template\n"; + +ok( (-d $tmpdir ) ); + +# Need to tidy up after myself +rmtree($tmpdir); + +# MKTEMP +# Just a filename, not opened + +$template = File::Spec->catfile(File::Spec->tmpdir, 'mytestXXXXXX'); + +my $tmpfile = mktemp($template); + +print "# MKTEMP: Tempfile is $template -> $tmpfile\n"; + +# Okay if template no longer has XXXXX in + + +ok( ($tmpfile !~ /XXXXX$/) ); diff --git a/t/lib/ftmp-posix.t b/t/lib/ftmp-posix.t new file mode 100755 index 0000000000..f28785e87a --- /dev/null +++ b/t/lib/ftmp-posix.t @@ -0,0 +1,66 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +# Test for File::Temp - POSIX functions + +use strict; +use Test; +BEGIN { plan tests => 7} + +use File::Temp qw/ :POSIX unlink0 /; +ok(1); + +# TMPNAM - scalar + +print "# TMPNAM: in a scalar context: \n"; +my $tmpnam = tmpnam(); + +# simply check that the file does not exist +# Not a 100% water tight test though if another program +# has managed to create one in the meantime. +ok( !(-e $tmpnam )); + +print "# TMPNAM file name: $tmpnam\n"; + +# TMPNAM array context +# Not strict posix behaviour +(my $fh, $tmpnam) = tmpnam(); + +print "# TMPNAM: in array context: $fh $tmpnam\n"; + +# File is opened - make sure it exists +ok( (-e $tmpnam )); + +# Unlink it +ok( unlink0($fh, $tmpnam) ); + +# TMPFILE + +$fh = tmpfile(); + +ok( $fh ); +print "# TMPFILE: tmpfile got FH $fh\n"; + +$fh->autoflush(1) if $] >= 5.006; + +# print something to it +my $original = "Hello a test\n"; +print "# TMPFILE: Wrote line: $original"; +print $fh $original + or die "Error printing to tempfile\n"; + +# rewind it +ok( seek($fh,0,0) ); + + +# Read from it +my $line = <$fh>; + +print "# TMPFILE: Read line: $line"; +ok( $original, $line); + +close($fh); diff --git a/t/lib/ftmp-security.t b/t/lib/ftmp-security.t new file mode 100755 index 0000000000..50e177958a --- /dev/null +++ b/t/lib/ftmp-security.t @@ -0,0 +1,119 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +# Test for File::Temp - Security levels + +# Some of the security checking will not work on all platforms +# Test a simple open in the cwd and tmpdir foreach of the +# security levels + +use strict; +use Test; +BEGIN { plan tests => 13} + +use File::Spec; +use File::Temp qw/ tempfile unlink0 /; +ok(1); + +# The high security tests must currently be skipped on Windows +my $skipplat = ( $^O eq 'MSWin32' ? 1 : 0 ); + +# Can not run high security tests in perls before 5.6.0 +my $skipperl = ($] < 5.006 ? 1 : 0 ); + +# Determine whether we need to skip things and why +my $skip = 0; +if ($skipplat) { + $skip = "Skip Not supported on this platform"; +} elsif ($skipperl) { + $skip = "Skip Perl version must be v5.6.0 for these tests"; + +} + +print "# We will be skipping some tests : $skip\n" if $skip; + +# start off with basic checking + +File::Temp->safe_level( File::Temp::STANDARD ); + +print "# Testing with STANDARD security...\n"; + +&test_security(0); + +# Try medium + +File::Temp->safe_level( File::Temp::MEDIUM ) + unless $skip; + +print "# Testing with MEDIUM security...\n"; + +# Now we need to start skipping tests +&test_security($skip); + +# Try HIGH + +File::Temp->safe_level( File::Temp::HIGH ) + unless $skip; + +print "# Testing with HIGH security...\n"; + +&test_security($skip); + +exit; + +# Subroutine to open two temporary files. +# one is opened in the current dir and the other in the temp dir + +sub test_security { + + # Read in the skip flag + my $skip = shift; + + # If we are skipping we need to simply fake the correct number + # of tests -- we dont use skip since the tempfile() commands will + # fail with MEDIUM/HIGH security before the skip() command would be run + if ($skip) { + + skip($skip,1); + skip($skip,1); + + # plus we need an end block so the tests come out in the right order + eval q{ END { skip($skip,1); skip($skip,1) } 1; } || die; + + return; + } + + + # End blocks are evaluated in reverse order + # If I want to check that the file was unlinked by the autmoatic + # feature of the module I have to set up the end block before + # creating the file. + # Use quoted end block to retain access to lexicals + my @files; + + eval q{ END { foreach (@files) { ok( !(-e $_) )} } 1; } || die; + + + my $template = "temptestXXXXXXXX"; + my ($fh1, $fname1) = tempfile ( $template, + DIR => File::Spec->curdir, + UNLINK => 1, + ); + print "# Fname1 = $fname1\n"; + ok( ( -e $fname1) ); + + # Explicitly + my ($fh2, $fname2) = tempfile ($template, UNLINK => 1 ); + ok( (-e $fname2) ); + close($fh2); + + # Store filenames for the end block + push(@files, $fname1, $fname2); + + + +} diff --git a/t/lib/ftmp-tempfile.t b/t/lib/ftmp-tempfile.t new file mode 100755 index 0000000000..9c0de8b955 --- /dev/null +++ b/t/lib/ftmp-tempfile.t @@ -0,0 +1,92 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +# Test for File::Temp - tempfile function + +use strict; +use Test; +BEGIN { plan tests => 10} +use File::Spec; +use File::Temp qw/ tempfile tempdir/; + +# Will need to check that all files were unlinked correctly +# Set up an END block here to do it (since the END blocks +# set up by File::Temp will be evaluated in reverse order we +# set ours up first.... + +# Loop over an array hoping that the files dont exist +my @files; +eval q{ END { foreach (@files) { ok( !(-e $_) )} } 1; } || die; + +# And a test for directories +my @dirs; +eval q{ END { foreach (@dirs) { ok( !(-d $_) )} } 1; } || die; + + +# Tempfile +# Open tempfile in some directory, unlink at end +my ($fh, $tempfile) = tempfile( + UNLINK => 1, + SUFFIX => '.txt', + ); + +ok( (-f $tempfile) ); +push(@files, $tempfile); + +# TEMPDIR test +# Create temp directory in current dir +my $template = 'tmpdirXXXXXX'; +print "# Template: $template\n"; +my $tempdir = tempdir( $template , + DIR => File::Spec->curdir, + CLEANUP => 1, + ); + +print "# TEMPDIR: $tempdir\n"; + +ok( (-d $tempdir) ); +push(@dirs, $tempdir); + +# Create file in the temp dir +($fh, $tempfile) = tempfile( + DIR => $tempdir, + UNLINK => 1, + SUFFIX => '.dat', + ); + +print "# TEMPFILE: Created $tempfile\n"; + +ok( (-f $tempfile)); +push(@files, $tempfile); + +# Test tempfile +# ..and again +($fh, $tempfile) = tempfile( + DIR => $tempdir, + ); + + +ok( (-f $tempfile )); +push(@files, $tempfile); + +print "# TEMPFILE: Created $tempfile\n"; + +# and another (with template) + +($fh, $tempfile) = tempfile( 'helloXXXXXXX', + DIR => $tempdir, + UNLINK => 1, + SUFFIX => '.dat', + ); + +print "# TEMPFILE: Created $tempfile\n"; + +ok( (-f $tempfile) ); +push(@files, $tempfile); + +# no tests yet to make sure that the END{} blocks correctly remove +# the files diff --git a/t/lib/peek.t b/t/lib/peek.t index ecba70516c..255512fac5 100644 --- a/t/lib/peek.t +++ b/t/lib/peek.t @@ -15,12 +15,14 @@ use Devel::Peek; print "1..17\n"; our $DEBUG = 0; +open(SAVERR, ">&STDERR") or die "Can't dup STDERR: $!"; sub do_test { my $pattern = pop; if (open(OUT,">peek$$")) { - open(STDERR,">&OUT"); + open(STDERR, ">&OUT") or die "Can't dup OUT: $!"; Dump($_[1]); + open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!"; close(OUT); if (open(IN, "peek$$")) { local $/; @@ -28,7 +30,7 @@ sub do_test { print $pattern, "\n" if $DEBUG; my $dump = <IN>; print $dump, "\n" if $DEBUG; - print "not " unless $dump =~ /$pattern/m; + print "[$dump] vs [$pattern]\nnot " unless $dump =~ /$pattern/m; print "ok $_[0]\n"; close(IN); } else { @@ -58,7 +60,7 @@ do_test( 2, "bar", 'SV = PV\\($ADDR\\) at $ADDR REFCNT = 1 - FLAGS = \\(POK,READONLY,pPOK\\) + FLAGS = \\(.*POK,READONLY,pPOK\\) PV = $ADDR "bar"\\\0 CUR = 3 LEN = 4'); @@ -74,7 +76,7 @@ do_test( 4, 456, 'SV = IV\\($ADDR\\) at $ADDR REFCNT = 1 - FLAGS = \\(IOK,READONLY,pIOK\\) + FLAGS = \\(.*IOK,READONLY,pIOK\\) IV = 456'); do_test( 5, @@ -108,7 +110,7 @@ do_test( 8, 0xabcd, 'SV = IV\\($ADDR\\) at $ADDR REFCNT = 1 - FLAGS = \\(IOK,READONLY,pIOK,IsUV\\) + FLAGS = \\(.*IOK,READONLY,pIOK,IsUV\\) UV = 43981'); do_test( 9, @@ -230,9 +232,9 @@ do_test(14, DEPTH = 1 FLAGS = 0x0 PADLIST = $ADDR - 1\\. $ADDR \\("\\$pattern" \\d+-\\d+\\) - 12\\. $ADDR \\(FAKE "\\$DEBUG" 0-\\d+\\) - 13\\. $ADDR \\("\\$dump" \\d+-\\d+\\) + \\d+\\. $ADDR \\("\\$pattern" \\d+-\\d+\\) + \\d+\\. $ADDR \\(FAKE "\\$DEBUG" 0-\\d+\\) + \\d+\\. $ADDR \\("\\$dump" \\d+-\\d+\\) OUTSIDE = $ADDR \\(MAIN\\)'); do_test(15, @@ -300,7 +302,7 @@ do_test(17, GPFLAGS = 0x0 LINE = \\d+ FILE = ".+\\b(?i:peek\\.t)" - FLAGS = 0x2 + FLAGS = $ADDR EGV = $ADDR\\t"a"'); END { diff --git a/t/op/substr.t b/t/op/substr.t index 5764e67e7a..a67eae56ac 100755 --- a/t/op/substr.t +++ b/t/op/substr.t @@ -1,5 +1,5 @@ -print "1..125\n"; +print "1..130\n"; #P = start of string Q = start of substr R = end of substr S = end of string @@ -268,3 +268,16 @@ ok 123, $@ && $@ =~ /Can't modify substr/ && $a eq "foo"; $a = "abcdefgh"; ok 124, sub { shift }->(substr($a, 0, 4, "xxxx")) eq 'abcd'; ok 125, $a eq 'xxxxefgh'; + +# utf8 sanity +{ + my $x = substr("a\x{263a}b",0); + ok 126, length($x) eq 3; + $x = substr($x,1,1); + ok 127, $x eq "\x{263a}"; + $x = $x x 2; + ok 128, length($x) eq 2; + substr($x,0,1) = "abcd"; + ok 129, $x eq "abcd\x{263a}"; + ok 130, length($x) eq 5; +} diff --git a/utils/perlbug.PL b/utils/perlbug.PL index 208da3667c..9e7936dfcb 100644 --- a/utils/perlbug.PL +++ b/utils/perlbug.PL @@ -91,7 +91,7 @@ BEGIN { $::HaveUtil = ($@ eq ""); }; -my $Version = "1.28"; +my $Version = "1.29"; # Changed in 1.06 to skip Mail::Send and Mail::Util if not available. # Changed in 1.07 to see more sendmail execs, and added pipe output. @@ -124,6 +124,7 @@ my $Version = "1.28"; # Changed in 1.26 Don't require -t STDIN for -ok. HVDS 98-07-15 # Changed in 1.27 Added Mac OS and File::Spec support CNANDOR 99-07-27 # Changed in 1.28 Additional questions for Perlbugtron RFOLEY 20.03.2000 +# Changed in 1.29 Perlbug(tron): auto(-ok), short prompts RFOLEY 05-05-2000 # TODO: - Allow the user to re-name the file on mail failure, and # make sure failure (transmission-wise) of Mail::Send is @@ -158,30 +159,45 @@ Send(); exit; -sub ask_for_alternatives { +sub ask_for_alternatives { # (category|severity) my $name = shift; - my $default = shift; - my @alts = @_; + my %alts = ( + 'category' => { + 'default' => 'core', + 'ok' => 'install', + 'opts' => [qw(core docs install library utilities)], # patch, notabug + }, + 'severity' => { + 'default' => 'low', + 'ok' => 'none', + 'opts' => [qw(critical high medium low wishlist none)], # zero + }, + ); + die "Invalid alternative($name) requested\n" unless grep(/^$name$/, keys %alts); my $alt = ""; - paraprint <<EOF; + if ($ok) { + $alt = $alts{$name}{'ok'}; + } else { + my @alts = @{$alts{$name}{'opts'}}; + paraprint <<EOF; Please pick a \u$name from the following: @alts EOF - my $err = 0; - my $joined_alts = join('|', @alts); - do { - if ($err++ > 5) { - die "Invalid $name: aborting.\n"; - } - print "Please enter a \u$name [$default]: "; - $alt = <>; - chomp $alt; - if ($alt =~ /^\s*$/) { - $alt = $default; - } - } while ($alt !~ /^($joined_alts)$/i); + my $err = 0; + do { + if ($err++ > 5) { + die "Invalid $name: aborting.\n"; + } + print "Please enter a \u$name [$alts{$name}{'default'}]: "; + $alt = <>; + chomp $alt; + if ($alt =~ /^\s*$/) { + $alt = $alts{$name}{'default'}; + } + } while !((($alt) = grep(/^$alt/i, @alts))); + } lc $alt; } @@ -276,8 +292,6 @@ EOF $subject = ($::opt_n ? 'Not ' : '') . "OK: perl $perl_version ${patch_tags}on" ." $::Config{'archname'} $::Config{'osvers'} $subject"; - $category = "install"; - $severity = "none"; $ok = 1; } else { Help(); @@ -468,14 +482,10 @@ EOF } # Prompt for category of bug - $category ||= ask_for_alternatives("category", "core", - qw(core docs install - library utilities)); + $category ||= ask_for_alternatives('category'); # Prompt for severity of bug - $severity ||= ask_for_alternatives("severity", "low", - qw(critical high medium - low wishlist none)); + $severity ||= ask_for_alternatives('severity'); # Generate scratch file to edit report in $filename = filename(); @@ -911,6 +911,30 @@ my_mkdir(char *dir, Mode_t mode) } /* end of my_mkdir */ /*}}}*/ +/*{{{int my_chdir(char *)*/ +int +my_chdir(char *dir) +{ + STRLEN dirlen = strlen(dir); + dTHX; + + /* zero length string sometimes gives ACCVIO */ + if (dirlen == 0) return -1; + + /* some versions of CRTL chdir() doesn't tolerate trailing /, since + * that implies + * null file name/type. However, it's commonplace under Unix, + * so we'll allow it for a gain in portability. + */ + if (dir[dirlen-1] == '/') { + char *newdir = savepvn(dir,dirlen-1); + int ret = chdir(newdir); + Safefree(newdir); + return ret; + } + else return chdir(dir); +} /* end of my_chdir */ +/*}}}*/ static void create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc) diff --git a/vms/vmsish.h b/vms/vmsish.h index e53c604d16..c21f8f329e 100644 --- a/vms/vmsish.h +++ b/vms/vmsish.h @@ -109,6 +109,7 @@ #define do_rmdir Perl_do_rmdir #define kill_file Perl_kill_file #define my_mkdir Perl_my_mkdir +#define my_chdir Perl_my_chdir #define my_utime Perl_my_utime #define rmsexpand Perl_rmsexpand #define rmsexpand_ts Perl_rmsexpand_ts @@ -447,8 +448,9 @@ struct utimbuf { /* Ditto for sys$hash_passwrod() . . . */ #define crypt my_crypt -/* Tweak arg to mkdir first, so we can tolerate trailing /. */ +/* Tweak arg to mkdir & chdir first, so we can tolerate trailing /. */ #define Mkdir(dir,mode) my_mkdir((dir),(mode)) +#define Chdir(dir) my_chdir((dir)) /* Use our own stat() clones, which handle Unix-style directory names */ #define Stat(name,bufptr) flex_stat(name,bufptr) @@ -638,6 +640,7 @@ char * my_gconvert (double, int, int, char *); int do_rmdir (char *); int kill_file (char *); int my_mkdir (char *, Mode_t); +int my_chdir (char *); int my_utime (char *, struct utimbuf *); char * rmsexpand (char *, char *, char *, unsigned); char * rmsexpand_ts (char *, char *, char *, unsigned); |