File Coverage

blib/lib/FFI/Temp.pm
Criterion Covered Total %
statement 36 36 100.0
branch 8 14 57.1
condition 1 2 50.0
subroutine 10 10 100.0
pod 0 2 0.0
total 55 64 85.9


line stmt bran cond sub pod time code
1             package FFI::Temp;
2              
3 16     16   730673 use strict;
  16         56  
  16         462  
4 16     16   82 use warnings;
  16         39  
  16         363  
5 16     16   307 use 5.008004;
  16         52  
6 16     16   98 use Carp qw( croak );
  16         36  
  16         876  
7 16     16   110 use File::Spec;
  16         48  
  16         455  
8 16     16   9648 use File::Temp qw( tempdir );
  16         228561  
  16         5793  
9              
10             # ABSTRACT: Temp Dir support for FFI::Platypus
11             our $VERSION = '2.08'; # VERSION
12              
13              
14             # problem with vanilla File::Temp is that is often uses
15             # as /tmp that has noexec turned on. Workaround is to
16             # create a temp directory in the build directory, but
17             # we have to be careful about cleanup. This puts all that
18             # (attempted) carefulness in one place so that when we
19             # later discover it isn't so careful we can fix it in
20             # one place rather thabn alllll the places that we need
21             # temp directories.
22              
23             my %root;
24              
25             sub _root
26             {
27 44     44   2353 my $root = File::Spec->rel2abs(File::Spec->catdir(".tmp"));
28 44         559 my $lock = File::Spec->catfile($root, "l$$");
29              
30 44         299 foreach my $try (0..9)
31             {
32 44 50       176 sleep $try if $try != 0;
33 44 100 50     2052 mkdir $root or die "unable to create temp root $!" unless -d $root;
34              
35             # There is a race condition here if the FFI::Temp is
36             # used in parallel. To work around we run this 10
37             # times until it works. There is still a race condition
38             # if it fails 10 times, but hopefully that is unlikely.
39              
40             # ??: doesn't account for fork, but probably doesn't need to.
41 44 50       3292 open my $fh, '>', $lock or next;
42 44 50       716 close $fh or next;
43              
44 44         206 $root{$root} = 1;
45 44         735 return $root;
46             }
47             }
48              
49             END {
50 16     16   238395 foreach my $root (keys %root)
51             {
52 12         338 my $lock = File::Spec->catfile($root, "l$$");
53 12         647 unlink $lock;
54             # try to delete if possible.
55             # if not possible then punt
56 12 50       864 rmdir $root if -d $root;
57             }
58             }
59              
60             sub newdir
61             {
62 25     25 0 61848 my $class = shift;
63 25 50       183 croak "uneven" if @_ % 2;
64 25         116 File::Temp->newdir(DIR => _root, @_);
65             }
66              
67             sub new
68             {
69 19     19 0 7484 my $class = shift;
70 19 50       107 croak "uneven" if @_ % 2;
71 19         109 File::Temp->new(DIR => _root, @_);
72             }
73              
74             1;
75              
76             __END__