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::Builder;
   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.06
  21
  22 =cut
  23
  24 our $VERSION = '0.06';
  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 $Test = Test::Builder->new;
 102
 103 my $run;
 104
 105 sub _counter {
 106  (defined $_[0] and $_[0] == 0) ? 1 : 0;
 107 }
 108
 109 sub _tester {
 110  $Test->is_num($_[0], 0, $_[1]);
 111  _counter(@_);
 112 }
 113
 114 sub import {
 115  shift;
 116  croak 'Optional arguments must be passed as key => value pairs' if @_ % 2;
 117  my %args = @_;
 118  if (!defined $args{run} && !$run) {
 119   my ($file, $pm, $next);
 120   my $l = 0;
 121   while ($l < 1000) {
 122    $next = (caller $l++)[1];
 123    last unless defined $next;
 124    next unless $next ne '-e' and $next !~ /^\s*\(\s*eval\s*\d*\s*\)\s*$/
 125                              and -f $next;
 126    if ($next =~ /\.pm$/) {
 127     $pm = $next;
 128    } else {
 129     $file = $next;
 130    }
 131   }
 132   unless (defined $file) {
 133    $file = $pm;
 134    return unless defined $pm;
 135   }
 136   my $callers = $args{callers};
 137   $callers = 12 unless defined $callers;
 138   $callers = int $callers;
 139   my $vg = Test::Valgrind::Suppressions::VG_PATH;
 140   if (!$vg || !-x $vg) {
 141    for (split /:/, $ENV{PATH}) {
 142     $_ .= '/valgrind';
 143     if (-x) {
 144      $vg = $_;
 145      last;
 146     }
 147    }
 148    if (!$vg) {
 149     $Test->skip_all('No valgrind executable could be found in your path');
 150     return;
 151    }
 152   }
 153   pipe my $rdr, my $wtr or croak "pipe(\$rdr, \$wtr): $!";
 154   my $pid = fork;
 155   if (!defined $pid) {
 156    croak "fork(): $!";
 157   } elsif ($pid == 0) {
 158    setpgrp 0, 0 or croak "setpgrp(0, 0): $!";
 159    close $rdr or croak "close(\$rdr): $!";
 160    open STDERR, '>&', $wtr or croak "open(STDERR, '>&', \$wtr): $!";
 161    my @args = (
 162     '--tool=memcheck',
 163     '--leak-check=full',
 164     '--leak-resolution=high',
 165     '--num-callers=' . $callers,
 166     '--error-limit=yes'
 167    );
 168    unless ($args{no_supp}) {
 169     for (Test::Valgrind::Suppressions::supp_path(), $args{supp}) {
 170      push @args, '--suppressions=' . $_ if $_;
 171     }
 172    }
 173    if (defined $args{extra} and ref $args{extra} eq 'ARRAY') {
 174     push @args, @{$args{extra}};
 175    }
 176    push @args, $^X;
 177    push @args, '-I' . $_ for @INC;
 178    push @args, '-MTest::Valgrind=run,1', $file;
 179    print STDERR "valgrind @args\n" if $args{diag};
 180    local $ENV{PERL_DESTRUCT_LEVEL} = 3;
 181    local $ENV{PERL_DL_NONLAZY} = 1;
 182    exec $vg, @args;
 183   }
 184   close $wtr or croak "close(\$wtr): $!";
 185   local $SIG{INT} = sub { kill -(SIGTERM) => $pid };
 186   $Test->plan(tests => 5) unless $args{no_test} or defined $Test->has_plan;
 187   my @tests = (
 188    'errors',
 189    'definitely lost', 'indirectly lost', 'possibly lost', 'still reachable'
 190   );
 191   my %res = map { $_ => 0 } @tests;
 192   while (<$rdr>) {
 193    $Test->diag($_) if $args{diag};
 194    if (/^=+\d+=+\s*FATAL\s*:\s*(.*)/) {
 195     chomp(my $err = $1);
 196     $Test->diag("Valgrind error: $err");
 197     $res{$_} = undef for @tests;
 198    }
 199    if (/ERROR\s+SUMMARY\s*:\s+(\d+)/) {
 200     $res{errors} = int $1;
 201    } elsif (/([a-z][a-z\s]*[a-z])\s*:\s*([\d.,]+)/) {
 202     my ($cat, $count) = ($1, $2);
 203     if (exists $res{$cat}) {
 204      $cat =~ s/\s+/ /g;
 205      $count =~ s/[.,]//g;
 206      $res{$cat} = int $count;
 207     }
 208    }
 209   }
 210   waitpid $pid, 0;
 211   my $failed = 5;
 212   my $cb = ($args{no_test} ? \&_counter
 213                            : ($args{cb} ? $args{cb} : \&_tester));
 214   for (@tests) {
 215    $failed -= $cb->($res{$_}, 'valgrind ' . $_) ? 1 : 0;
 216   }
 217   exit $failed;
 218  } else {
 219   $run = 1;
 220  }
 221 }
 222
 223 =head1 CAVEATS
 224
 225 You can't use this module to test code given by the C<-e> command-line switch.
 226
 227 Results will most likely be better if your perl is built with debugging enabled. Using the latest valgrind available will also help.
 228
 229 This module is not really secure. It's definitely not taint safe. That shouldn't be a problem for test files.
 230
 231 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.
 232
 233 =head1 DEPENDENCIES
 234
 235 Valgrind 3.1.0 (L<http://valgrind.org>).
 236
 237 L<Carp>, L<POSIX> (core modules since perl 5) and L<Test::Builder> (since 5.6.2).
 238
 239 L<Perl::Destruct::Level>.
 240
 241 =head1 SEE ALSO
 242
 243 L<Devel::Leak>, L<Devel::LeakTrace>, L<Devel::LeakTrace::Fast>.
 244
 245 =head1 AUTHOR
 246
 247 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 248
 249 You can contact me by mail or on #perl @ FreeNode (vincent or Prof_Vince).
 250
 251 =head1 BUGS
 252
 253 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.
 254
 255 =head1 SUPPORT
 256
 257 You can find documentation for this module with the perldoc command.
 258
 259     perldoc Test::Valgrind
 260
 261 =head1 ACKNOWLEDGEMENTS
 262
 263 Rafaël Garcia-Suarez, for writing and instructing me about the existence of L<Perl::Destruct::Level> (Elizabeth Mattijsen is a close second).
 264
 265 H.Merijn Brand, for daring to test this thing.
 266
 267 =head1 COPYRIGHT & LICENSE
 268
 269 Copyright 2008 Vincent Pit, all rights reserved.
 270
 271 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 272
 273 =cut
 274
 275 1; # End of Test::Valgrind