+sub check_suppressions_file {
+ my ($self, $file) = @_;
+
+ {
+ open my $fh, '<', $file or return 0;
+
+ local $_;
+ while (<$fh>) {
+ return 1 if /^\s*fun:(Perl|S|XS)_/
+ or /^\s*obj:.*perl/;
+ }
+
+ close $fh;
+ }
+
+ return 0;
+}
+
+sub filter {
+ my ($self, $session, $report) = @_;
+
+ return $report if $report->is_diag
+ or not $report->isa('Test::Valgrind::Report::Suppressions');
+
+ my @frames = grep length, split /\n/, $report->data;
+
+ # If we see the runloop, match from here.
+ my $top = List::Util::first(sub {
+ $frames[$_] =~ /^\s*fun:Perl_runops_(?:standard|debug)\b/
+ }, 0 .. $#frames);
+ --$top if $top;
+
+ unless (defined $top) {
+ # Otherwise, match from the latest Perl_ symbol.
+ $top = List::Util::first(sub {
+ $frames[$_] =~ /^\s*fun:Perl_/
+ }, reverse 0 .. $#frames);
+ }
+
+ unless (defined $top) {
+ # Otherwise, match from the latest S_ symbol.
+ $top = List::Util::first(sub {
+ $frames[$_] =~ /^\s*fun:S_/
+ }, reverse 0 .. $#frames);
+ }
+
+ unless (defined $top) {
+ # Otherwise, match from the latest XS_ symbol.
+ $top = List::Util::first(sub {
+ $frames[$_] =~ /^\s*fun:XS_/
+ }, reverse 0 .. $#frames);
+ }
+
+ $#frames = $top if defined $top;
+
+ my $data = join "\n", @frames, '';
+
+ $data = Test::Valgrind::Suppressions->maybe_generalize($session, $data);
+
+ $report->new(
+ id => $report->id,
+ kind => $report->kind,
+ data => $data,
+ );
+}
+