- close $wtr or croak "close(\$wtr): $!";
- 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;
- while (<$rdr>) {
- $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;
- }
+ }
+
+ my $status = $sess->status;
+ $status = 255 unless defined $status;
+
+ return $status;
+}
+
+=head2 C<import>
+
+ use Test::Valgrind %options;
+
+In the parent process, L</import> calls L</analyse> with the arguments it received itself - except that if no C<file> option was supplied, it tries to pick the first caller context that looks like a script.
+When the analysis ends, it exits with the status returned by the action (for the default TAP-generator action, it's the number of failed tests).
+
+In the child process, it just C<return>s so that the calling code is actually run under C<valgrind>, albeit two side-effects :
+
+=over 4
+
+=item *
+
+L<Perl::Destruct::Level> is loaded and the destruction level is set to C<3>.
+
+=item *
+
+Autoflush on C<STDOUT> is turned on.
+
+=back
+
+=cut
+
+# We use as little modules as possible in run mode so that they don't pollute
+# the analysis. Hence all the requires.
+
+my $run;
+
+sub import {
+ my $class = shift;
+ $class = ref($class) || $class;
+
+ _croak('Optional arguments must be passed as key => value pairs') if @_ % 2;
+ my %args = @_;
+
+ if (defined delete $args{run} or $run) {
+ require Perl::Destruct::Level;
+ Perl::Destruct::Level::set_destruct_level(3);
+ {
+ my $oldfh = select STDOUT;
+ $|++;
+ select $oldfh;
+ }
+ $run = 1;
+ return;
+ }
+
+ my $file = delete $args{file};
+ unless (defined $file) {
+ my ($next, $last_pm);
+ for (my $l = 0; 1; ++$l) {
+ $next = (caller $l)[1];
+ last unless defined $next;
+ next if $next =~ /^\s*\(\s*eval\s*\d*\s*\)\s*$/;
+ if ($next =~ /\.pmc?$/) {
+ $last_pm = $next;
+ } else {
+ $file = $next;
+ last;