File Coverage

blib/lib/Test/Exec.pm
Criterion Covered Total %
statement 37 37 100.0
branch 2 2 100.0
condition 4 5 80.0
subroutine 11 11 100.0
pod 2 2 100.0
total 56 57 98.2


line stmt bran cond sub pod time code
1             package Test::Exec;
2              
3 3     3   540422 use strict;
  3         8  
  3         97  
4 3     3   20 use warnings;
  3         7  
  3         100  
5 3     3   20 use Test2::API qw( context );
  3         7  
  3         145  
6 3     3   1320 use Return::MultiLevel qw( with_return );
  3         10295  
  3         163  
7 3     3   22 use base 'Exporter';
  3         6  
  3         413  
8              
9             # ABSTRACT: Test that some code calls exec without terminating testing
10             our $VERSION = '0.04'; # VERSION
11              
12              
13             our @EXPORT = qw( exec_arrayref never_exec_ok );
14              
15             our $exec_handler = sub {
16             CORE::exec(@_);
17             };
18             BEGIN {
19 3     3   699 *CORE::GLOBAL::exec = sub { $exec_handler->(@_) };
  4     4   201  
20             }
21              
22              
23             my $last;
24              
25             sub exec_arrayref(&)
26             {
27 7     7 1 5740 my($code) = @_;
28            
29 7         16 undef $last;
30            
31             return with_return {
32 7     7   431 my($return) = @_;
33             local $exec_handler = sub {
34 4         30 $last = [caller(1)];
35 4         18 $return->([@_]);
36 7         24 };
37 7         20 $code->();
38 3         526 undef;
39 7         39 };
40             }
41              
42              
43             sub never_exec_ok (&;$)
44             {
45 3     3 1 10564 my($code, $name) = @_;
46            
47 3   100     17 $name ||= 'does not call exec';
48            
49 3     3   13 my $ret = exec_arrayref { $code->() };
  3         8  
50 3         32 my $ok = !defined $ret;
51            
52 3         12 my $ctx = context();
53 3         229 $ctx->ok($ok, $name);
54            
55 3 100 66     316 if(!$ok && $last)
56             {
57 1         3 my($package, $filename, $line) = @$last;
58 1         5 $ctx->diag("exec at $filename line $line");
59             }
60            
61 3         70 $ctx->release;
62             }
63              
64             1;
65              
66             __END__