rpms/perl
3
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity
748021e3d6
perl/perl-update-File-Temp.patch
Štěpán Kasal 26b7a08961 - remove compatibility obsolete sitelib directories 
- use a better BuildRoot
- drop a redundant mkdir in %%install
- call patchlevel.h only once; rm patchlevel.bak
- update modules Sys::Syslog, Module::Load::Conditional, Module::CoreList,
    Test::Harness, Test::Simple, CGI.pm (dropping the upstreamed patch),
    File::Path (that includes our perl-5.10.0-CVE-2008-2827.patch),
    constant, Pod::Simple, Archive::Tar, Archive::Extract, File::Fetch,
    File::Temp, IPC::Cmd, Time::HiRes, Module::Build, ExtUtils::CBuilder
- standardize the patches for updating embedded modules
- work around a bug in Module::Build tests bu setting TMPDIR to a directory
    inside the source tree
2009-03-11 21:12:37 +00:00

1399 lines
44 KiB
Diff
Raw Blame History

File-Temp-0.21
diff -urN perl-5.10.0.orig/MANIFEST perl-5.10.0/MANIFEST
--- perl-5.10.0.orig/MANIFEST 2009-02-20 18:22:32.000000000 +0100
+++ perl-5.10.0/MANIFEST 2009-03-10 15:19:19.000000000 +0100
@@ -1890,6 +1890,8 @@
lib/File/stat.t See if File::stat works
lib/File/Temp.pm create safe temporary files and file handles
lib/File/Temp/t/cmp.t See if File::Temp works
+lib/File/Temp/t/fork.t See if File::Temp works
+lib/File/Temp/t/lock.t See if File::Temp works
lib/File/Temp/t/mktemp.t See if File::Temp works
lib/File/Temp/t/object.t See if File::Temp works
lib/File/Temp/t/posix.t See if File::Temp works
diff -urN perl-5.10.0.orig/lib/File/Temp/t/fork.t perl-5.10.0/lib/File/Temp/t/fork.t
--- perl-5.10.0.orig/lib/File/Temp/t/fork.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/File/Temp/t/fork.t 2009-03-10 15:26:34.000000000 +0100
@@ -0,0 +1,90 @@
+#!/usr/bin/perl
+$| = 1;
+
+# Note that because fork loses test count we do not use Test::More
+
+use strict;
+
+BEGIN { print "1..8\n"; }
+
+use File::Temp;
+
+# OO interface
+
+my $file = File::Temp->new(CLEANUP=>1);
+
+myok( 1, -f $file->filename, "OO File exists" );
+
+my $children = 2;
+for my $i (1 .. $children) {
+ my $pid = fork;
+ die "Can't fork: $!" unless defined $pid;
+ if ($pid) {
+ # parent process
+ next;
+ } else {
+ # in a child we can't keep the count properly so we do it manually
+ # make sure that child 1 dies first
+ srand();
+ my $time = (($i-1) * 5) +int(rand(5));
+ print "# child $i sleeping for $time seconds\n";
+ sleep($time);
+ my $count = $i + 1;
+ myok( $count, -f $file->filename(), "OO file present in child $i" );
+ print "# child $i exiting\n";
+ exit;
+ }
+}
+
+while ($children) {
+ wait;
+ $children--;
+}
+
+
+
+myok( 4, -f $file->filename(), "OO File exists in parent" );
+
+# non-OO interface
+
+my ($fh, $filename) = File::Temp::tempfile( CLEANUP => 1 );
+
+myok( 5, -f $filename, "non-OO File exists" );
+
+$children = 2;
+for my $i (1 .. $children) {
+ my $pid = fork;
+ die "Can't fork: $!" unless defined $pid;
+ if ($pid) {
+ # parent process
+ next;
+ } else {
+ srand();
+ my $time = (($i-1) * 5) +int(rand(5));
+ print "# child $i sleeping for $time seconds\n";
+ sleep($time);
+ my $count = 5 + $i;
+ myok( $count, -f $filename, "non-OO File present in child $i" );
+ print "# child $i exiting\n";
+ exit;
+ }
+}
+
+while ($children) {
+ wait;
+ $children--;
+}
+myok(8, -f $filename, "non-OO File exists in parent" );
+
+
+# Local ok sub handles explicit number
+sub myok {
+ my ($count, $test, $msg) = @_;
+
+ if ($test) {
+ print "ok $count - $msg\n";
+ } else {
+ print "not ok $count - $msg\n";
+ }
+ return $test;
+}
diff -urN perl-5.10.0.orig/lib/File/Temp/t/lock.t perl-5.10.0/lib/File/Temp/t/lock.t
--- perl-5.10.0.orig/lib/File/Temp/t/lock.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/File/Temp/t/lock.t 2009-03-10 15:26:34.000000000 +0100
@@ -0,0 +1,60 @@
+#!perl -w
+# Test O_EXLOCK
+
+use Test::More;
+use strict;
+use Fcntl;
+
+BEGIN {
+# see if we have O_EXLOCK
+ eval { &Fcntl::O_EXLOCK; };
+ if ($@) {
+ plan skip_all => 'Do not seem to have O_EXLOCK';
+ } else {
+ plan tests => 4;
+ use_ok( "File::Temp" );
+ }
+}
+
+# Need Symbol package for lexical filehandle on older perls
+require Symbol if $] < 5.006;
+
+# Get a tempfile with O_EXLOCK
+my $fh = new File::Temp();
+ok( -e "$fh", "temp file is present" );
+
+# try to open it with a lock
+my $flags = O_CREAT | O_RDWR | O_EXLOCK;
+
+my $timeout = 5;
+my $status;
+eval {
+ local $SIG{ALRM} = sub { die "alarm\n" }; # NB: \n required
+ alarm $timeout;
+ my $newfh;
+ $newfh = &Symbol::gensym if $] < 5.006;
+ $status = sysopen($newfh, "$fh", $flags, 0600);
+ alarm 0;
+};
+if ($@) {
+ die unless $@ eq "alarm\n"; # propagate unexpected errors
+ # timed out
+}
+ok( !$status, "File $fh is locked" );
+
+# Now get a tempfile with locking disabled
+$fh = new File::Temp( EXLOCK => 0 );
+
+eval {
+ local $SIG{ALRM} = sub { die "alarm\n" }; # NB: \n required
+ alarm $timeout;
+ my $newfh;
+ $newfh = &Symbol::gensym if $] < 5.006;
+ $status = sysopen($newfh, "$fh", $flags, 0600);
+ alarm 0;
+};
+if ($@) {
+ die unless $@ eq "alarm\n"; # propagate unexpected errors
+ # timed out
+}
+ok( $status, "File $fh is not locked");
diff -urN perl-5.10.0.orig/lib/File/Temp/t/object.t perl-5.10.0/lib/File/Temp/t/object.t
--- perl-5.10.0.orig/lib/File/Temp/t/object.t 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/lib/File/Temp/t/object.t 2009-03-10 15:26:34.000000000 +0100
@@ -2,7 +2,7 @@
# Test for File::Temp - OO interface
use strict;
-use Test::More tests => 26;
+use Test::More tests => 30;
use File::Spec;
# Will need to check that all files were unlinked correctly
@@ -44,7 +44,22 @@
# Check again at exit
push(@files, "$fh");
-# TEMPDIR test
+# OO tempdir
+my $tdir = File::Temp->newdir();
+my $dirname = "$tdir"; # Stringify overload
+ok( -d $dirname, "Directory $tdir exists");
+undef $tdir;
+ok( !-d $dirname, "Directory should now be gone");
+
+# Quick basic tempfile test
+my $qfh = File::Temp->new();
+my $qfname = "$qfh";
+ok (-f $qfname, "temp file exists");
+undef $qfh;
+ok( !-f $qfname, "temp file now gone");
+
+
+# TEMPDIR test as somewhere to put the temp files
# Create temp directory in current dir
my $template = 'tmpdirXXXXXX';
print "# Template: $template\n";
diff -urN perl-5.10.0.orig/lib/File/Temp/t/seekable.t perl-5.10.0/lib/File/Temp/t/seekable.t
--- perl-5.10.0.orig/lib/File/Temp/t/seekable.t 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/lib/File/Temp/t/seekable.t 2009-03-10 15:26:34.000000000 +0100
@@ -6,7 +6,7 @@
# change 'tests => 1' to 'tests => last_test_to_print';
-use Test::More tests => 7;
+use Test::More tests => 10;
BEGIN { use_ok('File::Temp') };
#########################
@@ -18,10 +18,17 @@
$tmp = File::Temp->new;
isa_ok( $tmp, 'File::Temp' );
isa_ok( $tmp, 'IO::Handle' );
-isa_ok( $tmp, 'IO::Seekable' );
+SKIP: {
+ skip "->isa is broken on 5.6.0", 1 if $] == 5.006000;
+ isa_ok( $tmp, 'IO::Seekable' );
+}
# make sure the seek method is available...
-ok( File::Temp->can('seek'), 'tmp can seek' );
+# Note that we need a reasonably modern IO::Seekable
+SKIP: {
+ skip "IO::Seekable is too old", 1 if IO::Seekable->VERSION <= 1.06;
+ ok( File::Temp->can('seek'), 'tmp can seek' );
+}
# make sure IO::Handle methods are still there...
ok( File::Temp->can('print'), 'tmp can print' );
@@ -30,3 +37,7 @@
$c = scalar @File::Temp::EXPORT;
$l = join ' ', @File::Temp::EXPORT;
ok( $c == 9, "really exporting $c: $l" );
+
+ok(defined eval { SEEK_SET() }, 'SEEK_SET defined by File::Temp') or diag $@;
+ok(defined eval { SEEK_END() }, 'SEEK_END defined by File::Temp') or diag $@;
+ok(defined eval { SEEK_CUR() }, 'SEEK_CUR defined by File::Temp') or diag $@;
diff -urN perl-5.10.0.orig/lib/File/Temp.pm perl-5.10.0/lib/File/Temp.pm
--- perl-5.10.0.orig/lib/File/Temp.pm 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/lib/File/Temp.pm 2009-03-10 15:25:28.000000000 +0100
@@ -52,7 +52,9 @@
($fh, $filename) = tempfile( $template, DIR => $dir);
($fh, $filename) = tempfile( $template, SUFFIX => '.dat');
+ ($fh, $filename) = tempfile( $template, TMPDIR => 1 );
+ binmode( $fh, ":utf8" );
$dir = tempdir( CLEANUP => 1 );
($fh, $filename) = tempfile( DIR => $dir );
@@ -63,13 +65,13 @@
use File::Temp ();
use File::Temp qw/ :seekable /;
- $fh = new File::Temp();
+ $fh = File::Temp->new();
$fname = $fh->filename;
- $fh = new File::Temp(TEMPLATE => $template);
+ $fh = File::Temp->new(TEMPLATE => $template);
$fname = $fh->filename;
- $tmp = new File::Temp( UNLINK => 0, SUFFIX => '.dat' );
+ $tmp = File::Temp->new( UNLINK => 0, SUFFIX => '.dat' );
print $tmp "Some data\n";
print "Filename is $tmp\n";
$tmp->seek( 0, SEEK_END );
@@ -130,6 +132,8 @@
that was valid when function was called, so cannot guarantee
that the file will not exist by the time the caller opens the filename.
+Filehandles returned by these functions support the seekable methods.
+
=cut
# 5.6.0 gives us S_IWOTH, S_IWGRP, our and auto-vivifying filehandls
@@ -140,7 +144,7 @@
use File::Spec 0.8;
use File::Path qw/ rmtree /;
use Fcntl 1.03;
-use IO::Seekable; # For SEEK_*
+use IO::Seekable; # For SEEK_*
use Errno;
require VMS::Stdio if $^O eq 'VMS';
@@ -149,7 +153,7 @@
# us that Carp::Heavy won't load rather than an error telling us we
# have run out of file handles. We either preload croak() or we
# switch the calls to croak from _gettemp() to use die.
-require Carp::Heavy;
+eval { require Carp::Heavy; };
# Need the Symbol package if we are running older perl
require Symbol if $] < 5.006;
@@ -171,42 +175,42 @@
# Export list - to allow fine tuning of export table
@EXPORT_OK = qw{
- tempfile
- tempdir
- tmpnam
- tmpfile
- mktemp
- mkstemp
- mkstemps
- mkdtemp
- unlink0
- cleanup
- SEEK_SET
- SEEK_CUR
- SEEK_END
- };
+ tempfile
+ tempdir
+ tmpnam
+ tmpfile
+ mktemp
+ mkstemp
+ mkstemps
+ mkdtemp
+ unlink0
+ cleanup
+ SEEK_SET
+ SEEK_CUR
+ SEEK_END
+ };
# Groups of functions for export
%EXPORT_TAGS = (
- 'POSIX' => [qw/ tmpnam tmpfile /],
- 'mktemp' => [qw/ mktemp mkstemp mkstemps mkdtemp/],
- 'seekable' => [qw/ SEEK_SET SEEK_CUR SEEK_END /],
- );
+ 'POSIX' => [qw/ tmpnam tmpfile /],
+ 'mktemp' => [qw/ mktemp mkstemp mkstemps mkdtemp/],
+ 'seekable' => [qw/ SEEK_SET SEEK_CUR SEEK_END /],
+ );
# add contents of these tags to @EXPORT
Exporter::export_tags('POSIX','mktemp','seekable');
# Version number
-$VERSION = '0.18';
+$VERSION = '0.21';
# 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 _
- /);
+ 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
@@ -229,9 +233,10 @@
# us an optimisation when many temporary files are requested
my $OPENFLAGS = O_CREAT | O_EXCL | O_RDWR;
+my $LOCKFLAG;
unless ($^O eq 'MacOS') {
- for my $oflag (qw/ NOFOLLOW BINARY LARGEFILE EXLOCK NOINHERIT /) {
+ for my $oflag (qw/ NOFOLLOW BINARY LARGEFILE NOINHERIT /) {
my ($bit, $func) = (0, "Fcntl::O_" . $oflag);
no strict 'refs';
$OPENFLAGS |= $bit if eval {
@@ -243,6 +248,12 @@
1;
};
}
+ # Special case O_EXLOCK
+ $LOCKFLAG = eval {
+ local $SIG{__DIE__} = sub {};
+ local $SIG{__WARN__} = sub {};
+ &Fcntl::O_EXLOCK();
+ };
}
# On some systems the O_TEMPORARY flag can be used to tell the OS
@@ -256,6 +267,7 @@
unless ($^O eq 'MacOS') {
for my $oflag (qw/ TEMPORARY /) {
my ($bit, $func) = (0, "Fcntl::O_" . $oflag);
+ local($@);
no strict 'refs';
$OPENTEMPFLAGS |= $bit if eval {
# Make sure that redefined die handlers do not cause problems
@@ -268,6 +280,9 @@
}
}
+# Private hash tracking which files have been created by each process id via the OO interface
+my %FILES_CREATED_BY_OBJECT;
+
# INTERNAL ROUTINES - not to be used outside of package
# Generic routine for getting a temporary filename
@@ -292,6 +307,7 @@
# the file as soon as it is closed. Usually indicates
# use of the O_TEMPORARY flag to sysopen.
# Usually irrelevant on unix
+# "use_exlock" => Indicates that O_EXLOCK should be used. Default is true.
# 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
@@ -324,12 +340,13 @@
# Default options
my %options = (
- "open" => 0,
- "mkdir" => 0,
- "suffixlen" => 0,
- "unlink_on_close" => 0,
- "ErrStr" => \$tempErrStr,
- );
+ "open" => 0,
+ "mkdir" => 0,
+ "suffixlen" => 0,
+ "unlink_on_close" => 0,
+ "use_exlock" => 1,
+ "ErrStr" => \$tempErrStr,
+ );
# Read the template
my $template = shift;
@@ -389,7 +406,7 @@
# or a tempfile
my ($volume, $directories, $file);
- my $parent; # parent directory
+ my $parent; # parent directory
if ($options{"mkdir"}) {
# There is no filename at the end
($volume, $directories, $file) = File::Spec->splitpath( $path, 1);
@@ -404,16 +421,16 @@
$parent = File::Spec->curdir;
} else {
- if ($^O eq 'VMS') { # need volume to avoid relative dir spec
+ 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]);
+ # 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, '');
+ # ...and attach the volume (no filename)
+ $parent = File::Spec->catpath($volume, $parent, '');
}
}
@@ -437,15 +454,14 @@
# not a file -- no point returning a name that includes a directory
# that does not exist or is not writable
+ unless (-e $parent) {
+ ${$options{ErrStr}} = "Parent directory ($parent) does not exist";
+ return ();
+ }
unless (-d $parent) {
${$options{ErrStr}} = "Parent directory ($parent) is not a directory";
return ();
}
- unless (-w $parent) {
- ${$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
@@ -475,7 +491,7 @@
# If we are running before perl5.6.0 we can not auto-vivify
if ($] < 5.006) {
- $fh = &Symbol::gensym;
+ $fh = &Symbol::gensym;
}
# Try to make sure this will be marked close-on-exec
@@ -487,52 +503,53 @@
my $open_success = undef;
if ( $^O eq 'VMS' and $options{"unlink_on_close"} && !$KEEP_ALL) {
# make it auto delete on close by setting FAB$V_DLT bit
- $fh = VMS::Stdio::vmssysopen($path, $OPENFLAGS, 0600, 'fop=dlt');
- $open_success = $fh;
+ $fh = VMS::Stdio::vmssysopen($path, $OPENFLAGS, 0600, 'fop=dlt');
+ $open_success = $fh;
} else {
- my $flags = ( ($options{"unlink_on_close"} && !$KEEP_ALL) ?
- $OPENTEMPFLAGS :
- $OPENFLAGS );
- $open_success = sysopen($fh, $path, $flags, 0600);
+ my $flags = ( ($options{"unlink_on_close"} && !$KEEP_ALL) ?
+ $OPENTEMPFLAGS :
+ $OPENFLAGS );
+ $flags |= $LOCKFLAG if (defined $LOCKFLAG && $options{use_exlock});
+ $open_success = sysopen($fh, $path, $flags, 0600);
}
if ( $open_success ) {
- # in case of odd umask force rw
- chmod(0600, $path);
+ # in case of odd umask force rw
+ chmod(0600, $path);
- # Opened successfully - return file handle and name
- return ($fh, $path);
+ # Opened successfully - return file handle and name
+ return ($fh, $path);
} else {
- # Error opening file - abort with error
- # if the reason was anything but EEXIST
- unless ($!{EEXIST}) {
- ${$options{ErrStr}} = "Could not create temp file $path: $!";
- return ();
- }
+ # Error opening file - abort with error
+ # if the reason was anything but EEXIST
+ unless ($!{EEXIST}) {
+ ${$options{ErrStr}} = "Could not create temp file $path: $!";
+ return ();
+ }
- # Loop round for another try
+ # Loop round for another try
}
} elsif ($options{"mkdir"}) {
# Open the temp directory
if (mkdir( $path, 0700)) {
- # in case of odd umask
- chmod(0700, $path);
+ # in case of odd umask
+ chmod(0700, $path);
- return undef, $path;
+ return undef, $path;
} else {
- # Abort with error if the reason for failure was anything
- # except EEXIST
- unless ($!{EEXIST}) {
- ${$options{ErrStr}} = "Could not create directory $path: $!";
- return ();
- }
+ # Abort with error if the reason for failure was anything
+ # except EEXIST
+ unless ($!{EEXIST}) {
+ ${$options{ErrStr}} = "Could not create directory $path: $!";
+ return ();
+ }
- # Loop round for another try
+ # Loop round for another try
}
@@ -559,7 +576,7 @@
# attempt and make sure that none are repeated
my $original = $path;
- my $counter = 0; # Stop infinite loop
+ my $counter = 0; # Stop infinite loop
my $MAX_GUESS = 50;
do {
@@ -587,22 +604,6 @@
}
-# 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
-
-# No longer called since _replace_XX runs a few percent faster if
-# I inline the code. This is important if we are creating thousands of
-# temporary files.
-
-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
@@ -623,11 +624,12 @@
# 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.
+ my $end = ( $] >= 5.006 ? "\\z" : "\\Z" );
if ($ignore) {
- substr($path, 0, - $ignore) =~ s/X(?=X*\z)/$CHARS[ int( rand( $#CHARS ) ) ]/ge;
+ substr($path, 0, - $ignore) =~ s/X(?=X*$end)/$CHARS[ int( rand( @CHARS ) ) ]/ge;
} else {
- $path =~ s/X(?=X*\z)/$CHARS[ int( rand( $#CHARS ) ) ]/ge;
+ $path =~ s/X(?=X*$end)/$CHARS[ int( rand( @CHARS ) ) ]/ge;
}
return $path;
}
@@ -670,16 +672,17 @@
unless (scalar(@info)) {
$$err_ref = "stat(path) returned no values";
return 0;
- };
- return 1 if $^O eq 'VMS'; # owner delete control at file level
+ }
+ ;
+ return 1 if $^O eq 'VMS'; # owner delete control at file level
# Check to see whether owner is neither superuser (or a system uid) nor me
# Use the effective uid from the $> variable
# UID is in [4]
if ($info[4] > File::Temp->top_system_uid() && $info[4] != $>) {
- Carp::cluck(sprintf "uid=$info[4] topuid=%s euid=$< path='$path'",
- File::Temp->top_system_uid());
+ Carp::cluck(sprintf "uid=$info[4] topuid=%s euid=$> path='$path'",
+ File::Temp->top_system_uid());
$$err_ref = "Directory owned neither by root nor the current user"
if ref($err_ref);
@@ -691,18 +694,18 @@
# 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?
+ if (($info[2] & &Fcntl::S_IWGRP) || # Is group writable?
+ ($info[2] & &Fcntl::S_IWOTH) ) { # Is world writable?
# Must be a directory
unless (-d $path) {
$$err_ref = "Path ($path) is not a directory"
- if ref($err_ref);
+ if ref($err_ref);
return 0;
}
# Must have sticky bit set
unless (-k $path) {
$$err_ref = "Sticky bit not set on $path when dir is group|world writable"
- if ref($err_ref);
+ if ref($err_ref);
return 0;
}
}
@@ -727,12 +730,13 @@
my $path = shift;
print "_is_verysafe testing $path\n" if $DEBUG;
- return 1 if $^O eq 'VMS'; # owner delete control at file level
+ return 1 if $^O eq 'VMS'; # owner delete control at file level
my $err_ref = shift;
# Should Get the value of _PC_CHOWN_RESTRICTED if it is defined
# and If it is not there do the extensive test
+ local($@);
my $chown_restricted;
$chown_restricted = &POSIX::_PC_CHOWN_RESTRICTED()
if eval { &POSIX::_PC_CHOWN_RESTRICTED(); 1};
@@ -769,9 +773,9 @@
foreach my $pos (0.. $#dirs) {
# Get a directory name
my $dir = File::Spec->catpath($volume,
- File::Spec->catdir(@dirs[0.. $#dirs - $pos]),
- ''
- );
+ File::Spec->catdir(@dirs[0.. $#dirs - $pos]),
+ ''
+ );
print "TESTING DIR $dir\n" if $DEBUG;
@@ -863,6 +867,7 @@
# Set up an end block to use these arrays
END {
+ local($., $@, $!, $^E, $?);
cleanup();
}
@@ -872,33 +877,38 @@
if (!$KEEP_ALL) {
# Files
my @files = (exists $files_to_unlink{$$} ?
- @{ $files_to_unlink{$$} } : () );
+ @{ $files_to_unlink{$$} } : () );
foreach my $file (@files) {
- # 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($file->[0]); # file handle is [0]
-
- if (-f $file->[1]) { # file name is [1]
- _force_writable( $file->[1] ); # for windows
- unlink $file->[1] or warn "Error removing ".$file->[1];
- }
+ # 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($file->[0]); # file handle is [0]
+
+ if (-f $file->[1]) { # file name is [1]
+ _force_writable( $file->[1] ); # for windows
+ unlink $file->[1] or warn "Error removing ".$file->[1];
+ }
}
# Dirs
my @dirs = (exists $dirs_to_unlink{$$} ?
- @{ $dirs_to_unlink{$$} } : () );
+ @{ $dirs_to_unlink{$$} } : () );
foreach my $dir (@dirs) {
- if (-d $dir) {
- rmtree($dir, $DEBUG, 0);
- }
+ if (-d $dir) {
+ # Some versions of rmtree will abort if you attempt to remove
+ # the directory you are sitting in. We protect that and turn it
+ # into a warning. We do this because this occurs during
+ # cleanup and so can not be caught by the user.
+ eval { rmtree($dir, $DEBUG, 0); };
+ warn $@ if ($@ && $^W);
+ }
}
# clear the arrays
@{ $files_to_unlink{$$} } = ()
- if exists $files_to_unlink{$$};
+ if exists $files_to_unlink{$$};
@{ $dirs_to_unlink{$$} } = ()
- if exists $dirs_to_unlink{$$};
+ if exists $dirs_to_unlink{$$};
}
}
@@ -923,28 +933,28 @@
if (-d $fname) {
- # Directory exists so store it
- # first on VMS turn []foo into [.foo] for rmtree
- $fname = VMS::Filespec::vmspath($fname) if $^O eq 'VMS';
- $dirs_to_unlink{$$} = []
- unless exists $dirs_to_unlink{$$};
- push (@{ $dirs_to_unlink{$$} }, $fname);
+ # Directory exists so store it
+ # first on VMS turn []foo into [.foo] for rmtree
+ $fname = VMS::Filespec::vmspath($fname) if $^O eq 'VMS';
+ $dirs_to_unlink{$$} = []
+ unless exists $dirs_to_unlink{$$};
+ push (@{ $dirs_to_unlink{$$} }, $fname);
} else {
- carp "Request to remove directory $fname could not be completed since it does not exist!\n" if $^W;
+ carp "Request to remove directory $fname could not be completed since it does not exist!\n" if $^W;
}
} else {
if (-f $fname) {
- # file exists so store handle and name for later removal
- $files_to_unlink{$$} = []
- unless exists $files_to_unlink{$$};
- push(@{ $files_to_unlink{$$} }, [$fh, $fname]);
+ # file exists so store handle and name for later removal
+ $files_to_unlink{$$} = []
+ unless exists $files_to_unlink{$$};
+ push(@{ $files_to_unlink{$$} }, [$fh, $fname]);
} else {
- carp "Request to remove file $fname could not be completed since it is not there!\n" if $^W;
+ carp "Request to remove file $fname could not be completed since it is not there!\n" if $^W;
}
}
@@ -974,7 +984,7 @@
Create a temporary file object.
- my $tmp = new File::Temp();
+ my $tmp = File::Temp->new();
by default the object is constructed as if C<tempfile>
was called without options, but with the additional behaviour
@@ -982,11 +992,11 @@
if UNLINK is set to true (the default).
Supported arguments are the same as for C<tempfile>: UNLINK
-(defaulting to true), DIR and SUFFIX. Additionally, the filename
+(defaulting to true), DIR, EXLOCK and SUFFIX. Additionally, the filename
template is specified using the TEMPLATE option. The OPEN option
is not supported (the file is always opened).
- $tmp = new File::Temp( TEMPLATE => 'tempXXXXX',
+ $tmp = File::Temp->new( TEMPLATE => 'tempXXXXX',
DIR => 'mydir',
SUFFIX => '.dat');
@@ -1008,8 +1018,8 @@
my $unlink = (exists $args{UNLINK} ? $args{UNLINK} : 1 );
delete $args{UNLINK};
- # template (store it in an error so that it will
- # disappear from the arg list of tempfile
+ # template (store it in an array so that it will
+ # disappear from the arg list of tempfile)
my @template = ( exists $args{TEMPLATE} ? $args{TEMPLATE} : () );
delete $args{TEMPLATE};
@@ -1024,6 +1034,9 @@
# Store the filename in the scalar slot
${*$fh} = $path;
+ # Cache the filename by pid so that the destructor can decide whether to remove it
+ $FILES_CREATED_BY_OBJECT{$$}{$path} = 1;
+
# Store unlink information in hash slot (plus other constructor info)
%{*$fh} = %args;
@@ -1036,9 +1049,48 @@
return $fh;
}
+=item B<newdir>
+
+Create a temporary directory using an object oriented interface.
+
+ $dir = File::Temp->newdir();
+
+By default the directory is deleted when the object goes out of scope.
+
+Supports the same options as the C<tempdir> function. Note that directories
+created with this method default to CLEANUP => 1.
+
+ $dir = File::Temp->newdir( $template, %options );
+
+=cut
+
+sub newdir {
+ my $self = shift;
+
+ # need to handle args as in tempdir because we have to force CLEANUP
+ # default without passing CLEANUP to tempdir
+ my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef );
+ my %options = @_;
+ my $cleanup = (exists $options{CLEANUP} ? $options{CLEANUP} : 1 );
+
+ delete $options{CLEANUP};
+
+ my $tempdir;
+ if (defined $template) {
+ $tempdir = tempdir( $template, %options );
+ } else {
+ $tempdir = tempdir( %options );
+ }
+ return bless { DIRNAME => $tempdir,
+ CLEANUP => $cleanup,
+ LAUNCHPID => $$,
+ }, "File::Temp::Dir";
+}
+
=item B<filename>
-Return the name of the temporary file associated with this object.
+Return the name of the temporary file associated with this object
+(if the object was created using the "new" constructor).
$filename = $tmp->filename;
@@ -1057,6 +1109,15 @@
return $self->filename;
}
+=item B<dirname>
+
+Return the name of the temporary directory associated with this
+object (if the object was created using the "newdir" constructor).
+
+ $dirname = $tmpdir->dirname;
+
+This method is called automatically when the object is used in string context.
+
=item B<unlink_on_destroy>
Control whether the file is unlinked when the object goes out of scope.
@@ -1085,24 +1146,47 @@
No error is given if the unlink fails.
-If the global variable $KEEP_ALL is true, the file will not be removed.
+If the object has been passed to a child process during a fork, the
+file will be deleted when the object goes out of scope in the parent.
+
+For a temporary directory object the directory will be removed
+unless the CLEANUP argument was used in the constructor (and set to
+false) or C<unlink_on_destroy> was modified after creation.
+
+If the global variable $KEEP_ALL is true, the file or directory
+will not be removed.
=cut
sub DESTROY {
+ local($., $@, $!, $^E, $?);
my $self = shift;
+
+ # Make sure we always remove the file from the global hash
+ # on destruction. This prevents the hash from growing uncontrollably
+ # and post-destruction there is no reason to know about the file.
+ my $file = $self->filename;
+ my $was_created_by_proc;
+ if (exists $FILES_CREATED_BY_OBJECT{$$}{$file}) {
+ $was_created_by_proc = 1;
+ delete $FILES_CREATED_BY_OBJECT{$$}{$file};
+ }
+
if (${*$self}{UNLINK} && !$KEEP_ALL) {
print "# ---------> Unlinking $self\n" if $DEBUG;
+ # only delete if this process created it
+ return unless $was_created_by_proc;
+
# The unlink1 may fail if the file has been closed
# by the caller. This leaves us with the decision
# of whether to refuse to remove the file or simply
# do an unlink without test. Seems to be silly
# to do this when we are trying to be careful
# about security
- _force_writable( $self->filename ); # for windows
- unlink1( $self, $self->filename )
- or unlink($self->filename);
+ _force_writable( $file ); # for windows
+ unlink1( $self, $file )
+ or unlink($file);
}
}
@@ -1145,6 +1229,12 @@
Translates the template as before except that a directory name
is specified.
+ ($fh, $filename) = tempfile($template, TMPDIR => 1);
+
+Equivalent to specifying a DIR of "File::Spec->tmpdir", writing the file
+into the same temporary directory as would be used if no template was
+specified at all.
+
($fh, $filename) = tempfile($template, UNLINK => 1);
Return the filename and filehandle as before except that the file is
@@ -1163,7 +1253,7 @@
(L<File::Spec>) unless a directory is specified explicitly with the
DIR option.
- $fh = tempfile( $template, DIR => $dir );
+ $fh = tempfile( DIR => $dir );
If called in scalar context, only the filehandle is returned and the
file will automatically be deleted when closed on operating systems
@@ -1186,6 +1276,16 @@
and mktemp() functions described elsewhere in this document
if opening the file is not required.
+If the operating system supports it (for example BSD derived systems), the
+filehandle will be opened with O_EXLOCK (open with exclusive file lock).
+This can sometimes cause problems if the intention is to pass the filename
+to another system that expects to take an exclusive lock itself (such as
+DBD::SQLite) whilst ensuring that the tempfile is not reused. In this
+situation the "EXLOCK" option can be passed to tempfile. By default EXLOCK
+will be true (this retains compatibility with earlier releases).
+
+ ($fh, $filename) = tempfile($template, EXLOCK => 0);
+
Options can be combined as required.
Will croak() if there is an error.
@@ -1199,11 +1299,13 @@
# Default options
my %options = (
- "DIR" => undef, # Directory prefix
- "SUFFIX" => '', # Template suffix
- "UNLINK" => 0, # Do not unlink file on exit
- "OPEN" => 1, # Open file
- );
+ "DIR" => undef, # Directory prefix
+ "SUFFIX" => '', # Template suffix
+ "UNLINK" => 0, # Do not unlink file on exit
+ "OPEN" => 1, # Open file
+ "TMPDIR" => 0, # Place tempfile in tempdir if template specified
+ "EXLOCK" => 1, # Open file with O_EXLOCK
+ );
# Check to see whether we have an odd or even number of arguments
my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef);
@@ -1221,8 +1323,8 @@
if ($options{"DIR"} and $^O eq 'VMS') {
- # on VMS turn []foo into [.foo] for concatenation
- $options{"DIR"} = VMS::Filespec::vmspath($options{"DIR"});
+ # on VMS turn []foo into [.foo] for concatenation
+ $options{"DIR"} = VMS::Filespec::vmspath($options{"DIR"});
}
# Construct the template
@@ -1234,10 +1336,15 @@
# First generate a template if not defined and prefix the directory
# If no template must prefix the temp directory
if (defined $template) {
+ # End up with current directory if neither DIR not TMPDIR are set
if ($options{"DIR"}) {
$template = File::Spec->catfile($options{"DIR"}, $template);
+ } elsif ($options{TMPDIR}) {
+
+ $template = File::Spec->catfile(File::Spec->tmpdir, $template );
+
}
} else {
@@ -1273,12 +1380,13 @@
my ($fh, $path, $errstr);
croak "Error in tempfile() using $template: $errstr"
unless (($fh, $path) = _gettemp($template,
- "open" => $options{'OPEN'},
- "mkdir"=> 0 ,
+ "open" => $options{'OPEN'},
+ "mkdir"=> 0 ,
"unlink_on_close" => $unlink_on_close,
- "suffixlen" => length($options{'SUFFIX'}),
- "ErrStr" => \$errstr,
- ) );
+ "suffixlen" => length($options{'SUFFIX'}),
+ "ErrStr" => \$errstr,
+ "use_exlock" => $options{EXLOCK},
+ ) );
# Set up an exit handler that can do whatever is right for the
# system. This removes files at exit when requested explicitly or when
@@ -1312,7 +1420,15 @@
=item B<tempdir>
-This is the recommended interface for creation of temporary directories.
+This is the recommended interface for creation of temporary
+directories. By default the directory will not be removed on exit
+(that is, it won't be temporary; this behaviour can not be changed
+because of issues with backwards compatibility). To enable removal
+either use the CLEANUP option which will trigger removal on program
+exit, or consider using the "newdir" method in the object interface which
+will allow the directory to be cleaned up when the object goes out of
+scope.
+
The behaviour of the function depends on the arguments:
$tempdir = tempdir();
@@ -1374,10 +1490,10 @@
# Default options
my %options = (
- "CLEANUP" => 0, # Remove directory on exit
- "DIR" => '', # Root directory
- "TMPDIR" => 0, # Use tempdir with template
- );
+ "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 );
@@ -1409,8 +1525,8 @@
} elsif ($options{TMPDIR}) {
- # Prepend tmpdir
- $template = File::Spec->catdir(File::Spec->tmpdir, $template);
+ # Prepend tmpdir
+ $template = File::Spec->catdir(File::Spec->tmpdir, $template);
}
@@ -1433,7 +1549,7 @@
# Create the directory
my $tempdir;
my $suffixlen = 0;
- if ($^O eq 'VMS') { # dir names can end in delimiters
+ if ($^O eq 'VMS') { # dir names can end in delimiters
$template =~ m/([\.\]:>]+)$/;
$suffixlen = length($1);
}
@@ -1445,11 +1561,11 @@
my $errstr;
croak "Error in tempdir() using $template: $errstr"
unless ((undef, $tempdir) = _gettemp($template,
- "open" => 0,
- "mkdir"=> 1 ,
- "suffixlen" => $suffixlen,
- "ErrStr" => \$errstr,
- ) );
+ "open" => 0,
+ "mkdir"=> 1 ,
+ "suffixlen" => $suffixlen,
+ "ErrStr" => \$errstr,
+ ) );
# Install exit handler; must be dynamic to get lexical
if ( $options{'CLEANUP'} && -d $tempdir) {
@@ -1499,11 +1615,11 @@
my ($fh, $path, $errstr);
croak "Error in mkstemp using $template: $errstr"
unless (($fh, $path) = _gettemp($template,
- "open" => 1,
- "mkdir"=> 0 ,
- "suffixlen" => 0,
- "ErrStr" => \$errstr,
- ) );
+ "open" => 1,
+ "mkdir"=> 0 ,
+ "suffixlen" => 0,
+ "ErrStr" => \$errstr,
+ ) );
if (wantarray()) {
return ($fh, $path);
@@ -1544,11 +1660,11 @@
my ($fh, $path, $errstr);
croak "Error in mkstemps using $template: $errstr"
unless (($fh, $path) = _gettemp($template,
- "open" => 1,
- "mkdir"=> 0 ,
- "suffixlen" => length($suffix),
- "ErrStr" => \$errstr,
- ) );
+ "open" => 1,
+ "mkdir"=> 0 ,
+ "suffixlen" => length($suffix),
+ "ErrStr" => \$errstr,
+ ) );
if (wantarray()) {
return ($fh, $path);
@@ -1582,7 +1698,7 @@
my $template = shift;
my $suffixlen = 0;
- if ($^O eq 'VMS') { # dir names can end in delimiters
+ if ($^O eq 'VMS') { # dir names can end in delimiters
$template =~ m/([\.\]:>]+)$/;
$suffixlen = length($1);
}
@@ -1593,11 +1709,11 @@
my ($junk, $tmpdir, $errstr);
croak "Error creating temp directory from template $template\: $errstr"
unless (($junk, $tmpdir) = _gettemp($template,
- "open" => 0,
- "mkdir"=> 1 ,
- "suffixlen" => $suffixlen,
- "ErrStr" => \$errstr,
- ) );
+ "open" => 0,
+ "mkdir"=> 1 ,
+ "suffixlen" => $suffixlen,
+ "ErrStr" => \$errstr,
+ ) );
return $tmpdir;
@@ -1626,11 +1742,11 @@
my ($tmpname, $junk, $errstr);
croak "Error getting name to temp file from template $template: $errstr"
unless (($junk, $tmpname) = _gettemp($template,
- "open" => 0,
- "mkdir"=> 0 ,
- "suffixlen" => 0,
- "ErrStr" => \$errstr,
- ) );
+ "open" => 0,
+ "mkdir"=> 0 ,
+ "suffixlen" => 0,
+ "ErrStr" => \$errstr,
+ ) );
return $tmpname;
}
@@ -1680,20 +1796,20 @@
sub tmpnam {
- # Retrieve the temporary directory name
- my $tmpdir = File::Spec->tmpdir;
+ # Retrieve the temporary directory name
+ my $tmpdir = File::Spec->tmpdir;
- croak "Error temporary directory is not writable"
- if $tmpdir eq '';
+ 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);
+ # 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);
- }
+ if (wantarray() ) {
+ return mkstemp($template);
+ } else {
+ return mktemp($template);
+ }
}
@@ -1939,12 +2055,12 @@
# 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
+ my @okstat = (0..$#fh); # Use all by default
if ($^O eq 'MSWin32') {
@okstat = (1,2,3,4,5,7,8,9,10);
} elsif ($^O eq 'os2') {
@okstat = (0, 2..$#fh);
- } elsif ($^O eq 'VMS') { # device and file ID are sufficient
+ } elsif ($^O eq 'VMS') { # device and file ID are sufficient
@okstat = (0, 1);
} elsif ($^O eq 'dos') {
@okstat = (0,2..7,11..$#fh);
@@ -2045,11 +2161,10 @@
=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.
+Do the basic security measures to ensure the directory exists and is
+writable, 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
@@ -2113,15 +2228,15 @@
if (@_) {
my $level = shift;
if (($level != STANDARD) && ($level != MEDIUM) && ($level != HIGH)) {
- carp "safe_level: Specified level ($level) not STANDARD, MEDIUM or HIGH - ignoring\n" if $^W;
+ carp "safe_level: Specified level ($level) not STANDARD, MEDIUM or HIGH - ignoring\n" if $^W;
} else {
- # Dont allow this on perl 5.005 or earlier
- if ($] < 5.006 && $level != STANDARD) {
- # Cant do MEDIUM or HIGH checks
- croak "Currently requires perl 5.006 or newer to do the safe checks";
- }
- # Check that we are allowed to change level
- # Silently ignore if we can not.
+ # Dont allow this on perl 5.005 or earlier
+ if ($] < 5.006 && $level != STANDARD) {
+ # Cant do MEDIUM or HIGH checks
+ croak "Currently requires perl 5.006 or newer to do the safe checks";
+ }
+ # Check that we are allowed to change level
+ # Silently ignore if we can not.
$LEVEL = $level if _can_do_level($level);
}
}
@@ -2234,12 +2349,21 @@
through the same set of random file names and may well cause
themselves to give up if they exceed the number of retry attempts.
+=head2 Directory removal
+
+Note that if you have chdir'ed into the temporary directory and it is
+subsequently cleaned up (either in the END block or as part of object
+destruction), then you will get a warning from File::Path::rmtree().
+
=head2 BINMODE
The file returned by File::Temp will have been opened in binary mode
-if such a mode is available. If that is not correct, use the binmode()
+if such a mode is available. If that is not correct, use the C<binmode()>
function to change the mode of the filehandle.
+Note that you can modify the encoding of a file opened by File::Temp
+also by using C<binmode()>.
+
=head1 HISTORY
Originally began life in May 1999 as an XS interface to the system
@@ -2256,10 +2380,14 @@
See L<IO::File> and L<File::MkTemp>, L<Apache::TempFile> for
different implementations of temporary file handling.
+See L<File::Tempdir> for an alternative object-oriented wrapper for
+the C<tempdir> function.
+
=head1 AUTHOR
Tim Jenness E<lt>tjenness@cpan.orgE<gt>
+Copyright (C) 2007-2008 Tim Jenness.
Copyright (C) 1999-2007 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
@@ -2272,4 +2400,53 @@
=cut
+package File::Temp::Dir;
+
+use File::Path qw/ rmtree /;
+use strict;
+use overload '""' => "STRINGIFY", fallback => 1;
+
+# private class specifically to support tempdir objects
+# created by File::Temp->newdir
+
+# ostensibly the same method interface as File::Temp but without
+# inheriting all the IO::Seekable methods and other cruft
+
+# Read-only - returns the name of the temp directory
+
+sub dirname {
+ my $self = shift;
+ return $self->{DIRNAME};
+}
+
+sub STRINGIFY {
+ my $self = shift;
+ return $self->dirname;
+}
+
+sub unlink_on_destroy {
+ my $self = shift;
+ if (@_) {
+ $self->{CLEANUP} = shift;
+ }
+ return $self->{CLEANUP};
+}
+
+sub DESTROY {
+ my $self = shift;
+ local($., $@, $!, $^E, $?);
+ if ($self->unlink_on_destroy &&
+ $$ == $self->{LAUNCHPID} && !$File::Temp::KEEP_ALL) {
+ if (-d $self->{DIRNAME}) {
+ # Some versions of rmtree will abort if you attempt to remove
+ # the directory you are sitting in. We protect that and turn it
+ # into a warning. We do this because this occurs during object
+ # destruction and so can not be caught by the user.
+ eval { rmtree($self->{DIRNAME}, $File::Temp::DEBUG, 0); };
+ warn $@ if ($@ && $^W);
+ }
+ }
+}
+
+
1;
Reference in New Issue View Git Blame Copy Permalink