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