lib/Test/Valgrind.pm

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