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.15
  13
  14 =cut
  15
  16 our $VERSION = '1.15';
  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<50>.
 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<< regen_def_supp => $bool >>
 112
 113 If true, forcefully regenerate the default suppression file.
 114
 115 Defaults to false.
 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 =item *
 126
 127 C<< extra_supps => \@files >>
 128
 129 Also use suppressions from C<@files> besides C<perl>'s.
 130
 131 Defaults to empty.
 132
 133 =back
 134
 135 =cut
 136
 137 sub _croak {
 138  require Carp;
 139  Carp::croak(@_);
 140 }
 141
 142 my %skippable_errors = (
 143  session => [
 144   'Empty valgrind candidates list',
 145   'No appropriate valgrind executable could be found',
 146  ],
 147  action  => [ ],
 148  tool    => [ ],
 149  command => [ ],
 150  run     => [
 151   'No compatible suppressions available',
 152  ],
 153 );
 154
 155 my %filter_errors;
 156
 157 for my $obj (keys %skippable_errors) {
 158  my @errors = @{$skippable_errors{$obj} || []};
 159  if (@errors) {
 160   my $rxp   = join '|', @errors;
 161   $rxp      = qr/($rxp)\s+at.*/;
 162   $filter_errors{$obj} = sub {
 163    my ($err) = @_;
 164    if ($err =~ /$rxp/) {
 165     return ($1, 1);
 166    } else {
 167     return ($err, 0);
 168    }
 169   };
 170  } else {
 171   $filter_errors{$obj} = sub {
 172    return ($_[0], 0);
 173   };
 174  }
 175 }
 176
 177 sub _default_abort {
 178  my ($err) = @_;
 179
 180  require Test::Builder;
 181  my $tb   = Test::Builder->new;
 182  my $plan = $tb->has_plan;
 183  if (defined $plan) {
 184   $tb->BAIL_OUT($err);
 185   return 255;
 186  } else {
 187   $tb->skip_all($err);
 188   return 0;
 189  }
 190 }
 191
 192 sub analyse {
 193  shift;
 194
 195  my %args = @_;
 196
 197  my $instanceof = sub {
 198   require Scalar::Util;
 199   Scalar::Util::blessed($_[0]) && $_[0]->isa($_[1]);
 200  };
 201
 202  my $tool = delete $args{tool};
 203  unless ($tool->$instanceof('Test::Valgrind::Tool')) {
 204   require Test::Valgrind::Tool;
 205   local $@;
 206   $tool = eval {
 207    Test::Valgrind::Tool->new(
 208     tool     => $tool || 'memcheck',
 209     callers  => delete $args{callers},
 210    );
 211   };
 212   unless ($tool) {
 213    my ($err, $skippable) = $filter_errors{tool}->($@);
 214    _croak($err) unless $skippable;
 215    return _default_abort($err);
 216   }
 217  }
 218
 219  require Test::Valgrind::Session;
 220  my $sess = eval {
 221   Test::Valgrind::Session->new(
 222    min_version => $tool->requires_version,
 223    map { $_ => delete $args{$_} } qw<regen_def_supp no_def_supp extra_supps>
 224   );
 225  };
 226  unless ($sess) {
 227   my ($err, $skippable) = $filter_errors{session}->($@);
 228   _croak($err) unless $skippable;
 229   return _default_abort($err);
 230  }
 231
 232  my $action = delete $args{action};
 233  unless ($action->$instanceof('Test::Valgrind::Action')) {
 234   require Test::Valgrind::Action;
 235   local $@;
 236   $action = eval {
 237    Test::Valgrind::Action->new(
 238     action => $action || 'Test',
 239     diag   => delete $args{diag},
 240    );
 241   };
 242   unless ($action) {
 243    my ($err, $skippable) = $filter_errors{action}->($@);
 244    _croak($err) unless $skippable;
 245    return _default_abort($err);
 246   }
 247  }
 248
 249  my $cmd = delete $args{command};
 250  unless ($cmd->$instanceof('Test::Valgrind::Command')) {
 251   require Test::Valgrind::Command;
 252   local $@;
 253   $cmd = eval {
 254    Test::Valgrind::Command->new(
 255     command => $cmd || 'PerlScript',
 256     file    => delete $args{file},
 257     args    => [ '-MTest::Valgrind=run,1' ],
 258    );
 259   };
 260   unless ($cmd) {
 261    my ($err, $skippable) = $filter_errors{command}->($@);
 262    _croak($err) unless $skippable;
 263    $action->abort($sess, $err);
 264    return $action->status($sess);
 265   }
 266  }
 267
 268  {
 269   local $@;
 270   eval {
 271    $sess->run(
 272     command => $cmd,
 273     tool    => $tool,
 274     action  => $action,
 275    );
 276    1
 277   } or do {
 278    my ($err, $skippable) = $filter_errors{run}->($@);
 279    if ($skippable) {
 280     $action->abort($sess, $err);
 281     return $action->status($sess);
 282    } else {
 283     require Test::Valgrind::Report;
 284     $action->report($sess, Test::Valgrind::Report->new_diag($@));
 285    }
 286   }
 287  }
 288
 289  my $status = $sess->status;
 290  $status = 255 unless defined $status;
 291
 292  return $status;
 293 }
 294
 295 =head2 C<import>
 296
 297     use Test::Valgrind %options;
 298
 299 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.
 300 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).
 301
 302 In the child process, it just C<return>s so that the calling code is actually run under C<valgrind>, albeit two side-effects :
 303
 304 =over 4
 305
 306 =item *
 307
 308 L<Perl::Destruct::Level> is loaded and the destruction level is set to C<3>.
 309
 310 =item *
 311
 312 Autoflush on C<STDOUT> is turned on.
 313
 314 =back
 315
 316 =cut
 317
 318 # We use as little modules as possible in run mode so that they don't pollute
 319 # the analysis. Hence all the requires.
 320
 321 my $run;
 322
 323 sub import {
 324  my $class = shift;
 325  $class = ref($class) || $class;
 326
 327  _croak('Optional arguments must be passed as key => value pairs') if @_ % 2;
 328  my %args = @_;
 329
 330  if (defined delete $args{run} or $run) {
 331   require Perl::Destruct::Level;
 332   Perl::Destruct::Level::set_destruct_level(3);
 333   {
 334    my $oldfh = select STDOUT;
 335    $|++;
 336    select $oldfh;
 337   }
 338   $run = 1;
 339   return;
 340  }
 341
 342  my $file = delete $args{file};
 343  unless (defined $file) {
 344   my ($next, $last_pm);
 345   for (my $l = 0; 1; ++$l) {
 346    $next = (caller $l)[1];
 347    last unless defined $next;
 348    next if $next =~ /^\s*\(\s*eval\s*\d*\s*\)\s*$/;
 349    if ($next =~ /\.pmc?$/) {
 350     $last_pm = $next;
 351    } else {
 352     $file = $next;
 353     last;
 354    }
 355   }
 356   $file = $last_pm unless defined $file;
 357  }
 358
 359  unless (defined $file) {
 360   require Test::Builder;
 361   Test::Builder->new->diag('Couldn\'t find a valid source file');
 362   return;
 363  }
 364
 365  if ($file ne '-e') {
 366   exit $class->analyse(
 367    file => $file,
 368    %args,
 369   );
 370  }
 371
 372  require File::Temp;
 373  my $tmp = File::Temp->new;
 374
 375  require Filter::Util::Call;
 376  Filter::Util::Call::filter_add(sub {
 377   my $status = Filter::Util::Call::filter_read();
 378   if ($status > 0) {
 379    print $tmp $_;
 380   } elsif ($status == 0) {
 381    close $tmp;
 382    my $code = $class->analyse(
 383     file => $tmp->filename,
 384     %args,
 385    );
 386    exit $code;
 387   }
 388   $status;
 389  });
 390 }
 391
 392 =head1 VARIABLES
 393
 394 =head2 C<$dl_unload>
 395
 396 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>.
 397
 398 Since this obfuscates error stack traces, it's disabled by default.
 399
 400 =cut
 401
 402 our $dl_unload;
 403
 404 END {
 405  if ($dl_unload and $run and eval { require DynaLoader; 1 }) {
 406   my @rest;
 407   DynaLoader::dl_unload_file($_) or push @rest, $_ for @DynaLoader::dl_librefs;
 408   @DynaLoader::dl_librefs = @rest;
 409  }
 410 }
 411
 412 =head1 CAVEATS
 413
 414 Perl 5.8 is notorious for leaking like there's no tomorrow, so the suppressions are very likely not to be complete on it.
 415 You also have a better chance to get more accurate results if your perl is built with debugging enabled.
 416 Using the latest C<valgrind> available will also help.
 417
 418 This module is not really secure.
 419 It's definitely not taint safe.
 420 That shouldn't be a problem for test files.
 421
 422 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.
 423
 424 =head1 DEPENDENCIES
 425
 426 L<XML::Twig>, L<version>, L<File::HomeDir>, L<Env::Sanctify>, L<Perl::Destruct::Level>.
 427
 428 =head1 SEE ALSO
 429
 430 All the C<Test::Valgrind::*> API, including L<Test::Valgrind::Command>, L<Test::Valgrind::Tool>, L<Test::Valgrind::Action> and L<Test::Valgrind::Session>.
 431
 432 The C<valgrind(1)> man page.
 433
 434 L<Test::LeakTrace>.
 435
 436 L<Devel::Leak>, L<Devel::LeakTrace>, L<Devel::LeakTrace::Fast>.
 437
 438 =head1 AUTHOR
 439
 440 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 441
 442 You can contact me by mail or on C<irc.perl.org> (vincent).
 443
 444 =head1 BUGS
 445
 446 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>.
 447 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 448
 449 =head1 SUPPORT
 450
 451 You can find documentation for this module with the perldoc command.
 452
 453     perldoc Test::Valgrind
 454
 455 =head1 ACKNOWLEDGEMENTS
 456
 457 RafaE<euml>l Garcia-Suarez, for writing and instructing me about the existence of L<Perl::Destruct::Level> (Elizabeth Mattijsen is a close second).
 458
 459 H.Merijn Brand, for daring to test this thing.
 460
 461 David Cantrell, for providing shell access to one of his smokers where the tests were failing.
 462
 463 The Debian-perl team, for offering all the feedback they could regarding the build issues they met.
 464
 465 All you people that showed interest in this module, which motivated me into completely rewriting it.
 466
 467 =head1 COPYRIGHT & LICENSE
 468
 469 Copyright 2008,2009,2010,2011,2013,2015 Vincent Pit, all rights reserved.
 470
 471 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 472
 473 =cut
 474
 475 1; # End of Test::Valgrind