File Coverage

blib/lib/FFI/CheckLib.pm
Criterion Covered Total %
statement 146 174 83.9
branch 67 96 69.7
condition 15 28 53.5
subroutine 18 23 78.2
pod 9 9 100.0
total 255 330 77.2


line stmt bran cond sub pod time code
1             package FFI::CheckLib;
2              
3 6     6   1243646 use strict;
  6         53  
  6         175  
4 6     6   31 use warnings;
  6         10  
  6         148  
5 6     6   29 use File::Spec;
  6         11  
  6         177  
6 6     6   30 use List::Util 1.33 qw( any );
  6         154  
  6         359  
7 6     6   34 use Carp qw( croak carp );
  6         10  
  6         269  
8 6     6   30 use base qw( Exporter );
  6         11  
  6         1383  
9              
10             our @EXPORT = qw(
11             find_lib
12             assert_lib
13             check_lib
14             check_lib_or_exit
15             find_lib_or_exit
16             find_lib_or_die
17             );
18              
19             our @EXPORT_OK = qw(
20             which
21             where
22             has_symbols
23             );
24              
25             # ABSTRACT: Check that a library is available for FFI
26             our $VERSION = '0.29'; # VERSION
27              
28              
29             our $system_path = [];
30             our $os ||= $^O;
31             my $try_ld_on_text = 0;
32              
33             if($os eq 'MSWin32' || $os eq 'msys')
34             {
35             $system_path = eval {
36             require Env;
37             Env->import('@PATH');
38             \our @PATH;
39             };
40             die $@ if $@;
41             }
42             else
43             {
44             $system_path = eval {
45             require DynaLoader;
46 6     6   38 no warnings 'once';
  6         10  
  6         12614  
47             \@DynaLoader::dl_library_path;
48             };
49             die $@ if $@;
50             }
51              
52             our $pattern = [ qr{^lib(.*?)\.so(?:\.([0-9]+(?:\.[0-9]+)*))?$} ];
53             our $version_split = qr/\./;
54              
55             if($os eq 'cygwin')
56             {
57             push @$pattern, qr{^cyg(.*?)(?:-([0-9])+)?\.dll$};
58             }
59             elsif($os eq 'msys')
60             {
61             # doesn't seem as though msys uses psudo libfoo.so files
62             # in the way that cygwin sometimes does. we can revisit
63             # this if we find otherwise.
64             $pattern = [ qr{^msys-(.*?)(?:-([0-9])+)?\.dll$} ];
65             }
66             elsif($os eq 'MSWin32')
67             {
68             # handle cases like libgeos-3-7-0___.dll, libproj_9_1.dll and libgtk-2.0-0.dll
69             $pattern = [ qr{^(?:lib)?(\w+?)(?:[_-]([0-9\-\._]+))?_*\.dll$}i ];
70             $version_split = qr/[_\-]/;
71             }
72             elsif($os eq 'darwin')
73             {
74             push @$pattern, qr{^lib(.*?)(?:\.([0-9]+(?:\.[0-9]+)*))?\.(?:dylib|bundle)$};
75             }
76             elsif($os eq 'linux')
77             {
78             if(-e '/etc/redhat-release' && -x '/usr/bin/ld')
79             {
80             $try_ld_on_text = 1;
81             }
82             }
83              
84             sub _matches
85             {
86 1562     1562   54876 my($filename, $path) = @_;
87              
88 1562         2201 foreach my $regex (@$pattern)
89             {
90             return [
91 2078 100       18209 $1, # 0 capture group 1 library name
    100          
92             File::Spec->catfile($path, $filename), # 1 full path to library
93             defined $2 ? (split $version_split, $2) : (), # 2... capture group 2 library version
94             ] if $filename =~ $regex;
95             }
96 537         1476 return ();
97             }
98              
99             sub _cmp
100             {
101 210     210   367 my($A,$B) = @_;
102              
103 210 100       520 return $A->[0] cmp $B->[0] if $A->[0] ne $B->[0];
104              
105 152         177 my $i=2;
106 152         161 while(1)
107             {
108 256 50 66     401 return 0 if !defined($A->[$i]) && !defined($B->[$i]);
109 256 100       347 return -1 if !defined $A->[$i];
110 246 100       478 return 1 if !defined $B->[$i];
111 118 100       284 return $B->[$i] <=> $A->[$i] if $A->[$i] != $B->[$i];
112 104         106 $i++;
113             }
114             }
115              
116              
117             my $diagnostic;
118              
119             sub _is_binary
120             {
121 0     0   0 -B $_[0]
122             }
123              
124             sub find_lib
125             {
126 80     80   156408 my(%args) = @_;
127              
128 80         152 undef $diagnostic;
129 80 50       196 croak "find_lib requires lib argument" unless defined $args{lib};
130              
131 80   100     388 my $recursive = $args{_r} || $args{recursive} || 0;
132              
133             # make arguments be lists.
134 80         161 foreach my $arg (qw( lib libpath symbol verify alien ))
135             {
136 400 100       696 next if ref $args{$arg} eq 'ARRAY';
137 380 100       514 if(defined $args{$arg})
138             {
139 94         218 $args{$arg} = [ $args{$arg} ];
140             }
141             else
142             {
143 286         504 $args{$arg} = [];
144             }
145             }
146              
147 80 50 33     252 if(defined $args{systempath} && !ref($args{systempath}))
148             {
149 0         0 $args{systempath} = [ $args{systempath} ];
150             }
151              
152 80         99 my @path = @{ $args{libpath} };
  80         142  
153 80 100       150 @path = map { _recurse($_) } @path if $recursive;
  2         5  
154 150         626 push @path, grep { defined } defined $args{systempath}
155 80 50       237 ? @{ $args{systempath} }
  0         0  
156             : @$system_path;
157              
158 80     83   250 my $any = any { $_ eq '*' } @{ $args{lib} };
  83         162  
  80         274  
159 80         202 my %missing = map { $_ => 1 } @{ $args{lib} };
  83         236  
  80         178  
160 80         121 my %symbols = map { $_ => 1 } @{ $args{symbol} };
  27         55  
  80         129  
161 80         112 my @found;
162              
163 80         191 delete $missing{'*'};
164              
165 80         96 alien: foreach my $alien (@{ $args{alien} })
  80         154  
166             {
167 5 100       33 unless($alien =~ /^([A-Za-z_][A-Za-z_0-9]*)(::[A-Za-z_][A-Za-z_0-9]*)*$/)
168             {
169 1         188 croak "Doesn't appear to be a valid Alien name $alien";
170             }
171 4 100       6 unless(eval { $alien->can('dynamic_libs') })
  4         30  
172             {
173             {
174 3         5 my $pm = "$alien.pm";
  3         7  
175 3         11 $pm =~ s/::/\//g;
176 3         5 local $@ = '';
177 3         5 eval { require $pm };
  3         573  
178 3 100       12 next alien if $@;
179             }
180 2 100       3 unless(eval { $alien->can('dynamic_libs') })
  2         14  
181             {
182 1         91 croak "Alien $alien doesn't provide a dynamic_libs method";
183             }
184             }
185 2         7 push @path, [$alien->dynamic_libs];
186             }
187              
188 78         125 foreach my $path (@path)
189             {
190 164 50 66     2787 next if ref $path ne 'ARRAY' && ! -d $path;
191              
192             my @maybe =
193             # make determinist based on names and versions
194 147         225 sort { _cmp($a,$b) }
195             # Filter out the items that do not match the name that we are looking for
196             # Filter out any broken symbolic links
197 957 100 100     5067 grep { ($any || $missing{$_->[0]} ) && (-e $_->[1]) }
198             ref $path eq 'ARRAY'
199             ? do {
200             map {
201 2         4 my($v, $d, $f) = File::Spec->splitpath($_);
  2         22  
202 2         16 _matches($f, File::Spec->catpath($v,$d,''));
203             } @$path;
204             }
205 164 100       458 : do {
206 162         201 my $dh;
207 162         3755 opendir $dh, $path;
208             # get [ name, full_path ] mapping,
209             # each entry is a 2 element list ref
210 162         3366 map { _matches($_,$path) } readdir $dh;
  1492         3145  
211             };
212              
213 164 0 33     666 if($try_ld_on_text && $args{try_linker_script})
214             {
215             # This is tested in t/ci.t only
216             @maybe = map {
217 0 0       0 -B $_->[1] ? $_ : do {
  0         0  
218 0         0 my($name, $so) = @$_;
219 0         0 my $output = `/usr/bin/ld -t $so -o /dev/null -shared`;
220 0 0       0 $output =~ /\((.*?lib.*\.so.*?)\)/
221             ? [$name, $1]
222             : die "unable to parse ld output";
223             }
224             } @maybe;
225             }
226              
227             midloop:
228 164         310 foreach my $lib (@maybe)
229             {
230 178 100 100     1212 next unless $any || $missing{$lib->[0]};
231              
232 111         131 foreach my $verify (@{ $args{verify} })
  111         200  
233             {
234 48 100       113 next midloop unless $verify->(@$lib);
235             }
236              
237 66         401 delete $missing{$lib->[0]};
238              
239 66 100       128 if(%symbols)
240             {
241 12         92 require DynaLoader;
242 12         51 my $dll = DynaLoader::dl_load_file($lib->[1],0);
243 12         1385 foreach my $symbol (keys %symbols)
244             {
245 27 100       64 if(DynaLoader::dl_find_symbol($dll, $symbol) ? 1 : 0)
    100          
246             {
247 21         168 delete $symbols{$symbol}
248             }
249             }
250 12         105 DynaLoader::dl_unload_file($dll);
251             }
252              
253 66         158 my $found = $lib->[1];
254              
255 66 100       112 unless($any)
256             {
257 63         694 while(-l $found)
258             {
259 0         0 require File::Basename;
260 0         0 my $dir = File::Basename::dirname($found);
261 0         0 $found = File::Spec->rel2abs( readlink($found), $dir );
262             }
263             }
264              
265 66         256 push @found, $found;
266             }
267             }
268              
269 78 100       237 if(%missing)
    100          
270             {
271 17         60 my @missing = sort keys %missing;
272 17 50       47 if(@missing > 1)
273 0         0 { $diagnostic = "libraries not found: @missing" }
274             else
275 17         52 { $diagnostic = "library not found: @missing" }
276             }
277             elsif(%symbols)
278             {
279 6         23 my @missing = sort keys %symbols;
280 6 50       33 if(@missing > 1)
281 0         0 { $diagnostic = "symbols not found: @missing" }
282             else
283 6         21 { $diagnostic = "symbol not found: @missing" }
284             }
285              
286 78 100       177 return if %symbols;
287 72 100       791 return $found[0] unless wantarray;
288 47         257 return @found;
289             }
290              
291             sub _recurse
292             {
293 6     6   10 my($dir) = @_;
294 6 50       72 return unless -d $dir;
295 6         11 my $dh;
296 6         139 opendir $dh, $dir;
297 6         137 my @list = grep { -d $_ } map { File::Spec->catdir($dir, $_) } grep !/^\.\.?$/, readdir $dh;
  10         112  
  10         75  
298 6         62 closedir $dh;
299 6         52 ($dir, map { _recurse($_) } @list);
  4         11  
300             }
301              
302              
303             sub assert_lib
304             {
305 6 100 50 6 1 9560 croak $diagnostic || 'library not found' unless check_lib(@_);
306             }
307              
308              
309             sub check_lib_or_exit
310             {
311 0 0   0 1 0 unless(check_lib(@_))
312             {
313 0   0     0 carp $diagnostic || 'library not found';
314 0         0 exit;
315             }
316             }
317              
318              
319             sub find_lib_or_exit
320             {
321 0     0 1 0 my(@libs) = find_lib(@_);
322 0 0       0 unless(@libs)
323             {
324 0   0     0 carp $diagnostic || 'library not found';
325 0         0 exit;
326             }
327 0 0       0 return unless @libs;
328 0 0       0 wantarray ? @libs : $libs[0];
329             }
330              
331              
332             sub find_lib_or_die
333             {
334 0     0 1 0 my(@libs) = find_lib(@_);
335 0 0       0 unless(@libs)
336             {
337 0   0     0 croak $diagnostic || 'library not found';
338             }
339 0 0       0 return unless @libs;
340 0 0       0 wantarray ? @libs : $libs[0];
341             }
342              
343              
344             sub check_lib
345             {
346 12 100   12 1 10228 find_lib(@_) ? 1 : 0;
347             }
348              
349              
350             sub which
351             {
352 1     1 1 2518 my($name) = @_;
353 1 50       4 croak("cannot which *") if $name eq '*';
354 1         3 scalar find_lib( lib => $name );
355             }
356              
357              
358             sub where
359             {
360 2     2 1 5099 my($name) = @_;
361             $name eq '*'
362             ? find_lib(lib => '*')
363 2 100   0   9 : find_lib(lib => '*', verify => sub { $_[0] eq $name });
  0         0  
364             }
365              
366              
367             sub has_symbols
368             {
369 6     6 1 5839 my($path, @symbols) = @_;
370 6         27 require DynaLoader;
371 6         14 my $dll = DynaLoader::dl_load_file($path, 0);
372              
373 6         619 my $ok = 1;
374              
375 6         12 foreach my $symbol (@symbols)
376             {
377 11 100       53 unless(DynaLoader::dl_find_symbol($dll, $symbol))
378             {
379 2         14 $ok = 0;
380 2         6 last;
381             }
382             }
383              
384 6         29 DynaLoader::dl_unload_file($dll);
385              
386 6         49 $ok;
387             }
388              
389              
390             sub system_path
391             {
392 1     1 1 2031 $system_path;
393             }
394              
395             1;
396              
397             __END__