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