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     # From the command-line, snippet style
  24     perl -MTest::Valgrind -e 'leaky()'
  25
  26     # In a test file
  27     use Test::More;
  28     eval 'use Test::Valgrind';
  29     plan skip_all => 'Test::Valgrind is required to test your distribution with valgrind' if $@;
  30     leaky();
  31
  32     # In all the test files of a directory
  33     prove --exec 'perl -Iblib/lib -Iblib/arch -MTest::Valgrind' t/*.t
  34
  35 =head1 DESCRIPTION
  36
  37 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.
  38 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>.
  39 The actual run will then take place, and tests will be passed or failed according to the result of the analysis.
  40
  41 Due to the nature of perl's memory allocator, this module can't track leaks of Perl objects.
  42 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>.
  43 As such, it's complementary to the other very good leak detectors listed in the L</SEE ALSO> section.
  44
  45 =head1 METHODS
  46
  47 =head2 C<analyse [ %options ]>
  48
  49 Run a C<valgrind> analysis configured by C<%options> :
  50
  51 =over 4
  52
  53 =item *
  54
  55 C<< command => $command >>
  56
  57 The L<Test::Valgrind::Command> object (or class name) to use.
  58
  59 Defaults to L<Test::Valgrind::Command::PerlScript>.
  60
  61 =item *
  62
  63 C<< tool => $tool >>
  64
  65 The L<Test::Valgrind::Tool> object (or class name) to use.
  66
  67 Defaults to L<Test::Valgrind::Tool::memcheck>.
  68
  69 =item *
  70
  71 C<< action => $action >>
  72
  73 The L<Test::Valgrind::Action> object (or class name) to use.
  74
  75 Defaults to L<Test::Valgrind::Action::Test>.
  76
  77 =item *
  78
  79 C<< file => $file >>
  80
  81 The file name of the script to analyse.
  82
  83 Ignored if you supply your own custom C<command>, but mandatory otherwise.
  84
  85 =item *
  86
  87 C<< callers => $number >>
  88
  89 Specify the maximum stack depth studied when valgrind encounters an error.
  90 Raising this number improves granularity.
  91
  92 Ignored if you supply your own custom C<tool>, otherwise defaults to C<12>.
  93
  94 =item *
  95
  96 C<< diag => $bool >>
  97
  98 If true, print the output of the test script as diagnostics.
  99
 100 Ignored if you supply your own custom C<action>, otherwise defaults to false.
 101
 102 =item *
 103
 104 C<< extra_supps => \@files >>
 105
 106 Also use suppressions from C<@files> besides C<perl>'s.
 107
 108 Defaults to empty.
 109
 110 =item *
 111
 112 C<< no_def_supp => $bool >>
 113
 114 If true, do not use the default suppression file.
 115
 116 Defaults to false.
 117
 118 =back
 119
 120 =cut
 121
 122 sub analyse {
 123  shift;
 124
 125  my %args = @_;
 126
 127  my $instanceof = sub {
 128   require Scalar::Util;
 129   Scalar::Util::blessed($_[0]) && $_[0]->isa($_[1]);
 130  };
 131
 132  my $cmd = delete $args{command};
 133  unless ($cmd->$instanceof('Test::Valgrind::Command')) {
 134   require Test::Valgrind::Command;
 135   $cmd = Test::Valgrind::Command->new(
 136    command => $cmd || 'PerlScript',
 137    file    => delete $args{file},
 138    args    => [ '-MTest::Valgrind=run,1' ],
 139   );
 140  }
 141
 142  my $tool = delete $args{tool};
 143  unless ($tool->$instanceof('Test::Valgrind::Tool')) {
 144   require Test::Valgrind::Tool;
 145   $tool = Test::Valgrind::Tool->new(
 146    tool     => $tool || 'memcheck',
 147    callers  => delete $args{callers},
 148   );
 149  }
 150
 151  my $action = delete $args{action};
 152  unless ($action->$instanceof('Test::Valgrind::Action')) {
 153   require Test::Valgrind::Action;
 154   $action = Test::Valgrind::Action->new(
 155    action => $action || 'Test',
 156    diag   => delete $args{diag},
 157   );
 158  }
 159
 160  require Test::Valgrind::Session;
 161  my $sess = eval {
 162   Test::Valgrind::Session->new(
 163    min_version => $tool->requires_version,
 164    map { $_ => delete $args{$_} } qw/extra_supps no_def_supp/
 165   );
 166  };
 167  unless ($sess) {
 168   $action->abort($sess, $@);
 169   return $action->status($sess);
 170  }
 171
 172  eval {
 173   $sess->run(
 174    command => $cmd,
 175    tool    => $tool,
 176    action  => $action,
 177   );
 178  };
 179  if ($@) {
 180   require Test::Valgrind::Report;
 181   $action->report($sess, Test::Valgrind::Report->new_diag($@));
 182  }
 183
 184  my $status = $sess->status;
 185  $status = 255 unless defined $status;
 186
 187  return $status;
 188 }
 189
 190 =head2 C<import [ %options ]>
 191
 192 In the parent process, L</import> calls L</analyse> with the arguments it received itself - except that if no C<file> option was supplied, it tries to pick the highest caller context that looks like a script.
 193 When the analyse finishes, it exists with the status that was returned.
 194
 195 In the child process, it just C<return>s so that the calling code is actually run under C<valgrind>.
 196
 197 =cut
 198
 199 # We use as little modules as possible in run mode so that they don't pollute
 200 # the analysis. Hence all the requires.
 201
 202 my $run;
 203
 204 sub import {
 205  my $class = shift;
 206  $class = ref($class) || $class;
 207
 208  if (@_ % 2) {
 209   require Carp;
 210   Carp::croak('Optional arguments must be passed as key => value pairs');
 211  }
 212  my %args = @_;
 213
 214  if (defined delete $args{run} or $run) {
 215   require Perl::Destruct::Level;
 216   Perl::Destruct::Level::set_destruct_level(3);
 217   {
 218    my $oldfh = select STDOUT;
 219    $|++;
 220    select $oldfh;
 221   }
 222   $run = 1;
 223   return;
 224  }
 225
 226  my $file = delete $args{file};
 227  unless (defined $file) {
 228   my ($next, $last_pm);
 229   for (my $l = 0; 1; ++$l) {
 230    $next = (caller $l)[1];
 231    last unless defined $next;
 232    next if $next =~ /^\s*\(\s*eval\s*\d*\s*\)\s*$/;
 233    if ($next =~ /\.pmc?$/) {
 234     $last_pm = $next;
 235    } else {
 236     $file = $next;
 237     last;
 238    }
 239   }
 240   $file = $last_pm unless defined $file;
 241  }
 242
 243  unless (defined $file) {
 244   require Test::Builder;
 245   Test::Builder->new->diag('Couldn\'t find a valid source file');
 246   return;
 247  }
 248
 249  if ($file ne '-e') {
 250   exit $class->analyse(
 251    file => $file,
 252    %args,
 253   );
 254  }
 255
 256  require File::Temp;
 257  my $tmp = File::Temp->new;
 258
 259  require Filter::Util::Call;
 260  Filter::Util::Call::filter_add(sub {
 261   my $status = Filter::Util::Call::filter_read();
 262   if ($status > 0) {
 263    print $tmp $_;
 264   } elsif ($status == 0) {
 265    close $tmp;
 266    my $code = $class->analyse(
 267     file => $tmp->filename,
 268     %args,
 269    );
 270    exit $code;
 271   }
 272   $status;
 273  });
 274 }
 275
 276 END {
 277  if ($run and eval { require DynaLoader; 1 }) {
 278   my @rest;
 279   DynaLoader::dl_unload_file($_) or push @rest, $_ for @DynaLoader::dl_librefs;
 280   @DynaLoader::dl_librefs = @rest;
 281  }
 282 }
 283
 284 =head1 CAVEATS
 285
 286 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.
 287
 288 This module is not really secure. It's definitely not taint safe. That shouldn't be a problem for test files.
 289
 290 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.
 291
 292 =head1 DEPENDENCIES
 293
 294 Valgrind 3.1.0 (L<http://valgrind.org>).
 295
 296 L<XML::Twig>, L<version>, L<File::HomeDir>, L<Env::Sanctify>, L<Perl::Destruct::Level>.
 297
 298 =head1 SEE ALSO
 299
 300 All the C<Test::Valgrind::*> API, including L<Test::Valgrind::Command>, L<Test::Valgrind::Tool>, L<Test::Valgrind::Action> and L<Test::Valgrind::Session>.
 301
 302 L<Test::LeakTrace>.
 303
 304 L<Devel::Leak>, L<Devel::LeakTrace>, L<Devel::LeakTrace::Fast>.
 305
 306 =head1 AUTHOR
 307
 308 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 309
 310 You can contact me by mail or on C<irc.perl.org> (vincent).
 311
 312 =head1 BUGS
 313
 314 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>.
 315 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 316
 317 =head1 SUPPORT
 318
 319 You can find documentation for this module with the perldoc command.
 320
 321     perldoc Test::Valgrind
 322
 323 =head1 ACKNOWLEDGEMENTS
 324
 325 Rafaël Garcia-Suarez, for writing and instructing me about the existence of L<Perl::Destruct::Level> (Elizabeth Mattijsen is a close second).
 326
 327 H.Merijn Brand, for daring to test this thing.
 328
 329 All you people that showed interest in this module, which motivated me into completely rewriting it.
 330
 331 =head1 COPYRIGHT & LICENSE
 332
 333 Copyright 2008-2009 Vincent Pit, all rights reserved.
 334
 335 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 336
 337 =cut
 338
 339 1; # End of Test::Valgrind