File Coverage

blib/lib/File/Temp.pm
Criterion Covered Total %
statement 418 543 76.9
branch 197 360 54.7
condition 45 102 44.1
subroutine 60 61 98.3
pod 18 21 85.7
total 738 1087 67.8


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