Re: valgrind as a leak hound?

From: "Marcus Holland-Moritz" <mhx-perl@gmx.net>
Message-ID: <002201c368f4$4e5a5e40$0c2f1fac@R2D2>

Add the leak detection to valgrind testing.

p4raw-id: //depot/perl@20850

4 files changed, 70 insertions, 28 deletions

diff --git a/MANIFEST b/MANIFEST
index 6e5ab396fa..60a2f9745a 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -2796,6 +2796,7 @@ t/op/vec.t			See if vectors work
 t/op/ver.t			See if v-strings and the %v format flag work
 t/op/wantarray.t		See if wantarray works
 t/op/write.t			See if write works (formats work)
+t/perl.supp			Perl valgrind suppressions
 t/pod/emptycmd.t		Test empty pod directives
 t/pod/emptycmd.xr		Expected results for emptycmd.t
 t/pod/find.t			See if Pod::Find works
diff --git a/pod/perlhack.pod b/pod/perlhack.pod
index 3214b330d3..08a9906f45 100644
--- a/pod/perlhack.pod
+++ b/pod/perlhack.pod
@@ -2075,13 +2075,13 @@ simply kill away that testing process.
 The excellent valgrind tool can be used to find out both memory leaks
 and illegal memory accesses.  As of August 2003 it unfortunately works
 only on x86 (ELF) Linux.  The special "test.valgrind" target can be used
-to run the tests under valgrind.  Note that in the test script (t/TEST)
-currently (as of Perl 5.8.1) only naughty memory accesses are logged,
-not memory leaks.  Found errors are logged in files named F<test.valgrind>.
-Also note that with Perl built with ithreads, the glibc (at least 2.2.5)
-seems to have a bug of its own, where a non-locked POSIX mutex is
-unlocked, and valgrind catches this, for every test-- therefore the
-test script ignores that error.
+to run the tests under valgrind.  Found errors and memory leaks are
+logged in files named F<test.valgrind>.
+
+As system libraries (most notably glibc) are also triggering errors,
+valgrind allows to suppress such errors using suppression files. The
+default suppression file that comes with valgrind already catches a lot
+of them. Some additional suppressions are defined in F<t/perl.supp>.
 
 To get valgrind and for more information see
 
diff --git a/t/TEST b/t/TEST
index a3ed8f6354..5f95d00740 100755
--- a/t/TEST
+++ b/t/TEST
@@ -112,7 +112,7 @@ unless (@ARGV) {
         warn "$0: cannot open $mani: $!\n";
     }
     unless ($core) {
-	_find_tests('pod');  
+	_find_tests('pod');
 	_find_tests('x2p');
 	_find_tests('japh') if $torture;
     }
@@ -265,7 +265,9 @@ EOT
 	    my $perl = $ENV{PERL} || './perl';
 	    my $redir = ($^O eq 'VMS' || $ENV{PERL_VALGRIND} ? '2>&1' : '');
 	    if ($ENV{PERL_VALGRIND}) {
-		$perl = "valgrind --num-callers=50 --leak-check=yes $perl";
+		$perl = "valgrind --suppressions=perl.supp --leak-check=yes "
+                               . "--leak-resolution=high --show-reachable=yes "
+                               . "--num-callers=50 $perl";
 	    }
 	    my $run = "$perl" . _quote_args("$testswitch $switch $utf") . " $test $redir|";
 	    open(RESULTS,$run) or print "can't run '$run': $!.\n";
@@ -364,30 +366,30 @@ EOT
 	close RESULTS;
 	if ($ENV{PERL_VALGRIND}) {
 	    if (@valgrind) {
-		my $skip_pthread_mutex_unlock;
+		my $leaks = 0;
+		my $errors = 0;
 		for my $i (0..$#valgrind) {
 		    local $_ = $valgrind[$i];
-		    my $pid;
-		    if (/^==(\d+)== pthread_mutex_unlock: mutex is not locked/ &&
-			($pid = $1) &&
-			$valgrind[$i+2] =~ m{\(in .+/libc.+\.so\)}) {
-			$skip_pthread_mutex_unlock++;
-		    } elsif (/^==\d+== ERROR SUMMARY: (\d+) errors? /) {
-			$errors = $1;
+		    if (/^==\d+== ERROR SUMMARY: (\d+) errors? /) {
+			$errors += $1;   # there may be multiple error summaries
+		    } elsif (/^==\d+== LEAK SUMMARY:/) {
+			for my $off (1 .. 4) {
+			    if ($valgrind[$i+$off] =~
+				/(?:lost|reachable):\s+\d+ bytes in (\d+) blocks/) {
+				$leaks += $1;
+			    }
+			}
 		    }
 		}
-		if (defined $errors) {
-		    $errors -= $skip_pthread_mutex_unlock;
-		    if ($errors) {
-			if (open(V, ">$test.valgrind")) {
-			    for (@valgrind) {
-				print V $_;
-			    }
-			    close V;
-			    $valgrind++;
-			} else {
-			    warn "$0: Failed to create '$test.valgrind': $!\n";
+		if ($errors or $leaks) {
+		    if (open(V, ">$test.valgrind")) {
+			for (@valgrind) {
+			    print V $_;
 			}
+			close V;
+			$valgrind++;
+		    } else {
+			warn "$0: Failed to create '$test.valgrind': $!\n";
 		    }
 		}
 	    } else {
diff --git a/t/perl.supp b/t/perl.supp
new file mode 100644
index 0000000000..fb25ea7c5c
--- /dev/null
+++ b/t/perl.supp
@@ -0,0 +1,39 @@
+## Catch various leaks during dlopen...
+{
+   calloc
+   Memcheck:Leak
+   fun:calloc
+   obj:/lib/ld-2.*.so
+}
+{
+   malloc
+   Memcheck:Leak
+   fun:malloc
+   obj:/lib/ld-2.*.so
+}
+{
+   realloc
+   Memcheck:Leak
+   fun:malloc
+   fun:realloc
+   obj:/lib/ld-2.*.so
+}
+{
+   calloc
+   Memcheck:Leak
+   fun:calloc
+   obj:/lib/libdl-2.*.so
+}
+{
+   malloc
+   Memcheck:Leak
+   fun:malloc
+   obj:/lib/libdl-2.*.so
+}
+{
+   realloc
+   Memcheck:Leak
+   fun:malloc
+   fun:realloc
+   obj:/lib/libdl-2.*.so
+}