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  my $taint_mode;
 140  {
 141   open my $fh, '<', $file or last;
 142   my $first = <$fh>;
 143   close $fh;
 144   if ($first and my ($args) = $first =~ /^\s*#\s*!\s*perl\s*(.*)/) {
 145    $taint_mode = 1 if $args =~ /(?:^|\s)-T(?:$|\s)/;
 146   }
 147  }
 148
 149  require Test::Valgrind::Command;
 150  my $cmd = Test::Valgrind::Command->new(
 151   command => 'Perl',
 152   args    => [ '-MTest::Valgrind=run,1', (('-T') x!! $taint_mode), $file ],
 153  );
 154
 155  my $instanceof = sub {
 156   require Scalar::Util;
 157   Scalar::Util::blessed($_[0]) && $_[0]->isa($_[1]);
 158  };
 159
 160  my $tool = delete $args{tool};
 161  unless ($tool->$instanceof('Test::Valgrind::Tool')) {
 162   require Test::Valgrind::Tool;
 163   $tool = Test::Valgrind::Tool->new(
 164    tool     => $tool || 'memcheck',
 165    callers  => delete($args{callers}),
 166   );
 167  }
 168
 169  my $action = delete $args{action};
 170  unless ($action->$instanceof('Test::Valgrind::Action')) {
 171   require Test::Valgrind::Action;
 172   $action = Test::Valgrind::Action->new(
 173    action => $action || 'Test',
 174    diag   => delete($args{diag}),
 175   );
 176  }
 177
 178  require Test::Valgrind::Session;
 179  my $sess = eval {
 180   Test::Valgrind::Session->new(
 181    min_version => $tool->requires_version,
 182    map { $_ => delete $args{$_} } qw/extra_supps no_def_supp/
 183   );
 184  };
 185  unless ($sess) {
 186   $action->abort($sess, $@);
 187   exit $action->status($sess);
 188  }
 189
 190  eval {
 191   $sess->run(
 192    command => $cmd,
 193    tool    => $tool,
 194    action  => $action,
 195   );
 196  };
 197  if ($@) {
 198   require Test::Valgrind::Report;
 199   $action->report($sess, Test::Valgrind::Report->new_diag($@));
 200  }
 201
 202  my $status = $sess->status;
 203  $status = 255 unless defined $status;
 204
 205  exit $status;
 206 }
 207
 208 END {
 209  if ($run and eval { require DynaLoader; 1 }) {
 210   my @rest;
 211   DynaLoader::dl_unload_file($_) or push @rest, $_ for @DynaLoader::dl_librefs;
 212   @DynaLoader::dl_librefs = @rest;
 213  }
 214 }
 215
 216 =head1 CAVEATS
 217
 218 You can't use this module to test code given by the C<-e> command-line switch.
 219
 220 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.
 221
 222 This module is not really secure. It's definitely not taint safe. That shouldn't be a problem for test files.
 223
 224 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.
 225
 226 =head1 DEPENDENCIES
 227
 228 Valgrind 3.1.0 (L<http://valgrind.org>).
 229
 230 L<XML::Twig>, L<version>, L<File::HomeDir>, L<Env::Sanctify>, L<Perl::Destruct::Level>.
 231
 232 =head1 SEE ALSO
 233
 234 All the C<Test::Valgrind::*> API, including L<Test::Valgrind::Command>, L<Test::Valgrind::Tool>, L<Test::Valgrind::Action> and L<Test::Valgrind::Session>.
 235
 236 L<Test::LeakTrace>.
 237
 238 L<Devel::Leak>, L<Devel::LeakTrace>, L<Devel::LeakTrace::Fast>.
 239
 240 =head1 AUTHOR
 241
 242 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 243
 244 You can contact me by mail or on C<irc.perl.org> (vincent).
 245
 246 =head1 BUGS
 247
 248 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>.
 249 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 250
 251 =head1 SUPPORT
 252
 253 You can find documentation for this module with the perldoc command.
 254
 255     perldoc Test::Valgrind
 256
 257 =head1 ACKNOWLEDGEMENTS
 258
 259 Rafaël Garcia-Suarez, for writing and instructing me about the existence of L<Perl::Destruct::Level> (Elizabeth Mattijsen is a close second).
 260
 261 H.Merijn Brand, for daring to test this thing.
 262
 263 All you people that showed interest in this module, which motivated me into completely rewriting it.
 264
 265 =head1 COPYRIGHT & LICENSE
 266
 267 Copyright 2008-2009 Vincent Pit, all rights reserved.
 268
 269 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 270
 271 =cut
 272
 273 1; # End of Test::Valgrind