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