lib/Test/Valgrind.pm

   1 package Test::Valgrind;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Carp qw/croak/;
   7 use POSIX qw/SIGTERM/;
   8 use Test::More;
   9
  10 use Perl::Destruct::Level level => 3;
  11
  12 use Test::Valgrind::Suppressions;
  13
  14 =head1 NAME
  15
  16 Test::Valgrind - Test Perl code through valgrind.
  17
  18 =head1 VERSION
  19
  20 Version 0.04
  21
  22 =cut
  23
  24 our $VERSION = '0.04';
  25
  26 =head1 SYNOPSIS
  27
  28     use Test::More;
  29     eval 'use Test::Valgrind';
  30     plan skip_all => 'Test::Valgrind is required to test your distribution with valgrind' if $@;
  31
  32     # Code to inspect for memory leaks/errors.
  33
  34 =head1 DESCRIPTION
  35
  36 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.
  37
  38 You can also use it from the command-line to test a given script :
  39
  40     perl -MTest::Valgrind leaky.pl
  41
  42 =head1 CONFIGURATION
  43
  44 You can pass parameters to C<import> as a list of key / value pairs, where valid keys are :
  45
  46 =over 4
  47
  48 =item C<< supp => $file >>
  49
  50 Also use suppressions from C<$file> besides perl's.
  51
  52 =item C<< no_supp => $bool >>
  53
  54 If true, do not use any suppressions.
  55
  56 =item C<< callers => $number >>
  57
  58 Specify the maximum stack depth studied when valgrind encounters an error. Raising this number improves granularity. Default is 12.
  59
  60 =item C<< extra => [ @args ] >>
  61
  62 Add C<@args> to valgrind parameters.
  63
  64 =item C<< diag => $bool >>
  65
  66 If true, print the raw output of valgrind as diagnostics (may be quite verbose).
  67
  68 =item C<< no_test => $bool >>
  69
  70 If true, do not actually output the plan and the tests results.
  71
  72 =back
  73
  74 =cut
  75
  76 my $run;
  77
  78 sub import {
  79  shift;
  80  croak 'Optional arguments must be passed as key => value pairs' if @_ % 2;
  81  my %args = @_;
  82  if (!defined $args{run} && !$run) {
  83   my ($file, $next);
  84   my $l = 0;
  85   while ($l < 1000) {
  86    $next = (caller $l++)[1];
  87    last unless defined $next;
  88    $file = $next;
  89   }
  90   return if not $file or $file eq '-e';
  91   my $callers = $args{callers};
  92   $callers = 12 unless defined $callers;
  93   $callers = int $callers;
  94   my $vg = Test::Valgrind::Suppressions::VG_PATH;
  95   if (!$vg || !-x $vg) {
  96    for (split /:/, $ENV{PATH}) {
  97     $_ .= '/valgrind';
  98     if (-x) {
  99      $vg = $_;
 100      last;
 101     }
 102    }
 103    if (!$vg) {
 104     plan skip_all => 'No valgrind executable could be found in your path';
 105     return;
 106    }
 107   }
 108   pipe my $rdr, my $wtr or croak "pipe(\$rdr, \$wtr): $!";
 109   my $pid = fork;
 110   if (!defined $pid) {
 111    croak "fork(): $!";
 112   } elsif ($pid == 0) {
 113    setpgrp 0, 0 or croak "setpgrp(0, 0): $!";
 114    close $rdr or croak "close(\$rdr): $!";
 115    open STDERR, '>&', $wtr or croak "open(STDERR, '>&', \$wtr): $!";
 116    my @args = (
 117     '--tool=memcheck',
 118     '--leak-check=full',
 119     '--leak-resolution=high',
 120     '--num-callers=' . $callers,
 121     '--error-limit=yes'
 122    );
 123    unless ($args{no_supp}) {
 124     for (Test::Valgrind::Suppressions::supp_path(), $args{supp}) {
 125      push @args, '--suppressions=' . $_ if $_;
 126     }
 127    }
 128    if (defined $args{extra} and ref $args{extra} eq 'ARRAY') {
 129     push @args, @{$args{extra}};
 130    }
 131    push @args, $^X;
 132    push @args, '-I' . $_ for @INC;
 133    push @args, '-MTest::Valgrind=run,1', $file;
 134    print STDERR "valgrind @args\n" if $args{diag};
 135    local $ENV{PERL_DESTRUCT_LEVEL} = 3;
 136    local $ENV{PERL_DL_NONLAZY} = 1;
 137    exec $vg, @args;
 138   }
 139   close $wtr or croak "close(\$wtr): $!";
 140   local $SIG{INT} = sub { kill -(SIGTERM) => $pid };
 141   plan tests => 5 unless $args{no_test};
 142   my @tests = (
 143    'errors',
 144    'definitely lost', 'indirectly lost', 'possibly lost', 'still reachable'
 145   );
 146   my %res = map { $_ => 0 } @tests;
 147   while (<$rdr>) {
 148    diag $_ if $args{diag};
 149    if (/^=+\d+=+\s*FATAL\s*:\s*(.*)/) {
 150     chomp(my $err = $1);
 151     diag "Valgrind error: $err";
 152     $res{$_} = undef for @tests;
 153    }
 154    if (/ERROR\s+SUMMARY\s*:\s+(\d+)/) {
 155     $res{errors} = int $1;
 156    } elsif (/([a-z][a-z\s]*[a-z])\s*:\s*([\d.,]+)/) {
 157     my ($cat, $count) = ($1, $2);
 158     if (exists $res{$cat}) {
 159      $cat =~ s/\s+/ /g;
 160      $count =~ s/[.,]//g;
 161      $res{$cat} = int $count;
 162     }
 163    }
 164   }
 165   waitpid $pid, 0;
 166   my $failed = 0;
 167   for (@tests) {
 168    is($res{$_}, 0, 'valgrind ' . $_) unless $args{no_test};
 169    ++$failed if defined $res{$_} and $res{$_} != 0;
 170   }
 171   exit $failed;
 172  } else {
 173   $run = 1;
 174  }
 175 }
 176
 177 =head1 CAVEATS
 178
 179 You can't use this module to test code given by the C<-e> command-line switch.
 180
 181 Results will most likely be better if your perl is built with debugging enabled. Using the latest valgrind available will also help.
 182
 183 This module is not really secure. It's definitely not taint safe. That shouldn't be a problem for test files.
 184
 185 If your tests output to STDERR, everything will be eaten in the process. In particular, running this module against test files will obliterate their original test results.
 186
 187 =head1 DEPENDENCIES
 188
 189 Valgrind 3.1.0 (L<http://valgrind.org>).
 190
 191 L<Carp>, L<POSIX> (core modules since perl 5) and L<Test::More> (since 5.6.2).
 192
 193 L<Perl::Destruct::Level>.
 194
 195 =head1 AUTHOR
 196
 197 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 198
 199 You can contact me by mail or on #perl @ FreeNode (vincent or Prof_Vince).
 200
 201 =head1 BUGS
 202
 203 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.
 204
 205 =head1 SUPPORT
 206
 207 You can find documentation for this module with the perldoc command.
 208
 209     perldoc Test::Valgrind
 210
 211 =head1 ACKNOWLEDGEMENTS
 212
 213 Rafaël Garcia-Suarez, for writing and instructing me about the existence of L<Perl::Destruct::Level> (Elizabeth Mattijsen is a close second).
 214
 215 H.Merijn Brand, for daring to test this thing.
 216
 217 =head1 COPYRIGHT & LICENSE
 218
 219 Copyright 2008 Vincent Pit, all rights reserved.
 220
 221 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 222
 223 =cut
 224
 225 1; # End of Test::Valgrind