lib/Test/Valgrind.pm

   1 package Test::Valgrind;
   2
   3 use strict;
   4 use warnings;
   5
   6 =head1 NAME
   7
   8 Test::Valgrind - Test Perl code through valgrind.
   9
  10 =head1 VERSION
  11
  12 Version 1.00
  13
  14 =cut
  15
  16 our $VERSION = '1.00';
  17
  18 =head1 SYNOPSIS
  19
  20     # From the command-line
  21     perl -MTest::Valgrind leaky.pl
  22
  23     # In a test file
  24     use Test::More;
  25     eval 'use Test::Valgrind';
  26     plan skip_all => 'Test::Valgrind is required to test your distribution with valgrind' if $@;
  27     ...
  28
  29     # In all the test files of a directory
  30     prove --exec 'perl -Iblib/lib -Iblib/arch -MTest::Valgrind' t/*.t
  31
  32 =head1 DESCRIPTION
  33
  34 This module is a front-end to the C<Test::Valgrind::*> API that lets you run Perl code through the C<memcheck> tool of the C<valgrind> memory debugger, to test it for memory errors and leaks.
  35 If they aren't available yet, it will first generate suppressions for the current C<perl> interpreter and store them in the portable flavour of F<~/.perl/Test-Valgrind/suppressions/$VERSION>.
  36 The actual run will then take place, and tests will be passed or failed according to the result of the analysis.
  37
  38 Due to the nature of perl's memory allocator, this module can't track leaks of Perl objects.
  39 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>.
  40 As such, it's complementary to the other very good leak detectors listed in the L</SEE ALSO> section.
  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<< tool => $tool >>
  51
  52 The L<Test::Valgrind::Tool> object (or class name) to use.
  53
  54 Defaults to L<Test::Valgrind::Tool::memcheck>.
  55
  56 =item *
  57
  58 C<< action => $action >>
  59
  60 The L<Test::Valgrind::Action> object (or class name) to use.
  61
  62 Defaults to L<Test::Valgrind::Action::Test>.
  63
  64 =item *
  65
  66 C<< diag => $bool >>
  67
  68 If true, print the output of the test script as diagnostics.
  69
  70 =item *
  71
  72 C<< callers => $number >>
  73
  74 Specify the maximum stack depth studied when valgrind encounters an error.
  75 Raising this number improves granularity.
  76
  77 Default is 12.
  78
  79 =item *
  80
  81 C<< extra_supps => \@files >>
  82
  83 Also use suppressions from C<@files> besides C<perl>'s.
  84
  85 =item *
  86
  87 C<< no_def_supp => $bool >>
  88
  89 If true, do not use the default suppression file.
  90
  91 =back
  92
  93 =cut
  94
  95 # We use as little modules as possible in run mode so that they don't pollute
  96 # the analysis. Hence all the requires.
  97
  98 my $run;
  99
 100 sub import {
 101  shift;
 102
 103  if (@_ % 2) {
 104   require Carp;
 105   Carp::croak('Optional arguments must be passed as key => value pairs');
 106  }
 107  my %args = @_;
 108
 109  if (defined $args{run} or $run) {
 110   require Perl::Destruct::Level;
 111   Perl::Destruct::Level::set_destruct_level(3);
 112   {
 113    my $oldfh = select STDOUT;
 114    $|++;
 115    select $oldfh;
 116   }
 117   $run = 1;
 118   return;
 119  }
 120
 121  my ($file, $pm, $next);
 122  my $l = 0;
 123  while ($l < 1000) {
 124   $next = (caller $l++)[1];
 125   last unless defined $next;
 126   next if $next eq '-e' or $next =~ /^\s*\(\s*eval\s*\d*\s*\)\s*$/ or !-f $next;
 127   if ($next =~ /\.pm$/) {
 128    $pm   = $next;
 129   } else {
 130    $file = $next;
 131   }
 132  }
 133  unless (defined($file) or defined($file = $pm)) {
 134   require Test::Builder;
 135   Test::Builder->new->diag('Couldn\'t find a valid source file');
 136   return;
 137  }
 138
 139  require Test::Valgrind::Command;
 140  my $cmd = Test::Valgrind::Command->new(
 141   command => 'PerlScript',
 142   file    => $file,
 143   args    => [ '-MTest::Valgrind=run,1' ],
 144  );
 145
 146  my $instanceof = sub {
 147   require Scalar::Util;
 148   Scalar::Util::blessed($_[0]) && $_[0]->isa($_[1]);
 149  };
 150
 151  my $tool = delete $args{tool};
 152  unless ($tool->$instanceof('Test::Valgrind::Tool')) {
 153   require Test::Valgrind::Tool;
 154   $tool = Test::Valgrind::Tool->new(
 155    tool     => $tool || 'memcheck',
 156    callers  => delete($args{callers}),
 157   );
 158  }
 159
 160  my $action = delete $args{action};
 161  unless ($action->$instanceof('Test::Valgrind::Action')) {
 162   require Test::Valgrind::Action;
 163   $action = Test::Valgrind::Action->new(
 164    action => $action || 'Test',
 165    diag   => delete($args{diag}),
 166   );
 167  }
 168
 169  require Test::Valgrind::Session;
 170  my $sess = eval {
 171   Test::Valgrind::Session->new(
 172    min_version => $tool->requires_version,
 173    map { $_ => delete $args{$_} } qw/extra_supps no_def_supp/
 174   );
 175  };
 176  unless ($sess) {
 177   $action->abort($sess, $@);
 178   exit $action->status($sess);
 179  }
 180
 181  eval {
 182   $sess->run(
 183    command => $cmd,
 184    tool    => $tool,
 185    action  => $action,
 186   );
 187  };
 188  if ($@) {
 189   require Test::Valgrind::Report;
 190   $action->report($sess, Test::Valgrind::Report->new_diag($@));
 191  }
 192
 193  my $status = $sess->status;
 194  $status = 255 unless defined $status;
 195
 196  exit $status;
 197 }
 198
 199 END {
 200  if ($run and eval { require DynaLoader; 1 }) {
 201   my @rest;
 202   DynaLoader::dl_unload_file($_) or push @rest, $_ for @DynaLoader::dl_librefs;
 203   @DynaLoader::dl_librefs = @rest;
 204  }
 205 }
 206
 207 =head1 CAVEATS
 208
 209 You can't use this module to test code given by the C<-e> command-line switch.
 210
 211 Perl 5.8 is notorious for leaking like there's no tomorrow, so the suppressions are very likely not to be very accurate on it. Anyhow, results will most likely be better if your perl is built with debugging enabled. Using the latest C<valgrind> available will also help.
 212
 213 This module is not really secure. It's definitely not taint safe. That shouldn't be a problem for test files.
 214
 215 What your tests output to C<STDOUT> and C<STDERR> is eaten unless you pass the C<diag> option, in which case it will be reprinted as diagnostics.
 216
 217 =head1 DEPENDENCIES
 218
 219 Valgrind 3.1.0 (L<http://valgrind.org>).
 220
 221 L<XML::Twig>, L<version>, L<File::HomeDir>, L<Env::Sanctify>, L<Perl::Destruct::Level>.
 222
 223 =head1 SEE ALSO
 224
 225 All the C<Test::Valgrind::*> API, including L<Test::Valgrind::Command>, L<Test::Valgrind::Tool>, L<Test::Valgrind::Action> and L<Test::Valgrind::Session>.
 226
 227 L<Test::LeakTrace>.
 228
 229 L<Devel::Leak>, L<Devel::LeakTrace>, L<Devel::LeakTrace::Fast>.
 230
 231 =head1 AUTHOR
 232
 233 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 234
 235 You can contact me by mail or on C<irc.perl.org> (vincent).
 236
 237 =head1 BUGS
 238
 239 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>.
 240 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 241
 242 =head1 SUPPORT
 243
 244 You can find documentation for this module with the perldoc command.
 245
 246     perldoc Test::Valgrind
 247
 248 =head1 ACKNOWLEDGEMENTS
 249
 250 Rafaël Garcia-Suarez, for writing and instructing me about the existence of L<Perl::Destruct::Level> (Elizabeth Mattijsen is a close second).
 251
 252 H.Merijn Brand, for daring to test this thing.
 253
 254 All you people that showed interest in this module, which motivated me into completely rewriting it.
 255
 256 =head1 COPYRIGHT & LICENSE
 257
 258 Copyright 2008-2009 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