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 *
  49
  50 C<< supp => $file >>
  51
  52 Also use suppressions from C<$file> besides perl's.
  53
  54 =item *
  55
  56 C<< no_supp => $bool >>
  57
  58 If true, do not use any suppressions.
  59
  60 =item *
  61
  62 C<< callers => $number >>
  63
  64 Specify the maximum stack depth studied when valgrind encounters an error. Raising this number improves granularity. Default is 12.
  65
  66 =item *
  67
  68 C<< extra => [ @args ] >>
  69
  70 Add C<@args> to valgrind parameters.
  71
  72 =item *
  73
  74 C<< diag => $bool >>
  75
  76 If true, print the raw output of valgrind as diagnostics (may be quite verbose).
  77
  78 =item *
  79
  80 C<< no_test => $bool >>
  81
  82 If true, do not actually output the plan and the tests results.
  83
  84 =item *
  85
  86 C<< cb => sub { my ($val, $name) = @_; ...; return $passed } >>
  87
  88 Specifies a subroutine to execute for each test instead of C<Test::More::is>. It receives the number of bytes leaked in C<$_[0]> and the test name in C<$_[1]>, and is expected to return true if the test passed and false otherwise. Defaults to
  89
  90     sub {
  91      is($_[0], 0, $_[1]);
  92      (defined $_[0] and $_[0] == 0) : 1 : 0
  93     }
  94
  95 =back
  96
  97 =cut
  98
  99 my $run;
 100
 101 sub _counter {
 102  (defined $_[0] and $_[0] == 0) ? 1 : 0;
 103 }
 104
 105 sub _tester {
 106  is($_[0], 0, $_[1]);
 107  _counter(@_);
 108 }
 109
 110 sub import {
 111  shift;
 112  croak 'Optional arguments must be passed as key => value pairs' if @_ % 2;
 113  my %args = @_;
 114  if (!defined $args{run} && !$run) {
 115   my ($file, $next);
 116   my $l = 0;
 117   while ($l < 1000) {
 118    $next = (caller $l++)[1];
 119    last unless defined $next;
 120    $file = $next;
 121   }
 122   return if not $file or $file eq '-e';
 123   my $callers = $args{callers};
 124   $callers = 12 unless defined $callers;
 125   $callers = int $callers;
 126   my $vg = Test::Valgrind::Suppressions::VG_PATH;
 127   if (!$vg || !-x $vg) {
 128    for (split /:/, $ENV{PATH}) {
 129     $_ .= '/valgrind';
 130     if (-x) {
 131      $vg = $_;
 132      last;
 133     }
 134    }
 135    if (!$vg) {
 136     plan skip_all => 'No valgrind executable could be found in your path';
 137     return;
 138    }
 139   }
 140   pipe my $rdr, my $wtr or croak "pipe(\$rdr, \$wtr): $!";
 141   my $pid = fork;
 142   if (!defined $pid) {
 143    croak "fork(): $!";
 144   } elsif ($pid == 0) {
 145    setpgrp 0, 0 or croak "setpgrp(0, 0): $!";
 146    close $rdr or croak "close(\$rdr): $!";
 147    open STDERR, '>&', $wtr or croak "open(STDERR, '>&', \$wtr): $!";
 148    my @args = (
 149     '--tool=memcheck',
 150     '--leak-check=full',
 151     '--leak-resolution=high',
 152     '--num-callers=' . $callers,
 153     '--error-limit=yes'
 154    );
 155    unless ($args{no_supp}) {
 156     for (Test::Valgrind::Suppressions::supp_path(), $args{supp}) {
 157      push @args, '--suppressions=' . $_ if $_;
 158     }
 159    }
 160    if (defined $args{extra} and ref $args{extra} eq 'ARRAY') {
 161     push @args, @{$args{extra}};
 162    }
 163    push @args, $^X;
 164    push @args, '-I' . $_ for @INC;
 165    push @args, '-MTest::Valgrind=run,1', $file;
 166    print STDERR "valgrind @args\n" if $args{diag};
 167    local $ENV{PERL_DESTRUCT_LEVEL} = 3;
 168    local $ENV{PERL_DL_NONLAZY} = 1;
 169    exec $vg, @args;
 170   }
 171   close $wtr or croak "close(\$wtr): $!";
 172   local $SIG{INT} = sub { kill -(SIGTERM) => $pid };
 173   plan tests => 5 unless $args{no_test};
 174   my @tests = (
 175    'errors',
 176    'definitely lost', 'indirectly lost', 'possibly lost', 'still reachable'
 177   );
 178   my %res = map { $_ => 0 } @tests;
 179   while (<$rdr>) {
 180    diag $_ if $args{diag};
 181    if (/^=+\d+=+\s*FATAL\s*:\s*(.*)/) {
 182     chomp(my $err = $1);
 183     diag "Valgrind error: $err";
 184     $res{$_} = undef for @tests;
 185    }
 186    if (/ERROR\s+SUMMARY\s*:\s+(\d+)/) {
 187     $res{errors} = int $1;
 188    } elsif (/([a-z][a-z\s]*[a-z])\s*:\s*([\d.,]+)/) {
 189     my ($cat, $count) = ($1, $2);
 190     if (exists $res{$cat}) {
 191      $cat =~ s/\s+/ /g;
 192      $count =~ s/[.,]//g;
 193      $res{$cat} = int $count;
 194     }
 195    }
 196   }
 197   waitpid $pid, 0;
 198   my $failed = 5;
 199   my $cb = ($args{no_test} ? \&_counter
 200                            : ($args{cb} ? $args{cb} : \&_tester));
 201   for (@tests) {
 202    $failed -= $cb->($res{$_}, 'valgrind ' . $_) ? 1 : 0;
 203   }
 204   exit $failed;
 205  } else {
 206   $run = 1;
 207  }
 208 }
 209
 210 =head1 CAVEATS
 211
 212 You can't use this module to test code given by the C<-e> command-line switch.
 213
 214 Results will most likely be better if your perl is built with debugging enabled. Using the latest valgrind available will also help.
 215
 216 This module is not really secure. It's definitely not taint safe. That shouldn't be a problem for test files.
 217
 218 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.
 219
 220 =head1 DEPENDENCIES
 221
 222 Valgrind 3.1.0 (L<http://valgrind.org>).
 223
 224 L<Carp>, L<POSIX> (core modules since perl 5) and L<Test::More> (since 5.6.2).
 225
 226 L<Perl::Destruct::Level>.
 227
 228 =head1 AUTHOR
 229
 230 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 231
 232 You can contact me by mail or on #perl @ FreeNode (vincent or Prof_Vince).
 233
 234 =head1 BUGS
 235
 236 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.
 237
 238 =head1 SUPPORT
 239
 240 You can find documentation for this module with the perldoc command.
 241
 242     perldoc Test::Valgrind
 243
 244 =head1 ACKNOWLEDGEMENTS
 245
 246 Rafaël Garcia-Suarez, for writing and instructing me about the existence of L<Perl::Destruct::Level> (Elizabeth Mattijsen is a close second).
 247
 248 H.Merijn Brand, for daring to test this thing.
 249
 250 =head1 COPYRIGHT & LICENSE
 251
 252 Copyright 2008 Vincent Pit, all rights reserved.
 253
 254 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 255
 256 =cut
 257
 258 1; # End of Test::Valgrind