Test real-life leaks with some XS

diff --git a/.gitignore b/.gitignore
index 10678cacf2a0cdcf04afa76e043bb22d9f9d4a86..8989f53bb3e6d18adaaa0a62d61dac69ab9a3205 100644 (file)
--- a/.gitignore
+++ b/.gitignore
@@ -3,6 +3,7 @@ pm_to_blib*
 
 Makefile
 Makefile.old
+Makefile.bak
 Build
 _build*
 

diff --git a/FixInstall.PL b/FixInstall.PL
new file mode 100755 (executable)
index 0000000..958f1f9
--- /dev/null
+++ b/FixInstall.PL
@@ -0,0 +1,33 @@
+use strict;
+use warnings;
+
+use File::Copy qw/copy/;
+
+my ($bak) = @ARGV;
+exit 1 unless defined $bak;
+
+my $mk = './Makefile';
+exit 1 unless defined $mk and -e $mk and -r _ and -w _;
+
+select STDERR;
+
+print "Fixing Makefile install targets\n";
+
+if (-e $bak && (stat $bak)[9] >= (stat $mk)[9]) { # mtime
+ print "Makefile is old\n";
+ copy($bak, $mk);
+} else {
+ print "Makefile is new\n";
+ copy($mk, $bak);
+}
+
+open my $in,  '<', $bak or die "open(<$bak): $!";
+open my $out, '>', $mk  or die "open(>$mk): $!";
+while (<$in>) {
+ s!^(\s*)\$\(INST_ARCHLIB\)\s+(\$\(DESTINSTALL(?:ARCHLIB|SITEARCH|VENDORARCH)\))\s*\\\s*!$1blib/archpub $2/\$(FULLEXT) \\\n!g;
+ print $out $_;
+}
+close $out;
+close $in;
+
+utime time, time, $bak; # Update mtime

diff --git a/MANIFEST b/MANIFEST
index 774c1e28863962e02c6a22ce4076fc39a8504799..074e4a05f7dbb02ed67c7bd223efd36b59b19884 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1,8 +1,10 @@
 Changes
+FixInstall.PL
 Gensupp.PL
 MANIFEST
 Makefile.PL
 README
+Valgrind.xs
 gen.pl
 lib/Test/Valgrind.pm
 lib/Test/Valgrind/perlTestValgrind.supp
@@ -13,6 +15,7 @@ t/00-load.t
 t/01-import.t
 t/10-suppressions.t
 t/20-good.t
+t/30-bad.t
 t/90-boilerplate.t
 t/91-pod.t
 t/92-pod-coverage.t

diff --git a/Makefile.PL b/Makefile.PL
index 62a9060bca44076d67a588b4ad2f05770a812e9c..1ac71726eae30d9e71bc2f3cbe8b3b752c4754f9 100644 (file)
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -4,6 +4,14 @@ use strict;
 use warnings;
 use ExtUtils::MakeMaker;
 
+BEGIN {
+ eval { require Config };
+ die 'OS unsupported' if $@;
+ Config->import(qw/%Config/);
+ eval { require File::Spec };
+ die 'OS unsupported' if $@;
+}
+
 my $vg;
 print 'Checking for valgrind >= 3.1.0 in PATH... ';
 for (split /:/, $ENV{PATH}) {
@@ -13,7 +21,7 @@ for (split /:/, $ENV{PATH}) {
   if ($ver =~ s/^valgrind-//) {
    $ver = join '', map chr, split /\./, $ver;
    if ($ver ge v3.1.0) {
-    print "yes, $_\n";
+    print "$_\n";
     $vg = $_;
     last;
    }
@@ -25,9 +33,36 @@ if (!$vg) {
  die 'OS unsupported';
 }
 
+# Inspired from Module::Install::Can
+print "Checking for a valid C compiler in the PATH... ";
+my @ccs = ($Config{cc});
+unshift @ccs, $ENV{CC} if $ENV{CC};
+my $cc;
+CC:
+for my $c (@ccs) {
+ for my $dir (split /$Config{path_sep}/, $ENV{PATH}) {
+  my $abs = File::Spec->catfile($dir, $c);
+  if (-x $abs or MM->maybe_command($abs)) {
+   $cc = $c;
+   last CC;
+  }
+ }
+}
+my (@C);
+if ($cc) {
+ my $xs = 'Valgrind.xs';
+ (my $c = $xs) =~ s/\.xs$/.c/;
+ push @C, $c;
+ print $cc, "\n";
+} else {
+ print "none\n";
+}
+
 my $BUILD_REQUIRES = {
  'ExtUtils::MakeMaker' => 0,
- 'Test::More'          => 0
+ 'File::Copy'          => 0,
+ 'Test::More'          => 0,
+ 'XSLoader'            => 0
 };
 
 sub build_req {
@@ -58,14 +93,18 @@ WriteMakefile(
     LICENSE       => 'perl',
     VERSION_FROM  => 'lib/Test/Valgrind.pm',
     ABSTRACT_FROM => 'lib/Test/Valgrind.pm',
-    PL_FILES      => { './Gensupp.PL' => 'lib/' . $supp },
+    PL_FILES      => {
+        './Gensupp.PL'    => 'blib/archpub/' . $supp,
+        './FixInstall.PL' => 'Makefile.bak',
+    },
+    OPTIMIZE      => '-g',
     PM            => {
         'lib/Test/Valgrind.pm'
         => '$(INST_LIB)/Test/Valgrind.pm',
         'lib/Test/Valgrind/Suppressions.pm'
-        => '$(INST_ARCHLIB)/Test/Valgrind/Suppressions.pm',
-        'lib/' . $supp => '$(INST_ARCHLIB)/' . $supp,
+        => 'blib/archpub/Test/Valgrind/Suppressions.pm',
     },
+    C             => \@C,
     PREREQ_PM     => {
         'Carp'                  => 0,
         'Exporter'              => 0,
@@ -74,20 +113,21 @@ WriteMakefile(
         'Test::More'            => 0,
     },
     dist          => {
-        PREOP      => 'pod2text lib/Test/Valgrind.pm > $(DISTVNAME)/README; '
+        PREOP      => "touch lib/$supp; "
+                      . 'pod2text lib/Test/Valgrind.pm > $(DISTVNAME)/README; '
                       . build_req,
         COMPRESS   => 'gzip -9f', SUFFIX => 'gz',
     },
-    clean         => { FILES => "Test-Valgrind-* lib/$supp *.gcov *.gcda *.gcno cover_db Debian_CPANTS.txt" },
+    clean         => { FILES => "Test-Valgrind-* lib/$supp Makefile.bak *.gcov *.gcda *.gcno cover_db Debian_CPANTS.txt" },
 );
 1 while unlink 'lib/' . $supp;
 
 package MY;
 
 sub postamble {
- <<POSTAMBLE;
+ <<'POSTAMBLE';
 clean ::
-\t\$(CP) lib/Test/Valgrind/Suppressions.{tpl,pm}
-\t\$(TOUCH) lib/Test/Valgrind/perlTestValgrind.supp
+       $(CP) lib/Test/Valgrind/Suppressions.{tpl,pm}
+       $(TOUCH) lib/Test/Valgrind/perlTestValgrind.supp
 POSTAMBLE
 }

diff --git a/Valgrind.xs b/Valgrind.xs
new file mode 100644 (file)
index 0000000..d504856
--- /dev/null
+++ b/Valgrind.xs
@@ -0,0 +1,46 @@
+/* This file is part of the Scalar::Vec::Util Perl module.
+ * See http://search.cpan.org/dist/Scalar-Vec-Util/ */
+
+#define PERL_NO_GET_CONTEXT
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#define __PACKAGE__ "Test::Valgrind"
+
+#ifndef Newx
+# define Newx(v, n, c) New(0, v, n, c)
+#endif
+
+#ifndef DEBUGGING
+# define DEBUGGING 0
+#endif
+
+const char *tvtxs_leaky = NULL;
+
+/* --- XS ------------------------------------------------------------------ */
+
+MODULE = Test::Valgrind            PACKAGE = Test::Valgrind
+
+PROTOTYPES: DISABLE
+
+BOOT:
+{
+ HV *stash = gv_stashpv(__PACKAGE__, 1);
+ newCONSTSUB(stash, "DEBUGGING", newSVuv(DEBUGGING));
+}
+
+void
+leak()
+CODE:
+ Newx(tvtxs_leaky, 10000, char);
+ XSRETURN_UNDEF;
+
+SV *
+notleak(SV *sv)
+CODE:
+ Newx(tvtxs_leaky, 10000, char);
+ Safefree(tvtxs_leaky);
+ RETVAL = newSVsv(sv);
+OUTPUT:
+ RETVAL

diff --git a/gen.pl b/gen.pl
index ff82e873813d9f3d8cbcf11bae6a0288a414a587..828a6b9279380589ced71dade59828d527b155de 100755 (executable)
--- a/gen.pl
+++ b/gen.pl
@@ -5,16 +5,24 @@ use warnings;
 
 use Test::More;
 eval <<'EOD';
-use Test::Valgrind diag => 1,
-                   no_test => 1,
-                   no_supp => 1,
-                   extra => [
-                    q{--show-reachable=yes},
-                    q{--gen-suppressions=all},
-#                    q{--log-fd=1}
-                   ]
+use Test::Valgrind
+ diag    => 1,
+ no_test => 1,
+ no_supp => 1,
+ callers => 50,
+ extra   => [ qw/--show-reachable=yes --gen-suppressions=all/ ]
 EOD
-plan skip_all => 'Test::Valgrind is required to run test your distribution with valgrind' if $@;
+if ($@) {
+ plan skip_all => 'Test::Valgrind is required to run test your distribution with valgrind';
+} else {
+ eval {
+  require XSLoader;
+  XSLoader::load('Test::Valgrind', $Test::Valgrind::VERSION);
+ };
+ unless ($@) {
+  Test::Valgrind::notleak("valgrind it!");
+ }
+}
 
 1;
 

diff --git a/samples/map.pl b/samples/map.pl
index e291605aa6b7ddfffac24f2d29928f81de8435e1..f19ab3a9e3443af88a1cdd5b83b756e9e45909a7 100755 (executable)
--- a/samples/map.pl
+++ b/samples/map.pl
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use lib qw{blib/lib blib/arch};
+use lib qw{blib/lib blib/archpub};
 use Test::Valgrind;
 
 {

diff --git a/t/00-load.t b/t/00-load.t
index 91a8a960cd1d1dfd086622545e6043766600e4ef..de83532fecb82231f7fd58698db947d187ca0d78 100644 (file)
--- a/t/00-load.t
+++ b/t/00-load.t
@@ -5,6 +5,7 @@ use warnings;
 
 use Test::More tests => 1;
 
+use lib qw{blib/archpub};
 BEGIN {
        use_ok( 'Test::Valgrind::Suppressions' );
 }

diff --git a/t/01-import.t b/t/01-import.t
index cb0938f7ae33efa1049fbf0e3685549c913566c8..26733da5a9206bc3cba68e0797027b1f20ca3a8c 100644 (file)
--- a/t/01-import.t
+++ b/t/01-import.t
@@ -5,6 +5,7 @@ use warnings;
 
 use Test::More tests => 2;
 
+use lib qw{blib/archpub};
 require Test::Valgrind::Suppressions;
 
 for (qw/supp_path VG_PATH/) {

diff --git a/t/10-suppressions.t b/t/10-suppressions.t
index 935dfbee5011d98d7388764c39b8c3f15766ae3b..ca9db49ff0cc5bb427fb44ff028ce1118a221da3 100644 (file)
--- a/t/10-suppressions.t
+++ b/t/10-suppressions.t
@@ -4,6 +4,7 @@ use strict;
 use warnings;
 use Test::More tests => 2;
 
+use lib qw{blib/archpub};
 use Test::Valgrind::Suppressions qw/supp_path VG_PATH/;
 
 my $path = supp_path();

diff --git a/t/20-good.t b/t/20-good.t
index 781bf385df45e51280821c700820c92e31fbcbf1..d13977d91f3886eb25f9295932b942a6d86d7399 100644 (file)
--- a/t/20-good.t
+++ b/t/20-good.t
@@ -4,7 +4,8 @@ use strict;
 use warnings;
 
 use Test::More;
-eval 'use Test::Valgrind'; # diag => 1';
+use lib qw{blib/archpub};
+eval 'use Test::Valgrind';
 plan skip_all => 'Test::Valgrind is required to run test your distribution with valgrind' if $@;
 
 1;

diff --git a/t/30-bad.t b/t/30-bad.t
new file mode 100644 (file)
index 0000000..93765cf
--- /dev/null
+++ b/t/30-bad.t
@@ -0,0 +1,46 @@
+#!perl
+
+use strict;
+use warnings;
+
+use Config qw/%Config/;
+
+use Test::More;
+
+sub tester {
+ my ($a, $desc) = @_;
+ my $passed;
+ my $dbg = eval "Test::Valgrind::DEBUGGING()";
+ if ($desc =~ /still\s+reachable/) {
+  $passed = $a >= 9900 && $a < 10100;
+  if ($dbg) {
+   ok($passed, $desc);
+  } else {
+   TODO: {
+    local $TODO = "Leak count may be off on non-debugging perls";
+    ok($passed, $desc);
+   }
+   return 1;
+  }
+ } else {
+  $passed = defined $a && $a == 0;
+  is($a, 0, $desc);
+ }
+ return $passed;
+}
+
+eval {
+ require XSLoader;
+ XSLoader::load('Test::Valgrind', 0.04);
+};
+if ($@) {
+ plan skip_all => "XS test code not available ($@)";
+} else {
+ use lib qw{blib/archpub};
+ eval 'use Test::Valgrind cb => \&tester;';
+ if ($@) {
+  plan skip_all => 'Test::Valgrind is required to run test your distribution with valgrind';
+ } else {
+  Test::Valgrind::leak();
+ }
+}