File Coverage

blib/lib/Test/Alien.pm
Criterion Covered Total %
statement 224 288 77.7
branch 64 108 59.2
condition 16 35 45.7
subroutine 33 36 91.6
pod 5 6 83.3
total 342 473 72.3


line stmt bran cond sub pod time code
1             package Test::Alien;
2              
3 7     7   1020839 use strict;
  7         10  
  7         162  
4 7     7   23 use warnings;
  7         5  
  7         131  
5 7     7   136 use 5.008001;
  7         15  
6 7     7   4977 use Env qw( @PATH );
  7         13373  
  7         33  
7 7     7   3224 use File::Which 1.10 qw( which );
  7         4551  
  7         441  
8 7     7   3552 use if $^O ne 'MSWin32', 'Capture::Tiny' => 'capture_merged';
  7         52  
  7         32  
9 7     7   89944 use Capture::Tiny qw( capture );
  7         17  
  7         228  
10 7     7   26 use File::Temp qw( tempdir );
  7         8  
  7         225  
11 7     7   24 use Carp qw( croak );
  7         9  
  7         203  
12 7     7   64 use File::Spec;
  7         8  
  7         128  
13 7     7   25 use File::Basename qw( dirname );
  7         7  
  7         365  
14 7     7   22 use File::Path qw( mkpath );
  7         7  
  7         221  
15 7     7   2975 use File::Copy qw( move );
  7         11601  
  7         329  
16 7     7   1986 use Text::ParseWords qw( shellwords );
  7         4572  
  7         366  
17 7     7   31 use Test2::API qw( context run_subtest );
  7         8  
  7         316  
18 7     7   27 use base qw( Exporter );
  7         9  
  7         854  
19              
20             BEGIN {
21             *capture_merged = sub (&;@)
22             {
23             # TODO: fix this error properly:
24             #Error in tempfile() using template C:\Users\ollisg\AppData\Local\Temp\XXXXXXXXXX: Could not create temp file C:\Users\ollisg\AppData\Local\Temp\eysiq7e9w5: Permission denied at N:/home/ollisg/perl5/straw
25             # rry/x86/5.22.1/lib/perl5/Capture/Tiny.pm line 360.
26            
27             # this seems to work more reliably on windows, at the cost of being much noisier.
28 0         0 my $code = shift;
29 0 0       0 wantarray ? ('', $code->(@_)) : '';
30 7 50   7   14032 } if $^O eq 'MSWin32';
31             }
32              
33             our @EXPORT = qw( alien_ok run_ok xs_ok ffi_ok with_subtest synthetic );
34              
35             # ABSTRACT: Testing tools for Alien modules
36             our $VERSION = '0.12'; # VERSION
37              
38              
39             our @aliens;
40              
41             sub alien_ok ($;$)
42             {
43 5     5 1 11767 my($alien, $message) = @_;
44              
45 5 100       16 my $name = ref $alien ? ref($alien) . '[instance]' : $alien;
46            
47 5         11 my @methods = qw( cflags libs dynamic_libs bin_dir );
48 5   33     28 $message ||= "$name responds to: @methods";
49 5         8 my @missing = grep { ! $alien->can($_) } @methods;
  20         105  
50            
51 5         7 my $ok = !@missing;
52 5         10 my $ctx = context();
53 5         224 $ctx->ok($ok, $message);
54 5         633 $ctx->diag(" missing method $_") for @missing;
55 5         170 $ctx->release;
56            
57 5 100       78 if($ok)
58             {
59 4         7 push @aliens, $alien;
60 4         14 unshift @PATH, $alien->bin_dir;
61             }
62            
63 5         141 $ok;
64             }
65              
66              
67             sub synthetic
68             {
69 7     7 1 2563 my($opt) = @_;
70 7   100     21 $opt ||= {};
71 7         19 my %alien = %$opt;
72 7         499 require Test::Alien::Synthetic;
73 7         50 bless \%alien, 'Test::Alien::Synthetic',
74             }
75              
76              
77             sub run_ok
78             {
79 5     5 1 21903 my($command, $message) = @_;
80            
81 5 50       23 my(@command) = ref $command ? @$command : ($command);
82 5   66     24 $message ||= "run @command";
83            
84 5         460 require Test::Alien::Run;
85 5         45 my $run = bless {
86             out => '',
87             err => '',
88             exit => 0,
89             sig => 0,
90             cmd => [@command],
91             }, 'Test::Alien::Run';
92            
93 5         15 my $ctx = context();
94 5         259 my $exe = which $command[0];
95 5 100       156 if(defined $exe)
96             {
97 4         4 shift @command;
98 4         15 $run->{cmd} = [$exe, @command];
99 4         7 my @diag;
100 4         7 my $ok = 1;
101 4         4 my($exit, $errno);
102 4     4   216 ($run->{out}, $run->{err}, $exit, $errno) = capture { system $exe, @command; ($?,$!); };
  4         3411  
  4         18803  
103            
104 4 100       2765 if($exit == -1)
    100          
105             {
106 1         2 $ok = 0;
107 1         6 $run->{fail} = "failed to execute: $errno";
108 1         38 push @diag, " failed to execute: $errno";
109             }
110             elsif($exit & 127)
111             {
112 1         5 $ok = 0;
113 1         3 push @diag, " killed with signal: @{[ $exit & 127 ]}";
  1         7  
114 1         4 $run->{sig} = $exit & 127;
115             }
116             else
117             {
118 2         7 $run->{exit} = $exit >> 8;
119             }
120              
121 4         30 $ctx->ok($ok, $message);
122 4 100       535 $ok
123             ? $ctx->note(" using $exe")
124             : $ctx->diag(" using $exe");
125 4         252 $ctx->diag(@diag) for @diag;
126              
127             }
128             else
129             {
130 1         5 $ctx->ok(0, $message);
131 1         97 $ctx->diag(" command not found");
132 1         34 $run->{fail} = 'command not found';
133             }
134            
135 5         104 $ctx->release;
136            
137 5         109 $run;
138             }
139              
140              
141             sub _flags
142             {
143 0     0   0 my($class, $method) = @_;
144 0         0 my $static = "${method}_static";
145 0 0 0     0 $class->can($static) && $class->can('install_type') && $class->install_type eq 'share'
146             ? $class->$static
147             : $class->$method;
148             }
149              
150             sub xs_ok
151             {
152 9     9 1 17653 my $cb;
153 9 100 66     93 $cb = pop if defined $_[-1] && ref $_[-1] eq 'CODE';
154 9         20 my($xs, $message) = @_;
155 9   100     43 $message ||= 'xs';
156              
157 9         79 require ExtUtils::CBuilder;
158 9         120 my $skip = !ExtUtils::CBuilder->new->have_compiler;
159              
160 9 100       309202 if($skip)
161             {
162 4         715 my $ctx = context();
163 4         349 $ctx->skip($message, 'test requires a compiler');
164 4 100       1188 $ctx->skip("$message subtest", 'test requires a compiler') if $cb;
165 4         286 $ctx->release;
166 4         108 return;
167             }
168            
169 5 100       3048 $xs = { xs => $xs } unless ref $xs;
170             # make sure this is a copy because we may
171             # modify it.
172 5         15 $xs->{xs} = "@{[ $xs->{xs} ]}";
  5         40  
173 5   50     50 $xs->{pxs} ||= {};
174 5         9 my $verbose = $xs->{verbose};
175 5         9 my $ok = 1;
176 5         5 my @diag;
177 5         49 my $dir = tempdir( CLEANUP => 1 );
178 5         2441 my $xs_filename = File::Spec->catfile($dir, 'test.xs');
179 5         34 my $c_filename = File::Spec->catfile($dir, 'test.c');
180            
181 5         43 my $ctx = context();
182 5         1018 my $module;
183              
184 5 100       41 if($xs->{xs} =~ /\bTA_MODULE\b/)
185             {
186 1         4 our $count;
187 1 50       7 $count = 0 unless defined $count;
188 1         8 my $name = sprintf "Test::Alien::XS::Mod%s", $count++;
189 1         3 my $code = $xs->{xs};
190 1         12 $code =~ s{\bTA_MODULE\b}{$name}g;
191 1         3 $xs->{xs} = $code;
192             }
193              
194             # this regex copied shamefully from ExtUtils::ParseXS
195             # in part because we need the module name to do the bootstrap
196             # and also because if this regex doesn't match then ParseXS
197             # does an exit() which we don't want.
198 5 100       57 if($xs->{xs} =~ /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/m)
199             {
200 3         21 $module = $1;
201 3 100       24 $ctx->note("detect module name $module") if $verbose;
202             }
203             else
204             {
205 2         4 $ok = 0;
206 2         10 push @diag, ' XS does not have a module decleration that we could find';
207             }
208              
209 5 100       499 if($ok)
210             {
211 3         208 open my $fh, '>', $xs_filename;
212 3         41 print $fh $xs->{xs};
213 3         74 close $fh;
214            
215 3         777 require ExtUtils::ParseXS;
216 3         17091 my $pxs = ExtUtils::ParseXS->new;
217            
218             my($out, $err) = capture_merged {
219 3     3   2650 eval {
220             $pxs->process_file(
221             filename => $xs_filename,
222             output => $c_filename,
223             versioncheck => 0,
224             prototypes => 0,
225 3         6 %{ $xs->{pxs} },
  3         21  
226             );
227             };
228 3         79681 $@;
229 3         167 };
230            
231 3 100       1854 $ctx->note("parse xs $xs_filename => $c_filename") if $verbose;
232 3 100       441 $ctx->note($out) if $verbose;
233 3 50 66     171 $ctx->note("error: $err") if $verbose && $err;
234              
235 3 50       14 unless($pxs->report_error_count == 0)
236             {
237 0         0 $ok = 0;
238 0         0 push @diag, ' ExtUtils::ParseXS failed:';
239 0 0       0 push @diag, " $err" if $err;
240 0         0 push @diag, " $_" for split /\r?\n/, $out;
241             }
242             }
243              
244 5 100       266 if($ok)
245             {
246 3         46 my $cb = ExtUtils::CBuilder->new;
247              
248             my($out, $obj, $err) = capture_merged {
249 3     3   2512 my $obj = eval {
250             $cb->compile(
251             source => $c_filename,
252 3         29 extra_compiler_flags => [shellwords map { _flags $_, 'cflags' } @aliens],
  0         0  
253             );
254             };
255 3         395667 ($obj, $@);
256 3         18911 };
257            
258 3 100       2536 $ctx->note("compile $c_filename") if $verbose;
259 3 100       540 $ctx->note($out) if $verbose;
260 3 50 66     191 $ctx->note($err) if $verbose && $err;
261            
262 3 100       12 unless($obj)
263             {
264 1         3 $ok = 0;
265 1         4 push @diag, ' ExtUtils::CBuilder->compile failed';
266 1 50       6 push @diag, " $err" if $err;
267 1         122 push @diag, " $_" for split /\r?\n/, $out;
268             }
269            
270 3 100       28 if($ok)
271             {
272            
273             my($out, $lib, $err) = capture_merged {
274 2     2   2036 my $lib = eval {
275             $cb->link(
276             objects => [$obj],
277             module_name => $module,
278 2         39 extra_linker_flags => [shellwords map { _flags $_, 'libs' } @aliens],
  0         0  
279             );
280             };
281 2         48453 ($lib, $@);
282 2         138 };
283            
284 2 100       1442 $ctx->note("link $obj") if $verbose;
285 2 100       449 $ctx->note($out) if $verbose;
286 2 50 66     181 $ctx->note($err) if $verbose && $err;
287            
288 2 50       10 if($lib)
289             {
290 2 100       15 $ctx->note("created lib $lib") if $xs->{verbose};
291             }
292             else
293             {
294 0         0 $ok = 0;
295 0         0 push @diag, ' ExtUtils::CBuilder->link failed';
296 0 0       0 push @diag, " $err" if $err;
297 0         0 push @diag, " $_" for split /\r?\n/, $out;
298             }
299            
300 2 50       164 if($ok)
301             {
302 2         23 require Config;
303 2         18 my @modparts = split(/::/,$module);
304 2         32 my $dl_dlext = $Config::Config{dlext};
305 2         6 my $modfname = $modparts[-1];
306              
307 2         38 my $libpath = File::Spec->catfile($dir, 'auto', @modparts, "$modfname.$dl_dlext");
308 2         820 mkpath(dirname($libpath), 0, 0700);
309 2 50       17 move($lib, $libpath) || die "unable to copy $lib => $libpath $!";
310            
311 2         169 pop @modparts;
312 2         24 my $pmpath = File::Spec->catfile($dir, @modparts, "$modfname.pm");
313 2         320 mkpath(dirname($pmpath), 0, 0700);
314 2         124 open my $fh, '>', $pmpath;
315 2         22 print $fh '# line '. __LINE__ . ' "' . __FILE__ . qq("\n) . qq{
316             package $module;
317            
318 1     1   4 use strict;
  1     1   2  
  1         26  
  1         5  
  1         3  
  1         27  
319 1     1   3 use warnings;
  1     1   1  
  1         77  
  1         5  
  1         62  
  1         72  
320             require XSLoader;
321             our \$VERSION = '0.01';
322             XSLoader::load('$module','\$VERSION');
323            
324             1;
325             };
326 2         45 close $fh;
327              
328             {
329 2         5 local @INC = @INC;
  2         26  
330 2         6 unshift @INC, $dir;
331 2         143 eval '# line '. __LINE__ . ' "' . __FILE__ . qq("\n) . qq{
332 1     1   111 use $module;
  1     1   2  
  1         17  
  1         89  
  1         2  
  1         19  
333             };
334             }
335            
336 2 50       28 if(my $error = $@)
337             {
338 0         0 $ok = 0;
339 0         0 push @diag, ' DynaLoader failed';
340 0         0 push @diag, " $error";
341             }
342             }
343             }
344             }
345              
346 5         1540 $ctx->ok($ok, $message);
347 5         1639 $ctx->diag($_) for @diag;
348 5         1755 $ctx->release;
349            
350 5 100       145 if($cb)
351             {
352             $cb = sub {
353 1     1   270 my $ctx = context();
354 1         58 $ctx->plan(0, 'SKIP', "subtest requires xs success");
355 0         0 $ctx->release;
356 3 100       22 } unless $ok;
357              
358 3         25 @_ = ("$message subtest", $cb, 1, $module);
359              
360 3         27 goto \&Test2::API::run_subtest;
361             }
362              
363 2         11 $ok;
364             }
365              
366 2     2 0 2407 sub with_subtest (&) { $_[0]; }
367              
368              
369             sub ffi_ok
370             {
371 0     0 1 0 my $cb;
372 0 0 0     0 $cb = pop if defined $_[-1] && ref $_[-1] eq 'CODE';
373 0         0 my($opt, $message) = @_;
374            
375 0   0     0 $message ||= 'ffi';
376            
377 0         0 my $ok = 1;
378 0         0 my $skip;
379             my $ffi;
380 0         0 my @diag;
381            
382             {
383 0         0 my $min = '0.12'; # the first CPAN release
  0         0  
384 0 0       0 $min = '0.15' if $opt->{ignore_not_found};
385 0 0       0 $min = '0.18' if $opt->{lang};
386 0         0 eval qq{ use FFI::Platypus $min };
387 0 0       0 if($@)
388             {
389 0         0 $ok = 0;
390 0         0 $skip = "Test requires FFI::Platypus $min";
391             }
392             }
393            
394 0 0 0     0 if($ok && $opt->{lang})
395             {
396 0         0 my $class = "FFI::Platypus::Lang::@{[ $opt->{lang} ]}";
  0         0  
397 0         0 eval qq{ use $class () };
398 0 0       0 if($@)
399             {
400 0         0 $ok = 0;
401 0         0 $skip = "Test requires FFI::Platypus::Lang::@{[ $opt->{lang} ]}";
  0         0  
402             }
403             }
404            
405 0 0       0 if($ok)
406             {
407             $ffi = FFI::Platypus->new(
408 0         0 lib => [map { $_->dynamic_libs } @aliens],
409             ignore_not_found => $opt->{ignore_not_found},
410             lang => $opt->{lang},
411 0         0 );
412 0 0       0 foreach my $symbol (@{ $opt->{symbols} || [] })
  0         0  
413             {
414 0 0       0 unless($ffi->find_symbol($symbol))
415             {
416 0         0 $ok = 0;
417 0         0 push @diag, " $symbol not found"
418             }
419             }
420             }
421            
422 0         0 my $ctx = context();
423            
424 0 0       0 if($skip)
425             {
426 0         0 $ctx->skip($message, $skip);
427             }
428             else
429             {
430 0         0 $ctx->ok($ok, $message);
431             }
432 0         0 $ctx->diag($_) for @diag;
433            
434 0         0 $ctx->release;
435              
436 0 0       0 if($cb)
437             {
438             $cb = sub {
439 0     0   0 my $ctx = context();
440 0         0 $ctx->plan(0, 'SKIP', "subtest requires ffi success");
441 0         0 $ctx->release;
442 0 0       0 } unless $ok;
443              
444 0         0 @_ = ("$message subtest", $cb, 1, $ffi);
445              
446 0         0 goto \&Test2::API::run_subtest;
447             }
448            
449 0         0 $ok;
450             }
451              
452             1;
453              
454             __END__