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

package Test::RunValgrind;
$Test::RunValgrind::VERSION = '0.2.0';
use strict;
use warnings;

use 5.014;

use Test::More;
use Path::Tiny qw/path/;

use Test::Trap
    qw( trap $trap :flow:stderr(systemsafe):stdout(systemsafe):warn );

use Carp;

sub new
{
    my $class = shift;

    my $self = bless {}, $class;

    $self->_init(@_);

    return $self;
}

sub _supress_stderr
{
    my $self = shift;

    if (@_)
    {
        $self->{_supress_stderr} = shift;
    }

    return $self->{_supress_stderr};
}

sub _ignore_leaks
{
    my $self = shift;

    if (@_)
    {
        $self->{_ignore_leaks} = shift;
    }

    return $self->{_ignore_leaks};
}

sub _valgrind_args
{
    my $self = shift;

    if (@_)
    {
        $self->{_valgrind_args} = shift;
    }

    return $self->{_valgrind_args};
}

sub _init
{
    my ( $self, $args ) = @_;

    $self->_supress_stderr( $args->{supress_stderr} // 0 );
    $self->_ignore_leaks( $args->{ignore_leaks} // 0 );
    $self->_valgrind_args( $args->{valgrind_args} // 0 );

    return;
}

sub _calc_verdict
{
    my ( $self, $out_text ) = @_;

    return (
        (
            index( $$out_text, q{ERROR SUMMARY: 0 errors from 0 contexts} ) >= 0
        )
            && ( $self->_ignore_leaks
            || ( index( $$out_text, q{in use at exit: 0 bytes} ) >= 0 ) )
    );
}

sub run
{
    local $Test::Builder::Level = $Test::Builder::Level + 1;

    my ( $self, $args ) = @_;

    my $blurb = $args->{blurb}
        or Carp::confess("blurb not specified.");

    my $log_fn = $args->{log_fn}
        or Carp::confess("log_fn not specified.");

    my $prog = $args->{prog}
        or Carp::confess("prog not specified.");

    my $argv = $args->{argv}
        or Carp::confess("argv not specified.");

    trap
    {

        system(
            "valgrind",
            "--track-origins=yes",
            ( $self->_ignore_leaks ? () : ("--leak-check=yes") ),
            "--log-file=$log_fn",
            ( $self->_valgrind_args ? @{ $self->_valgrind_args } : () ),
            $prog,
            @$argv,
        );
    };

    STDOUT->print( $trap->stdout );
    my $out_text = path($log_fn)->slurp_utf8;
    my $VERDICT  = $self->_calc_verdict( \$out_text );

    if ( ( !$VERDICT ) and ( !$self->_supress_stderr ) )
    {
        STDERR->print( $trap->stderr );
    }
    my $ret = Test::More::ok( $VERDICT, $blurb );
    if ($ret)
    {
        unlink($log_fn);
    }
    return $ret;
}

1;

__END__