- my $callers = $args{callers} || 50;
- $callers = int $callers;
- pipe my $rdr, my $wtr or croak "pipe(\$rdr, \$wtr): $!";
- my $pid = fork;
- if (!defined $pid) {
- croak "fork(): $!";
- } elsif ($pid == 0) {
- setpgrp 0, 0 or croak "setpgrp(0, 0): $!";
- close $rdr or croak "close(\$rdr): $!";
- open STDERR, '>&', $wtr or croak "open(STDERR, '>&', \$wtr): $!";
- my @args = (
- '--tool=memcheck',
- '--leak-check=full',
- '--leak-resolution=high',
- '--num-callers=' . $callers,
- '--error-limit=yes'
- );
- 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 STDERR "valgrind @args\n" if $args{diag};
- local $ENV{PERL_DESTRUCT_LEVEL} = 3;
- local $ENV{PERL_DL_NONLAZY} = 1;
- my $vg = Test::Valgrind::Suppressions::VG_PATH;
- exec $vg, @args if $vg and -x $vg;
+ $run = 1;
+ return;
+ }
+
+ my ($file, $pm, $next);
+ my $l = 0;
+ while ($l < 1000) {
+ $next = (caller $l++)[1];
+ last unless defined $next;
+ next if $next eq '-e' or $next =~ /^\s*\(\s*eval\s*\d*\s*\)\s*$/ or !-f $next;
+ if ($next =~ /\.pm$/) {
+ $pm = $next;
+ } else {
+ $file = $next;