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.02
  13
  14 =cut
  15
  16 our $VERSION = '1.02';
  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   $action->abort($sess, $@);
 172   return $action->status($sess);
 173  }
 174
 175  eval {
 176   $sess->run(
 177    command => $cmd,
 178    tool    => $tool,
 179    action  => $action,
 180   );
 181  };
 182  if ($@) {
 183   require Test::Valgrind::Report;
 184   $action->report($sess, Test::Valgrind::Report->new_diag($@));
 185  }
 186
 187  my $status = $sess->status;
 188  $status = 255 unless defined $status;
 189
 190  return $status;
 191 }
 192
 193 =head2 C<import [ %options ]>
 194
 195 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.
 196 When the analyse ends, it exits with the status that was returned.
 197
 198 In the child process, it just C<return>s so that the calling code is actually run under C<valgrind>.
 199
 200 =cut
 201
 202 # We use as little modules as possible in run mode so that they don't pollute
 203 # the analysis. Hence all the requires.
 204
 205 my $run;
 206
 207 sub import {
 208  my $class = shift;
 209  $class = ref($class) || $class;
 210
 211  if (@_ % 2) {
 212   require Carp;
 213   Carp::croak('Optional arguments must be passed as key => value pairs');
 214  }
 215  my %args = @_;
 216
 217  if (defined delete $args{run} or $run) {
 218   require Perl::Destruct::Level;
 219   Perl::Destruct::Level::set_destruct_level(3);
 220   {
 221    my $oldfh = select STDOUT;
 222    $|++;
 223    select $oldfh;
 224   }
 225   $run = 1;
 226   return;
 227  }
 228
 229  my $file = delete $args{file};
 230  unless (defined $file) {
 231   my ($next, $last_pm);
 232   for (my $l = 0; 1; ++$l) {
 233    $next = (caller $l)[1];
 234    last unless defined $next;
 235    next if $next =~ /^\s*\(\s*eval\s*\d*\s*\)\s*$/;
 236    if ($next =~ /\.pmc?$/) {
 237     $last_pm = $next;
 238    } else {
 239     $file = $next;
 240     last;
 241    }
 242   }
 243   $file = $last_pm unless defined $file;
 244  }
 245
 246  unless (defined $file) {
 247   require Test::Builder;
 248   Test::Builder->new->diag('Couldn\'t find a valid source file');
 249   return;
 250  }
 251
 252  if ($file ne '-e') {
 253   exit $class->analyse(
 254    file => $file,
 255    %args,
 256   );
 257  }
 258
 259  require File::Temp;
 260  my $tmp = File::Temp->new;
 261
 262  require Filter::Util::Call;
 263  Filter::Util::Call::filter_add(sub {
 264   my $status = Filter::Util::Call::filter_read();
 265   if ($status > 0) {
 266    print $tmp $_;
 267   } elsif ($status == 0) {
 268    close $tmp;
 269    my $code = $class->analyse(
 270     file => $tmp->filename,
 271     %args,
 272    );
 273    exit $code;
 274   }
 275   $status;
 276  });
 277 }
 278
 279 =head1 VARIABLES
 280
 281 =head2 C<$dl_unload>
 282
 283 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>.
 284
 285 Since this obfuscates error stack traces, it's disabled by default.
 286
 287 =cut
 288
 289 our $dl_unload;
 290
 291 END {
 292  if ($dl_unload and $run and eval { require DynaLoader; 1 }) {
 293   my @rest;
 294   DynaLoader::dl_unload_file($_) or push @rest, $_ for @DynaLoader::dl_librefs;
 295   @DynaLoader::dl_librefs = @rest;
 296  }
 297 }
 298
 299 =head1 CAVEATS
 300
 301 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.
 302
 303 This module is not really secure. It's definitely not taint safe. That shouldn't be a problem for test files.
 304
 305 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.
 306
 307 =head1 DEPENDENCIES
 308
 309 Valgrind 3.1.0 (L<http://valgrind.org>).
 310
 311 L<XML::Twig>, L<version>, L<File::HomeDir>, L<Env::Sanctify>, L<Perl::Destruct::Level>.
 312
 313 =head1 SEE ALSO
 314
 315 All the C<Test::Valgrind::*> API, including L<Test::Valgrind::Command>, L<Test::Valgrind::Tool>, L<Test::Valgrind::Action> and L<Test::Valgrind::Session>.
 316
 317 L<Test::LeakTrace>.
 318
 319 L<Devel::Leak>, L<Devel::LeakTrace>, L<Devel::LeakTrace::Fast>.
 320
 321 =head1 AUTHOR
 322
 323 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 324
 325 You can contact me by mail or on C<irc.perl.org> (vincent).
 326
 327 =head1 BUGS
 328
 329 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>.
 330 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 331
 332 =head1 SUPPORT
 333
 334 You can find documentation for this module with the perldoc command.
 335
 336     perldoc Test::Valgrind
 337
 338 =head1 ACKNOWLEDGEMENTS
 339
 340 Rafaël Garcia-Suarez, for writing and instructing me about the existence of L<Perl::Destruct::Level> (Elizabeth Mattijsen is a close second).
 341
 342 H.Merijn Brand, for daring to test this thing.
 343
 344 All you people that showed interest in this module, which motivated me into completely rewriting it.
 345
 346 =head1 COPYRIGHT & LICENSE
 347
 348 Copyright 2008-2009 Vincent Pit, all rights reserved.
 349
 350 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 351
 352 =cut
 353
 354 1; # End of Test::Valgrind