+package Test::Valgrind;
+
+use strict;
+use warnings;
+
+use Carp qw/croak/;
+use POSIX qw/SIGTERM/;
+use Test::More;
+
+use Test::Valgrind::Suppressions;
+
+=head1 NAME
+
+Test::Valgrind - Test your code through valgrind.
+
+=head1 VERSION
+
+Version 0.01
+
+=cut
+
+our $VERSION = '0.01';
+
+=head1 SYNOPSIS
+
+ use Test::More;
+ eval 'use Test::Valgrind';
+ plan skip_all => 'Test::Valgrind is required to test your distribution with valgrind';
+
+ # Code to inspect for memory leaks/errors.
+
+=head1 DESCRIPTION
+
+This module lets you run some code through the B<valgrind> memory debugger, to test it for memory errors and leaks. Just add C<use Test::Valgrind> at the beginning of the code you want to test. Behind the hood, C<Test::Valgrind::import> forks so that the child can basically C<exec 'valgrind', $^X, $0> (except that of course C<$0> isn't right there). The parent then parses the report output by valgrind and pass or fail tests accordingly.
+
+=head1 CONFIGURATION
+
+You can pass parameters to C<import> as a list of key / value pairs, where valid keys are :
+
+=over 4
+
+=item C<< supp => $file >>
+
+Also use suppressions from C<$file> besides perl's.
+
+=item C<< no_supp => $bool >>
+
+If true, do not use any suppressions.
+
+=item C<< callers => $number >>
+
+Specify the maximum stack depth studied when valgrind encounters an error. Raising this number improves granularity. Default is 50.
+
+=item C<< extra => [ @args ] >>
+
+Add C<@args> to valgrind parameters.
+
+=item C<< diag => $bool >>
+
+If true, print the raw output of valgrind as diagnostics (may be quite verbose).
+
+=item C<< no_test => $bool >>
+
+If true, do not actually output the plan and the tests results.
+
+=back
+
+=cut
+
+my $run;
+
+sub import {
+ shift;
+ croak 'Optional arguments must be passed as key => value pairs' if @_ % 2;
+ my %args = @_;
+ if (!defined $args{run} && !$run) {
+ my ($file, $next);
+ my $l = 0;
+ while ($l < 1000) {
+ $next = (caller $l++)[1];
+ last unless defined $next;
+ $file = $next;
+ }
+ return if not $file or $file eq '-e';
+ my $valgrind;
+ for (split /:/, $ENV{PATH}) {
+ my $vg = $_ . '/valgrind';
+ if (-x $vg) {
+ $valgrind = $vg;
+ last;
+ }
+ }
+ if (!$valgrind) {
+ plan skip_all => 'No valgrind executable could be found in your path';
+ return;
+ }
+ my $callers = $args{callers} || 50;
+ $callers = int $callers;
+ pipe my $rdr, my $wtr or croak "pipe(\$rdr, \$wtr): $!";
+ my $pid = fork;
+ if (!defined $pid) {
+ croak "fork(): $!";
+ } elsif ($pid == 0) {
+ setpgrp 0, 0 or croak "setpgrp(0, 0): $!";
+ close $rdr or croak "close(\$rdr): $!";
+ open STDERR, '>&', $wtr or croak "open(STDERR, '>&', \$wtr): $!";
+ my @args = (
+ '--tool=memcheck',
+ '--leak-check=full',
+ '--leak-resolution=high',
+ '--num-callers=' . $callers,
+ '--error-limit=yes'
+ );
+ unless ($args{no_supp}) {
+ for (Test::Valgrind::Suppressions::supppath(), $args{supp}) {
+ push @args, '--suppressions=' . $_ if $_;
+ }
+ }
+ if (defined $args{extra} and ref $args{extra} eq 'ARRAY') {
+ push @args, @{$args{extra}};
+ }
+ push @args, $^X;
+ push @args, '-I' . $_ for @INC;
+ push @args, '-MTest::Valgrind=run,1', $file;
+ print STDERR "valgrind @args\n" if $args{diag};
+ local $ENV{PERL_DESTRUCT_LEVEL} = 3;
+ local $ENV{PERL_DL_NONLAZY} = 1;
+ exec 'valgrind', @args;
+ }
+ close $wtr or croak "close(\$wtr): $!";
+ local $SIG{INT} = sub { kill -(SIGTERM) => $pid };
+ plan tests => 5 unless $args{no_test};
+ my @tests = (
+ 'errors',
+ 'definitely lost', 'indirectly lost', 'possibly lost', 'still reachable'
+ );
+ 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;
+ }
+}
+
+=head1 CAVEATS
+
+You can't use this module to test code given by the C<-e> command-line switch.
+This module is not really secure. It's definitely not taint safe. That shouldn't be a problem for test files.
+If your tests output to STDERR, everything will be eaten in the process.
+
+=head1 DEPENDENCIES
+
+Valgrind 3.1.0 (L<http://valgrind.org>).
+
+L<Carp>, L<POSIX> (core modules since perl 5) and L<Test::More> (since 5.6.2).
+
+=head1 AUTHOR
+
+Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
+
+You can contact me by mail or on #perl @ FreeNode (vincent or Prof_Vince).
+
+=head1 BUGS
+
+Please report any bugs or feature requests to C<bug-test-valgrind at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Valgrind>. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+ perldoc Test::Valgrind
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2008 Vincent Pit, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+1; # End of Test::Valgrind