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 = 2;
  20   *report = *report_smart;
  21  }
  22 }
  23
  24 use Test::Builder;
  25
  26 sub new { shift->SUPER::new(extra_tests => $extra_tests) }
  27
  28 sub report_smart {
  29  my ($self, $sess, $report) = @_;
  30
  31  if ($report->can('is_leak') and $report->is_leak) {
  32   my $data  = $report->data;
  33   my @trace = map $_->[2] || '?',
  34                @{$data->{stack} || []}[0 .. 3];
  35   my $valid_trace = (
  36        $trace[0] eq 'malloc'
  37    and $trace[1] eq 'tv_leak'
  38    and ($trace[2] eq 'Perl_pp_entersub' or $trace[3] eq 'Perl_pp_entersub')
  39   );
  40
  41   if ($valid_trace) {
  42    my $tb = Test::Builder->new;
  43    $tb->diag("The subsequent report was correctly caught:\n" . $report->dump);
  44    $tb->is_eq($data->{leakedbytes},  10_000, '10_000 bytes leaked');
  45    $tb->is_eq($data->{leakedblocks}, 1,      '  in one block');
  46    return;
  47   }
  48  }
  49
  50  $self->SUPER::report($sess, $report);
  51 }
  52
  53 1;