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  }
  22 }
  23
  24 use Test::Builder;
  25
  26 sub new {
  27  my $class = shift;
  28
  29  $class->SUPER::new(
  30   diag        => 1,
  31   extra_tests => $extra_tests,
  32  );
  33 }
  34
  35 my @filtered_reports;
  36
  37 sub report_smart {
  38  my ($self, $sess, $report) = @_;
  39
  40  if ($report->can('is_leak') and $report->is_leak) {
  41   my $data  = $report->data;
  42   my @trace = map $_->[2] || '?',
  43                @{$data->{stack} || []}[0 .. 3];
  44   my $valid_trace = (
  45        $trace[0] eq 'malloc'
  46    and $trace[1] eq 'tv_leak'
  47    and ($trace[2] eq 'Perl_pp_entersub' or $trace[3] eq 'Perl_pp_entersub')
  48   );
  49
  50   if ($valid_trace) {
  51    push @filtered_reports, [
  52     $report->dump,
  53     $data->{leakedbytes},
  54     $data->{leakedblocks},
  55    ];
  56    return;
  57   }
  58  }
  59
  60  $self->SUPER::report($sess, $report);
  61 }
  62
  63 sub DESTROY {
  64  return unless $extra_tests;
  65
  66  my $tb = Test::Builder->new;
  67
  68  $tb->is_eq(scalar(@filtered_reports), 1, 'caught one extra leak');
  69
  70  if (@filtered_reports) {
  71   my $first = shift @filtered_reports;
  72   $tb->diag("The subsequent report was correctly caught:\n" . $first->[0]);
  73   $tb->is_eq($first->[1], 10_000, '10_000 bytes leaked');
  74   $tb->is_eq($first->[2], 1,      '  in one block');
  75
  76   for my $extra_report (@filtered_reports) {
  77    $tb->diag(
  78     "The subsequent report should NOT have been caught:\n" . $extra_report->[0]
  79    );
  80   }
  81  } else {
  82   $tb->ok(0, 'no extra leak caught, hence no bytes leaked');
  83   $tb->ok(0, 'no extra leak caught, hence no block leaked');
  84  }
  85 }
  86
  87 1;