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