← Index
NYTProf Performance Profile   « line view »
For /Users/timbo/perl5/perlbrew/perls/perl-5.18.2/bin/perlcritic
  Run on Sat Mar 19 22:12:22 2016
Reported on Sat Mar 19 22:14:12 2016

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