← Index
NYTProf Performance Profile   « line view »
For ./view
  Run on Fri Jul 31 19:05:14 2015
Reported on Fri Jul 31 19:08:09 2015

Filename/usr/share/perl5/vendor_perl/File/Temp.pm
StatementsExecuted 11120 statements in 60.8ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
1641130.3ms41.6msFile::Temp::::_gettemp File::Temp::_gettemp
1641112.0ms68.2msFile::Temp::::tempfile File::Temp::tempfile
164115.81ms5.81msFile::Temp::::_replace_XX File::Temp::_replace_XX
164114.98ms4.98msFile::Temp::::_parse_args File::Temp::_parse_args
1112.74ms4.45msFile::Temp::::BEGIN@13 File::Temp::BEGIN@13
328111.21ms1.21msFile::Temp::::safe_level File::Temp::safe_level
11133µs61µsFile::Temp::::END File::Temp::END
11132µs64µsFile::Temp::::BEGIN@11 File::Temp::BEGIN@11
11128µs28µsFile::Temp::::cleanup File::Temp::cleanup
11126µs220µsFile::Temp::::BEGIN@14 File::Temp::BEGIN@14
11119µs19µsFile::Temp::::BEGIN@8 File::Temp::BEGIN@8
11118µs39µsFile::Temp::Dir::::BEGIN@1573File::Temp::Dir::BEGIN@1573
11112µs42µsFile::Temp::::BEGIN@17 File::Temp::BEGIN@17
11110µs37µsFile::Temp::::BEGIN@10 File::Temp::BEGIN@10
11110µs29µsFile::Temp::::BEGIN@15 File::Temp::BEGIN@15
11110µs46µsFile::Temp::::BEGIN@36 File::Temp::BEGIN@36
1119µs143µsFile::Temp::::BEGIN@31 File::Temp::BEGIN@31
1119µs22µsFile::Temp::::BEGIN@107 File::Temp::BEGIN@107
1119µs22µsFile::Temp::Dir::::BEGIN@1574File::Temp::Dir::BEGIN@1574
1119µs50µsFile::Temp::Dir::::BEGIN@1575File::Temp::Dir::BEGIN@1575
1119µs48µsFile::Temp::::BEGIN@83 File::Temp::BEGIN@83
1119µs51µsFile::Temp::::BEGIN@32 File::Temp::BEGIN@32
1119µs22µsFile::Temp::::BEGIN@9 File::Temp::BEGIN@9
1119µs22µsFile::Temp::::BEGIN@137 File::Temp::BEGIN@137
1119µs19µsFile::Temp::::BEGIN@16 File::Temp::BEGIN@16
1118µs32µsFile::Temp::::BEGIN@90 File::Temp::BEGIN@90
1118µs25µsFile::Temp::::BEGIN@43 File::Temp::BEGIN@43
1118µs34µsFile::Temp::::BEGIN@86 File::Temp::BEGIN@86
1118µs32µsFile::Temp::::BEGIN@94 File::Temp::BEGIN@94
1118µs34µsFile::Temp::::BEGIN@95 File::Temp::BEGIN@95
1117µs34µsFile::Temp::::BEGIN@96 File::Temp::BEGIN@96
1114µs4µsFile::Temp::::BEGIN@12 File::Temp::BEGIN@12
1111µs1µsFile::Temp::::__ANON__[:111] File::Temp::__ANON__[:111]
1111µs1µsFile::Temp::::__ANON__[:141] File::Temp::__ANON__[:141]
111900ns900nsFile::Temp::::__ANON__[:119] File::Temp::__ANON__[:119]
0000s0sFile::Temp::::DESTROY File::Temp::DESTROY
0000s0sFile::Temp::Dir::::DESTROYFile::Temp::Dir::DESTROY
0000s0sFile::Temp::Dir::::STRINGIFYFile::Temp::Dir::STRINGIFY
0000s0sFile::Temp::Dir::::dirnameFile::Temp::Dir::dirname
0000s0sFile::Temp::Dir::::unlink_on_destroyFile::Temp::Dir::unlink_on_destroy
0000s0sFile::Temp::::NUMIFY File::Temp::NUMIFY
0000s0sFile::Temp::::STRINGIFY File::Temp::STRINGIFY
0000s0sFile::Temp::::__ANON__[:112] File::Temp::__ANON__[:112]
0000s0sFile::Temp::::__ANON__[:120] File::Temp::__ANON__[:120]
0000s0sFile::Temp::::__ANON__[:142] File::Temp::__ANON__[:142]
0000s0sFile::Temp::::_can_do_level File::Temp::_can_do_level
0000s0sFile::Temp::::_can_unlink_opened_file File::Temp::_can_unlink_opened_file
0000s0sFile::Temp::::_deferred_unlink File::Temp::_deferred_unlink
0000s0sFile::Temp::::_force_writable File::Temp::_force_writable
0000s0sFile::Temp::::_is_safe File::Temp::_is_safe
0000s0sFile::Temp::::_is_verysafe File::Temp::_is_verysafe
0000s0sFile::Temp::::cmpstat File::Temp::cmpstat
0000s0sFile::Temp::::filename File::Temp::filename
0000s0sFile::Temp::::mkdtemp File::Temp::mkdtemp
0000s0sFile::Temp::::mkstemp File::Temp::mkstemp
0000s0sFile::Temp::::mkstemps File::Temp::mkstemps
0000s0sFile::Temp::::mktemp File::Temp::mktemp
0000s0sFile::Temp::::new File::Temp::new
0000s0sFile::Temp::::newdir File::Temp::newdir
0000s0sFile::Temp::::tempdir File::Temp::tempdir
0000s0sFile::Temp::::tempnam File::Temp::tempnam
0000s0sFile::Temp::::tmpfile File::Temp::tmpfile
0000s0sFile::Temp::::tmpnam File::Temp::tmpnam
0000s0sFile::Temp::::top_system_uid File::Temp::top_system_uid
0000s0sFile::Temp::::unlink0 File::Temp::unlink0
0000s0sFile::Temp::::unlink1 File::Temp::unlink1
0000s0sFile::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
1package File::Temp;
2# ABSTRACT: return name and handle of a temporary file safely
31700nsour $VERSION = '0.2301'; # VERSION
4
5
6# 5.6.0 gives us S_IWOTH, S_IWGRP, our and auto-vivifying filehandls
7# People would like a version on 5.004 so give them what they want :-)
8252µs119µs
# spent 19µs within File::Temp::BEGIN@8 which was called: # once (19µs+0s) by Foswiki::Sandbox::BEGIN@37 at line 8
use 5.004;
# spent 19µs making 1 call to File::Temp::BEGIN@8
9232µs236µs
# spent 22µs (9+14) within File::Temp::BEGIN@9 which was called: # once (9µs+14µs) by Foswiki::Sandbox::BEGIN@37 at line 9
use strict;
# spent 22µs making 1 call to File::Temp::BEGIN@9 # spent 14µs making 1 call to strict::import
10232µs264µs
# spent 37µs (10+27) within File::Temp::BEGIN@10 which was called: # once (10µs+27µs) by Foswiki::Sandbox::BEGIN@37 at line 10
use Carp;
# spent 37µs making 1 call to File::Temp::BEGIN@10 # spent 27µs making 1 call to Exporter::import
11388µs297µs
# spent 64µs (32+33) within File::Temp::BEGIN@11 which was called: # once (32µs+33µs) by Foswiki::Sandbox::BEGIN@37 at line 11
use File::Spec 0.8;
# spent 64µs making 1 call to File::Temp::BEGIN@11 # spent 32µs making 1 call to version::vxs::_VERSION
12236µs14µs
# spent 4µs within File::Temp::BEGIN@12 which was called: # once (4µs+0s) by Foswiki::Sandbox::BEGIN@37 at line 12
use Cwd ();
# spent 4µs making 1 call to File::Temp::BEGIN@12
132116µs24.48ms
# spent 4.45ms (2.74+1.71) within File::Temp::BEGIN@13 which was called: # once (2.74ms+1.71ms) by Foswiki::Sandbox::BEGIN@37 at line 13
use File::Path qw/ rmtree /;
# spent 4.45ms making 1 call to File::Temp::BEGIN@13 # spent 24µs making 1 call to Exporter::import
14350µs3414µs
# spent 220µs (26+194) within File::Temp::BEGIN@14 which was called: # once (26µs+194µs) by Foswiki::Sandbox::BEGIN@37 at line 14
use Fcntl 1.03;
# spent 220µs making 1 call to File::Temp::BEGIN@14 # spent 182µs making 1 call to Exporter::import # spent 12µs making 1 call to version::vxs::_VERSION
15228µs247µs
# spent 29µs (10+19) within File::Temp::BEGIN@15 which was called: # once (10µs+19µs) by Foswiki::Sandbox::BEGIN@37 at line 15
use IO::Seekable; # For SEEK_*
# spent 29µs making 1 call to File::Temp::BEGIN@15 # spent 19µs making 1 call to Exporter::import
16227µs229µs
# spent 19µs (9+10) within File::Temp::BEGIN@16 which was called: # once (9µs+10µs) by Foswiki::Sandbox::BEGIN@37 at line 16
use Errno;
# spent 19µs making 1 call to File::Temp::BEGIN@16 # spent 10µs making 1 call to Exporter::import
17281µs272µs
# spent 42µs (12+30) within File::Temp::BEGIN@17 which was called: # once (12µs+30µs) by Foswiki::Sandbox::BEGIN@37 at line 17
use Scalar::Util 'refaddr';
# spent 42µs making 1 call to File::Temp::BEGIN@17 # spent 30µs making 1 call to Exporter::import
1811µsrequire VMS::Stdio if $^O eq 'VMS';
19
20# pre-emptively load Carp::Heavy. If we don't when we run out of file
21# handles and attempt to call croak() we get an error message telling
22# us that Carp::Heavy won't load rather than an error telling us we
23# have run out of file handles. We either preload croak() or we
24# switch the calls to croak from _gettemp() to use die.
25276µseval { require Carp::Heavy; };
26
27# Need the Symbol package if we are running older perl
281800nsrequire Symbol if $] < 5.006;
29
30### For the OO interface
31238µs2277µs
# spent 143µs (9+134) within File::Temp::BEGIN@31 which was called: # once (9µs+134µs) by Foswiki::Sandbox::BEGIN@37 at line 31
use base qw/ IO::Handle IO::Seekable /;
# spent 143µs making 1 call to File::Temp::BEGIN@31 # spent 134µs making 1 call to base::import
3216µs142µs
# spent 51µs (9+42) within File::Temp::BEGIN@32 which was called: # once (9µs+42µs) by Foswiki::Sandbox::BEGIN@37 at line 33
use overload '""' => "STRINGIFY", '0+' => "NUMIFY",
# spent 42µs making 1 call to overload::import
33127µs151µs fallback => 1;
# spent 51µs making 1 call to File::Temp::BEGIN@32
34
35# use 'our' on v5.6.0
36240µs282µs
# spent 46µs (10+36) within File::Temp::BEGIN@36 which was called: # once (10µs+36µs) by Foswiki::Sandbox::BEGIN@37 at line 36
use vars qw(@EXPORT_OK %EXPORT_TAGS $DEBUG $KEEP_ALL);
# spent 46µs making 1 call to File::Temp::BEGIN@36 # spent 36µs making 1 call to vars::import
37
381300ns$DEBUG = 0;
391200ns$KEEP_ALL = 0;
40
41# We are exporting functions
42
432113µs241µs
# spent 25µs (8+17) within File::Temp::BEGIN@43 which was called: # once (8µs+17µs) by Foswiki::Sandbox::BEGIN@37 at line 43
use base qw/Exporter/;
# spent 25µs making 1 call to File::Temp::BEGIN@43 # spent 17µs making 1 call to base::import
44
45# Export list - to allow fine tuning of export table
46
4713µs@EXPORT_OK = qw{
48 tempfile
49 tempdir
50 tmpnam
51 tmpfile
52 mktemp
53 mkstemp
54 mkstemps
55 mkdtemp
56 unlink0
57 cleanup
58 SEEK_SET
59 SEEK_CUR
60 SEEK_END
61 };
62
63# Groups of functions for export
64
6514µs%EXPORT_TAGS = (
66 'POSIX' => [qw/ tmpnam tmpfile /],
67 'mktemp' => [qw/ mktemp mkstemp mkstemps mkdtemp/],
68 'seekable' => [qw/ SEEK_SET SEEK_CUR SEEK_END /],
69 );
70
71# add contents of these tags to @EXPORT
7214µs121µsExporter::export_tags('POSIX','mktemp','seekable');
# spent 21µs making 1 call to Exporter::export_tags
73
74# This is a list of characters that can be used in random filenames
75
7618µsmy @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
77 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
78 0 1 2 3 4 5 6 7 8 9 _
79 /);
80
81# Maximum number of tries to make a temp file before failing
82
83231µs286µs
# spent 48µs (9+38) within File::Temp::BEGIN@83 which was called: # once (9µs+38µs) by Foswiki::Sandbox::BEGIN@37 at line 83
use constant MAX_TRIES => 1000;
# spent 48µs making 1 call to File::Temp::BEGIN@83 # spent 38µs making 1 call to constant::import
84
85# Minimum number of X characters that should be in a template
86231µs260µs
# spent 34µs (8+26) within File::Temp::BEGIN@86 which was called: # once (8µs+26µs) by Foswiki::Sandbox::BEGIN@37 at line 86
use constant MINX => 4;
# spent 34µs making 1 call to File::Temp::BEGIN@86 # spent 26µs making 1 call to constant::import
87
88# Default template when no template supplied
89
90229µs257µs
# spent 32µs (8+24) within File::Temp::BEGIN@90 which was called: # once (8µs+24µs) by Foswiki::Sandbox::BEGIN@37 at line 90
use constant TEMPXXX => 'X' x 10;
# spent 32µs making 1 call to File::Temp::BEGIN@90 # spent 24µs making 1 call to constant::import
91
92# Constants for the security level
93
94226µs256µs
# spent 32µs (8+24) within File::Temp::BEGIN@94 which was called: # once (8µs+24µs) by Foswiki::Sandbox::BEGIN@37 at line 94
use constant STANDARD => 0;
# spent 32µs making 1 call to File::Temp::BEGIN@94 # spent 24µs making 1 call to constant::import
95226µs261µs
# spent 34µs (8+27) within File::Temp::BEGIN@95 which was called: # once (8µs+27µs) by Foswiki::Sandbox::BEGIN@37 at line 95
use constant MEDIUM => 1;
# spent 34µs making 1 call to File::Temp::BEGIN@95 # spent 27µs making 1 call to constant::import
96294µs261µs
# spent 34µs (7+27) within File::Temp::BEGIN@96 which was called: # once (7µs+27µs) by Foswiki::Sandbox::BEGIN@37 at line 96
use constant HIGH => 2;
# spent 34µs making 1 call to File::Temp::BEGIN@96 # spent 27µs making 1 call to constant::import
97
98# OPENFLAGS. If we defined the flag to use with Sysopen here this gives
99# us an optimisation when many temporary files are requested
100
1011300nsmy $OPENFLAGS = O_CREAT | O_EXCL | O_RDWR;
1021200nsmy $LOCKFLAG;
103
10412µsunless ($^O eq 'MacOS') {
10511µs for my $oflag (qw/ NOFOLLOW BINARY LARGEFILE NOINHERIT /) {
10643µs my ($bit, $func) = (0, "Fcntl::O_" . $oflag);
1072171µs234µs
# spent 22µs (9+12) within File::Temp::BEGIN@107 which was called: # once (9µs+12µs) by Foswiki::Sandbox::BEGIN@37 at line 107
no strict 'refs';
# spent 22µs making 1 call to File::Temp::BEGIN@107 # spent 12µs making 1 call to strict::unimport
10844µs $OPENFLAGS |= $bit if eval {
109 # Make sure that redefined die handlers do not cause problems
110 # e.g. CGI::Carp
111514µs
# spent 1µs within File::Temp::__ANON__[/usr/share/perl5/vendor_perl/File/Temp.pm:111] which was called: # once (1µs+0s) by Fcntl::O_NOINHERIT at line 113
local $SIG{__DIE__} = sub {};
11246µs local $SIG{__WARN__} = sub {};
113460µs539µs $bit = &$func();
# spent 24µs making 1 call to Fcntl::O_NOINHERIT # spent 6µs making 1 call to Fcntl::O_NOFOLLOW # spent 4µs making 1 call to Fcntl::O_LARGEFILE # spent 4µs making 1 call to Fcntl::O_BINARY # spent 1µs making 1 call to File::Temp::__ANON__[File/Temp.pm:111]
11437µs 1;
115 };
116 }
117 # Special case O_EXLOCK
1181200ns $LOCKFLAG = eval {
11927µs
# spent 900ns within File::Temp::__ANON__[/usr/share/perl5/vendor_perl/File/Temp.pm:119] which was called: # once (900ns+0s) by Fcntl::O_EXLOCK at line 121
local $SIG{__DIE__} = sub {};
12012µs local $SIG{__WARN__} = sub {};
121114µs214µs &Fcntl::O_EXLOCK();
# spent 13µs making 1 call to Fcntl::O_EXLOCK # spent 900ns making 1 call to File::Temp::__ANON__[File/Temp.pm:119]
122 };
123}
124
125# On some systems the O_TEMPORARY flag can be used to tell the OS
126# to automatically remove the file when it is closed. This is fine
127# in most cases but not if tempfile is called with UNLINK=>0 and
128# the filename is requested -- in the case where the filename is to
129# be passed to another routine. This happens on windows. We overcome
130# this by using a second open flags variable
131
1321300nsmy $OPENTEMPFLAGS = $OPENFLAGS;
13311µsunless ($^O eq 'MacOS') {
1341700ns for my $oflag (qw/ TEMPORARY /) {
13511µs my ($bit, $func) = (0, "Fcntl::O_" . $oflag);
1361200ns local($@);
13724.76ms236µs
# spent 22µs (9+14) within File::Temp::BEGIN@137 which was called: # once (9µs+14µs) by Foswiki::Sandbox::BEGIN@37 at line 137
no strict 'refs';
# spent 22µs making 1 call to File::Temp::BEGIN@137 # spent 14µs making 1 call to strict::unimport
13811µs $OPENTEMPFLAGS |= $bit if eval {
139 # Make sure that redefined die handlers do not cause problems
140 # e.g. CGI::Carp
14126µs
# spent 1µs within File::Temp::__ANON__[/usr/share/perl5/vendor_perl/File/Temp.pm:141] which was called: # once (1µs+0s) by Fcntl::O_TEMPORARY at line 143
local $SIG{__DIE__} = sub {};
14212µs local $SIG{__WARN__} = sub {};
143115µs213µs $bit = &$func();
# spent 12µs making 1 call to Fcntl::O_TEMPORARY # spent 1µs making 1 call to File::Temp::__ANON__[File/Temp.pm:141]
144 1;
145 };
146 }
147}
148
149# Private hash tracking which files have been created by each process id via the OO interface
1501200nsmy %FILES_CREATED_BY_OBJECT;
151
152# INTERNAL ROUTINES - not to be used outside of package
153
154# Generic routine for getting a temporary filename
155# modelled on OpenBSD _gettemp() in mktemp.c
156
157# The template must contain X's that are to be replaced
158# with the random values
159
160# Arguments:
161
162# TEMPLATE - string containing the XXXXX's that is converted
163# to a random filename and opened if required
164
165# Optionally, a hash can also be supplied containing specific options
166# "open" => if true open the temp file, else just return the name
167# default is 0
168# "mkdir"=> if true, we are creating a temp directory rather than tempfile
169# default is 0
170# "suffixlen" => number of characters at end of PATH to be ignored.
171# default is 0.
172# "unlink_on_close" => indicates that, if possible, the OS should remove
173# the file as soon as it is closed. Usually indicates
174# use of the O_TEMPORARY flag to sysopen.
175# Usually irrelevant on unix
176# "use_exlock" => Indicates that O_EXLOCK should be used. Default is true.
177
178# Optionally a reference to a scalar can be passed into the function
179# On error this will be used to store the reason for the error
180# "ErrStr" => \$errstr
181
182# "open" and "mkdir" can not both be true
183# "unlink_on_close" is not used when "mkdir" is true.
184
185# The default options are equivalent to mktemp().
186
187# Returns:
188# filehandle - open file handle (if called with doopen=1, else undef)
189# temp name - name of the temp file or directory
190
191# For example:
192# ($fh, $name) = _gettemp($template, "open" => 1);
193
194# for the current version, failures are associated with
195# stored in an error string and returned to give the reason whilst debugging
196# This routine is not called by any external function
197
# spent 41.6ms (30.3+11.2) within File::Temp::_gettemp which was called 164 times, avg 253µs/call: # 164 times (30.3ms+11.2ms) by File::Temp::tempfile at line 1093, avg 253µs/call
sub _gettemp {
198
199164123µs croak 'Usage: ($fh, $name) = _gettemp($template, OPTIONS);'
200 unless scalar(@_) >= 1;
201
202 # the internal error string - expect it to be overridden
203 # Need this in case the caller decides not to supply us a value
204 # need an anonymous scalar
20516456µs my $tempErrStr;
206
207 # Default options
2081641.34ms my %options = (
209 "open" => 0,
210 "mkdir" => 0,
211 "suffixlen" => 0,
212 "unlink_on_close" => 0,
213 "use_exlock" => 1,
214 "ErrStr" => \$tempErrStr,
215 );
216
217 # Read the template
218164122µs my $template = shift;
21916470µs if (ref($template)) {
220 # Use a warning here since we have not yet merged ErrStr
221 carp "File::Temp::_gettemp: template must not be a reference";
222 return ();
223 }
224
225 # Check that the number of entries on stack are even
226164177µs if (scalar(@_) % 2 != 0) {
227 # Use a warning here since we have not yet merged ErrStr
228 carp "File::Temp::_gettemp: Must have even number of options";
229 return ();
230 }
231
232 # Read the options and merge with defaults
2331641.57ms %options = (%options, @_) if @_;
234
235 # Make sure the error string is set to undef
236164226µs ${$options{ErrStr}} = undef;
237
238 # Can not open the file and make a directory in a single call
239164133µs if ($options{"open"} && $options{"mkdir"}) {
240 ${$options{ErrStr}} = "doopen and domkdir can not both be true\n";
241 return ();
242 }
243
244 # Find the start of the end of the Xs (position of last X)
245 # Substr starts from 0
246164387µs my $start = length($template) - 1 - $options{"suffixlen"};
247
248 # Check that we have at least MINX x X (e.g. 'XXXX") at the end of the string
249 # (taking suffixlen into account). Any fewer is insecure.
250
251 # Do it using substr - no reason to use a pattern match since
252 # we know where we are looking and what we are looking for
253
254164513µs if (substr($template, $start - MINX + 1, MINX) ne 'X' x MINX) {
255 ${$options{ErrStr}} = "The template must end with at least ".
256 MINX . " 'X' characters\n";
257 return ();
258 }
259
260 # Replace all the X at the end of the substring with a
261 # random character or just all the XX at the end of a full string.
262 # Do it as an if, since the suffix adjusts which section to replace
263 # and suffixlen=0 returns nothing if used in the substr directly
264 # and generate a full path from the template
265
266164671µs1645.81ms my $path = _replace_XX($template, $options{"suffixlen"});
# spent 5.81ms making 164 calls to File::Temp::_replace_XX, avg 35µs/call
267
268
269 # Split the path into constituent parts - eventually we need to check
270 # whether the directory exists
271 # We need to know whether we are making a temp directory
272 # or a tempfile
273
274164251µs my ($volume, $directories, $file);
27516441µs my $parent; # parent directory
276164169µs if ($options{"mkdir"}) {
277 # There is no filename at the end
278 ($volume, $directories, $file) = File::Spec->splitpath( $path, 1);
279
280 # The parent is then $directories without the last directory
281 # Split the directory and put it back together again
282 my @dirs = File::Spec->splitdir($directories);
283
284 # If @dirs only has one entry (i.e. the directory template) that means
285 # we are in the current directory
286 if ($#dirs == 0) {
287 $parent = File::Spec->curdir;
288 } else {
289
290 if ($^O eq 'VMS') { # need volume to avoid relative dir spec
291 $parent = File::Spec->catdir($volume, @dirs[0..$#dirs-1]);
292 $parent = 'sys$disk:[]' if $parent eq '';
293 } else {
294
295 # Put it back together without the last one
296 $parent = File::Spec->catdir(@dirs[0..$#dirs-1]);
297
298 # ...and attach the volume (no filename)
299 $parent = File::Spec->catpath($volume, $parent, '');
300 }
301
302 }
303
304 } else {
305
306 # Get rid of the last filename (use File::Basename for this?)
3071641.51ms1642.90ms ($volume, $directories, $file) = File::Spec->splitpath( $path );
# spent 2.90ms making 164 calls to File::Spec::Unix::splitpath, avg 18µs/call
308
309 # Join up without the file part
310164921µs1641.33ms $parent = File::Spec->catpath($volume,$directories,'');
# spent 1.33ms making 164 calls to File::Spec::Unix::catpath, avg 8µs/call
311
312 # If $parent is empty replace with curdir
313164142µs $parent = File::Spec->curdir
314 unless $directories ne '';
315
316 }
317
318 # Check that the parent directories exist
319 # Do this even for the case where we are simply returning a name
320 # not a file -- no point returning a name that includes a directory
321 # that does not exist or is not writable
322
3231641.11ms unless (-e $parent) {
324 ${$options{ErrStr}} = "Parent directory ($parent) does not exist";
325 return ();
326 }
327164461µs unless (-d $parent) {
328 ${$options{ErrStr}} = "Parent directory ($parent) is not a directory";
329 return ();
330 }
331
332 # Check the stickiness of the directory and chown giveaway if required
333 # If the directory is world writable the sticky bit
334 # must be set
335
3361641.98ms3281.21ms if (File::Temp->safe_level == MEDIUM) {
# spent 1.21ms making 328 calls to File::Temp::safe_level, avg 4µs/call
337 my $safeerr;
338 unless (_is_safe($parent,\$safeerr)) {
339 ${$options{ErrStr}} = "Parent directory ($parent) is not safe ($safeerr)";
340 return ();
341 }
342 } elsif (File::Temp->safe_level == HIGH) {
343 my $safeerr;
344 unless (_is_verysafe($parent, \$safeerr)) {
345 ${$options{ErrStr}} = "Parent directory ($parent) is not safe ($safeerr)";
346 return ();
347 }
348 }
349
350
351 # Now try MAX_TRIES time to open the file
352164266µs for (my $i = 0; $i < MAX_TRIES; $i++) {
353
354 # Try to open the file if requested
355164145µs if ($options{"open"}) {
35616442µs my $fh;
357
358 # If we are running before perl5.6.0 we can not auto-vivify
359164105µs if ($] < 5.006) {
360 $fh = &Symbol::gensym;
361 }
362
363 # Try to make sure this will be marked close-on-exec
364 # XXX: Win32 doesn't respect this, nor the proper fcntl,
365 # but may have O_NOINHERIT. This may or may not be in Fcntl.
366164732µs local $^F = 2;
367
368 # Attempt to open the file
36916494µs my $open_success = undef;
370164346µs if ( $^O eq 'VMS' and $options{"unlink_on_close"} && !$KEEP_ALL) {
371 # make it auto delete on close by setting FAB$V_DLT bit
372 $fh = VMS::Stdio::vmssysopen($path, $OPENFLAGS, 0600, 'fop=dlt');
373 $open_success = $fh;
374 } else {
375164289µs my $flags = ( ($options{"unlink_on_close"} && !$KEEP_ALL) ?
376 $OPENTEMPFLAGS :
377 $OPENFLAGS );
37816456µs $flags |= $LOCKFLAG if (defined $LOCKFLAG && $options{use_exlock});
37916411.6ms $open_success = sysopen($fh, $path, $flags, 0600);
380 }
381164128µs if ( $open_success ) {
382
383 # in case of odd umask force rw
3841641.83ms chmod(0600, $path);
385
386 # Opened successfully - return file handle and name
3871642.01ms return ($fh, $path);
388
389 } else {
390
391 # Error opening file - abort with error
392 # if the reason was anything but EEXIST
393 unless ($!{EEXIST}) {
394 ${$options{ErrStr}} = "Could not create temp file $path: $!";
395 return ();
396 }
397
398 # Loop round for another try
399
400 }
401 } elsif ($options{"mkdir"}) {
402
403 # Open the temp directory
404 if (mkdir( $path, 0700)) {
405 # in case of odd umask
406 chmod(0700, $path);
407
408 return undef, $path;
409 } else {
410
411 # Abort with error if the reason for failure was anything
412 # except EEXIST
413 unless ($!{EEXIST}) {
414 ${$options{ErrStr}} = "Could not create directory $path: $!";
415 return ();
416 }
417
418 # Loop round for another try
419
420 }
421
422 } else {
423
424 # Return true if the file can not be found
425 # Directory has been checked previously
426
427 return (undef, $path) unless -e $path;
428
429 # Try again until MAX_TRIES
430
431 }
432
433 # Did not successfully open the tempfile/dir
434 # so try again with a different set of random letters
435 # No point in trying to increment unless we have only
436 # 1 X say and the randomness could come up with the same
437 # file MAX_TRIES in a row.
438
439 # Store current attempt - in principal this implies that the
440 # 3rd time around the open attempt that the first temp file
441 # name could be generated again. Probably should store each
442 # attempt and make sure that none are repeated
443
444 my $original = $path;
445 my $counter = 0; # Stop infinite loop
446 my $MAX_GUESS = 50;
447
448 do {
449
450 # Generate new name from original template
451 $path = _replace_XX($template, $options{"suffixlen"});
452
453 $counter++;
454
455 } until ($path ne $original || $counter > $MAX_GUESS);
456
457 # Check for out of control looping
458 if ($counter > $MAX_GUESS) {
459 ${$options{ErrStr}} = "Tried to get a new temp name different to the previous value $MAX_GUESS times.\nSomething wrong with template?? ($template)";
460 return ();
461 }
462
463 }
464
465 # If we get here, we have run out of tries
466 ${ $options{ErrStr} } = "Have exceeded the maximum number of attempts ("
467 . MAX_TRIES . ") to open temp file/dir";
468
469 return ();
470
471}
472
473# Internal routine to replace the XXXX... with random characters
474# This has to be done by _gettemp() every time it fails to
475# open a temp file/dir
476
477# Arguments: $template (the template with XXX),
478# $ignore (number of characters at end to ignore)
479
480# Returns: modified template
481
482
# spent 5.81ms within File::Temp::_replace_XX which was called 164 times, avg 35µs/call: # 164 times (5.81ms+0s) by File::Temp::_gettemp at line 266, avg 35µs/call
sub _replace_XX {
483
484164225µs croak 'Usage: _replace_XX($template, $ignore)'
485 unless scalar(@_) == 2;
486
487164142µs my ($path, $ignore) = @_;
488
489 # Do it as an if, since the suffix adjusts which section to replace
490 # and suffixlen=0 returns nothing if used in the substr directly
491 # Alternatively, could simply set $ignore to length($path)-1
492 # Don't want to always use substr when not required though.
493164171µs my $end = ( $] >= 5.006 ? "\\z" : "\\Z" );
494
495164209µs if ($ignore) {
496 substr($path, 0, - $ignore) =~ s/X(?=X*$end)/$CHARS[ int( rand( @CHARS ) ) ]/ge;
497 } else {
4981644.39ms $path =~ s/X(?=X*$end)/$CHARS[ int( rand( @CHARS ) ) ]/ge;
499 }
5001641.12ms return $path;
501}
502
503# Internal routine to force a temp file to be writable after
504# it is created so that we can unlink it. Windows seems to occasionally
505# force a file to be readonly when written to certain temp locations
506sub _force_writable {
507 my $file = shift;
508 chmod 0600, $file;
509}
510
511
512# internal routine to check to see if the directory is safe
513# First checks to see if the directory is not owned by the
514# current user or root. Then checks to see if anyone else
515# can write to the directory and if so, checks to see if
516# it has the sticky bit set
517
518# Will not work on systems that do not support sticky bit
519
520#Args: directory path to check
521# Optionally: reference to scalar to contain error message
522# Returns true if the path is safe and false otherwise.
523# Returns undef if can not even run stat() on the path
524
525# This routine based on version written by Tom Christiansen
526
527# Presumably, by the time we actually attempt to create the
528# file or directory in this directory, it may not be safe
529# anymore... Have to run _is_safe directly after the open.
530
531sub _is_safe {
532
533 my $path = shift;
534 my $err_ref = shift;
535
536 # Stat path
537 my @info = stat($path);
538 unless (scalar(@info)) {
539 $$err_ref = "stat(path) returned no values";
540 return 0;
541 }
542 ;
543 return 1 if $^O eq 'VMS'; # owner delete control at file level
544
545 # Check to see whether owner is neither superuser (or a system uid) nor me
546 # Use the effective uid from the $> variable
547 # UID is in [4]
548 if ($info[4] > File::Temp->top_system_uid() && $info[4] != $>) {
549
550 Carp::cluck(sprintf "uid=$info[4] topuid=%s euid=$> path='$path'",
551 File::Temp->top_system_uid());
552
553 $$err_ref = "Directory owned neither by root nor the current user"
554 if ref($err_ref);
555 return 0;
556 }
557
558 # check whether group or other can write file
559 # use 066 to detect either reading or writing
560 # use 022 to check writability
561 # Do it with S_IWOTH and S_IWGRP for portability (maybe)
562 # mode is in info[2]
563 if (($info[2] & &Fcntl::S_IWGRP) || # Is group writable?
564 ($info[2] & &Fcntl::S_IWOTH) ) { # Is world writable?
565 # Must be a directory
566 unless (-d $path) {
567 $$err_ref = "Path ($path) is not a directory"
568 if ref($err_ref);
569 return 0;
570 }
571 # Must have sticky bit set
572 unless (-k $path) {
573 $$err_ref = "Sticky bit not set on $path when dir is group|world writable"
574 if ref($err_ref);
575 return 0;
576 }
577 }
578
579 return 1;
580}
581
582# Internal routine to check whether a directory is safe
583# for temp files. Safer than _is_safe since it checks for
584# the possibility of chown giveaway and if that is a possibility
585# checks each directory in the path to see if it is safe (with _is_safe)
586
587# If _PC_CHOWN_RESTRICTED is not set, does the full test of each
588# directory anyway.
589
590# Takes optional second arg as scalar ref to error reason
591
592sub _is_verysafe {
593
594 # Need POSIX - but only want to bother if really necessary due to overhead
595 require POSIX;
596
597 my $path = shift;
598 print "_is_verysafe testing $path\n" if $DEBUG;
599 return 1 if $^O eq 'VMS'; # owner delete control at file level
600
601 my $err_ref = shift;
602
603 # Should Get the value of _PC_CHOWN_RESTRICTED if it is defined
604 # and If it is not there do the extensive test
605 local($@);
606 my $chown_restricted;
607 $chown_restricted = &POSIX::_PC_CHOWN_RESTRICTED()
608 if eval { &POSIX::_PC_CHOWN_RESTRICTED(); 1};
609
610 # If chown_resticted is set to some value we should test it
611 if (defined $chown_restricted) {
612
613 # Return if the current directory is safe
614 return _is_safe($path,$err_ref) if POSIX::sysconf( $chown_restricted );
615
616 }
617
618 # To reach this point either, the _PC_CHOWN_RESTRICTED symbol
619 # was not available or the symbol was there but chown giveaway
620 # is allowed. Either way, we now have to test the entire tree for
621 # safety.
622
623 # Convert path to an absolute directory if required
624 unless (File::Spec->file_name_is_absolute($path)) {
625 $path = File::Spec->rel2abs($path);
626 }
627
628 # Split directory into components - assume no file
629 my ($volume, $directories, undef) = File::Spec->splitpath( $path, 1);
630
631 # Slightly less efficient than having a function in File::Spec
632 # to chop off the end of a directory or even a function that
633 # can handle ../ in a directory tree
634 # Sometimes splitdir() returns a blank at the end
635 # so we will probably check the bottom directory twice in some cases
636 my @dirs = File::Spec->splitdir($directories);
637
638 # Concatenate one less directory each time around
639 foreach my $pos (0.. $#dirs) {
640 # Get a directory name
641 my $dir = File::Spec->catpath($volume,
642 File::Spec->catdir(@dirs[0.. $#dirs - $pos]),
643 ''
644 );
645
646 print "TESTING DIR $dir\n" if $DEBUG;
647
648 # Check the directory
649 return 0 unless _is_safe($dir,$err_ref);
650
651 }
652
653 return 1;
654}
655
- -
658# internal routine to determine whether unlink works on this
659# platform for files that are currently open.
660# Returns true if we can, false otherwise.
661
662# Currently WinNT, OS/2 and VMS can not unlink an opened file
663# On VMS this is because the O_EXCL flag is used to open the
664# temporary file. Currently I do not know enough about the issues
665# on VMS to decide whether O_EXCL is a requirement.
666
667sub _can_unlink_opened_file {
668
669 if (grep { $^O eq $_ } qw/MSWin32 os2 VMS dos MacOS haiku/) {
670 return 0;
671 } else {
672 return 1;
673 }
674
675}
676
677# internal routine to decide which security levels are allowed
678# see safe_level() for more information on this
679
680# Controls whether the supplied security level is allowed
681
682# $cando = _can_do_level( $level )
683
684sub _can_do_level {
685
686 # Get security level
687 my $level = shift;
688
689 # Always have to be able to do STANDARD
690 return 1 if $level == STANDARD;
691
692 # Currently, the systems that can do HIGH or MEDIUM are identical
693 if ( $^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'cygwin' || $^O eq 'dos' || $^O eq 'MacOS' || $^O eq 'mpeix') {
694 return 0;
695 } else {
696 return 1;
697 }
698
699}
700
701# This routine sets up a deferred unlinking of a specified
702# filename and filehandle. It is used in the following cases:
703# - Called by unlink0 if an opened file can not be unlinked
704# - Called by tempfile() if files are to be removed on shutdown
705# - Called by tempdir() if directories are to be removed on shutdown
706
707# Arguments:
708# _deferred_unlink( $fh, $fname, $isdir );
709#
710# - filehandle (so that it can be explicitly closed if open
711# - filename (the thing we want to remove)
712# - isdir (flag to indicate that we are being given a directory)
713# [and hence no filehandle]
714
715# Status is not referred to since all the magic is done with an END block
716
717{
718 # Will set up two lexical variables to contain all the files to be
719 # removed. One array for files, another for directories They will
720 # only exist in this block.
721
722 # This means we only have to set up a single END block to remove
723 # all files.
724
725 # in order to prevent child processes inadvertently deleting the parent
726 # temp files we use a hash to store the temp files and directories
727 # created by a particular process id.
728
729 # %files_to_unlink contains values that are references to an array of
730 # array references containing the filehandle and filename associated with
731 # the temp file.
7322800ns my (%files_to_unlink, %dirs_to_unlink);
733
734 # Set up an end block to use these arrays
735
# spent 61µs (33+28) within File::Temp::END which was called: # once (33µs+28µs) by main::RUNTIME at line 0 of view
END {
736120µs local($., $@, $!, $^E, $?);
737110µs128µs cleanup(at_exit => 1);
# spent 28µs making 1 call to File::Temp::cleanup
738 }
739
740 # Cleanup function. Always triggered on END (with at_exit => 1) but
741 # can be invoked manually.
742
# spent 28µs within File::Temp::cleanup which was called: # once (28µs+0s) by File::Temp::END at line 737
sub cleanup {
74313µs my %h = @_;
74412µs my $at_exit = delete $h{at_exit};
7451400ns $at_exit = 0 if not defined $at_exit;
74637µs { my @k = sort keys %h; die "unrecognized parameters: @k" if @k }
747
74817µs if (!$KEEP_ALL) {
749 # Files
750 my @files = (exists $files_to_unlink{$$} ?
75114µs @{ $files_to_unlink{$$} } : () );
75212µs foreach my $file (@files) {
753 # close the filehandle without checking its state
754 # in order to make real sure that this is closed
755 # if its already closed then I dont care about the answer
756 # probably a better way to do this
757 close($file->[0]); # file handle is [0]
758
759 if (-f $file->[1]) { # file name is [1]
760 _force_writable( $file->[1] ); # for windows
761 unlink $file->[1] or warn "Error removing ".$file->[1];
762 }
763 }
764 # Dirs
765 my @dirs = (exists $dirs_to_unlink{$$} ?
76611µs @{ $dirs_to_unlink{$$} } : () );
7671300ns my ($cwd, $cwd_to_remove);
76811µs foreach my $dir (@dirs) {
769 if (-d $dir) {
770 # Some versions of rmtree will abort if you attempt to remove
771 # the directory you are sitting in. For automatic cleanup
772 # at program exit, we avoid this by chdir()ing out of the way
773 # first. If not at program exit, it's best not to mess with the
774 # current directory, so just let it fail with a warning.
775 if ($at_exit) {
776 $cwd = Cwd::abs_path(File::Spec->curdir) if not defined $cwd;
777 my $abs = Cwd::abs_path($dir);
778 if ($abs eq $cwd) {
779 $cwd_to_remove = $dir;
780 next;
781 }
782 }
783 eval { rmtree($dir, $DEBUG, 0); };
784 warn $@ if ($@ && $^W);
785 }
786 }
787
7881400ns if (defined $cwd_to_remove) {
789 # We do need to clean up the current directory, and everything
790 # else is done, so get out of there and remove it.
791 chdir $cwd_to_remove or die "cannot chdir to $cwd_to_remove: $!";
792 my $updir = File::Spec->updir;
793 chdir $updir or die "cannot chdir to $updir: $!";
794 eval { rmtree($cwd_to_remove, $DEBUG, 0); };
795 warn $@ if ($@ && $^W);
796 }
797
798 # clear the arrays
7991900ns @{ $files_to_unlink{$$} } = ()
800 if exists $files_to_unlink{$$};
8011700ns @{ $dirs_to_unlink{$$} } = ()
802 if exists $dirs_to_unlink{$$};
803 }
804 }
805
806
807 # This is the sub called to register a file for deferred unlinking
808 # This could simply store the input parameters and defer everything
809 # until the END block. For now we do a bit of checking at this
810 # point in order to make sure that (1) we have a file/dir to delete
811 # and (2) we have been called with the correct arguments.
812 sub _deferred_unlink {
813
814 croak 'Usage: _deferred_unlink($fh, $fname, $isdir)'
815 unless scalar(@_) == 3;
816
817 my ($fh, $fname, $isdir) = @_;
818
819 warn "Setting up deferred removal of $fname\n"
820 if $DEBUG;
821
822 # make sure we save the absolute path for later cleanup
823 # OK to untaint because we only ever use this internally
824 # as a file path, never interpolating into the shell
825 $fname = Cwd::abs_path($fname);
826 ($fname) = $fname =~ /^(.*)$/;
827
828 # If we have a directory, check that it is a directory
829 if ($isdir) {
830
831 if (-d $fname) {
832
833 # Directory exists so store it
834 # first on VMS turn []foo into [.foo] for rmtree
835 $fname = VMS::Filespec::vmspath($fname) if $^O eq 'VMS';
836 $dirs_to_unlink{$$} = []
837 unless exists $dirs_to_unlink{$$};
838 push (@{ $dirs_to_unlink{$$} }, $fname);
839
840 } else {
841 carp "Request to remove directory $fname could not be completed since it does not exist!\n" if $^W;
842 }
843
844 } else {
845
846 if (-f $fname) {
847
848 # file exists so store handle and name for later removal
849 $files_to_unlink{$$} = []
850 unless exists $files_to_unlink{$$};
851 push(@{ $files_to_unlink{$$} }, [$fh, $fname]);
852
853 } else {
854 carp "Request to remove file $fname could not be completed since it is not there!\n" if $^W;
855 }
856
857 }
858
859 }
860
861
862}
863
864# normalize argument keys to upper case and do consistent handling
865# of leading template vs TEMPLATE
866
# spent 4.98ms within File::Temp::_parse_args which was called 164 times, avg 30µs/call: # 164 times (4.98ms+0s) by File::Temp::tempfile at line 1022, avg 30µs/call
sub _parse_args {
867164462µs my $leading_template = (scalar(@_) % 2 == 1 ? shift(@_) : '' );
868164457µs my %args = @_;
8691642.18ms %args = map { uc($_), $args{$_} } keys %args;
870
871 # template (store it in an array so that it will
872 # disappear from the arg list of tempfile)
873164627µs my @template = (
874 exists $args{TEMPLATE} ? $args{TEMPLATE} :
875 $leading_template ? $leading_template : ()
876 );
877164177µs delete $args{TEMPLATE};
878
8791641.44ms return( \@template, \%args );
880}
881
882
883sub new {
884 my $proto = shift;
885 my $class = ref($proto) || $proto;
886
887 my ($maybe_template, $args) = _parse_args(@_);
888
889 # see if they are unlinking (defaulting to yes)
890 my $unlink = (exists $args->{UNLINK} ? $args->{UNLINK} : 1 );
891 delete $args->{UNLINK};
892
893 # Protect OPEN
894 delete $args->{OPEN};
895
896 # Open the file and retain file handle and file name
897 my ($fh, $path) = tempfile( @$maybe_template, %$args );
898
899 print "Tmp: $fh - $path\n" if $DEBUG;
900
901 # Store the filename in the scalar slot
902 ${*$fh} = $path;
903
904 # Cache the filename by pid so that the destructor can decide whether to remove it
905 $FILES_CREATED_BY_OBJECT{$$}{$path} = 1;
906
907 # Store unlink information in hash slot (plus other constructor info)
908 %{*$fh} = %$args;
909
910 # create the object
911 bless $fh, $class;
912
913 # final method-based configuration
914 $fh->unlink_on_destroy( $unlink );
915
916 return $fh;
917}
918
919
920sub newdir {
921 my $self = shift;
922
923 my ($maybe_template, $args) = _parse_args(@_);
924
925 # handle CLEANUP without passing CLEANUP to tempdir
926 my $cleanup = (exists $args->{CLEANUP} ? $args->{CLEANUP} : 1 );
927 delete $args->{CLEANUP};
928
929 my $tempdir = tempdir( @$maybe_template, %$args);
930
931 # get a safe absolute path for cleanup, just like
932 # happens in _deferred_unlink
933 my $real_dir = Cwd::abs_path( $tempdir );
934 ($real_dir) = $real_dir =~ /^(.*)$/;
935
936 return bless { DIRNAME => $tempdir,
937 REALNAME => $real_dir,
938 CLEANUP => $cleanup,
939 LAUNCHPID => $$,
940 }, "File::Temp::Dir";
941}
942
943
944sub filename {
945 my $self = shift;
946 return ${*$self};
947}
948
949sub STRINGIFY {
950 my $self = shift;
951 return $self->filename;
952}
953
954# For reference, can't use '0+'=>\&Scalar::Util::refaddr directly because
955# refaddr() demands one parameter only, whereas overload.pm calls with three
956# even for unary operations like '0+'.
957sub NUMIFY {
958 return refaddr($_[0]);
959}
960
961
962sub unlink_on_destroy {
963 my $self = shift;
964 if (@_) {
965 ${*$self}{UNLINK} = shift;
966 }
967 return ${*$self}{UNLINK};
968}
969
970
971sub DESTROY {
972 local($., $@, $!, $^E, $?);
973 my $self = shift;
974
975 # Make sure we always remove the file from the global hash
976 # on destruction. This prevents the hash from growing uncontrollably
977 # and post-destruction there is no reason to know about the file.
978 my $file = $self->filename;
979 my $was_created_by_proc;
980 if (exists $FILES_CREATED_BY_OBJECT{$$}{$file}) {
981 $was_created_by_proc = 1;
982 delete $FILES_CREATED_BY_OBJECT{$$}{$file};
983 }
984
985 if (${*$self}{UNLINK} && !$KEEP_ALL) {
986 print "# ---------> Unlinking $self\n" if $DEBUG;
987
988 # only delete if this process created it
989 return unless $was_created_by_proc;
990
991 # The unlink1 may fail if the file has been closed
992 # by the caller. This leaves us with the decision
993 # of whether to refuse to remove the file or simply
994 # do an unlink without test. Seems to be silly
995 # to do this when we are trying to be careful
996 # about security
997 _force_writable( $file ); # for windows
998 unlink1( $self, $file )
999 or unlink($file);
1000 }
1001}
1002
1003
1004
# spent 68.2ms (12.0+56.2) within File::Temp::tempfile which was called 164 times, avg 416µs/call: # 164 times (12.0ms+56.2ms) by Foswiki::Sandbox::sysCommand at line 506 of /var/www/foswiki11/lib/Foswiki/Sandbox.pm, avg 416µs/call
sub tempfile {
1005164263µs if ( @_ && $_[0] eq 'File::Temp' ) {
1006 croak "'tempfile' can't be called as a method";
1007 }
1008 # Can not check for argument count since we can have any
1009 # number of args
1010
1011 # Default options
10121641.72ms my %options = (
1013 "DIR" => undef, # Directory prefix
1014 "SUFFIX" => '', # Template suffix
1015 "UNLINK" => 0, # Do not unlink file on exit
1016 "OPEN" => 1, # Open file
1017 "TMPDIR" => 0, # Place tempfile in tempdir if template specified
1018 "EXLOCK" => 1, # Open file with O_EXLOCK
1019 );
1020
1021 # Check to see whether we have an odd or even number of arguments
1022164925µs1644.98ms my ($maybe_template, $args) = _parse_args(@_);
# spent 4.98ms making 164 calls to File::Temp::_parse_args, avg 30µs/call
1023164239µs my $template = @$maybe_template ? $maybe_template->[0] : undef;
1024
1025 # Read the options and merge with defaults
10261641.38ms %options = (%options, %$args);
1027
1028 # First decision is whether or not to open the file
1029164132µs if (! $options{"OPEN"}) {
1030
1031 warn "tempfile(): temporary filename requested but not opened.\nPossibly unsafe, consider using tempfile() with OPEN set to true\n"
1032 if $^W;
1033
1034 }
1035
1036164802µs if ($options{"DIR"} and $^O eq 'VMS') {
1037
1038 # on VMS turn []foo into [.foo] for concatenation
1039 $options{"DIR"} = VMS::Filespec::vmspath($options{"DIR"});
1040 }
1041
1042 # Construct the template
1043
1044 # Have a choice of trying to work around the mkstemp/mktemp/tmpnam etc
1045 # functions or simply constructing a template and using _gettemp()
1046 # explicitly. Go for the latter
1047
1048 # First generate a template if not defined and prefix the directory
1049 # If no template must prefix the temp directory
1050164160µs if (defined $template) {
1051 # End up with current directory if neither DIR not TMPDIR are set
10521642.19ms1649.68ms if ($options{"DIR"}) {
# spent 9.68ms making 164 calls to File::Spec::Unix::catfile, avg 59µs/call
1053
1054 $template = File::Spec->catfile($options{"DIR"}, $template);
1055
1056 } elsif ($options{TMPDIR}) {
1057
1058 $template = File::Spec->catfile(File::Spec->tmpdir, $template );
1059
1060 }
1061
1062 } else {
1063
1064 if ($options{"DIR"}) {
1065
1066 $template = File::Spec->catfile($options{"DIR"}, TEMPXXX);
1067
1068 } else {
1069
1070 $template = File::Spec->catfile(File::Spec->tmpdir, TEMPXXX);
1071
1072 }
1073
1074 }
1075
1076 # Now add a suffix
1077164145µs $template .= $options{"SUFFIX"};
1078
1079 # Determine whether we should tell _gettemp to unlink the file
1080 # On unix this is irrelevant and can be worked out after the file is
1081 # opened (simply by unlinking the open filehandle). On Windows or VMS
1082 # we have to indicate temporary-ness when we open the file. In general
1083 # we only want a true temporary file if we are returning just the
1084 # filehandle - if the user wants the filename they probably do not
1085 # want the file to disappear as soon as they close it (which may be
1086 # important if they want a child process to use the file)
1087 # For this reason, tie unlink_on_close to the return context regardless
1088 # of OS.
1089164143µs my $unlink_on_close = ( wantarray ? 0 : 1);
1090
1091 # Create the file
109216476µs my ($fh, $path, $errstr);
10931641.92ms16441.6ms croak "Error in tempfile() using template $template: $errstr"
# spent 41.6ms making 164 calls to File::Temp::_gettemp, avg 253µs/call
1094 unless (($fh, $path) = _gettemp($template,
1095 "open" => $options{'OPEN'},
1096 "mkdir"=> 0 ,
1097 "unlink_on_close" => $unlink_on_close,
1098 "suffixlen" => length($options{'SUFFIX'}),
1099 "ErrStr" => \$errstr,
1100 "use_exlock" => $options{EXLOCK},
1101 ) );
1102
1103 # Set up an exit handler that can do whatever is right for the
1104 # system. This removes files at exit when requested explicitly or when
1105 # system is asked to unlink_on_close but is unable to do so because
1106 # of OS limitations.
1107 # The latter should be achieved by using a tied filehandle.
1108 # Do not check return status since this is all done with END blocks.
1109164167µs _deferred_unlink($fh, $path, 0) if $options{"UNLINK"};
1110
1111 # Return
11121641.26ms if (wantarray()) {
1113
1114 if ($options{'OPEN'}) {
1115 return ($fh, $path);
1116 } else {
1117 return (undef, $path);
1118 }
1119
1120 } else {
1121
1122 # Unlink the file. It is up to unlink0 to decide what to do with
1123 # this (whether to unlink now or to defer until later)
1124 unlink0($fh, $path) or croak "Error unlinking file $path using unlink0";
1125
1126 # Return just the filehandle.
1127 return $fh;
1128 }
1129
1130
1131}
1132
1133
1134# '
1135
1136sub tempdir {
1137 if ( @_ && $_[0] eq 'File::Temp' ) {
1138 croak "'tempdir' can't be called as a method";
1139 }
1140
1141 # Can not check for argument count since we can have any
1142 # number of args
1143
1144 # Default options
1145 my %options = (
1146 "CLEANUP" => 0, # Remove directory on exit
1147 "DIR" => '', # Root directory
1148 "TMPDIR" => 0, # Use tempdir with template
1149 );
1150
1151 # Check to see whether we have an odd or even number of arguments
1152 my ($maybe_template, $args) = _parse_args(@_);
1153 my $template = @$maybe_template ? $maybe_template->[0] : undef;
1154
1155 # Read the options and merge with defaults
1156 %options = (%options, %$args);
1157
1158 # Modify or generate the template
1159
1160 # Deal with the DIR and TMPDIR options
1161 if (defined $template) {
1162
1163 # Need to strip directory path if using DIR or TMPDIR
1164 if ($options{'TMPDIR'} || $options{'DIR'}) {
1165
1166 # Strip parent directory from the filename
1167 #
1168 # There is no filename at the end
1169 $template = VMS::Filespec::vmspath($template) if $^O eq 'VMS';
1170 my ($volume, $directories, undef) = File::Spec->splitpath( $template, 1);
1171
1172 # Last directory is then our template
1173 $template = (File::Spec->splitdir($directories))[-1];
1174
1175 # Prepend the supplied directory or temp dir
1176 if ($options{"DIR"}) {
1177
1178 $template = File::Spec->catdir($options{"DIR"}, $template);
1179
1180 } elsif ($options{TMPDIR}) {
1181
1182 # Prepend tmpdir
1183 $template = File::Spec->catdir(File::Spec->tmpdir, $template);
1184
1185 }
1186
1187 }
1188
1189 } else {
1190
1191 if ($options{"DIR"}) {
1192
1193 $template = File::Spec->catdir($options{"DIR"}, TEMPXXX);
1194
1195 } else {
1196
1197 $template = File::Spec->catdir(File::Spec->tmpdir, TEMPXXX);
1198
1199 }
1200
1201 }
1202
1203 # Create the directory
1204 my $tempdir;
1205 my $suffixlen = 0;
1206 if ($^O eq 'VMS') { # dir names can end in delimiters
1207 $template =~ m/([\.\]:>]+)$/;
1208 $suffixlen = length($1);
1209 }
1210 if ( ($^O eq 'MacOS') && (substr($template, -1) eq ':') ) {
1211 # dir name has a trailing ':'
1212 ++$suffixlen;
1213 }
1214
1215 my $errstr;
1216 croak "Error in tempdir() using $template: $errstr"
1217 unless ((undef, $tempdir) = _gettemp($template,
1218 "open" => 0,
1219 "mkdir"=> 1 ,
1220 "suffixlen" => $suffixlen,
1221 "ErrStr" => \$errstr,
1222 ) );
1223
1224 # Install exit handler; must be dynamic to get lexical
1225 if ( $options{'CLEANUP'} && -d $tempdir) {
1226 _deferred_unlink(undef, $tempdir, 1);
1227 }
1228
1229 # Return the dir name
1230 return $tempdir;
1231
1232}
1233
- -
1237sub mkstemp {
1238
1239 croak "Usage: mkstemp(template)"
1240 if scalar(@_) != 1;
1241
1242 my $template = shift;
1243
1244 my ($fh, $path, $errstr);
1245 croak "Error in mkstemp using $template: $errstr"
1246 unless (($fh, $path) = _gettemp($template,
1247 "open" => 1,
1248 "mkdir"=> 0 ,
1249 "suffixlen" => 0,
1250 "ErrStr" => \$errstr,
1251 ) );
1252
1253 if (wantarray()) {
1254 return ($fh, $path);
1255 } else {
1256 return $fh;
1257 }
1258
1259}
1260
- -
1263sub mkstemps {
1264
1265 croak "Usage: mkstemps(template, suffix)"
1266 if scalar(@_) != 2;
1267
1268
1269 my $template = shift;
1270 my $suffix = shift;
1271
1272 $template .= $suffix;
1273
1274 my ($fh, $path, $errstr);
1275 croak "Error in mkstemps using $template: $errstr"
1276 unless (($fh, $path) = _gettemp($template,
1277 "open" => 1,
1278 "mkdir"=> 0 ,
1279 "suffixlen" => length($suffix),
1280 "ErrStr" => \$errstr,
1281 ) );
1282
1283 if (wantarray()) {
1284 return ($fh, $path);
1285 } else {
1286 return $fh;
1287 }
1288
1289}
1290
1291
1292#' # for emacs
1293
1294sub mkdtemp {
1295
1296 croak "Usage: mkdtemp(template)"
1297 if scalar(@_) != 1;
1298
1299 my $template = shift;
1300 my $suffixlen = 0;
1301 if ($^O eq 'VMS') { # dir names can end in delimiters
1302 $template =~ m/([\.\]:>]+)$/;
1303 $suffixlen = length($1);
1304 }
1305 if ( ($^O eq 'MacOS') && (substr($template, -1) eq ':') ) {
1306 # dir name has a trailing ':'
1307 ++$suffixlen;
1308 }
1309 my ($junk, $tmpdir, $errstr);
1310 croak "Error creating temp directory from template $template\: $errstr"
1311 unless (($junk, $tmpdir) = _gettemp($template,
1312 "open" => 0,
1313 "mkdir"=> 1 ,
1314 "suffixlen" => $suffixlen,
1315 "ErrStr" => \$errstr,
1316 ) );
1317
1318 return $tmpdir;
1319
1320}
1321
1322
1323sub mktemp {
1324
1325 croak "Usage: mktemp(template)"
1326 if scalar(@_) != 1;
1327
1328 my $template = shift;
1329
1330 my ($tmpname, $junk, $errstr);
1331 croak "Error getting name to temp file from template $template: $errstr"
1332 unless (($junk, $tmpname) = _gettemp($template,
1333 "open" => 0,
1334 "mkdir"=> 0 ,
1335 "suffixlen" => 0,
1336 "ErrStr" => \$errstr,
1337 ) );
1338
1339 return $tmpname;
1340}
1341
1342
1343sub tmpnam {
1344
1345 # Retrieve the temporary directory name
1346 my $tmpdir = File::Spec->tmpdir;
1347
1348 croak "Error temporary directory is not writable"
1349 if $tmpdir eq '';
1350
1351 # Use a ten character template and append to tmpdir
1352 my $template = File::Spec->catfile($tmpdir, TEMPXXX);
1353
1354 if (wantarray() ) {
1355 return mkstemp($template);
1356 } else {
1357 return mktemp($template);
1358 }
1359
1360}
1361
1362
1363sub tmpfile {
1364
1365 # Simply call tmpnam() in a list context
1366 my ($fh, $file) = tmpnam();
1367
1368 # Make sure file is removed when filehandle is closed
1369 # This will fail on NFS
1370 unlink0($fh, $file)
1371 or return undef;
1372
1373 return $fh;
1374
1375}
1376
1377
1378sub tempnam {
1379
1380 croak 'Usage tempnam($dir, $prefix)' unless scalar(@_) == 2;
1381
1382 my ($dir, $prefix) = @_;
1383
1384 # Add a string to the prefix
1385 $prefix .= 'XXXXXXXX';
1386
1387 # Concatenate the directory to the file
1388 my $template = File::Spec->catfile($dir, $prefix);
1389
1390 return mktemp($template);
1391
1392}
1393
1394
1395sub unlink0 {
1396
1397 croak 'Usage: unlink0(filehandle, filename)'
1398 unless scalar(@_) == 2;
1399
1400 # Read args
1401 my ($fh, $path) = @_;
1402
1403 cmpstat($fh, $path) or return 0;
1404
1405 # attempt remove the file (does not work on some platforms)
1406 if (_can_unlink_opened_file()) {
1407
1408 # return early (Without unlink) if we have been instructed to retain files.
1409 return 1 if $KEEP_ALL;
1410
1411 # XXX: do *not* call this on a directory; possible race
1412 # resulting in recursive removal
1413 croak "unlink0: $path has become a directory!" if -d $path;
1414 unlink($path) or return 0;
1415
1416 # Stat the filehandle
1417 my @fh = stat $fh;
1418
1419 print "Link count = $fh[3] \n" if $DEBUG;
1420
1421 # Make sure that the link count is zero
1422 # - Cygwin provides deferred unlinking, however,
1423 # on Win9x the link count remains 1
1424 # On NFS the link count may still be 1 but we can't know that
1425 # we are on NFS. Since we can't be sure, we'll defer it
1426
1427 return 1 if $fh[3] == 0 || $^O eq 'cygwin';
1428 }
1429 # fall-through if we can't unlink now
1430 _deferred_unlink($fh, $path, 0);
1431 return 1;
1432}
1433
1434
1435sub cmpstat {
1436
1437 croak 'Usage: cmpstat(filehandle, filename)'
1438 unless scalar(@_) == 2;
1439
1440 # Read args
1441 my ($fh, $path) = @_;
1442
1443 warn "Comparing stat\n"
1444 if $DEBUG;
1445
1446 # Stat the filehandle - which may be closed if someone has manually
1447 # closed the file. Can not turn off warnings without using $^W
1448 # unless we upgrade to 5.006 minimum requirement
1449 my @fh;
1450 {
1451 local ($^W) = 0;
1452 @fh = stat $fh;
1453 }
1454 return unless @fh;
1455
1456 if ($fh[3] > 1 && $^W) {
1457 carp "unlink0: fstat found too many links; SB=@fh" if $^W;
1458 }
1459
1460 # Stat the path
1461 my @path = stat $path;
1462
1463 unless (@path) {
1464 carp "unlink0: $path is gone already" if $^W;
1465 return;
1466 }
1467
1468 # this is no longer a file, but may be a directory, or worse
1469 unless (-f $path) {
1470 confess "panic: $path is no longer a file: SB=@fh";
1471 }
1472
1473 # Do comparison of each member of the array
1474 # On WinNT dev and rdev seem to be different
1475 # depending on whether it is a file or a handle.
1476 # Cannot simply compare all members of the stat return
1477 # Select the ones we can use
1478 my @okstat = (0..$#fh); # Use all by default
1479 if ($^O eq 'MSWin32') {
1480 @okstat = (1,2,3,4,5,7,8,9,10);
1481 } elsif ($^O eq 'os2') {
1482 @okstat = (0, 2..$#fh);
1483 } elsif ($^O eq 'VMS') { # device and file ID are sufficient
1484 @okstat = (0, 1);
1485 } elsif ($^O eq 'dos') {
1486 @okstat = (0,2..7,11..$#fh);
1487 } elsif ($^O eq 'mpeix') {
1488 @okstat = (0..4,8..10);
1489 }
1490
1491 # Now compare each entry explicitly by number
1492 for (@okstat) {
1493 print "Comparing: $_ : $fh[$_] and $path[$_]\n" if $DEBUG;
1494 # Use eq rather than == since rdev, blksize, and blocks (6, 11,
1495 # and 12) will be '' on platforms that do not support them. This
1496 # is fine since we are only comparing integers.
1497 unless ($fh[$_] eq $path[$_]) {
1498 warn "Did not match $_ element of stat\n" if $DEBUG;
1499 return 0;
1500 }
1501 }
1502
1503 return 1;
1504}
1505
1506
1507sub unlink1 {
1508 croak 'Usage: unlink1(filehandle, filename)'
1509 unless scalar(@_) == 2;
1510
1511 # Read args
1512 my ($fh, $path) = @_;
1513
1514 cmpstat($fh, $path) or return 0;
1515
1516 # Close the file
1517 close( $fh ) or return 0;
1518
1519 # Make sure the file is writable (for windows)
1520 _force_writable( $path );
1521
1522 # return early (without unlink) if we have been instructed to retain files.
1523 return 1 if $KEEP_ALL;
1524
1525 # remove the file
1526 return unlink($path);
1527}
1528
1529
1530{
1531 # protect from using the variable itself
15322600ns my $LEVEL = STANDARD;
1533
# spent 1.21ms within File::Temp::safe_level which was called 328 times, avg 4µs/call: # 328 times (1.21ms+0s) by File::Temp::_gettemp at line 336, avg 4µs/call
sub safe_level {
1534328173µs my $self = shift;
1535328133µs if (@_) {
1536 my $level = shift;
1537 if (($level != STANDARD) && ($level != MEDIUM) && ($level != HIGH)) {
1538 carp "safe_level: Specified level ($level) not STANDARD, MEDIUM or HIGH - ignoring\n" if $^W;
1539 } else {
1540 # Don't allow this on perl 5.005 or earlier
1541 if ($] < 5.006 && $level != STANDARD) {
1542 # Cant do MEDIUM or HIGH checks
1543 croak "Currently requires perl 5.006 or newer to do the safe checks";
1544 }
1545 # Check that we are allowed to change level
1546 # Silently ignore if we can not.
1547 $LEVEL = $level if _can_do_level($level);
1548 }
1549 }
15503281.13ms return $LEVEL;
1551 }
1552}
1553
1554
1555{
15562400ns my $TopSystemUID = 10;
15571600ns $TopSystemUID = 197108 if $^O eq 'interix'; # "Administrator"
1558 sub top_system_uid {
1559 my $self = shift;
1560 if (@_) {
1561 my $newuid = shift;
1562 croak "top_system_uid: UIDs should be numeric"
1563 unless $newuid =~ /^\d+$/s;
1564 $TopSystemUID = $newuid;
1565 }
1566 return $TopSystemUID;
1567 }
1568}
1569
1570
1571package File::Temp::Dir;
1572
1573238µs260µs
# spent 39µs (18+21) within File::Temp::Dir::BEGIN@1573 which was called: # once (18µs+21µs) by Foswiki::Sandbox::BEGIN@37 at line 1573
use File::Path qw/ rmtree /;
# spent 39µs making 1 call to File::Temp::Dir::BEGIN@1573 # spent 21µs making 1 call to Exporter::import
1574242µs235µs
# spent 22µs (9+13) within File::Temp::Dir::BEGIN@1574 which was called: # once (9µs+13µs) by Foswiki::Sandbox::BEGIN@37 at line 1574
use strict;
# spent 22µs making 1 call to File::Temp::Dir::BEGIN@1574 # spent 13µs making 1 call to strict::import
157516µs141µs
# spent 50µs (9+41) within File::Temp::Dir::BEGIN@1575 which was called: # once (9µs+41µs) by Foswiki::Sandbox::BEGIN@37 at line 1577
use overload '""' => "STRINGIFY",
# spent 41µs making 1 call to overload::import
1576 '0+' => \&File::Temp::NUMIFY,
15771263µs150µs fallback => 1;
# spent 50µs making 1 call to File::Temp::Dir::BEGIN@1575
1578
1579# private class specifically to support tempdir objects
1580# created by File::Temp->newdir
1581
1582# ostensibly the same method interface as File::Temp but without
1583# inheriting all the IO::Seekable methods and other cruft
1584
1585# Read-only - returns the name of the temp directory
1586
1587sub dirname {
1588 my $self = shift;
1589 return $self->{DIRNAME};
1590}
1591
1592sub STRINGIFY {
1593 my $self = shift;
1594 return $self->dirname;
1595}
1596
1597sub unlink_on_destroy {
1598 my $self = shift;
1599 if (@_) {
1600 $self->{CLEANUP} = shift;
1601 }
1602 return $self->{CLEANUP};
1603}
1604
1605sub DESTROY {
1606 my $self = shift;
1607 local($., $@, $!, $^E, $?);
1608 if ($self->unlink_on_destroy &&
1609 $$ == $self->{LAUNCHPID} && !$File::Temp::KEEP_ALL) {
1610 if (-d $self->{REALNAME}) {
1611 # Some versions of rmtree will abort if you attempt to remove
1612 # the directory you are sitting in. We protect that and turn it
1613 # into a warning. We do this because this occurs during object
1614 # destruction and so can not be caught by the user.
1615 eval { rmtree($self->{REALNAME}, $File::Temp::DEBUG, 0); };
1616 warn $@ if ($@ && $^W);
1617 }
1618 }
1619}
1620
1621127µs1;
1622
1623__END__