t/lib/Test/Valgrind/Test/Action.pm

   1 package Test::Valgrind::Test::Action;
   2
   3 use strict;
   4 use warnings;
   5
   6 use base qw<Test::Valgrind::Action::Test>;
   7
   8 my $extra_tests;
   9
  10 BEGIN {
  11  eval {
  12   require Test::Valgrind;
  13   require XSLoader;
  14   XSLoader::load('Test::Valgrind', $Test::Valgrind::VERSION);
  15  };
  16  if ($@) {
  17   $extra_tests = 0;
  18  } else {
  19   $extra_tests = 3;
  20   *report = *report_smart;
  21   *abort  = *abort_smart;
  22  }
  23 }
  24
  25 use Test::Builder;
  26
  27 sub new {
  28  my $class = shift;
  29
  30  $class->SUPER::new(
  31   diag        => 1,
  32   extra_tests => $extra_tests,
  33  );
  34 }
  35
  36 my @filtered_reports;
  37
  38 sub report_smart {
  39  my ($self, $sess, $report) = @_;
  40
  41  if ($report->can('is_leak') and $report->is_leak) {
  42   my $data  = $report->data;
  43   my @trace = map $_->[2] || '?',
  44                @{$data->{stack} || []}[0 .. 3];
  45   my $valid_trace = (
  46        $trace[0] eq 'malloc'
  47    and $trace[1] eq 'tv_leak'
  48    and ($trace[2] eq 'Perl_pp_entersub' or $trace[3] eq 'Perl_pp_entersub')
  49   );
  50
  51   if ($valid_trace) {
  52    push @filtered_reports, [
  53     $report->dump,
  54     $data->{leakedbytes},
  55     $data->{leakedblocks},
  56    ];
  57    return;
  58   }
  59  }
  60
  61  $self->SUPER::report($sess, $report);
  62 }
  63
  64 sub abort_smart {
  65  my $self = shift;
  66
  67  $extra_tests = 0;
  68
  69  $self->SUPER::abort(@_);
  70 }
  71
  72 sub DESTROY {
  73  return unless $extra_tests;
  74
  75  my $tb = Test::Builder->new;
  76
  77  $tb->is_eq(scalar(@filtered_reports), 1, 'caught one extra leak');
  78
  79  if (@filtered_reports) {
  80   my $first = shift @filtered_reports;
  81   $tb->diag("The subsequent report was correctly caught:\n" . $first->[0]);
  82   $tb->is_eq($first->[1], 10_000, '10_000 bytes leaked');
  83   $tb->is_eq($first->[2], 1,      '  in one block');
  84
  85   for my $extra_report (@filtered_reports) {
  86    $tb->diag(
  87     "The subsequent report should NOT have been caught:\n" . $extra_report->[0]
  88    );
  89   }
  90  } else {
  91   $tb->ok(0, 'no extra leak caught, hence no bytes leaked');
  92   $tb->ok(0, 'no extra leak caught, hence no block leaked');
  93  }
  94 }
  95
  96 1;