1 package Test::Valgrind::Test::Action;
6 use base qw<Test::Valgrind::Action::Test>;
12 require Test::Valgrind;
14 XSLoader::load('Test::Valgrind', $Test::Valgrind::VERSION);
20 *report = *report_smart;
21 *abort = *abort_smart;
32 extra_tests => $extra_tests,
39 my ($self, $sess, $report) = @_;
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];
47 and $trace[1] eq 'tv_leak'
48 and ($trace[2] eq 'Perl_pp_entersub' or $trace[3] eq 'Perl_pp_entersub')
52 push @filtered_reports, [
55 $data->{leakedblocks},
61 $self->SUPER::report($sess, $report);
69 $self->SUPER::abort(@_);
73 return unless $extra_tests;
75 my $tb = Test::Builder->new;
77 $tb->is_eq(scalar(@filtered_reports), 1, 'caught one extra leak');
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');
85 for my $extra_report (@filtered_reports) {
87 "The subsequent report should NOT have been caught:\n" . $extra_report->[0]
91 $tb->ok(0, 'no extra leak caught, hence no bytes leaked');
92 $tb->ok(0, 'no extra leak caught, hence no block leaked');