- my %res = map { $_ => 0 } @tests;
- while (<$rdr>) {
- diag $_ if $args{diag};
- if (/^=+\d+=+\s*FATAL\s*:\s*(.*)/) {
- chomp(my $err = $1);
- 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;
- my $failed = 0;
- for (@tests) {
- is($res{$_}, 0, 'valgrind ' . $_) unless $args{no_test};
- ++$failed if defined $res{$_} and $res{$_} != 0;
- }
- exit $failed;
- } else {
- $run = 1;
+ }
+
+ my $tool = delete $args{tool};
+ unless ($tool->$instanceof('Test::Valgrind::Tool')) {
+ require Test::Valgrind::Tool;
+ $tool = Test::Valgrind::Tool->new(
+ tool => $tool || 'memcheck',
+ callers => delete($args{callers}),
+ );
+ }
+
+ my $action = delete $args{action};
+ unless ($action->$instanceof('Test::Valgrind::Action')) {
+ require Test::Valgrind::Action;
+ $action = Test::Valgrind::Action->new(
+ action => $action || 'Test',
+ diag => delete($args{diag}),
+ );
+ }
+
+ require Test::Valgrind::Session;
+ my $sess = eval {
+ Test::Valgrind::Session->new(
+ min_version => $tool->requires_version,
+ map { $_ => delete $args{$_} } qw/extra_supps no_def_supp/
+ );
+ };
+ unless ($sess) {
+ $action->abort($sess, $@);
+ exit $action->status($sess);
+ }
+
+ eval {
+ $sess->run(
+ command => $cmd,
+ tool => $tool,
+ action => $action,
+ );
+ };
+ if ($@) {
+ require Test::Valgrind::Report;
+ $action->report($sess, Test::Valgrind::Report->new_diag($@));
+ }
+
+ my $status = $sess->status;
+ $status = 255 unless defined $status;
+
+ exit $status;
+}
+
+END {
+ if ($run and eval { require DynaLoader; 1 }) {
+ my @rest;
+ DynaLoader::dl_unload_file($_) or push @rest, $_ for @DynaLoader::dl_librefs;
+ @DynaLoader::dl_librefs = @rest;