File Coverage

blib/lib/Fsdb/Support/NamedTmpfile.pm
Criterion Covered Total %
statement 12 30 40.0
branch 0 18 0.0
condition 0 6 0.0
subroutine 4 6 66.6
pod 3 3 100.0
total 19 63 30.1


line stmt bran cond sub pod time code
1             #!/usr/bin/perl
2              
3             #
4             # Fsdb::Support::NamedTmpfile.pm
5             # Copyright (C) 2007 by John Heidemann
6             # $Id: b84f24f02848d9777818453f2ced50674f8caa28 $
7             #
8             # This program is distributed under terms of the GNU general
9             # public license, version 2. See the file COPYING
10             # in $dblibdir for details.
11             #
12              
13              
14             package Fsdb::Support::NamedTmpfile;
15              
16             =head1 NAME
17              
18             Fsdb::Support::NamedTmpfile - dreate temporary files that can be opened
19              
20             =head1 SYNOPSIS
21              
22             use Fsdb::Support::NamedTmpfile;
23             $pathname = Fsdb::Support::NamedTmpfile::alloc($tmpdir);
24              
25             =head1 FUNCTIONS
26              
27             =head2 alloc
28              
29             $pathname = Fsdb::Support::NamedTmpfile::alloc($tmpdir);
30              
31             Create a unique filename for temporary data.
32             $TMPDIR is optional.
33             The file is automatically removed on program exit,
34             but the pathname exists for the duration of execution
35             (and can be opened).
36              
37             Note that there is a potential race condition between when we pick the file
38             and when the caller opens it, when an external program could intercede.
39             The caller therefor should open files with exclusive access.
40              
41             This routine is Perl thread-safe, and process fork safe.
42             (Files are only cleaned up by the process that creates them.)
43              
44             While this routine is basically "new", we don't call it such
45             because we do not return an object.
46              
47             =cut
48              
49             @ISA = ();
50             ($VERSION) = 1.0;
51              
52             # use threads;
53             # use threads::shared;
54              
55 1     1   9 use Carp;
  1         4  
  1         76  
56 1     1   676 use File::Temp qw(tempfile);
  1         12182  
  1         471  
57              
58             # my $named_tmpfiles_lock : shared;
59             # my %named_tmpfiles : shared;
60             my %named_tmpfiles;
61             my $tmpdir = undef;
62             my $template = undef;
63              
64             sub alloc {
65 0     0 1 0 my($tmpdir) = @_;
66              
67 0 0       0 if (!defined($tmpdir)) {
68 0 0       0 $tmpdir = (defined($ENV{'TMPDIR'}) ? $ENV{'TMPDIR'} : "/tmp") if (!defined($tmpdir));
    0          
69             };
70 0 0       0 if (!defined($template)) {
71 0         0 $template = sprintf("fsdb.%d.XXXXXX", $$);
72             };
73              
74 0 0       0 croak "tmpdir $tmpdir is not a directory\n" if (! -d $tmpdir);
75 0 0       0 croak "tmpdir $tmpdir is not writable\n" if (! -w $tmpdir);
76 0         0 my($fh, $fn) = tempfile($template, SUFFIX => "~", DIR => $tmpdir);
77 0         0 close $fh;
78             {
79             # lock($named_tmpfiles_lock);
80 0         0 $named_tmpfiles{$fn} = $$;
  0         0  
81             }
82              
83 0         0 return $fn;
84             }
85              
86             =head2 cleanup_one
87              
88             Fsdb::Support::NamedTmpfile::cleanup_one('some_filename');
89              
90             cleanup one tmpfile, forgetting about it if necessary.
91              
92              
93             =cut
94              
95             sub cleanup_one {
96 0     0 1 0 my($fn) = @_;
97 0 0       0 return if (!defined($fn));
98             # xxx: doesn't check for inclusion first
99             {
100             # lock($named_tmpfiles_lock);
101 0 0 0     0 unlink($fn) if ($named_tmpfiles{$fn} == $$ && -f $fn);
  0         0  
102 0         0 delete $named_tmpfiles{$fn};
103             }
104             }
105              
106              
107             =head2 cleanup_all
108              
109             Fsdb::Support::NamedTmpfile::cleanup_all
110              
111             Cleanup all tmpfiles
112             Not a method.
113              
114             =cut
115              
116             sub cleanup_all {
117 1     1 1 3 my(%named_tmpfiles_copy);
118             {
119             # lock($named_tmpfiles_lock);
120 1         3 %named_tmpfiles_copy = %named_tmpfiles;
  1         3  
121 1         3 %named_tmpfiles = ();
122             }
123              
124 1         7 foreach my $fn (keys %named_tmpfiles_copy) {
125 0 0 0       unlink($fn) if ($named_tmpfiles_copy{$fn} == $$ && -f $fn);
126             };
127             }
128              
129             sub END {
130             # graceful termination
131 1     1   6 cleanup_all;
132             }
133              
134              
135             1;