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   570764 use strict;
  16         45  
  16         359  
4 16     16   59 use warnings;
  16         26  
  16         358  
5 16     16   220 use 5.008004;
  16         47  
6 16     16   71 use Carp qw( croak );
  16         24  
  16         677  
7 16     16   90 use File::Spec;
  16         24  
  16         381  
8 16     16   7125 use File::Temp qw( tempdir );
  16         178993  
  16         4736  
9              
10             # ABSTRACT: Temp Dir support for FFI::Platypus
11             our $VERSION = '2.07'; # 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   1657 my $root = File::Spec->rel2abs(File::Spec->catdir(".tmp"));
28 44         436 my $lock = File::Spec->catfile($root, "l$$");
29              
30 44         166 foreach my $try (0..9)
31             {
32 44 50       130 sleep $try if $try != 0;
33 44 100 50     1754 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       2980 open my $fh, '>', $lock or next;
42 44 50       519 close $fh or next;
43              
44 44         158 $root{$root} = 1;
45 44         536 return $root;
46             }
47             }
48              
49             END {
50 16     16   236054 foreach my $root (keys %root)
51             {
52 12         240 my $lock = File::Spec->catfile($root, "l$$");
53 12         788 unlink $lock;
54             # try to delete if possible.
55             # if not possible then punt
56 12 50       723 rmdir $root if -d $root;
57             }
58             }
59              
60             sub newdir
61             {
62 25     25 0 56255 my $class = shift;
63 25 50       129 croak "uneven" if @_ % 2;
64 25         91 File::Temp->newdir(DIR => _root, @_);
65             }
66              
67             sub new
68             {
69 19     19 0 6371 my $class = shift;
70 19 50       87 croak "uneven" if @_ % 2;
71 19         85 File::Temp->new(DIR => _root, @_);
72             }
73              
74             1;
75              
76             __END__