File Coverage

blib/lib/Test/RunValgrind.pm
Criterion Covered Total %
statement 43 61 70.4
branch 4 22 18.1
condition 6 12 50.0
subroutine 13 15 86.6
pod 2 2 100.0
total 68 112 60.7


line stmt bran cond sub pod time code
1             package Test::RunValgrind;
2             $Test::RunValgrind::VERSION = '0.2.1';
3 1     1   67231 use strict;
  1         12  
  1         29  
4 1     1   5 use warnings;
  1         2  
  1         26  
5              
6 1     1   26 use 5.014;
  1         3  
7              
8 1     1   4 use Test::More;
  1         2  
  1         5  
9 1     1   1070 use Path::Tiny qw/path/;
  1         13138  
  1         72  
10              
11             use Test::Trap
12 1     1   562 qw( trap $trap :flow:stderr(systemsafe):stdout(systemsafe):warn );
  1         43059  
  1         6  
13              
14 1     1   275 use Carp;
  1         2  
  1         668  
15              
16             sub new
17             {
18 3     3 1 852 my $class = shift;
19              
20 3         10 my $self = bless {}, $class;
21              
22 3         10 $self->_init(@_);
23              
24 3         7 return $self;
25             }
26              
27             sub _supress_stderr
28             {
29 3     3   6 my $self = shift;
30              
31 3 50       7 if (@_)
32             {
33 3         11 $self->{_supress_stderr} = shift;
34             }
35              
36 3         7 return $self->{_supress_stderr};
37             }
38              
39             sub _ignore_leaks
40             {
41 5     5   8 my $self = shift;
42              
43 5 100       11 if (@_)
44             {
45 3         5 $self->{_ignore_leaks} = shift;
46             }
47              
48 5         21 return $self->{_ignore_leaks};
49             }
50              
51             sub _valgrind_args
52             {
53 3     3   5 my $self = shift;
54              
55 3 50       7 if (@_)
56             {
57 3         7 $self->{_valgrind_args} = shift;
58             }
59              
60 3         4 return $self->{_valgrind_args};
61             }
62              
63             sub _init
64             {
65 3     3   6 my ( $self, $args ) = @_;
66              
67 3   50     23 $self->_supress_stderr( $args->{supress_stderr} // 0 );
68 3   100     14 $self->_ignore_leaks( $args->{ignore_leaks} // 0 );
69 3   50     25 $self->_valgrind_args( $args->{valgrind_args} // 0 );
70              
71 3         5 return;
72             }
73              
74             sub _calc_verdict
75             {
76 3     3   15 my ( $self, $out_text ) = @_;
77              
78             return (
79             (
80 3   66     21 index( $$out_text, q{ERROR SUMMARY: 0 errors from 0 contexts} ) >= 0
81             )
82             && ( $self->_ignore_leaks
83             || ( index( $$out_text, q{in use at exit: 0 bytes} ) >= 0 ) )
84             );
85             }
86              
87             sub run
88             {
89 0     0 1   local $Test::Builder::Level = $Test::Builder::Level + 1;
90              
91 0           my ( $self, $args ) = @_;
92              
93             my $blurb = $args->{blurb}
94 0 0         or Carp::confess("blurb not specified.");
95              
96             my $log_fn = $args->{log_fn}
97 0 0         or Carp::confess("log_fn not specified.");
98              
99             my $prog = $args->{prog}
100 0 0         or Carp::confess("prog not specified.");
101              
102             my $argv = $args->{argv}
103 0 0         or Carp::confess("argv not specified.");
104              
105             trap
106             {
107              
108             system(
109             "valgrind",
110             "--track-origins=yes",
111             ( $self->_ignore_leaks ? () : ("--leak-check=yes") ),
112             "--log-file=$log_fn",
113 0 0   0     ( $self->_valgrind_args ? @{ $self->_valgrind_args } : () ),
  0 0          
114             $prog,
115             @$argv,
116             );
117 0           };
118              
119 0           STDOUT->print( $trap->stdout );
120 0           my $out_text = path($log_fn)->slurp_utf8;
121 0           my $VERDICT = $self->_calc_verdict( \$out_text );
122              
123 0 0 0       if ( ( !$VERDICT ) and ( !$self->_supress_stderr ) )
124             {
125 0           STDERR->print( $trap->stderr );
126             }
127 0           my $ret = Test::More::ok( $VERDICT, $blurb );
128 0 0         if ($ret)
129             {
130 0           unlink($log_fn);
131             }
132 0           return $ret;
133             }
134              
135             1;
136              
137             __END__