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

diff --git a/MANIFEST b/MANIFEST
index 6e5ab39..60a2f97 100644 (file)
--- 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 3214b33..08a9906 100644 (file)
--- 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 a3ed8f6..5f95d00 100755 (executable)
--- 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 (file)
index 0000000..fb25ea7
--- /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
+}