- if (!defined $args{run} && !$run) {
- my ($file, $pm, $next);
- my $l = 0;
- while ($l < 1000) {
- $next = (caller $l++)[1];
- last unless defined $next;
- next unless $next ne '-e' and $next !~ /^\s*\(\s*eval\s*\d*\s*\)\s*$/
- and -f $next;
- if ($next =~ /\.pm$/) {
- $pm = $next;
- } else {
- $file = $next;
- }
- }
- unless (defined $file) {
- $file = $pm;
- return unless defined $pm;
- }
- my $callers = $args{callers};
- $callers = 12 unless defined $callers;
- $callers = int $callers;
- my $vg = Test::Valgrind::Suppressions::VG_PATH;
- if (!$vg || !-x $vg) {
- for (split /:/, $ENV{PATH}) {
- $_ .= '/valgrind';
- if (-x) {
- $vg = $_;
- last;
- }
- }
- if (!$vg) {
- $Test->skip_all('No valgrind executable could be found in your path');
- return;
- }
- }
- pipe my $ordr, my $owtr or die "pipe(\$ordr, \$owtr): $!";
- pipe my $vrdr, my $vwtr or die "pipe(\$vrdr, \$vwtr): $!";
- my $pid = fork;
- if (!defined $pid) {
- die "fork(): $!";
- } elsif ($pid == 0) {
- setpgrp 0, 0 or die "setpgrp(0, 0): $!";
- close $ordr or die "close(\$ordr): $!";
- open STDOUT, '>&=', $owtr or die "open(STDOUT, '>&=', \$owtr): $!";
- close $vrdr or die "close(\$vrdr): $!";
- fcntl $vwtr, F_SETFD, 0 or die "fcntl(\$vwtr, F_SETFD, 0): $!";
- my @args = (
- $vg,
- '--tool=memcheck',
- '--leak-check=full',
- '--leak-resolution=high',
- '--num-callers=' . $callers,
- '--error-limit=yes',
- '--log-fd=' . fileno($vwtr)
- );
- unless ($args{no_supp}) {
- for (Test::Valgrind::Suppressions::supp_path(), $args{supp}) {
- push @args, '--suppressions=' . $_ if $_;
- }
- }
- if (defined $args{extra} and ref $args{extra} eq 'ARRAY') {
- push @args, @{$args{extra}};
- }
- push @args, $^X;
- push @args, '-I' . $_ for @INC;
- push @args, '-MTest::Valgrind=run,1', $file;
- print STDOUT "valgrind @args\n";
- local $ENV{PERL_DESTRUCT_LEVEL} = 3;
- local $ENV{PERL_DL_NONLAZY} = 1;
- exec { $args[0] } @args;
- die "exec @args: $!";
- }
- local $SIG{INT} = sub { kill -(SIGTERM) => $pid };
- $Test->plan(tests => 5) unless $args{no_test} or defined $Test->has_plan;
- my @tests = (
- 'errors',
- 'definitely lost', 'indirectly lost', 'possibly lost', 'still reachable'
- );
- my %res = map { $_ => 0 } @tests;
- close $owtr or die "close(\$owtr): $!";
- close $vwtr or die "close(\$vwtr): $!";
- while (<$vrdr>) {
- $Test->diag($_) if $args{diag};
- if (/^=+\d+=+\s*FATAL\s*:\s*(.*)/) {
- chomp(my $err = $1);
- $Test->diag("Valgrind error: $err");
- $res{$_} = undef for @tests;
- }
- if (/ERROR\s+SUMMARY\s*:\s+(\d+)/) {
- $res{errors} = int $1;
- } elsif (/([a-z][a-z\s]*[a-z])\s*:\s*([\d.,]+)/) {
- my ($cat, $count) = ($1, $2);
- if (exists $res{$cat}) {
- $cat =~ s/\s+/ /g;
- $count =~ s/[.,]//g;
- $res{$cat} = int $count;
- }
- }
- }
- waitpid $pid, 0;
- $Test->diag(do { local $/; <$ordr> }) if $args{diag};
- close $ordr or die "close(\$ordr): $!";
- my $failed = 5;
- my $cb = ($args{no_test} ? \&_counter
- : ($args{cb} ? $args{cb} : \&_tester));
- for (@tests) {
- $failed -= $cb->($res{$_}, 'valgrind ' . $_) ? 1 : 0;