Profile of File/Temp.pm

Filename	/usr/lib64/perl5/5.16.0/File/Temp.pm
Statements	Executed 120 statements in 37.5ms

Subroutines
Calls	P	F	Exclusive Time	Inclusive Time	Subroutine
1	1	1	15.0ms	16.5ms	File::Temp::::BEGIN@145 File::Temp::BEGIN@145
1	1	1	4.62ms	6.34ms	File::Temp::::BEGIN@148 File::Temp::BEGIN@148
1	1	1	123µs	2.33ms	File::Temp::::BEGIN@146 File::Temp::BEGIN@146
1	1	1	107µs	107µs	File::Temp::::BEGIN@141 File::Temp::BEGIN@141
1	1	1	92µs	146µs	File::Temp::::END File::Temp::END
1	1	1	90µs	158µs	File::Temp::::BEGIN@144 File::Temp::BEGIN@144
1	1	1	74µs	491µs	File::Temp::::BEGIN@143 File::Temp::BEGIN@143
1	1	1	68µs	167µs	File::Temp::::BEGIN@142 File::Temp::BEGIN@142
1	1	1	66µs	294µs	File::Temp::::BEGIN@217 File::Temp::BEGIN@217
1	1	1	66µs	513µs	File::Temp::::BEGIN@166 File::Temp::BEGIN@166
1	1	1	65µs	256µs	File::Temp::Dir::::BEGIN@2405File::Temp::Dir::BEGIN@2405
1	1	1	62µs	255µs	File::Temp::::BEGIN@147 File::Temp::BEGIN@147
1	1	1	61µs	702µs	File::Temp::::BEGIN@162 File::Temp::BEGIN@162
1	1	1	58µs	142µs	File::Temp::::BEGIN@241 File::Temp::BEGIN@241
1	1	1	54µs	54µs	File::Temp::::cleanup File::Temp::cleanup
1	1	1	54µs	156µs	File::Temp::::BEGIN@173 File::Temp::BEGIN@173
1	1	1	54µs	138µs	File::Temp::::BEGIN@271 File::Temp::BEGIN@271
1	1	1	54µs	237µs	File::Temp::::BEGIN@230 File::Temp::BEGIN@230
1	1	1	53µs	265µs	File::Temp::Dir::::BEGIN@2407File::Temp::Dir::BEGIN@2407
1	1	1	52µs	360µs	File::Temp::::BEGIN@163 File::Temp::BEGIN@163
1	1	1	52µs	142µs	File::Temp::Dir::::BEGIN@2406File::Temp::Dir::BEGIN@2406
1	1	1	49µs	216µs	File::Temp::::BEGIN@224 File::Temp::BEGIN@224
1	1	1	47µs	216µs	File::Temp::::BEGIN@220 File::Temp::BEGIN@220
1	1	1	46µs	213µs	File::Temp::::BEGIN@229 File::Temp::BEGIN@229
1	1	1	46µs	207µs	File::Temp::::BEGIN@228 File::Temp::BEGIN@228
1	1	1	8µs	8µs	File::Temp::::__ANON__[:245] File::Temp::__ANON__[:245]
1	1	1	7µs	7µs	File::Temp::::__ANON__[:253] File::Temp::__ANON__[:253]
1	1	1	7µs	7µs	File::Temp::::__ANON__[:275] File::Temp::__ANON__[:275]
0	0	0	0s	0s	File::Temp::::DESTROY File::Temp::DESTROY
0	0	0	0s	0s	File::Temp::Dir::::DESTROYFile::Temp::Dir::DESTROY
0	0	0	0s	0s	File::Temp::Dir::::STRINGIFYFile::Temp::Dir::STRINGIFY
0	0	0	0s	0s	File::Temp::Dir::::dirnameFile::Temp::Dir::dirname
0	0	0	0s	0s	File::Temp::Dir::::unlink_on_destroyFile::Temp::Dir::unlink_on_destroy
0	0	0	0s	0s	File::Temp::::STRINGIFY File::Temp::STRINGIFY
0	0	0	0s	0s	File::Temp::::__ANON__[:246] File::Temp::__ANON__[:246]
0	0	0	0s	0s	File::Temp::::__ANON__[:254] File::Temp::__ANON__[:254]
0	0	0	0s	0s	File::Temp::::__ANON__[:276] File::Temp::__ANON__[:276]
0	0	0	0s	0s	File::Temp::::_can_do_level File::Temp::_can_do_level
0	0	0	0s	0s	File::Temp::::_can_unlink_opened_file File::Temp::_can_unlink_opened_file
0	0	0	0s	0s	File::Temp::::_deferred_unlink File::Temp::_deferred_unlink
0	0	0	0s	0s	File::Temp::::_force_writable File::Temp::_force_writable
0	0	0	0s	0s	File::Temp::::_gettemp File::Temp::_gettemp
0	0	0	0s	0s	File::Temp::::_is_safe File::Temp::_is_safe
0	0	0	0s	0s	File::Temp::::_is_verysafe File::Temp::_is_verysafe
0	0	0	0s	0s	File::Temp::::_replace_XX File::Temp::_replace_XX
0	0	0	0s	0s	File::Temp::::cmpstat File::Temp::cmpstat
0	0	0	0s	0s	File::Temp::::filename File::Temp::filename
0	0	0	0s	0s	File::Temp::::mkdtemp File::Temp::mkdtemp
0	0	0	0s	0s	File::Temp::::mkstemp File::Temp::mkstemp
0	0	0	0s	0s	File::Temp::::mkstemps File::Temp::mkstemps
0	0	0	0s	0s	File::Temp::::mktemp File::Temp::mktemp
0	0	0	0s	0s	File::Temp::::new File::Temp::new
0	0	0	0s	0s	File::Temp::::newdir File::Temp::newdir
0	0	0	0s	0s	File::Temp::::safe_level File::Temp::safe_level
0	0	0	0s	0s	File::Temp::::tempdir File::Temp::tempdir
0	0	0	0s	0s	File::Temp::::tempfile File::Temp::tempfile
0	0	0	0s	0s	File::Temp::::tempnam File::Temp::tempnam
0	0	0	0s	0s	File::Temp::::tmpfile File::Temp::tmpfile
0	0	0	0s	0s	File::Temp::::tmpnam File::Temp::tmpnam
0	0	0	0s	0s	File::Temp::::top_system_uid File::Temp::top_system_uid
0	0	0	0s	0s	File::Temp::::unlink0 File::Temp::unlink0
0	0	0	0s	0s	File::Temp::::unlink1 File::Temp::unlink1
0	0	0	0s	0s	File::Temp::::unlink_on_destroy File::Temp::unlink_on_destroy

Call graph for these subroutines as a Graphviz dot language file.

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