File Coverage

blib/lib/FFI/Probe.pm
Criterion Covered Total %
statement 189 238 79.4
branch 36 76 47.3
condition 9 19 47.3
subroutine 27 32 84.3
pod 15 16 93.7
total 276 381 72.4


line stmt bran cond sub pod time code
1             package FFI::Probe;
2              
3 1     1   219753 use strict;
  1         7  
  1         28  
4 1     1   6 use warnings;
  1         3  
  1         21  
5 1     1   17 use 5.008004;
  1         3  
6 1     1   6 use File::Basename qw( dirname );
  1         2  
  1         89  
7 1     1   571 use Data::Dumper ();
  1         6147  
  1         28  
8 1     1   411 use FFI::Probe::Runner;
  1         4  
  1         35  
9 1     1   411 use FFI::Build;
  1         3  
  1         6  
10 1     1   416 use FFI::Build::File::C;
  1         3  
  1         33  
11 1     1   7 use Capture::Tiny qw( capture_merged capture );
  1         2  
  1         52  
12 1     1   5 use FFI::Temp;
  1         2  
  1         2839  
13              
14             # ABSTRACT: System detection and probing for FFI extensions.
15             our $VERSION = '2.06_01'; # TRIAL VERSION
16              
17              
18             sub new
19             {
20 3     3 1 3689 my($class, %args) = @_;
21              
22 3   50     13 $args{log} ||= "ffi-probe.log";
23 3   50     11 $args{data_filename} ||= "ffi-probe.pl";
24              
25 3 50       10 unless(ref $args{log})
26             {
27 3         8 my $fn = $args{log};
28 3         6 my $fh;
29 3         210 open $fh, '>>', $fn;
30 3         17 $args{log} = $fh;
31             }
32              
33 3         7 my $data;
34              
35 3 100       57 if(-r $args{data_filename})
36             {
37 1         10 my $fn = $args{data_filename};
38 1 50       775 unless($data = do $fn)
39             {
40 0 0       0 die "couldn't parse configuration $fn $@" if $@;
41 0 0       0 die "couldn't do $fn $!" if $!;
42 0         0 die "bad or missing config file $fn";
43             }
44             }
45              
46 3   100     28 $data ||= {};
47              
48             my $self = bless {
49             headers => [],
50             log => $args{log},
51             data_filename => $args{data_filename},
52             data => $data,
53             dir => FFI::Temp->newdir( TEMPLATE => 'ffi-probe-XXXXXX' ),
54             counter => 0,
55             runner => $args{runner},
56             alien => $args{alien} || [],
57             cflags => $args{cflags},
58             libs => $args{libs},
59 3   50     42 }, $class;
60              
61 3         1268 $self;
62             }
63              
64             sub _runner
65             {
66 5     5   91 my($self) = @_;
67 5   33     89 $self->{runner} ||= FFI::Probe::Runner->new;
68             }
69              
70              
71             sub check_header
72             {
73 7     7 1 3358 my($self, $header) = @_;
74              
75 7 100       50 return if defined $self->{data}->{header}->{$header};
76              
77 3         23 my $code = '';
78 3         7 $code .= "#include <$_>\n" for @{ $self->{headers} }, $header;
  3         25  
79              
80 3         67 my $build = FFI::Build->new("hcheck@{[ ++$self->{counter} ]}",
81             verbose => 2,
82             dir => $self->{dir},
83             alien => $self->{alien},
84             cflags => $self->{cflags},
85             libs => $self->{libs},
86 3         10 );
87             my $file = FFI::Build::File::C->new(
88             \$code,
89             dir => $self->{dir},
90 3         49 build => $build,
91             );
92             my($out, $o) = capture_merged {
93 3     3   3518 eval { $file->build_item };
  3         29  
94 3         173 };
95 3         3264 $self->log_code($code);
96 3         20 $self->log($out);
97 3 100       51 if($o)
98             {
99 2         37 $self->set('header', $header => 1);
100 2         12 push @{ $self->{headers} }, $header;
  2         35  
101 2         72 return 1;
102             }
103             else
104             {
105 1         22 $self->set('header', $header => 0);
106 1         6 return;
107             }
108             }
109              
110              
111             sub check_cpp
112             {
113 0     0 1 0 my($self, $code) = @_;
114              
115 0         0 my $build = FFI::Build->new("hcheck@{[ ++$self->{counter} ]}",
116             verbose => 2,
117             dir => $self->{dir},
118             alien => $self->{alien},
119             cflags => $self->{cflags},
120             libs => $self->{libs},
121 0         0 );
122             my $file = FFI::Build::File::C->new(
123             \$code,
124             dir => $self->{dir},
125 0         0 build => $build,
126             );
127             my($out, $i) = capture_merged {
128 0     0   0 eval { $file->build_item_cpp };
  0         0  
129 0         0 };
130 0         0 $self->log_code($code);
131 0         0 $self->log($out);
132              
133 0 0 0     0 if($i && -f $i->path)
134             {
135 0         0 return $i->slurp;
136             }
137             else
138             {
139 0         0 return;
140             }
141             }
142              
143              
144             sub check_eval
145             {
146 5     5 1 3404 my($self, %args) = @_;
147              
148 5   33     92 my $code = $args{_template} || $self->template;
149              
150 5 50       19 my $headers = join "", map { "#include <$_>\n" } (@{ $self->{headers} }, @{ $args{headers} || [] });
  3         42  
  5         18  
  5         74  
151 5 100       23 my @decl = @{ $args{decl} || [] };
  5         46  
152 5 100       15 my @stmt = @{ $args{stmt} || [] };
  5         41  
153 5 50       14 my %eval = %{ $args{eval} || {} };
  5         66  
154              
155 5         78 $code =~ s/##HEADERS##/$headers/;
156 5         38 $code =~ s/##DECL##/join "\n", @decl/e;
  5         33  
157 5         45 $code =~ s/##STMT##/join "\n", @stmt/e;
  5         31  
158              
159 5         15 my $eval = '';
160 5         13 my $i=0;
161 5         11 my %map;
162 5         41 foreach my $key (sort keys %eval)
163             {
164 9         24 $i++;
165 9         51 $map{$key} = "eval$i";
166 9         20 my($format,$expression) = @{ $eval{$key} };
  9         32  
167 9         45 $eval .= " printf(\"eval$i=<<<$format>>>\\n\", $expression);\n";
168             }
169              
170 5         34 $code =~ s/##EVAL##/$eval/;
171              
172 5         188 my $build = FFI::Build->new("eval@{[ ++$self->{counter} ]}",
173             verbose => 2,
174             dir => $self->{dir},
175             alien => $self->{alien},
176             cflags => $self->{cflags},
177             libs => $self->{libs},
178 5         13 export => ['dlmain'],
179             );
180             $build->source(
181             FFI::Build::File::C->new(
182             \$code,
183             dir => $self->{dir},
184 5         99 build => $build,
185             ),
186             );
187              
188 5         9 my $lib = do {
189             my($out, $lib, $error) = capture_merged {
190 5     5   6088 my $lib = eval {
191 5         66 $build->build;
192             };
193 5         151 ($lib, $@);
194 5         286 };
195              
196 5         6354 $self->log_code($code);
197 5         26 $self->log("[build]");
198 5         36 $self->log($out);
199 5 50       88 if($error)
    50          
200             {
201 0         0 $self->log("exception: $error");
202 0         0 return;
203             }
204             elsif(!$lib)
205             {
206 0         0 $self->log("failed");
207 0         0 return;
208             }
209 5         25 $lib;
210             };
211              
212 5         68 my $result = $self->_runner->run($lib->path);
213              
214 5         101 $self->log("[stdout]");
215 5         62 $self->log($result->stdout);
216 5         40 $self->log("[stderr]");
217 5         32 $self->log($result->stderr);
218 5         19 $self->log("rv = @{[ $result->rv ]}");
  5         62  
219 5 50       51 $self->log("sig = @{[ $result->signal ]}") if $result->signal;
  0         0  
220              
221 5 50       68 if($result->pass)
222             {
223 5         78 foreach my $key (sort keys %eval)
224             {
225 9         43 my $eval = $map{$key};
226 9 50       43 if($result->stdout =~ /$eval=<<<(.*?)>>>/)
227             {
228 9         64 my $value = $1;
229 9         71 my @key = split /\./, $key;
230 9         88 $self->set(@key, $value);
231             }
232             }
233 5         295 return 1;
234             }
235             else
236             {
237 0         0 return;
238             }
239             }
240              
241              
242             sub check
243             {
244 0     0 1 0 my($self, $name, $code) = @_;
245 0 0       0 if($self->check_eval(_template => $code))
246             {
247 0         0 $self->set('probe', $name, 1);
248 0         0 return 1;
249             }
250             else
251             {
252 0         0 $self->set('probe', $name, 0);
253 0         0 return;
254             }
255             }
256              
257              
258             sub check_type_int
259             {
260 1     1 1 1339 my($self, $type) = @_;
261              
262 1         15 $self->check_header('stddef.h');
263              
264 1         92 my $ret = $self->check_eval(
265             decl => [
266             '#define signed(type) (((type)-1) < 0) ? "signed" : "unsigned"',
267             "struct align { char a; $type b; };",
268             ],
269             eval => {
270             "type.$type.size" => [ '%d' => "(int)sizeof($type)" ],
271             "type.$type.sign" => [ '%s' => "signed($type)" ],
272             "type.$type.align" => [ '%d' => '(int)offsetof(struct align, b)' ],
273             },
274             );
275              
276 1 50       40 return unless $ret;
277              
278 1         21 my $size = $self->data->{type}->{$type}->{size};
279 1         15 my $sign = $self->data->{type}->{$type}->{sign};
280              
281 1 50       40 sprintf("%sint%d", $sign eq 'signed' ? 's' : 'u', $size*8);
282             }
283              
284              
285             sub check_type_enum
286             {
287 0     0 1 0 my($self) = @_;
288              
289 0         0 $self->check_header('stddef.h');
290              
291 0         0 my $ret = $self->check_eval(
292             decl => [
293             '#define signed(type) (((type)-1) < 0) ? "signed" : "unsigned"',
294             "typedef enum { ONE, TWO } myenum;",
295             "struct align { char a; myenum b; };",
296             ],
297             eval => {
298             "type.enum.size" => [ '%d' => '(int)sizeof(myenum)' ],
299             "type.enum.sign" => [ '%s' => 'signed(myenum)' ],
300             "type.enum.align" => [ '%d' => '(int)offsetof(struct align, b)' ],
301             },
302             );
303              
304 0 0       0 return unless $ret;
305              
306 0         0 my $size = $self->data->{type}->{enum}->{size};
307 0         0 my $sign = $self->data->{type}->{enum}->{sign};
308              
309 0 0       0 sprintf("%sint%d", $sign eq 'signed' ? 's' : 'u', $size*8);
310             }
311              
312              
313             sub check_type_signed_enum
314             {
315 0     0 0 0 my($self) = @_;
316              
317 0         0 $self->check_header('stddef.h');
318              
319 0         0 my $ret = $self->check_eval(
320             decl => [
321             '#define signed(type) (((type)-1) < 0) ? "signed" : "unsigned"',
322             "typedef enum { NEG = -1, ONE = 1, TWO = 2 } myenum;",
323             "struct align { char a; myenum b; };",
324             ],
325             eval => {
326             "type.senum.size" => [ '%d' => '(int)sizeof(myenum)' ],
327             "type.senum.sign" => [ '%s' => 'signed(myenum)' ],
328             "type.senum.align" => [ '%d' => '(int)offsetof(struct align, b)' ],
329             },
330             );
331              
332 0 0       0 return unless $ret;
333              
334 0         0 my $size = $self->data->{type}->{senum}->{size};
335 0         0 my $sign = $self->data->{type}->{senum}->{sign};
336              
337 0 0       0 sprintf("%sint%d", $sign eq 'signed' ? 's' : 'u', $size*8);
338             }
339              
340              
341             sub check_type_float
342             {
343 1     1 1 1264 my($self, $type) = @_;
344              
345 1         17 $self->check_header('stddef.h');
346              
347 1         25 my $ret = $self->check_eval(
348             decl => [
349             "struct align { char a; $type b; };",
350             ],
351             eval => {
352             "type.$type.size" => [ '%d' => "(int)sizeof($type)" ],
353             "type.$type.align" => [ '%d' => '(int)offsetof(struct align, b)' ],
354             },
355             );
356              
357 1 50       55 return unless $ret;
358              
359 1         18 my $size = $self->data->{type}->{$type}->{size};
360 1         15 my $complex = !!$type =~ /complex/;
361              
362 1 50       23 if($complex) {
363 0         0 $size /= 2;
364             }
365              
366 1         5 my $t;
367 1 50       12 if($size == 4)
    0          
    0          
368 1         9 { $t = 'float' }
369             elsif($size == 8)
370 0         0 { $t = 'double' }
371             elsif($size > 9)
372 0         0 { $t = 'longdouble' }
373              
374 1 50       17 $t = "complex_$t" if $complex;
375              
376 1         27 $t;
377             }
378              
379              
380             sub check_type_pointer
381             {
382 1     1 1 1244 my($self) = @_;
383              
384 1         11 $self->check_header('stddef.h');
385              
386 1         13 my $ret = $self->check_eval(
387             decl => [
388             "struct align { char a; void* b; };",
389             ],
390             eval => {
391             "type.pointer.size" => [ '%d' => '(int)sizeof(void *)' ],
392             "type.pointer.align" => [ '%d' => '(int)offsetof(struct align, b)' ],
393             },
394             );
395              
396 1 50       35 return unless $ret;
397 1         25 'pointer';
398             }
399              
400             sub _set
401             {
402 33     33   195 my($data, $value, @key) = @_;
403 33         115 my $key = shift @key;
404 33 100       101 if(@key > 0)
405             {
406 21   100     248 _set($data->{$key} ||= {}, $value, @key);
407             }
408             else
409             {
410 12         173 $data->{$key} = $value;
411             }
412             }
413              
414              
415             sub set
416             {
417 12     12 1 43 my $self = shift;
418 12         36 my $value = pop;
419 12         65 my @key = @_;
420              
421 12         31 my $print_value = $value;
422 12 50       53 if(ref $print_value)
423             {
424 0         0 my $d = Data::Dumper->new([$value], [qw($value)]);
425 0         0 $d->Indent(0);
426 0         0 $d->Terse(1);
427 0         0 $print_value = $d->Dump;
428             }
429              
430 12 100       36 my $key = join ".", map { /\./ ? "\"$_\"" : $_ } @key;
  33         359  
431 12         613 print "PR $key=$print_value\n";
432 12         157 $self->log("$key=$print_value");
433 12         69 _set($self->{data}, $value, @key);
434             }
435              
436              
437             sub save
438             {
439 4     4 1 16 my($self) = @_;
440              
441 4         293 my $dir = dirname($self->{data_filename});
442              
443 4         82 my $dd = Data::Dumper->new([$self->{data}],['x'])
444             ->Indent(1)
445             ->Terse(0)
446             ->Purity(1)
447             ->Sortkeys(1)
448             ->Dump;
449              
450 4 50       863 mkpath( $dir, 0, oct(755) ) unless -d $dir;
451              
452 4         12 my $fh;
453 4 50       348 open($fh, '>', $self->{data_filename}) || die "error writing @{[ $self->{data_filename} ]}";
  0         0  
454 4         33 print $fh 'do { my ';
455 4         8 print $fh $dd;
456 4         13 print $fh '$x;}';
457 4         290 close $fh;
458             }
459              
460              
461 18     18 1 6200 sub data { shift->{data} }
462              
463              
464             sub log
465             {
466 132     132 1 376 my($self, $string) = @_;
467 132         320 my $fh = $self->{log};
468 132         259 chomp $string;
469 132         604 print $fh $string, "\n";
470             }
471              
472              
473             sub log_code
474             {
475 8     8 1 93 my($self, $code) = @_;
476 8         109 my @code = split /\n/, $code;
477 8         109 chomp for @code;
478 8         89 $self->log("code: $_") for @code;
479             }
480              
481             sub DESTROY
482             {
483 3     3   1762 my($self) = @_;
484 3         15 $self->save;
485 3         13 my $fh = $self->{log};
486 3 50       12 return unless defined $fh;
487 3         150 close $fh;
488             }
489              
490             my $template;
491              
492              
493             sub template
494             {
495 5 100   5 1 33 unless(defined $template)
496             {
497 1         6 local $/;
498 1         28 $template = ;
499             }
500              
501 5         32 $template;
502             }
503              
504             1;
505              
506             =pod
507              
508             =encoding UTF-8
509              
510             =head1 NAME
511              
512             FFI::Probe - System detection and probing for FFI extensions.
513              
514             =head1 VERSION
515              
516             version 2.06_01
517              
518             =head1 SYNOPSIS
519              
520             use FFI::Probe;
521            
522             my $probe = FFI::Probe->new;
523             $probe->check_header('foo.h');
524             ...
525              
526             =head1 DESCRIPTION
527              
528             This class provides an interface for probing for system
529             capabilities. It is used internally as part of the
530             L build process, but it may also be useful
531             for extensions that use Platypus as well.
532              
533             =head1 CONSTRUCTOR
534              
535             =head2 new
536              
537             my $probe = FFI::Probe->new(%args);
538              
539             Creates a new instance.
540              
541             =over 4
542              
543             =item log
544              
545             Path to a log or file handle to write to.
546              
547             =item data_filename
548              
549             Path to a file which will be used to store/cache results.
550              
551             =back
552              
553             =head1 METHODS
554              
555             =head2 check_header
556              
557             my $bool = $probe->check_header($header);
558              
559             Checks that the given C header file is available.
560             Stores the result, and returns a true/false value.
561              
562             =head2 check_cpp
563              
564             =head2 check_eval
565              
566             my $bool = $probe>check_eval(%args);
567              
568             =over 4
569              
570             =item headers
571              
572             Any additional headers.
573              
574             =item decl
575              
576             Any C declarations that need to be made before the C function.
577              
578             =item stmt
579              
580             Any C statements that should be made before the evaluation.
581              
582             =item eval
583              
584             Any evaluations that should be returned.
585              
586             =back
587              
588             =head2 check
589              
590             =head2 check_type_int
591              
592             my $type = $probe->check_type_int($type);
593              
594             =head2 check_type_enum
595              
596             my $type = $probe->check_type_enum;
597              
598             =head2 check_type_enum
599              
600             my $type = $probe->check_type_enum;
601              
602             =head2 check_type_float
603              
604             my $type = $probe->check_type_float($type);
605              
606             =head2 check_type_pointer
607              
608             my $type = $probe->check_type_pointer;
609              
610             =head2 set
611              
612             $probe->set(@key, $value);
613              
614             Used internally to store a value.
615              
616             =head2 save
617              
618             $probe->save;
619              
620             Saves the values already detected.
621              
622             =head2 data
623              
624             my $data = $probe->data;
625              
626             Returns a hashref of the data already detected.
627              
628             =head2 log
629              
630             $probe->log($string);
631              
632             Sends the given string to the log.
633              
634             =head2 log_code
635              
636             $prbe->log_code($string);
637              
638             Sends the given multi-line code block to the log.
639              
640             =head2 template
641              
642             my $template = $probe->template;
643              
644             Returns the C code template used for C and other
645             C methods.
646              
647             =head1 AUTHOR
648              
649             Author: Graham Ollis Eplicease@cpan.orgE
650              
651             Contributors:
652              
653             Bakkiaraj Murugesan (bakkiaraj)
654              
655             Dylan Cali (calid)
656              
657             pipcet
658              
659             Zaki Mughal (zmughal)
660              
661             Fitz Elliott (felliott)
662              
663             Vickenty Fesunov (vyf)
664              
665             Gregor Herrmann (gregoa)
666              
667             Shlomi Fish (shlomif)
668              
669             Damyan Ivanov
670              
671             Ilya Pavlov (Ilya33)
672              
673             Petr Písař (ppisar)
674              
675             Mohammad S Anwar (MANWAR)
676              
677             Håkon Hægland (hakonhagland, HAKONH)
678              
679             Meredith (merrilymeredith, MHOWARD)
680              
681             Diab Jerius (DJERIUS)
682              
683             Eric Brine (IKEGAMI)
684              
685             szTheory
686              
687             José Joaquín Atria (JJATRIA)
688              
689             Pete Houston (openstrike, HOUSTON)
690              
691             =head1 COPYRIGHT AND LICENSE
692              
693             This software is copyright (c) 2015-2022 by Graham Ollis.
694              
695             This is free software; you can redistribute it and/or modify it under
696             the same terms as the Perl 5 programming language system itself.
697              
698             =cut
699              
700             __DATA__