Test-Valgrind-1.19/000755 000765 000024 00000000000 12747731467 014762 5ustar00vincentstaff000000 000000 Test-Valgrind-1.19/Changes000644 000765 000024 00000021153 12747731460 016250 0ustar00vincentstaff000000 000000 Revision history for Test-Valgrind 1.19 2016-08-01 21:00 UTC + Fix : valgrind 3.1x will no longer be treated as valgrind 3.1.0, causing the wrong command line arguments to be used. Thanks Lucas Nussbaum and Gregor Herrmann from Debian for reporting and providing feedback (Debian bug 832833). + Fix : The number of callers is now capped at 24, as this is the maximum number supported by valgrind. An higher number of frames could lead to the generation of unusable suppressions in both old and recent versions of valgrind. 1.18 2015-11-16 15:00 UTC + Chg : A new Test::Valgrind::Version class has been added to represent valgrind version numbers, instead of lazily relying on version.pm. + Fix : The detection of the valgrind executable has been slightly improved to cover some edge cases. + Tst : Test failures on Windows, or with old versions of Test::More or File::Temp, have been addressed. Thanks Paul Howarth for reporting. + Tst : A few extraneous warnings displayed by some tests when they were run with old versions of Test::Harnes were silenced. 1.17 2015-11-13 13:50 UTC + Fix : [RT #108873] : Tests fail due to "Text file busy" Thanks Paul Howarth for reporting. 1.16 2015-11-12 23:30 UTC + Chg : The Test::Valgrind tests will now be skipped when the default and user-supplied suppressions files do not refer to any perl- related symbol. This behaviour can be overridden by passing 'allow_no_supp => 1' to Test::Valgrind->import. This fixes the following RT issue. + Fix : [RT #101934] : t/20-bad.t failing on armv7hl While the root cause of this issue is probably not at Test::Valgrind's level, it should nevertheless not run the tests when the suppression files are obviously insufficient. Thanks Paul Howarth for reporting and providing helpful feedback. + Fix : The accuracy of the default perl suppression file has been improved. + Fix : The tests will be more reliably skipped when no valgrind or no suppressions are found. + Fix : Segmentation faults during the analysis are now more gracefully handled. + Fix : 'no_def_supp => 1' will no longer cause the extra suppressions to be ignored. + Tst : t/20-bad.t will no longer run the extra tests when no valgrind can be found (this was a regression in version 1.15). 1.15 2015-10-30 16:15 UTC + Add : The new 'regen_def_supp' option can be passed to Test::Valgrind->import to forcefully regenerate the default suppression file. + Fix : Build failures of the dummy XS code with PERL_IMPLICIT_SYS perls. + Fix : Handshake failures in tests with recent perls built with PERL_POISON. + Tst : Improved diagnostics on failure. + Upd : Freshen Makefile.PL. 1.14 2013-09-01 17:10 UTC This is a maintenance release. The code contains no functional change. Satisfied users of version 1.13 can skip this update. + Doc : POD headings are now properly linkable. + Tst : Author tests are no longer bundled with this distribution. They are only made available to authors in the git repository. + Tst : The stack traces used in t/20-bad.t have been made more predictable when compiler optimizations are in use. 1.13 2011-08-25 15:45 UTC + Fix : The session will now call the finish() method at the right time. + Fix : The README file is now properly UTF-8-encoded. + Tst : Test demangling of Z-encoded symbols. 1.12 2009-11-29 16:45 UTC + Doc : The front documentation in Test::Valgrind was improved. + Fix : Don't install Valgrind.so, as it's only used for testing. + Fix : "Non-portable hex number" warnings. + Fix : Old versions of valgrind could leave some Z-encoded symbols in the stack traces. We now make sure they're always decoded. 1.11 2009-10-08 20:55 UTC + Doc : Completion and improvements. + Fix : Work around Kwalitee test misfailures. + Upd : Freshen Makefile.PL. 1.10 2009-09-22 18:45 UTC + Chg : valgrind is no longer required to be installed before installing this module. + Chg : The parser logic that used to be located inside the tool was moved to a new Test::Valgrind::Parser hierarchy. The tool decides which parser should be used by implementing the "parser_class" method. + Fix : Compatibility with valgrind 3.5. + Fix : The "valgrind" option to Test::Valgrind::Session->new wasn't doing anything. + Fix : The "Test" action could generate inappropriate error messages. 1.02 2009-05-02 12:05 UTC + Add : Commands can now be aggregated. + Add : The commands can now also filter and mangle reports. + Chg : The perl suppressions are now stripped from everything below Perl_runops_*. + Doc : Typos, nits and clarifications. 1.01 2009-04-14 21:15 UTC + Add : Allow testing code given by -e. Hurray for source filters! + Fix : Lazily load version.pm in Test::Valgrind::Session so that it's not really needed at configure time. + Fix : Don't unload dynamic extensions by default so that their symbols still appear in the stack traces. 1.00 2009-04-12 22:50 UTC Complete rewrite. The options passed to Test::Valgrind->import have changed, so please have a look at the doc. + Add : A brand new reusable API. + Add : Suppressions are now versionized following the perl interpreter and valgrind. They are regenerated as needed and stored in the user home directory. + Add : memcheck output is parsed by XML::Twig. + Add : The output of the original script is now correctly captured. + Rem : Lots of ugly hacks in the toolchain. 0.08 2009-02-08 18:25 UTC + Add : Unload the libraries loaded by DynaLoader at END time, reducing the number of leaks in perl. + Rem : The useless t/21-good-block.t. + Upd : META.yml spec updated to 1.4. 0.07 2008-09-30 13:35 UTC + Chg : Now conforms to the Test::Builder framework. + Fix : STDERR is longer eaten. + Fix : Eat STDOUT or print it as diagnostics, but never let him go through naked, as this may fiddle with the tests output. + Fix : 'make test' without prior 'make'. 0.06 2008-09-09 22:10 UTC + Fix : Suppressions were installed in the wrong path. Thanks Marvin Humphrey for reporting this. + Fix : Really load XSLoader when generating suppressions. Thanks Marvin Humphrey again for bringing this to my attention. + Fix : The logic for finding the file to run through valgrind was flawed, which lead to generate suppressions against Test/Valgrind.pm only. 0.051 2008-09-02 17:20 UTC + Fix : Forgot to upgrade version of the suppression placeholder module. 0.05 2008-08-25 22:05 UTC + Chg : Lower the default caller to 12. + Tst : Add a real-life test that gets executed only if you have a C compiler. 0.04 2008-05-13 16:25 UTC + Chg : Don't smoke this on 5.005 please. + Chg : Better way to find the valgrind executable. 0.03 2008-04-21 15:35 UTC + Fix : Include the mock Suppressions.pm rather than an empty file. 0.02 2008-04-21 15:25 UTC + Add : Test::Valgrind now depends on Perl::Destruct::Level. This is needed for non-debugging perls because we can't set their level of memory cleanup correctness on exit with the PERL_DESTRUCT_LEVEL environment variable. + Add : Hardcode valgrind path into the new constant Test::Valgrind::Suppressions::VG_PATH. + Chg : Test::Valgrind::Suppressions::supppath() is now supp_path(). + Chg : lib/Test/Valgrind/Suppressions.pm.tpl was renamed to lib/Test/Valgrind/Suppressions.tpl for file portability reasons. 0.01 2008-04-19 15:50 UTC First version, released on an unsuspecting world. Test-Valgrind-1.19/INSTALL.SKIP000644 000765 000024 00000000044 12614662253 016543 0ustar00vincentstaff000000 000000 Valgrind\.(?:a|bs|def|dll|la|o|so)$ Test-Valgrind-1.19/lib/000755 000765 000024 00000000000 12747731467 015530 5ustar00vincentstaff000000 000000 Test-Valgrind-1.19/Makefile.PL000644 000765 000024 00000011131 12622352507 016713 0ustar00vincentstaff000000 000000 use 5.006; use strict; use warnings; use ExtUtils::MakeMaker; use Config; use File::Spec; sub validate_exe { my ($name, $preferred_path) = @_; my (@candidates, @args); if (File::Spec->file_name_is_absolute($name)) { # No need to look for args if the name is absolute. @candidates = $name; } else { my @path; if (defined $preferred_path) { @path = ($preferred_path, grep { $_ ne $preferred_path } File::Spec->path); } else { @path = File::Spec->path; } (my $base, @args) = split ' ', $name; for my $path_entry (@path) { my ($vol, $dir, $file) = File::Spec->splitpath($path_entry, 1); next if defined $file and length $file; push @candidates, File::Spec->catpath($vol, $dir, $base); } } for my $path (@candidates) { my $command = MM->maybe_command($path); if (defined $command) { $command .= " @args" if @args; return $command; } } return; } sub check_exe { my (%args) = @_; my $desc = delete $args{desc}; my $arg_var = delete $args{arg_var}; my $tries = delete $args{try}; my $preferred_path = delete $args{preferred_path}; my $exe; for (@ARGV) { if (/^\Q$arg_var\E=(.*)/) { $exe = validate_exe($1, $preferred_path); last if defined $exe; } } if (defined $exe) { print "Forcing the use of $exe as the $desc.\n"; } else { print "Checking for a valid $desc in the PATH... "; for my $try (@$tries) { next unless defined $try; $exe = validate_exe($try, $preferred_path); last if defined $exe; } if (defined $exe) { print "$exe\n"; } else { print "none\n"; } } return $exe; } my %PARAMS; my $cc = check_exe( desc => 'C compiler', arg_var => 'CC', try => [ $Config{cc}, $ENV{CC}, 'cc' ], ); if (defined $cc) { my ($vol, $dir, $file) = File::Spec->splitpath($cc); my $preferred_path = File::Spec->catpath($vol, $dir, ''); my $ld = check_exe( desc => 'linker', arg_var => 'LD', try => [ $Config{ld}, $ENV{LD}, 'ld' ], preferred_path => $preferred_path, ); if (defined $ld) { my $xs = 'Valgrind.xs'; (my $c = $xs) =~ s/\.xs$/.c/; my $opt = $Config{optimize}; $opt =~ s/-O\S*//g; $opt .= ' -O0 -g'; $PARAMS{C} = [ $c ]; $PARAMS{XS} = { $xs => $c }; $PARAMS{CC} = $cc; $PARAMS{LD} = $ld; $PARAMS{OPTIMIZE} = $opt; } } unless ($PARAMS{C}) { $PARAMS{C} = [ ]; $PARAMS{XS} = { }; $PARAMS{OBJECT} = ''; } my $dist = 'Test-Valgrind'; (my $name = $dist) =~ s{-}{::}g; (my $file = $dist) =~ s{-}{/}g; $file = "lib/$file.pm"; my %PREREQ_PM = ( 'Carp' => 0, 'Digest::MD5' => 0, 'Env::Sanctify' => 0, 'ExtUtils::MM' => 0, 'File::HomeDir' => '0.86', 'File::Path' => 0, 'File::Spec' => 0, 'File::Temp' => '0.19', # ->newdir in tests 'Filter::Util::Call' => 0, 'Fcntl' => 0, 'IO::Select' => 0, 'List::Util' => 0, 'POSIX' => 0, 'Perl::Destruct::Level' => 0, 'Scalar::Util' => 0, 'Test::Builder' => 0, 'Test::More' => 0, 'XML::Twig' => 0, 'base' => 0, 'overload' => 0, ); my %CONFIGURE_REQUIRES = ( 'Config' => 0, 'ExtUtils::MakeMaker' => 0, 'File::Spec' => 0, ); my %BUILD_REQUIRES = ( %CONFIGURE_REQUIRES, 'File::Temp' => '0.19', # ->newdir in tests 'IO::Handle' => 0, 'IO::Select' => 0, 'IPC::Open3' => 0, 'Socket' => 0, 'Test::More' => 0, 'base' => 0, 'lib' => 0, %PREREQ_PM, ); my %META = ( configure_requires => { %CONFIGURE_REQUIRES, }, build_requires => { %BUILD_REQUIRES, }, recommends => { 'DynaLoader' => 0, 'XSLoader' => 0, }, dynamic_config => 1, resources => { bugtracker => "http://rt.cpan.org/Dist/Display.html?Name=$dist", homepage => "http://search.cpan.org/dist/$dist/", license => 'http://dev.perl.org/licenses/', repository => "http://git.profvince.com/?p=perl%2Fmodules%2F$dist.git", }, ); WriteMakefile( NAME => $name, AUTHOR => 'Vincent Pit ', LICENSE => 'perl', VERSION_FROM => $file, ABSTRACT_FROM => $file, BUILD_REQUIRES => \%BUILD_REQUIRES, PREREQ_PM => \%PREREQ_PM, MIN_PERL_VERSION => '5.006', META_MERGE => \%META, dist => { PREOP => "pod2text -u $file > \$(DISTVNAME)/README", COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, clean => { FILES => "$dist-* *.gcov *.gcda *.gcno cover_db Debian_CPANTS.txt*" }, %PARAMS, ); Test-Valgrind-1.19/MANIFEST000644 000765 000024 00000002232 12622173356 016077 0ustar00vincentstaff000000 000000 Changes INSTALL.SKIP MANIFEST META.json META.yml Makefile.PL README Valgrind.xs lib/Test/Valgrind.pm lib/Test/Valgrind/Action.pm lib/Test/Valgrind/Action/Captor.pm lib/Test/Valgrind/Action/Suppressions.pm lib/Test/Valgrind/Action/Test.pm lib/Test/Valgrind/Carp.pm lib/Test/Valgrind/Command.pm lib/Test/Valgrind/Command/Aggregate.pm lib/Test/Valgrind/Command/Perl.pm lib/Test/Valgrind/Command/PerlScript.pm lib/Test/Valgrind/Component.pm lib/Test/Valgrind/Parser.pm lib/Test/Valgrind/Parser/Suppressions/Text.pm lib/Test/Valgrind/Parser/Text.pm lib/Test/Valgrind/Parser/XML.pm lib/Test/Valgrind/Parser/XML/Twig.pm lib/Test/Valgrind/Report.pm lib/Test/Valgrind/Session.pm lib/Test/Valgrind/Suppressions.pm lib/Test/Valgrind/Tool.pm lib/Test/Valgrind/Tool/memcheck.pm lib/Test/Valgrind/Util.pm lib/Test/Valgrind/Version.pm samples/map.pl samples/xml-output-protocol4.txt samples/xml-output.txt t/00-load.t t/10-good.t t/12-good-run-exception.t t/20-bad.t t/30-skip.t t/60-version.t t/70-session.t t/71-session-command.t t/80-suppressions.t t/81-suppressions-demangle.t t/lib/Test/Valgrind/FakeValgrind.pm t/lib/Test/Valgrind/Test/Action.pm t/lib/VPIT/TestHelpers.pm t/supp/no_perl Test-Valgrind-1.19/META.json000644 000765 000024 00000005624 12747731467 016412 0ustar00vincentstaff000000 000000 { "abstract" : "Generate suppressions, analyse and test any command with valgrind.", "author" : [ "Vincent Pit " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.18, CPAN::Meta::Converter version 2.150005", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Test-Valgrind", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "Carp" : "0", "Config" : "0", "Digest::MD5" : "0", "Env::Sanctify" : "0", "ExtUtils::MM" : "0", "ExtUtils::MakeMaker" : "0", "Fcntl" : "0", "File::HomeDir" : "0.86", "File::Path" : "0", "File::Spec" : "0", "File::Temp" : "0.19", "Filter::Util::Call" : "0", "IO::Handle" : "0", "IO::Select" : "0", "IPC::Open3" : "0", "List::Util" : "0", "POSIX" : "0", "Perl::Destruct::Level" : "0", "Scalar::Util" : "0", "Socket" : "0", "Test::Builder" : "0", "Test::More" : "0", "XML::Twig" : "0", "base" : "0", "lib" : "0", "overload" : "0" } }, "configure" : { "requires" : { "Config" : "0", "ExtUtils::MakeMaker" : "0", "File::Spec" : "0" } }, "runtime" : { "recommends" : { "DynaLoader" : "0", "XSLoader" : "0" }, "requires" : { "Carp" : "0", "Digest::MD5" : "0", "Env::Sanctify" : "0", "ExtUtils::MM" : "0", "Fcntl" : "0", "File::HomeDir" : "0.86", "File::Path" : "0", "File::Spec" : "0", "File::Temp" : "0.19", "Filter::Util::Call" : "0", "IO::Select" : "0", "List::Util" : "0", "POSIX" : "0", "Perl::Destruct::Level" : "0", "Scalar::Util" : "0", "Test::Builder" : "0", "Test::More" : "0", "XML::Twig" : "0", "base" : "0", "overload" : "0", "perl" : "5.006" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "http://rt.cpan.org/Dist/Display.html?Name=Test-Valgrind" }, "homepage" : "http://search.cpan.org/dist/Test-Valgrind/", "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "url" : "http://git.profvince.com/?p=perl%2Fmodules%2FTest-Valgrind.git" } }, "version" : "1.19", "x_serialization_backend" : "JSON::PP version 2.27400" } Test-Valgrind-1.19/META.yml000644 000765 000024 00000003324 12747731467 016235 0ustar00vincentstaff000000 000000 --- abstract: 'Generate suppressions, analyse and test any command with valgrind.' author: - 'Vincent Pit ' build_requires: Carp: '0' Config: '0' Digest::MD5: '0' Env::Sanctify: '0' ExtUtils::MM: '0' ExtUtils::MakeMaker: '0' Fcntl: '0' File::HomeDir: '0.86' File::Path: '0' File::Spec: '0' File::Temp: '0.19' Filter::Util::Call: '0' IO::Handle: '0' IO::Select: '0' IPC::Open3: '0' List::Util: '0' POSIX: '0' Perl::Destruct::Level: '0' Scalar::Util: '0' Socket: '0' Test::Builder: '0' Test::More: '0' XML::Twig: '0' base: '0' lib: '0' overload: '0' configure_requires: Config: '0' ExtUtils::MakeMaker: '0' File::Spec: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.18, CPAN::Meta::Converter version 2.150005' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Test-Valgrind no_index: directory: - t - inc recommends: DynaLoader: '0' XSLoader: '0' requires: Carp: '0' Digest::MD5: '0' Env::Sanctify: '0' ExtUtils::MM: '0' Fcntl: '0' File::HomeDir: '0.86' File::Path: '0' File::Spec: '0' File::Temp: '0.19' Filter::Util::Call: '0' IO::Select: '0' List::Util: '0' POSIX: '0' Perl::Destruct::Level: '0' Scalar::Util: '0' Test::Builder: '0' Test::More: '0' XML::Twig: '0' base: '0' overload: '0' perl: '5.006' resources: bugtracker: http://rt.cpan.org/Dist/Display.html?Name=Test-Valgrind homepage: http://search.cpan.org/dist/Test-Valgrind/ license: http://dev.perl.org/licenses/ repository: http://git.profvince.com/?p=perl%2Fmodules%2FTest-Valgrind.git version: '1.19' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Test-Valgrind-1.19/README000644 000765 000024 00000015637 12747731467 015656 0ustar00vincentstaff000000 000000 NAME Test::Valgrind - Generate suppressions, analyse and test any command with valgrind. VERSION Version 1.19 SYNOPSIS # From the command-line perl -MTest::Valgrind leaky.pl # From the command-line, snippet style perl -MTest::Valgrind -e 'leaky()' # In a test file use Test::More; eval 'use Test::Valgrind'; plan skip_all => 'Test::Valgrind is required to test your distribution with valgrind' if $@; leaky(); # In all the test files of a directory prove --exec 'perl -Iblib/lib -Iblib/arch -MTest::Valgrind' t/*.t DESCRIPTION This module is a front-end to the "Test::Valgrind::*" API that lets you run Perl code through the "memcheck" tool of the "valgrind" memory debugger, to test for memory errors and leaks. If they aren't available yet, it will first generate suppressions for the current "perl" interpreter and store them in the portable flavour of ~/.perl/Test-Valgrind/suppressions/$VERSION. The actual run will then take place, and tests will be passed or failed according to the result of the analysis. The complete API is much more versatile than this. By declaring an appropriate 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. 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 Test::Valgrind::Action class. Due to the nature of perl's memory allocator, this module can't track leaks of Perl objects. This includes non-mortalized scalars and memory cycles. However, it can track leaks of chunks of memory allocated in XS extensions with "Newx" and friends or "malloc". As such, it's complementary to the other very good leak detectors listed in the "SEE ALSO" section. METHODS "analyse" Test::Valgrind->analyse(%options); Run a "valgrind" analysis configured by %options : * "command => $command" The Test::Valgrind::Command object (or class name) to use. Defaults to Test::Valgrind::Command::PerlScript. * "tool => $tool" The Test::Valgrind::Tool object (or class name) to use. Defaults to Test::Valgrind::Tool::memcheck. * "action => $action" The Test::Valgrind::Action object (or class name) to use. Defaults to Test::Valgrind::Action::Test. * "file => $file" The file name of the script to analyse. Ignored if you supply your own custom "command", but mandatory otherwise. * "callers => $number" Specify the maximum stack depth studied when valgrind encounters an error. Raising this number improves granularity. Ignored if you supply your own custom "tool", otherwise defaults to 24 (the maximum allowed by "valgrind"). * "diag => $bool" If true, print the output of the test script as diagnostics. Ignored if you supply your own custom "action", otherwise defaults to false. * "regen_def_supp => $bool" If true, forcefully regenerate the default suppression file. Defaults to false. * "no_def_supp => $bool" If true, do not use the default suppression file. Defaults to false. * "allow_no_supp => $bool" If true, force running the analysis even if the suppression files do not refer to any "perl"-related symbol. Defaults to false. * "extra_supps => \@files" Also use suppressions from @files besides "perl"'s. Defaults to empty. "import" use Test::Valgrind %options; In the parent process, "import" calls "analyse" with the arguments it received itself - except that if no "file" option was supplied, it tries to pick the first caller context that looks like a script. 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). In the child process, it just "return"s so that the calling code is actually run under "valgrind", albeit two side-effects : * Perl::Destruct::Level is loaded and the destruction level is set to 3. * Autoflush on "STDOUT" is turned on. VARIABLES $dl_unload When set to true, all dynamic extensions that were loaded during the analysis will be unloaded at "END" time by "dl_unload_file" in DynaLoader. Since this obfuscates error stack traces, it's disabled by default. CAVEATS Perl 5.8 is notorious for leaking like there's no tomorrow, so the suppressions are very likely not to be complete on it. You also have a better chance to get more accurate results if your perl is built with debugging enabled. Using the latest "valgrind" available will also help. This module is not really secure. It's definitely not taint safe. That shouldn't be a problem for test files. What your tests output to "STDOUT" and "STDERR" is eaten unless you pass the "diag" option, in which case it will be reprinted as diagnostics. DEPENDENCIES XML::Twig, File::HomeDir, Env::Sanctify, Perl::Destruct::Level. SEE ALSO All the "Test::Valgrind::*" API, including Test::Valgrind::Command, Test::Valgrind::Tool, Test::Valgrind::Action and Test::Valgrind::Session. The valgrind(1) man page. Test::LeakTrace. Devel::Leak, Devel::LeakTrace, Devel::LeakTrace::Fast. AUTHOR Vincent Pit, "", . You can contact me by mail or on "irc.perl.org" (vincent). BUGS Please report any bugs or feature requests to "bug-test-valgrind at rt.cpan.org", or through the web interface at . I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. SUPPORT You can find documentation for this module with the perldoc command. perldoc Test::Valgrind ACKNOWLEDGEMENTS Rafaël Garcia-Suarez, for writing and instructing me about the existence of Perl::Destruct::Level (Elizabeth Mattijsen is a close second). H.Merijn Brand, for daring to test this thing. David Cantrell, for providing shell access to one of his smokers where the tests were failing. The Debian-perl team, for offering all the feedback they could regarding the build issues they met. All you people that showed interest in this module, which motivated me into completely rewriting it. COPYRIGHT & LICENSE Copyright 2008,2009,2010,2011,2013,2015,2016 Vincent Pit, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Test-Valgrind-1.19/samples/000755 000765 000024 00000000000 12747731467 016426 5ustar00vincentstaff000000 000000 Test-Valgrind-1.19/t/000755 000765 000024 00000000000 12747731467 015225 5ustar00vincentstaff000000 000000 Test-Valgrind-1.19/Valgrind.xs000644 000765 000024 00000002154 12614705465 017076 0ustar00vincentstaff000000 000000 /* This file is part of the Test::Valgrind Perl module. * See http://search.cpan.org/dist/Test::Valgrind/ */ #define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #define __PACKAGE__ "Test::Valgrind" #ifndef Newx # define Newx(v, n, c) New(0, v, n, c) #endif #ifndef DEBUGGING # define DEBUGGING 0 #endif const char *tv_leaky = NULL; /* malloc() on Windows needs the current interpreter. */ #ifdef PERL_IMPLICIT_SYS # define TV_LEAK_PROTO pTHX # define TV_LEAK_ARG aTHX #else # define TV_LEAK_PROTO void # define TV_LEAK_ARG #endif extern void tv_leak(TV_LEAK_PROTO); extern void tv_leak(TV_LEAK_PROTO) { tv_leaky = malloc(10000); return; } /* --- XS ------------------------------------------------------------------ */ MODULE = Test::Valgrind PACKAGE = Test::Valgrind PROTOTYPES: DISABLE BOOT: { HV *stash = gv_stashpv(__PACKAGE__, 1); newCONSTSUB(stash, "DEBUGGING", newSVuv(DEBUGGING)); } void leak() CODE: tv_leak(TV_LEAK_ARG); XSRETURN_UNDEF; SV * notleak(SV *sv) CODE: Newx(tv_leaky, 10000, char); Safefree(tv_leaky); RETVAL = newSVsv(sv); OUTPUT: RETVAL Test-Valgrind-1.19/t/00-load.t000644 000765 000024 00000000317 12614662253 016534 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => 1; BEGIN { use_ok( 'Test::Valgrind::Suppressions' ); } diag( "Testing Test::Valgrind $Test::Valgrind::Suppressions::VERSION, Perl $], $^X" ); Test-Valgrind-1.19/t/10-good.t000644 000765 000024 00000000716 12614710072 016542 0ustar00vincentstaff000000 000000 #!perl use strict; use warnings; use Test::More; use lib 't/lib'; eval { require Test::Valgrind; Test::Valgrind->import( diag => 1, regen_def_supp => 1, ); }; if ($@) { diag $@; plan skip_all => 'Test::Valgrind is required to test your distribution with valgrind'; } { package Test::Valgrind::Test::Fake; use base qw; } plan tests => 1; fail 'dummy test in the child, should not interfere with the actual TAP stream'; Test-Valgrind-1.19/t/12-good-run-exception.t000644 000765 000024 00000000507 12614706732 021350 0ustar00vincentstaff000000 000000 #!perl use strict; use warnings; use Test::More; use lib 't/lib'; eval { require Test::Valgrind; Test::Valgrind->import(diag => 1); }; if ($@) { diag $@; plan skip_all => 'Test::Valgrind is required to test your distribution with valgrind'; } die 'dummy run-time exception, should not cause the test to fail'; Test-Valgrind-1.19/t/20-bad.t000644 000765 000024 00000000730 12614706166 016346 0ustar00vincentstaff000000 000000 #!perl use strict; use warnings; use Test::More; use lib 't/lib'; eval { require Test::Valgrind; Test::Valgrind->import( action => 'Test::Valgrind::Test::Action', ); }; if ($@) { diag $@; plan skip_all => 'Test::Valgrind is required to test your distribution with valgrind'; } eval { require XSLoader; XSLoader::load('Test::Valgrind', $Test::Valgrind::VERSION); }; if ($@) { diag $@; } else { diag "leaking some bytes!"; Test::Valgrind::leak(); } Test-Valgrind-1.19/t/30-skip.t000644 000765 000024 00000002740 12622353114 016560 0ustar00vincentstaff000000 000000 #!perl use strict; use warnings; BEGIN { delete $ENV{PATH} } use lib 't/lib'; use VPIT::TestHelpers 'capture'; use Test::More tests => 3; use Test::Valgrind::FakeValgrind; SKIP: { my ($stat, $out, $err) = capture_perl 'BEGIN { delete $ENV{PATH} } use Test::Valgrind; 1'; skip CAPTURE_PERL_FAILED($out) => 1 unless defined $stat; like $out, qr/^1\.\.0 # (?:SKIP|Skip) Empty valgrind candidates list/, 'correctly skip when no valgrind is available'; } SKIP: { my $old_vg = Test::Valgrind::FakeValgrind->new( exe_name => 'valgrind', version => '3.0.0', ); skip $old_vg => 1 unless ref $old_vg; my $tmp_dir = $old_vg->dir; my ($stat, $out, $err) = capture_perl "BEGIN { \$ENV{PATH} = q[$tmp_dir] } use Test::Valgrind; 1"; skip CAPTURE_PERL_FAILED($out) => 1 unless defined $stat; like $out, qr/^1\.\.0 # (?:SKIP|Skip) No appropriate valgrind executable could be found/, 'correctly skip when no good valgrind was found'; } SKIP: { my $new_vg = Test::Valgrind::FakeValgrind->new( exe_name => 'valgrind', version => '3.4.0', ); skip $new_vg => 1 unless ref $new_vg; my $tmp_dir = $new_vg->dir; my ($stat, $out, $err) = capture_perl "BEGIN { \$ENV{PATH} = q[$tmp_dir] } use Test::Valgrind no_def_supp => 1, extra_supps => [ q[t/supp/no_perl] ]; 1"; skip CAPTURE_PERL_FAILED($out) => 1 unless defined $stat; like $out, qr/^1\.\.0 # (?:SKIP|Skip) No compatible suppressions available/, 'correctly skip when no compatible suppressions were available'; } Test-Valgrind-1.19/t/60-version.t000644 000765 000024 00000007333 12747161735 017323 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => 6 + 5 + 4 * 9 + 2 * 23 + 2 * 14; use Test::Valgrind::Version; sub TVV () { 'Test::Valgrind::Version' } sub sanitize { my $str = shift; $str = '(undef)' unless defined $str; 1 while chomp $str; $str =~ s/\n/\\n/g; $str; } my @command_failures = ( undef, 'valgrind', '1.2.3', 'valgrin-1.2.3', 'VALGRIND-1.2.3', "doo dah doo\nvalgrind-1.2.3", ); for my $failure (@command_failures) { my $desc = sanitize $failure; local $@; eval { TVV->new(command_output => $failure) }; like $@, qr/^Invalid argument/, "\"$desc\" correctly failed to parse as command_output"; } my @string_failures = ( undef, 'valgrind', 'valgrind-1.2.3', 'abc', 'd.e.f', ); for my $failure (@string_failures) { my $desc = sanitize $failure; local $@; eval { TVV->new(string => $failure) }; like $@, qr/^Invalid argument/, "\"$desc\" correctly failed to parse as string"; } my @command_valid = ( 'valgrind-1' => '1.0.0', 'valgrind-1.2' => '1.2.0', 'valgrind-1.2.3' => '1.2.3', 'valgrind-1.2.4-rc5' => '1.2.4', 'valgrind-1.2.6a' => '1.2.6', 'valgrind-1.2.7.' => '1.2.7', 'valgrind-1.2.x.8' => '1.2.0', 'valgrind-1.10.' => '1.10.0', 'valgrind-3.12.0.SVN' => '3.12.0', ); my @string_valid = map { my $s = $_; $s =~ s/^valgrind-//; $s } @command_valid; while (@command_valid) { my ($output, $exp) = splice @command_valid, 0, 2; my $desc = sanitize $output; local $@; my $res = eval { TVV->new(command_output => $output)->_stringify }; is $@, '', "\"$desc\" is parseable as command_output"; is $res, $exp, "\"$desc\" parses correctly as command_output"; } while (@string_valid) { my ($str, $exp) = splice @string_valid, 0, 2; my $desc = sanitize $str; local $@; my $res = eval { TVV->new(string => $str)->_stringify }; is $@, '', "\"$desc\" is parseable as string"; is $res, $exp, "\"$desc\" parses correctly as string"; } sub tvv_s { my ($string) = @_; local $@; eval { TVV->new(string => $string) }; } my @compare = ( '1', '1', 0, '1', '1.0', 0, '1', '1.0.0', 0, '1.1', '1', 1, '1.1', '1.0', 1, '1.1', '1.0.0', 1, '1', '1.1', -1, '1.0', '1.1', -1, '1.0.0', '1.1', -1, '1.1', '1.2', -1, '1.1.0', '1.2', -1, '1.1', '1.2.0', -1, '1.1.0', '1.2.0', -1, '1', '1', 0, '1.0.1', '1', 1, '1.0.1.0', '1', 1, '1.0.0.1', '1', 1, '1.0.0.1', '1.0.1', -1, '1.0.0.2', '1.0.1', -1, '3.4.0', '3.4.1', -1, '3.5.2', '3.5.1', 1, '3.12.0', '3.1.0', 1, '3.1.0', '3.12.0', -1, ); while (@compare) { my ($left, $right, $exp) = splice @compare, 0, 3; my $desc = sanitize($left) . ' <=> ' . sanitize($right); $left = tvv_s($left); $right = tvv_s($right); my ($err, $res) = ''; if (defined $left and defined $right) { local $@; $res = eval { $left <=> $right }; $err = $@; } elsif (defined $right) { $res = -2; } elsif (defined $left) { $res = 2; } is $err, '', "\"$desc\" compared without croaking"; is $res, $exp, "\"$desc\" compared correctly"; } my @stringify = ( '1', '1.0.0', '1.0', '1.0.0', '1.0.0', '1.0.0', '1.0.0.0', '1.0.0', '1.2', '1.2.0', '1.2.0', '1.2.0', '1.2.0.0', '1.2.0', '1.2.3', '1.2.3', '1.2.3.0', '1.2.3', '1.2.3.4', '1.2.3.4', '1.2.3.4.0', '1.2.3.4', '1.0.3', '1.0.3', '1.0.0.4', '1.0.0.4', '1.2.0.4', '1.2.0.4', ); while (@stringify) { my ($str, $exp) = splice @stringify, 0, 2; my $desc = sanitize($str); local $@; my $res = eval { my $v = TVV->new(string => $str); "$v" }; is $@, '', "\"$desc\" stringification did not croak"; is $res, $exp, "\"$desc\" stringified correctly"; } Test-Valgrind-1.19/t/70-session.t000644 000765 000024 00000002645 12622352671 017314 0ustar00vincentstaff000000 000000 #!perl use strict; use warnings; BEGIN { delete $ENV{PATH} } use Test::Valgrind::Session; use Test::More tests => 7; use lib 't/lib'; use Test::Valgrind::FakeValgrind; my $sess = eval { Test::Valgrind::Session->new( search_dirs => [ ], ) }; like $@, qr/^Empty valgrind candidates list/, 'no search_dirs'; $sess = eval { Test::Valgrind::Session->new( valgrind => 'wut', ) }; like $@, qr/^No appropriate valgrind executable/, 'nonexistant valgrind'; SKIP: { my $old_vg = Test::Valgrind::FakeValgrind->new( version => '3.0.0', ); skip $old_vg => 5 unless ref $old_vg; my $sess = eval { Test::Valgrind::Session->new( valgrind => $old_vg->path, min_version => '3.1.0', ) }; like $@, qr/^No appropriate valgrind executable/, 'old valgrind'; my $new_vg = Test::Valgrind::FakeValgrind->new( version => '3.4.0', ); skip $new_vg => 4 unless ref $new_vg; $sess = eval { Test::Valgrind::Session->new( valgrind => $new_vg->path, min_version => '3.1.0', ) }; is $@, '', 'new valgrind'; isa_ok $sess, 'Test::Valgrind::Session', 'new valgrind isa Test::Valgrind::Session'; $sess = eval { Test::Valgrind::Session->new( search_dirs => [ ], valgrind => [ $old_vg->path, $new_vg->path ], min_version => '3.1.0', ) }; is $@, '', 'old and new valgrind'; isa_ok $sess, 'Test::Valgrind::Session', 'old and new valgrind isa Test::Valgrind::Session'; } Test-Valgrind-1.19/t/71-session-command.t000644 000765 000024 00000003237 12621140017 020713 0ustar00vincentstaff000000 000000 #!perl use strict; use warnings; BEGIN { delete $ENV{PATH} } use Test::More tests => 2; use Test::Valgrind::Command; use Test::Valgrind::Tool; use Test::Valgrind::Session; use lib 't/lib'; use Test::Valgrind::FakeValgrind; my $cmd = Test::Valgrind::Command->new( command => 'Perl', args => [ '-e1' ], ); { package Test::Valgrind::Parser::Dummy; use base 'Test::Valgrind::Parser'; sub parse { } } { package Test::Valgrind::Tool::Dummy; use base 'Test::Valgrind::Tool::memcheck'; sub parser_class { 'Test::Valgrind::Parser::Dummy' } } my $tool = Test::Valgrind::Tool::Dummy->new(); { package Test::Valgrind::Action::Dummy; use base 'Test::Valgrind::Action'; sub do_suppressions { 0 } sub report { my ($self, $sess, $report) = @_; if ($report->is_diag) { my $contents = $report->data; if ($contents !~ /^(?:Using valgrind |No suppressions used)/) { ::diag($contents); } return; } else { $self->SUPER::report($sess, $report); } } } my $action = Test::Valgrind::Action::Dummy->new(); SKIP: { my $tmp_vg; my $sess; { my $dummy_vg = Test::Valgrind::FakeValgrind->new( exe_name => 'invisible_pink_unicorn' ); skip $dummy_vg => 2 unless ref $dummy_vg; $tmp_vg = $dummy_vg->path; local $@; $sess = eval { Test::Valgrind::Session->new( allow_no_supp => 1, no_def_supp => 1, valgrind => $tmp_vg, ); }; is $@, '', 'session was correctly created'; } skip 'dummy valgrind executable was not deleted' => 1 if -e $tmp_vg; local $@; eval { $sess->run( action => $action, command => $cmd, tool => $tool, ); }; like $@, qr/invisible_pink_unicorn/, 'command not found croaks'; } Test-Valgrind-1.19/t/80-suppressions.t000644 000765 000024 00000006150 12621207524 020375 0ustar00vincentstaff000000 000000 #!perl use strict; use warnings; use Test::More tests => 4; use Test::Valgrind::Command; use Test::Valgrind::Tool; use Test::Valgrind::Session; use lib 't/lib'; use Test::Valgrind::FakeValgrind; my $cmd = Test::Valgrind::Command->new( command => 'Perl', args => [ '-e1' ], ); { package Test::Valgrind::Parser::Dummy; use base 'Test::Valgrind::Parser'; sub parse { } } { package Test::Valgrind::Tool::Dummy; use base 'Test::Valgrind::Tool::memcheck'; sub parser_class { 'Test::Valgrind::Parser::Dummy' } } my $tool = Test::Valgrind::Tool::Dummy->new(); { package Test::Valgrind::Action::Dummy; use base 'Test::Valgrind::Action'; sub do_suppressions { 0 } sub report { my ($self, $sess, $report) = @_; if ($report->is_diag) { my $contents = $report->data; if ($contents !~ /^(?:Using valgrind |No suppressions used)/) { ::diag($contents); } return; } else { $self->SUPER::report($sess, $report); } } } my $dummy_action = Test::Valgrind::Action::Dummy->new(); SKIP: { my $sess = eval { Test::Valgrind::Session->new( min_version => $tool->requires_version, ) }; if (my $err = $@) { if ($err =~ /^(Empty valgrind candidates list|No appropriate valgrind executable could be found)\s+at.*/) { $err = $1; } skip $err => 2; } $sess->command($cmd); $sess->tool($tool); my $file = $sess->def_supp_file; my $VERSION = quotemeta $Test::Valgrind::Session::VERSION; my $exp = qr!$VERSION/memcheck-\d+(?:\.\d+)*-[0-9a-f]{32}\.supp$!; like $file, $exp, 'default suppression file is correctly named'; my $res = open my $supp_fh, '<', $file; my $err = $!; ok $res, 'default suppression file can be opened'; diag "open($file): $err" unless $res; if ($res) { my ($count, $non_empty, $perl_related) = (0, 0, 0); my ($in, $valid_frames, $seen_perl); while (<$supp_fh>) { chomp; s/^\s*//; s/\s*$//; if (!$in && $_ eq '{') { $in = 1; $valid_frames = 0; $seen_perl = 0; } elsif ($in) { if ($_ eq '}') { ++$count; ++$non_empty if $valid_frames; ++$perl_related if $seen_perl; $in = 0; } else { ++$valid_frames if /^\s*fun:/; ++$seen_perl if /^\s*fun:(Perl|S|XS)_/ or /^\s*obj:.*perl/; } } } diag "The default suppression file contains $count suppressions, of which $non_empty are not empty and $perl_related apply to perl"; close $supp_fh; } } delete $ENV{PATH}; SKIP: { my $dummy_vg = Test::Valgrind::FakeValgrind->new(); skip $dummy_vg => 2 unless ref $dummy_vg; eval { Test::Valgrind::Session->new( valgrind => $dummy_vg->path, no_def_supp => 1, extra_supp => [ 't/supp/no_perl' ], )->run( tool => $tool, command => $cmd, action => $dummy_action, ) }; like $@, qr/No compatible suppressions available/, 'incompatible suppression file'; eval { Test::Valgrind::Session->new( valgrind => $dummy_vg->path, no_def_supp => 1, allow_no_supp => 1, extra_supp => [ 't/supp/no_perl' ], )->run( tool => $tool, command => $cmd, action => $dummy_action, ) }; is $@, '', 'incompatible suppression file, but forced'; } Test-Valgrind-1.19/t/81-suppressions-demangle.t000644 000765 000024 00000002114 12621140032 022132 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; BEGIN { delete $ENV{PATH} } use Test::More tests => 2 * 7; use Test::Valgrind::Suppressions; my @Z_tests = ( [ 'malloc' => 'malloc', 'not encoded' ], [ '_vgrZU_VG_Z_dongs' => qr/Symbol with a "VG_Z_" prefix is invalid/, 'VG_Z' ], [ '_vgrZU_dongs' => qr/Symbol doesn't contain a function name/, 'no function name' ], [ '_vgrZU_libcZdsoZa_malloc' => 'malloc', 'soname encoded' ], [ '_vgrZU_libcZdsoZa_arZZZAel' => 'arZZZAel', 'soname encoded 2' ], [ '_vgrZZ_libcZdsoZa_arZZZAel' => 'arZ@el', 'function name encoded' ], [ '_vgrZZ_libcZdsoZa_arZdZXZa' => qr/Invalid escape sequence/, 'function name with invalid escapes' ], ); for (@Z_tests) { my ($sym, $exp, $desc) = @$_; my $res = eval { Test::Valgrind::Suppressions->maybe_z_demangle($sym) }; if (ref $exp) { like $@, $exp, "$desc croaks as expected"; is $res, undef, $desc; } else { is $@, '', "$desc does not croak as expected"; is $res, $exp, $desc; } } Test-Valgrind-1.19/t/lib/000755 000765 000024 00000000000 12747731467 015773 5ustar00vincentstaff000000 000000 Test-Valgrind-1.19/t/supp/000755 000765 000024 00000000000 12747731467 016214 5ustar00vincentstaff000000 000000 Test-Valgrind-1.19/t/supp/no_perl000644 000765 000024 00000000154 12620631526 017556 0ustar00vincentstaff000000 000000 { PerlSuppression999 Memcheck:Leak match-leak-kinds: definite fun:malloc fun:calloc fun:currentlocale ... } Test-Valgrind-1.19/t/lib/Test/000755 000765 000024 00000000000 12747731467 016712 5ustar00vincentstaff000000 000000 Test-Valgrind-1.19/t/lib/VPIT/000755 000765 000024 00000000000 12747731467 016555 5ustar00vincentstaff000000 000000 Test-Valgrind-1.19/t/lib/VPIT/TestHelpers.pm000644 000765 000024 00000035526 12747731211 021353 0ustar00vincentstaff000000 000000 package VPIT::TestHelpers; use strict; use warnings; use Config (); =head1 NAME VPIT::TestHelpers =head1 SYNTAX use VPIT::TestHelpers ( feature1 => \@feature1_args, feature2 => \@feature2_args, ); =cut sub export_to_pkg { my ($subs, $pkg) = @_; while (my ($name, $code) = each %$subs) { no strict 'refs'; *{$pkg.'::'.$name} = $code; } return 1; } sub sanitize_prefix { my $prefix = shift; if (defined $prefix) { if (length $prefix and $prefix !~ /_$/) { $prefix .= '_'; } } else { $prefix = ''; } return $prefix; } my %default_exports = ( load_or_skip => \&load_or_skip, load_or_skip_all => \&load_or_skip_all, skip_all => \&skip_all, ); my %features = ( threads => \&init_threads, usleep => \&init_usleep, run_perl => \&init_run_perl, capture => \&init_capture, ); sub import { shift; my @opts = @_; my %exports = %default_exports; for (my $i = 0; $i <= $#opts; ++$i) { my $feature = $opts[$i]; next unless defined $feature; my $args; if ($i < $#opts and defined $opts[$i+1] and ref $opts[$i+1] eq 'ARRAY') { ++$i; $args = $opts[$i]; } else { $args = [ ]; } my $handler = $features{$feature}; die "Unknown feature '$feature'" unless defined $handler; my %syms = $handler->(@$args); $exports{$_} = $syms{$_} for sort keys %syms; } export_to_pkg \%exports => scalar caller; } my $test_sub = sub { my $sub = shift; my $stash; if ($INC{'Test/Leaner.pm'}) { $stash = \%Test::Leaner::; } else { require Test::More; $stash = \%Test::More::; } my $glob = $stash->{$sub}; return $glob ? *$glob{CODE} : undef; }; sub skip { $test_sub->('skip')->(@_) } sub skip_all { $test_sub->('plan')->(skip_all => $_[0]) } sub diag { my $diag = $test_sub->('diag'); $diag->($_) for @_; } our $TODO; local $TODO; sub load { my ($pkg, $ver, $imports) = @_; my $spec = $ver && $ver !~ /^[0._]*$/ ? "$pkg $ver" : $pkg; my $err; local $@; if (eval "use $spec (); 1") { $ver = do { no strict 'refs'; ${"${pkg}::VERSION"} }; $ver = 'undef' unless defined $ver; if ($imports) { my @imports = @$imports; my $caller = (caller 1)[0]; local $@; my $res = eval <<"IMPORTER"; package $caller; BEGIN { \$pkg->import(\@imports) } 1; IMPORTER $err = "Could not import '@imports' from $pkg $ver: $@" unless $res; } } else { (my $file = "$pkg.pm") =~ s{::}{/}g; delete $INC{$file}; $err = "Could not load $spec"; } if ($err) { return wantarray ? (0, $err) : 0; } else { diag "Using $pkg $ver"; return 1; } } sub load_or_skip { my ($pkg, $ver, $imports, $tests) = @_; die 'You must specify how many tests to skip' unless defined $tests; my ($loaded, $err) = load($pkg, $ver, $imports); skip $err => $tests unless $loaded; return $loaded; } sub load_or_skip_all { my ($pkg, $ver, $imports) = @_; my ($loaded, $err) = load($pkg, $ver, $imports); skip_all $err unless $loaded; return $loaded; } =head1 FEATURES =head2 C =over 4 =item * Import : use VPIT::TestHelpers run_perl => [ $p ] where : =over 8 =item - C<$p> is prefixed to the constants exported by this feature (defaults to C<''>). =back =item * Dependencies : =over 8 =item - L =back =item * Exports : =over 8 =item - C =item - C =item - C (possibly prefixed by C<$p>) =back =back =cut sub fresh_perl_env (&) { my $handler = shift; my ($SystemRoot, $PATH) = @ENV{qw}; my $ld_name = $Config::Config{ldlibpthname}; my $ldlibpth = $ENV{$ld_name}; local %ENV; $ENV{$ld_name} = $ldlibpth if defined $ldlibpth; $ENV{SystemRoot} = $SystemRoot if $^O eq 'MSWin32' and defined $SystemRoot; $ENV{PATH} = $PATH if $^O eq 'cygwin' and defined $PATH; my $perl = $^X; unless (-e $perl and -x $perl) { $perl = $Config::Config{perlpath}; unless (-e $perl and -x $perl) { return undef; } } return $handler->($perl, '-T', map("-I$_", @INC)); } sub init_run_perl { my $p = sanitize_prefix(shift); # This is only required for run_perl_file(), so it is not needed for the # threads feature which only calls run_perl() - don't forget to update its # requirements if this ever changes. require File::Spec; return ( run_perl => \&run_perl, run_perl_file => \&run_perl_file, "${p}RUN_PERL_FAILED" => sub () { 'Could not execute perl subprocess' }, ); } sub run_perl { my $code = shift; if ($code =~ /"/) { die 'Double quotes in evaluated code are not portable'; } fresh_perl_env { my ($perl, @perl_args) = @_; system { $perl } $perl, @perl_args, '-e', $code; }; } sub run_perl_file { my $file = shift; $file = File::Spec->rel2abs($file); unless (-e $file and -r _) { die 'Could not run perl file'; } fresh_perl_env { my ($perl, @perl_args) = @_; system { $perl } $perl, @perl_args, $file; }; } =head2 C =over 4 =item * Import : use VPIT::TestHelpers capture => [ $p ]; where : =over 8 =item - C<$p> is prefixed to the constants exported by this feature (defaults to C<''>). =back =item * Dependencies : =over 8 =item - Neither VMS nor OS/2 =item - L =item - L =item - L =item - On MSWin32 : L =back =item * Exports : =over 8 =item - C =item - C (possibly prefixed by C<$p>) =item - C =item - C (possibly prefixed by C<$p>) =back =back =cut sub init_capture { my $p = sanitize_prefix(shift); skip_all 'Cannot capture output on VMS' if $^O eq 'VMS'; skip_all 'Cannot capture output on OS/2' if $^O eq 'os2'; load_or_skip_all 'IO::Handle', '0', [ ]; load_or_skip_all 'IO::Select', '0', [ ]; load_or_skip_all 'IPC::Open3', '0', [ ]; if ($^O eq 'MSWin32') { load_or_skip_all 'Socket', '0', [ ]; } return ( capture => \&capture, "${p}CAPTURE_FAILED" => \&capture_failed_msg, capture_perl => \&capture_perl, "${p}CAPTURE_PERL_FAILED" => \&capture_perl_failed_msg, ); } # Inspired from IPC::Cmd sub capture { my @cmd = @_; my $want = wantarray; my $fail = sub { my $err = $!; my $ext_err = $^O eq 'MSWin32' ? $^E : undef; my $syscall = shift; my $args = join ', ', @_; my $msg = "$syscall($args) failed: "; if (defined $err) { no warnings 'numeric'; my ($err_code, $err_str) = (int $err, "$err"); $msg .= "$err_str ($err_code)"; } if (defined $ext_err) { no warnings 'numeric'; my ($ext_err_code, $ext_err_str) = (int $ext_err, "$ext_err"); $msg .= ", $ext_err_str ($ext_err_code)"; } die "$msg\n"; }; my ($status, $content_out, $content_err); local $@; my $ok = eval { my ($pid, $out, $err); if ($^O eq 'MSWin32') { my $pipe = sub { socketpair $_[0], $_[1], &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC or $fail->(qw); shutdown $_[0], 1 or $fail->(qw); shutdown $_[1], 0 or $fail->(qw); return 1; }; local (*IN_R, *IN_W); local (*OUT_R, *OUT_W); local (*ERR_R, *ERR_W); $pipe->(*IN_R, *IN_W); $pipe->(*OUT_R, *OUT_W); $pipe->(*ERR_R, *ERR_W); $pid = IPC::Open3::open3('>&IN_R', '<&OUT_W', '<&ERR_W', @cmd); close *IN_W or $fail->(qw); $out = *OUT_R; $err = *ERR_R; } else { my $in = IO::Handle->new; $out = IO::Handle->new; $out->autoflush(1); $err = IO::Handle->new; $err->autoflush(1); $pid = IPC::Open3::open3($in, $out, $err, @cmd); close $in; } # Forward signals to the child (except SIGKILL) my %sig_handlers; foreach my $s (keys %SIG) { $sig_handlers{$s} = sub { kill "$s" => $pid; $SIG{$s} = $sig_handlers{$s}; }; } local $SIG{$_} = $sig_handlers{$_} for keys %SIG; unless ($want) { close $out or $fail->(qw); close $err or $fail->(qw); waitpid $pid, 0; $status = $?; return 1; } my $sel = IO::Select->new(); $sel->add($out, $err); my $fd_out = fileno $out; my $fd_err = fileno $err; my %contents; $contents{$fd_out} = ''; $contents{$fd_err} = ''; while (my @ready = $sel->can_read) { for my $fh (@ready) { my $buf; my $bytes_read = sysread $fh, $buf, 4096; if (not defined $bytes_read) { $fail->('sysread', 'fd(' . fileno($fh) . ')'); } elsif ($bytes_read) { $contents{fileno($fh)} .= $buf; } else { $sel->remove($fh); close $fh or $fail->('close', 'fd(' . fileno($fh) . ')'); last unless $sel->count; } } } waitpid $pid, 0; $status = $?; if ($^O eq 'MSWin32') { # Manual CRLF translation that couldn't be done with sysread. s/\x0D\x0A/\n/g for values %contents; } $content_out = $contents{$fd_out}; $content_err = $contents{$fd_err}; 1; }; if ("$]" < 5.014 and $ok and ($status >> 8) == 255 and defined $content_err and $content_err =~ /^open3/) { # Before perl commit 8960aa87 (between 5.12 and 5.14), exceptions in open3 # could be reported to STDERR instead of being propagated, so work around # this. $ok = 0; $@ = $content_err; } if ($ok) { return ($status, $content_out, $content_err); } else { my $err = $@; chomp $err; return (undef, $err); } } sub capture_failed_msg { my $details = shift; my $msg = 'Could not capture command output'; $msg .= " ($details)" if defined $details; return $msg; } sub capture_perl { my $code = shift; if ($code =~ /"/) { die 'Double quotes in evaluated code are not portable'; } fresh_perl_env { my @perl = @_; capture @perl, '-e', $code; }; } sub capture_perl_failed_msg { my $details = shift; my $msg = 'Could not capture perl output'; $msg .= " ($details)" if defined $details; return $msg; } =head2 C =over 4 =item * Import : use VPIT::TestHelpers threads => [ $pkg, $threadsafe_var, $force_var ]; where : =over 8 =item - C<$pkg> is the target package name that will be exercised by this test ; =item - C<$threadsafe_var> is the name of an optional variable in C<$pkg> that evaluates to true if and only if the module claims to be thread safe (not checked if either C<$threadsafe_var> or C<$pkg> is C) ; =item - C<$force_var> is the name of the environment variable that can be used to force the thread tests (defaults to C). =back =item * Dependencies : =over 8 =item - C 5.13.4 =item - L =item - L 1.67 =item - L 1.14 =back =item * Exports : =over 8 =item - C =back =item * Notes : =over 8 =item - C<< exit => 'threads_only' >> is passed to C<< threads->import >>. =back =back =cut sub init_threads { my ($pkg, $threadsafe_var, $force_var) = @_; skip_all 'This perl wasn\'t built to support threads' unless $Config::Config{useithreads}; if (defined $pkg and defined $threadsafe_var) { my $threadsafe; # run_perl() doesn't actually require anything my $stat = run_perl("require POSIX; require $pkg; exit($threadsafe_var ? POSIX::EXIT_SUCCESS() : POSIX::EXIT_FAILURE())"); if (defined $stat) { require POSIX; my $res = $stat >> 8; if ($res == POSIX::EXIT_SUCCESS()) { $threadsafe = 1; } elsif ($res == POSIX::EXIT_FAILURE()) { $threadsafe = !1; } } if (not defined $threadsafe) { skip_all "Could not detect if $pkg is thread safe or not"; } elsif (not $threadsafe) { skip_all "This $pkg is not thread safe"; } } $force_var = 'PERL_FORCE_TEST_THREADS' unless defined $force_var; my $force = $ENV{$force_var} ? 1 : !1; skip_all 'perl 5.13.4 required to test thread safety' unless $force or "$]" >= 5.013_004; unless ($INC{'threads.pm'}) { my $test_module; if ($INC{'Test/Leaner.pm'}) { $test_module = 'Test::Leaner'; } elsif ($INC{'Test/More.pm'}) { $test_module = 'Test::More'; } die "$test_module was loaded too soon" if defined $test_module; } load_or_skip_all 'threads', $force ? '0' : '1.67', [ exit => 'threads_only', ]; load_or_skip_all 'threads::shared', $force ? '0' : '1.14', [ ]; diag "Threads testing forced by \$ENV{$force_var}" if $force; return spawn => \&spawn; } sub spawn { local $@; my @diag; my $thread = eval { local $SIG{__WARN__} = sub { push @diag, "Thread creation warning: @_" }; threads->create(@_); }; push @diag, "Thread creation error: $@" if $@; diag @diag; return $thread ? $thread : (); } =head2 C =over 4 =item * Import : use VPIT::TestHelpers 'usleep' => [ @impls ]; where : =over 8 =item - C<@impls> is the list of desired implementations (which may be C<'Time::HiRes'>, C<'select'> or C<'sleep'>), in the order they should be checked. When the list is empty, it defaults to all of them. =back =item * Dependencies : none =item * Exports : =over 8 =item - C =back =back =cut sub init_usleep { my (@impls) = @_; my %impls = ( 'Time::HiRes' => sub { if (do { local $@; eval { require Time::HiRes; 1 } }) { defined and diag "Using usleep() from Time::HiRes $_" for $Time::HiRes::VERSION; return \&Time::HiRes::usleep; } else { return undef; } }, 'select' => sub { if ($Config::Config{d_select}) { diag 'Using select()-based fallback usleep()'; return sub ($) { my $s = $_[0]; my $r = 0; while ($s > 0) { my ($found, $t) = select(undef, undef, undef, $s / 1e6); last unless defined $t; $t = int($t * 1e6); $s -= $t; $r += $t; } return $r; }; } else { return undef; } }, 'sleep' => sub { diag 'Using sleep()-based fallback usleep()'; return sub ($) { my $ms = int $_[0]; my $s = int($ms / 1e6) + ($ms % 1e6 == 0 ? 0 : 1); my $t = sleep $s; return $t * 1e6; }; }, ); @impls = qw unless @impls; my $usleep; for my $impl (@impls) { next unless defined $impl and $impls{$impl}; $usleep = $impls{$impl}->(); last if defined $usleep; } skip_all "Could not find a suitable usleep() implementation among: @impls" unless $usleep; return usleep => $usleep; } =head1 CLASSES =head2 C Syntax : { my $guard = VPIT::TestHelpers::Guard->new($coderef); ... } # $codref called here =cut package VPIT::TestHelpers::Guard; sub new { my ($class, $code) = @_; bless { code => $code }, $class; } sub DESTROY { $_[0]->{code}->() } =head1 AUTHOR Vincent Pit, C<< >>, L. =head1 COPYRIGHT & LICENSE Copyright 2012,2013,2014,2015 Vincent Pit, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; Test-Valgrind-1.19/t/lib/Test/Valgrind/000755 000765 000024 00000000000 12747731467 020460 5ustar00vincentstaff000000 000000 Test-Valgrind-1.19/t/lib/Test/Valgrind/FakeValgrind.pm000644 000765 000024 00000004542 12622363743 023346 0ustar00vincentstaff000000 000000 package Test::Valgrind::FakeValgrind; use strict; use warnings; use Config (); use File::Spec; use File::Temp; sub _dummy_valgrind_code { my ($version, $body) = @_; my $perl = $^X; unless (-e $perl and -x $perl) { $perl = $Config::Config{perlpath}; unless (-e $perl and -x $perl) { return undef; } } if (defined $body) { $body = "\n$body"; } else { $body = ''; } return <<" FAKE_VG"; #!$perl if (\@ARGV == 1 && \$ARGV[0] eq '--version') { print "valgrind-$version\n"; exit 0; }$body FAKE_VG } my $good_enough_file_temp; BEGIN { $good_enough_file_temp = do { no warnings; local $@; eval { File::Temp->VERSION('0.19'); 1 } } } sub new { my ($class, %args) = @_; return 'Temporary executables do not work on Windows' if $^O eq 'MSWin32'; my $exe_name = $args{exe_name}; my $version = $args{version} || '3.1.0'; my $body = $args{body}; my $self = { }; my $exe_ext = $Config::Config{exe_ext}; $exe_ext = '' unless defined $exe_ext; if (defined $exe_name) { return 'File::Temp 0.19 is required to make a proper temporary directory' unless $good_enough_file_temp; if (length $exe_ext and $exe_name !~ /\Q$exe_ext\E$/) { $exe_name .= $exe_ext; } $self->{tmp_dir_obj} = File::Temp->newdir(CLEANUP => 1); $self->{tmp_dir} = $self->{tmp_dir_obj}->dirname; $self->{tmp_file} = File::Spec->catfile($self->{tmp_dir}, $exe_name); } else { # Can't use the OO interface if we don't wan't the file to be opened by # default, but then we have to deal with cleanup ourselves. my %args = ( TEMPLATE => 'fakevgXXXX', TMPDIR => 1, CLEANUP => 0, OPEN => 0, ); $args{SUFFIX} = $exe_ext if length $exe_ext; my $tmp_file = do { local $^W = 0; (File::Temp::tempfile(%args))[1] }; $self->{tmp_file} = $tmp_file; my ($vol, $dir) = File::Spec->splitpath($self->{tmp_file}); $self->{tmp_dir} = File::Spec->catpath($vol, $dir, ''); } my $code = _dummy_valgrind_code($version, $body); return 'Could not generate the dummy valgrind executable' unless $code; return 'Temporary file already exists' if -s $self->{tmp_file}; { open my $vg_fh, '>', $self->{tmp_file}; print $vg_fh $code; close $vg_fh; chmod 0755, $self->{tmp_file}; } bless $self, $class; } sub path { $_[0]->{tmp_file} } sub dir { $_[0]->{tmp_dir} } sub DESTROY { 1 while unlink $_[0]->{tmp_file} } 1; Test-Valgrind-1.19/t/lib/Test/Valgrind/Test/000755 000765 000024 00000000000 12747731467 021377 5ustar00vincentstaff000000 000000 Test-Valgrind-1.19/t/lib/Test/Valgrind/Test/Action.pm000644 000765 000024 00000003522 12615121574 023136 0ustar00vincentstaff000000 000000 package Test::Valgrind::Test::Action; use strict; use warnings; use base qw; my $extra_tests; BEGIN { eval { require Test::Valgrind; require XSLoader; XSLoader::load('Test::Valgrind', $Test::Valgrind::VERSION); }; if ($@) { $extra_tests = 0; } else { $extra_tests = 3; *report = *report_smart; *abort = *abort_smart; } } use Test::Builder; sub new { my $class = shift; $class->SUPER::new( diag => 1, extra_tests => $extra_tests, ); } my @filtered_reports; sub report_smart { my ($self, $sess, $report) = @_; if ($report->can('is_leak') and $report->is_leak) { my $data = $report->data; my @trace = map $_->[2] || '?', @{$data->{stack} || []}[0 .. 3]; my $valid_trace = ( $trace[0] eq 'malloc' and $trace[1] eq 'tv_leak' and ($trace[2] eq 'Perl_pp_entersub' or $trace[3] eq 'Perl_pp_entersub') ); if ($valid_trace) { push @filtered_reports, [ $report->dump, $data->{leakedbytes}, $data->{leakedblocks}, ]; return; } } $self->SUPER::report($sess, $report); } sub abort_smart { my $self = shift; $extra_tests = 0; $self->SUPER::abort(@_); } sub DESTROY { return unless $extra_tests; my $tb = Test::Builder->new; $tb->is_eq(scalar(@filtered_reports), 1, 'caught one extra leak'); if (@filtered_reports) { my $first = shift @filtered_reports; $tb->diag("The subsequent report was correctly caught:\n" . $first->[0]); $tb->is_eq($first->[1], 10_000, '10_000 bytes leaked'); $tb->is_eq($first->[2], 1, ' in one block'); for my $extra_report (@filtered_reports) { $tb->diag( "The subsequent report should NOT have been caught:\n" . $extra_report->[0] ); } } else { $tb->ok(0, 'no extra leak caught, hence no bytes leaked'); $tb->ok(0, 'no extra leak caught, hence no block leaked'); } } 1; Test-Valgrind-1.19/samples/map.pl000755 000765 000024 00000000254 12614662253 017531 0ustar00vincentstaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use lib 'blib/lib'; use Test::Valgrind; { local $SIG{ALRM} = sub { kill "TERM", $$ }; alarm 1; while (1) { map 1, 1 } } Test-Valgrind-1.19/samples/xml-output-protocol4.txt000644 000765 000024 00000053263 12614662253 023246 0ustar00vincentstaff000000 000000 ==================================================================== 11 May 2009 Protocols 1 through 3 supported Memcheck only. Protocol 4 provides XML output for Memcheck, Helgrind and Ptrcheck. Technically there are three variants of Protocol 4, one for each tool, since they produce different errors. The three variants differ only in the definition of the ERROR nonterminal and are otherwise identical. NOTE that Protocol 4 (for the current svn trunk, which will eventually become 3.5.x) is still under development. The text herein should not be regarded as the final definition. Identification of Protocols ~~~~~~~~~~~~~~~~~~~~~~~~~~~ In Protocols 1 through 3, a INT close to the start of the stream makes it possible for parsers to ascertain the version, so they can tell whether or not they can handle it. The presence of support for multiple tools brings a complication, though: it is not enough merely to state the protocol version -- the tool name must also be stated. Hence in Protocol 4, the INT is followed immediately by TEXT, to identify the tool. This duplicates the tool name present later in the preamble, but it was felt important to place the tool name right at the front along with the protocol number, for easy determination of parseability. How this specification is structured ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The TOPLEVEL nonterminal specifies top level XML output structure. It is common to all error producing tools. TOPLEVEL references TOOLSPECIFICs for each tool, and these are defined differently for each tool. Each TOOLSPECIFIC is an error, which is tool-specific. For Helgrind, a TOOLSPECIFIC may also contain a so-called thread-announcement record (described below). Overall there is a very high degree of format commonality between the three tools. Once a GUI is able to display the output correctly for one tool, it should be easy to extend it for the other two. Protocol 4 changes for Memcheck ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Protocol 4 for Memcheck is similar to Protocol 3, but has a number of changes to make it fit in the common framework: - the SUPPCOUNTS nonterminal now appears after the "Zero or more ERRORs" block, and not before it. - the abovementioned "Zero or more ERRORs" block now becomes "Zero or more of (either ERROR or ERRORCOUNTS)". - ERRORs for Memcheck may contain a SUPPRESSION field, which gives the corresponding suppression for it. - ERRORs for Memcheck now use the XWHAT and XAUXWHAT nonterminals, as well as WHAT and XWHAT. - The ad-hoc blocks and used by Memcheck have been moved inside the XWHAT for the relevant error kinds. This facilitates a common definition of ERROR across all three tools. The first two changes are required in order to correct a longstanding design flaw in the way Memcheck interacts with Valgrind's error management mechanism. See bug #186790 (https://bugs.kde.org/show_bug.cgi?id=186790). The third change was requested in #191189 (https://bugs.kde.org/show_bug.cgi?id=191189). For GUI authors upgrading from Protocol 3 or earlier, the most significant new concept to grasp is the relationship between WHAT and XWHAT, and between AUXWHAT and XAUXWHAT. The definition of Protocol 4 now follows. It is structured similarly to that of the previous protocols, except that there is a separate definition of a nonterminal called TOOLSPECIFIC for each of Memcheck, Helgrind and Ptrcheck. The XWHAT and XAUXWHAT nonterminals also have tool-specific components. Apart from that, the structure is common to all supported tools. ==================================================================== TOPLEVEL -------- The first line output is always this: All remaining output is contained within the tag-pair . Inside that, the first entity is an indication of the protocol version. This is provided so that existing parsers can identify XML created by future versions of Valgrind merely by observing that the protocol version is one they don't understand. Hence TOPLEVEL is: INT TEXT PROTOCOL Valgrind versions 3.0.0 and 3.0.1 emit protocol version 1. Versions 3.1.X and 3.2.X [and 3.3.X ??] emit protocol version 2. 3.4.X emits protocol version 3. 3.5.X emits version 4. The TEXT in is either "memcheck", "helgrind" or "exp-ptrcheck" and determines the allowed format of the ERROR nonterminal. Note that is only present when the protocol version is 4 or above. PROTOCOL for version 4 ---------------------- This is the main top-level construction. Roughly speaking, it contains a preamble, a program-started marker, the errors from the run of the program, a program-ended marker, and any further errors resulting from post-run analysis (eg, memory leak detection). Hence the following in sequence: * Various preamble lines which give version info for the various components. The text in them can be anything; it is not intended for interpretation by the GUI: Misc version/copyright text (zero or more of) * The PID of this process and of its parent: INT INT * The name of the tool being used: TEXT This can be anything, and it doesn't have to match the entry, although that might be wise. * Zero or more bindings of environment variable names to actual values. These describe precisely the instantiations of %q format specifiers used in the --xml-file= argument for the run, if any. There is one entry for each %q expanded: VAR $VAR * OPTIONALLY, if --xml-user-comment=STRING was given: STRING STRING is not escaped in any way, so that it itself may be a piece of XML with arbitrary tags etc. * The program and args: first those pertaining to Valgrind itself, and then those pertaining to the program to be run under Valgrind (the client): TEXT TEXT (zero or more of) TEXT TEXT (zero or more of) * The following, indicating that the program has now started: RUNNING The format of this string is not defined, but it is expected to be human-understandable. In current Valgrind versions it is the elapsed wallclock time since process start. * Zero or more of (either ERRORCOUNTS or TOOLSPECIFIC). * The following, indicating that the program has now finished, and that the any final wrapup (eg, for Memcheck, leak checking) is happening. FINISHED * Zero or more of (either ERRORCOUNTS or TOOLSPECIFIC). In Memcheck's case these will be complaints from the leak checker. For Ptrcheck and Helgrind we don't expect any output here (but the spec does not guarantee that either). * SUPPCOUNTS, indicating how many times each suppression was used. That's it. The tool-specific definitions for TOOLSPECIFIC are below; however let's first continue with some smaller nonterminals used in the construction of errors for all the tool types. ==================================================================== Nonterminals used in construction of ERRORs ------------------------------------------- STACK ----- STACK indicates locations in the program being debugged. A STACK is one or more FRAMEs. The first is the innermost frame, the next its caller, etc. one or more FRAME FRAME ----- FRAME records a single program location: HEX64 optionally TEXT optionally TEXT optionally TEXT optionally TEXT optionally INT Only the field is guaranteed to be present. It indicates a code ("instruction pointer") address. The optional fields, if present, appear in the order stated: * obj: gives the name of the ELF object containing the code address * fn: gives the name of the function containing the code address * dir: gives the source directory associated with the name specified by . Note the current implementation often does not put anything useful in this field. * file: gives the name of the source file containing the code address * line: gives the line number in the source file ERRORCOUNTS ----------- This specifies, for each error that has been so far presented, the number of occurrences of that error. zero or more of INT HEX64 Each gives the current error count for the error with unique tag . The counts do not have to give a count for each error so far presented - partial information is allowable. As at Valgrind rev 3793, error counts are only emitted at program termination. However, it is perfectly acceptable to periodically emit error counts as the program is running. Doing so would facilitate a GUI to dynamically update its error-count display as the program runs. SUPPCOUNTS ---------- A SUPPCOUNTS block appears exactly once, after the program terminates. It specifies the number of times each error-suppression was used. Suppressions not mentioned were used zero times. zero or more of INT TEXT The is as specified in the suppression name fields in .supp files. SUPPRESSION ----------- These are optionally emitted as part of ERRORs, and specify the suppression that would be needed to suppress the containing error. For convenience, the suppression is presented twice, once in a structured nicely wrapped up in tags, and once as raw text suitable for direct copying and pasting into a suppressions file. TEXT name of the suppression TEXT kind, eg "Memcheck:Param" TEXT (optional) aux kind, eg "write(buf)" SFRAME (one or more) frames CDATAS where CDATAS is a sequence of one or more blocks holding the raw text. Unfortunately, CDATA provides no way to escape the ending marker "]]>", which means that if the raw data contains such a sequence, it has to be split between two CDATA blocks, one ending with data "]]" and the other beginning with data "<". This is why the spec calls for one or more CDATA blocks rather than exactly one. Note that, so far, we cannot envisage a circumstance in which a generated suppression would contain the string "]]>", since neither "]" nor ">" appear to turn up in mangled symbol names. Hence it is not envisaged that there will ever be more than one CDATA block, and indeed the implementation as of Valgrind 3.5.0 will only ever generate one block (it ignores any possible escaping problems). Nevertheless the specification allows multiple blocks, as a matter of safety. SFRAME ------ Either TEXT eg denoting "obj:/usr/X11R6/lib*/libX11.so.6.2", or TEXT eg denoting "fun:*libc_write" WHAT and XWHAT -------------- WHAT supplies a single line of text, which is a human-understandable, primary description of an error. XWHAT is an extended version of WHAT. It also contains a piece of text intended for human reading, but in addition may contain arbitrary other tagged data. This extra data is tool-specific. One of its purposes is to supply GUIs with links to other data in the sequence of TOOLSPECIFICs, that are associated with the error. Another purpose is wrap certain quantities (numbers, file names, etc) embedded in the message, so that the GUIs can get hold of them without having to parse the text itself. For example, we could get: Possible data race on address 0x12345678 or alternatively Possible data race by thread #17 on address 0x12345678 17 And presumably the 17 refers to some previously emitted entity in the stream of TOOLSPECIFICs for this tool. In an XWHAT, the tag-pair is mandatory. GUIs which don't want to handle the extra fields can just ignore them and display the text part. In this way they have the option to present at least something useful to the user even in the case where the extra fields can't be handled, for whatever reason. A corollary of this is that the degenerate extended case T is exactly equivalent to T AUXWHAT and XAUXWHAT -------------------- AUXWHAT is exactly like WHAT: a single line of text. It provides additional, secondary description of an error, that should be shown to the user. XAUXWHAT relates to AUXWHAT in the same way XWHAT relates to WHAT: it wraps up extra tagged info along with the line of text that would be in the AUXWHAT. ==================================================================== ERROR definition -- common structure ------------------------------------ ERROR defines an error, and is the most complex nonterminal. For all of the tools, the structure is common, and always conforms to the following: HEX64 INT KIND (either WHAT or XWHAT) optionally: (either WHAT or XWHAT) STACK zero or more: (either AUXWHAT or XAUXWHAT or STACK) optionally: SUPPRESSION * Each error contains a unique, arbitrary 64-bit hex number. This is used to refer to the error in ERRORCOUNTS nonterminals (see above). * The tag indicates the Valgrind thread number. This value is arbitrary but may be used to determine which threads produced which errors (at least, the first instance of each error). * The tag specifies one of a small number of fixed error types, so that GUIs may roughly categorise errors by type if they want. The tags themselves are tool-specific and are defined further below, for each tool. * The "(either WHAT or XWHAT)" gives a primary description of the error. WHAT and XWHAT are defined earlier in this file. Any XWHATs appearing here may contain tool-specific subcomponents. * Optionally, a second line of primary description may be present. * A STACK gives the primary source location for the error. * There then follow zero or more of "(either AUXWHAT or XAUXWHAT or STACK)". These give further (auxiliary) information about the error, possibly including stack traces. They should be shown to the user in the order they appear. AUXWHAT and XAUXWHAT are defined earlier in this file. Any XAUXWHATs appearing here may contain tool-specific subcomponents. * Optionally, as the last field, a SUPPRESSION may be provided. This contains a suppression that would hide the error. ==================================================================== TOOLSPECIFIC definition for Memcheck ------------------------------------ For Memcheck, a TOOLSPECIFIC is simply an ERROR: TOOLSPECIFIC = ERROR ERROR details for Memcheck -------------------------- XWHATs (for definition, see above) may contain the following extra components (along with the mandatory ... component): * INT * INT These fields are used in errors that have a tag specifying a KIND of the form "Leak_*", to indicate the number of leaked bytes and blocks. XAUXWHATs (for definition, see above) may contain the following extra components (along with the mandatory ... component): * TEXT, as defined in FRAME * INT, as defined in FRAME * TEXT, as defined in FRAME KIND for Memcheck ----------------- This is a small enumeration indicating roughly the nature of an error. The possible values are: InvalidFree free/delete/delete[] on an invalid pointer MismatchedFree free/delete/delete[] does not match allocation function (eg doing new[] then free on the result) InvalidRead read of an invalid address InvalidWrite write of an invalid address InvalidJump jump to an invalid address Overlap args overlap other otherwise bogus in eg memcpy InvalidMemPool invalid mem pool specified in client request UninitCondition conditional jump/move depends on undefined value UninitValue other use of undefined value (primarily memory addresses) SyscallParam system call params are undefined or point to undefined/unaddressible memory ClientCheck "error" resulting from a client check request Leak_DefinitelyLost memory leak; the referenced blocks are definitely lost Leak_IndirectlyLost memory leak; the referenced blocks are lost because all pointers to them are also in leaked blocks Leak_PossiblyLost memory leak; only interior pointers to referenced blocks were found Leak_StillReachable memory leak; pointers to un-freed blocks are still available ==================================================================== TOOLSPECIFIC definition for Ptrcheck ------------------------------------ For Ptrcheck, a TOOLSPECIFIC is simply an ERROR: TOOLSPECIFIC = ERROR ERROR details for Ptrcheck -------------------------- Ptrcheck does not produce any XWHAT records, despite the fact that "ERROR definition -- common structure" says that tools may do so. XAUXWHATs (for definition, see above) may contain the following extra components (along with the mandatory ... component): * TEXT, as defined in FRAME * INT, as defined in FRAME * TEXT, as defined in FRAME KIND for Ptrcheck ----------------- This is a small enumeration indicating roughly the nature of an error. The possible values are: SorG Stack or global array inconsistency (roughly speaking, an overrun of a stack or global array). The blocks give further details. Heap Usage of a pointer derived from a heap block, to access outside that heap block Arith Doing arithmetic on pointers in a way that cannot possibly result in another valid pointer. Eg, adding two pointer values. SysParam Special case of "Heap", in which the invalidly-addressed memory is presented as an argument to a system call which reads or writes memory. ==================================================================== TOOLSPECIFIC definition for Helgrind ------------------------------------- For Helgrind, a TOOLSPECIFIC may be one of two things: TOOLSPECIFIC = either ERROR or ANNOUNCETHREAD ANNOUNCETHREAD -------------- The definition is INT STACK This states the creation point of a thread, and gives it a unique "hthreadid", which may be referred to in subsequent ERRORs. Note that 1. The appearance of ANNOUNCETHREAD does not mean that the thread was actually created at that point relative to any preceding or following ERRORs in the output stream -- in general the thread will have been created arbitrarily earlier. Helgrind only "announces" a thread when it needs to refer to it for the first time, in a subsequent ERROR. 2. The "hthreadid" is a number which uniquely identifies the thread for the run - no other thread will have the same hthreadid. The hthreadid is a Helgrind-specific piece of information and is unrelated to the fields in the common part of an ERROR. Be careful not to confuse the two. ERROR details for Helgrind -------------------------- XWHATs (for definition, see above) may contain the following extra components (along with the mandatory ... component): * INT fields. These refer to ANNOUNCETHREADs appearing previously in the scheme, and state the creation points of the thread(s) concerned in the ERROR. Hence it should be possible for GUIs to show users stacks of the creation points of all threads involved in each ERROR. XAUXWHATs (for definition, see above) may contain the following extra components (along with the mandatory ... component): * INT, same meaning as when referred to in XWHAT * TEXT, as defined in FRAME * INT, as defined in FRAME * TEXT, as defined in FRAME KIND for Helgrind ----------------- This is a small enumeration indicating roughly the nature of an error. The possible values are: Race Data race. Helgrind will try to show the stacks for both conflicting accesses if it can; it will always show the stack for at least one of them. UnlockUnlocked Unlocking a not-locked lock UnlockForeign Unlocking a lock held by some other thread UnlockBogus Unlocking an address which is not known to be a lock PthAPIerror One of the POSIX pthread_ functions that are intercepted by Helgrind, failed with an error code. Usually indicates something bad happening. LockOrder An inconsistency in the acquisition order of locks was observed; dangerous, as it can potentially lead to deadlocks Misc One of various miscellaneous noteworthy conditions was observed (eg, thread exited whilst holding locks, "impossible" behaviour from the underlying threading library, etc) Test-Valgrind-1.19/samples/xml-output.txt000644 000765 000024 00000027552 12614662253 021325 0ustar00vincentstaff000000 000000 As of May 2005, Valgrind can produce its output in XML form. The intention is to provide an easily parsed, stable format which is suitable for GUIs to read. Design goals ~~~~~~~~~~~~ * Produce XML output which is easily parsed * Have a stable output format which does not change much over time, so that investments in parser-writing by GUI developers is not lost as new versions of Valgrind appear. * Have an extensive output format, so that future changes to the format do not break backwards compatibility with existing parsers of it. * Produce output in a form which suitable for both offline GUIs (run all the way to the end, then examine output) and interactive GUIs (parse XML incrementally, update display as we go). * Put as much information as possible into the XML and let the GUIs decide what to show the user (a.k.a provide mechanism, not policy). * Make XML which is actually parseable by standard XML tools. How to use ~~~~~~~~~~ Run with flag --xml=yes. That`s all. Note however several caveats. * At the present time only Memcheck is supported. The scheme extends easily enough to cover Helgrind if needed. * When XML output is selected, various other settings are made. This is in order that the output format is more controlled. The settings which are changed are: - Suppression generation is disabled, as that would require user input. - Attaching to GDB is disabled for the same reason. - The verbosity level is set to 1 (-v). - Error limits are disabled. Usually if the program generates a lot of errors, Valgrind slows down and eventually stops collecting them. When outputting XML this is not the case. - VEX emulation warnings are not shown. - File descriptor leak checking is disabled. This could be re-enabled at some future point. - Maximum-detail leak checking is selected (--leak-check=full). The output format ~~~~~~~~~~~~~~~~~ For the most part this should be self descriptive. It is printed in a sort-of human-readable way for easy understanding. You may want to read the rest of this together with the results of "valgrind --xml=yes memcheck/tests/xml1" as an example. All tags are balanced: a tag is always closed by . Hence in the description that follows, mention of a tag implicitly means there is a matching closing tag . Symbols in CAPITALS are nonterminals in the grammar and are defined somewhere below. The root nonterminal is TOPLEVEL. The following nonterminals are not described further: INT is a 64-bit signed decimal integer. TEXT is arbitrary text. HEX64 is a 64-bit hexadecimal number, with leading "0x". Text strings are escaped so as to remove the <, > and & characters which would otherwise mess up parsing. They are replaced respectively with the standard encodings "<", ">" and "&" respectively. Note this is not (yet) done throughout, only for function names in .. tags-pairs. TOPLEVEL -------- The first line output is always this: All remaining output is contained within the tag-pair . Inside that, the first entity is an indication of the protocol version. This is provided so that existing parsers can identify XML created by future versions of Valgrind merely by observing that the protocol version is one they don`t understand. Hence TOPLEVEL is: INT PROTOCOL Valgrind versions 3.0.0 and 3.0.1 emit protocol version 1. Versions 3.1.X and 3.2.X emit protocol version 2. 3.4.X emits protocol version 3. PROTOCOL for version 3 ---------------------- Changes in 3.4.X (tentative): (jrs, 1 March 2008) * There may be more than one clause. * Some errors may have two blocks, rather than just one (resulting from merge of the DATASYMS branch) * Some errors may have an ORIGIN component, indicating the origins of uninitialised values. This results from the merge of the OTRACK_BY_INSTRUMENTATION branch. PROTOCOL for version 2 ---------------------- Version 2 is identical in every way to version 1, except that the time string in has changed format, and is also elapsed wallclock time since process start, and not local time or any such. In fact version 1 does not define the format of the string so in some ways this revision is irrelevant. PROTOCOL for version 1 ---------------------- This is the main top-level construction. Roughly speaking, it contains a load of preamble, the errors from the run of the program, and the result of the final leak check. Hence the following in sequence: * Various preamble lines which give version info for the various components. The text in them can be anything; it is not intended for interpretation by the GUI: Misc version/copyright text (zero or more of) * The PID of this process and of its parent: INT INT * The name of the tool being used: TEXT * OPTIONALLY, if --log-file-qualifier=VAR flag was given: VAR $VAR That is, both the name of the environment variable and its value are given. [update: as of v3.3.0, this is not present, as the --log-file-qualifier option has been removed, replaced by the %q format specifier in --log-file.] * OPTIONALLY, if --xml-user-comment=STRING was given: STRING STRING is not escaped in any way, so that it itself may be a piece of XML with arbitrary tags etc. * The program and args: first those pertaining to Valgrind itself, and then those pertaining to the program to be run under Valgrind (the client): TEXT TEXT (zero or more of) TEXT TEXT (zero or more of) * The following, indicating that the program has now started: RUNNING * Zero or more of (either ERROR or ERRORCOUNTS). * The following, indicating that the program has now finished, and that the wrapup (leak checking) is happening. FINISHED * SUPPCOUNTS, indicating how many times each suppression was used. * Zero or more ERRORs, each of which is a complaint from the leak checker. That's it. ERROR ----- This shows an error, and is the most complex nonterminal. The format is as follows: HEX64 INT KIND TEXT optionally: INT optionally: INT STACK optionally: TEXT optionally: STACK optionally: ORIGIN * Each error contains a unique, arbitrary 64-bit hex number. This is used to refer to the error in ERRORCOUNTS nonterminals (see below). * The tag indicates the Valgrind thread number. This value is arbitrary but may be used to determine which threads produced which errors (at least, the first instance of each error). * The tag specifies one of a small number of fixed error types (enumerated below), so that GUIs may roughly categorise errors by type if they want. * The tag gives a human-understandable description of the error. * For tags specifying a KIND of the form "Leak_*", the optional and indicate the number of bytes and blocks leaked by this error. * The primary STACK for this error, indicating where it occurred. * Some error types may have auxiliary information attached: TEXT gives an auxiliary human-readable description (usually of invalid addresses) STACK gives an auxiliary stack (usually the allocation/free point of a block). If this STACK is present then TEXT will precede it. KIND ---- This is a small enumeration indicating roughly the nature of an error. The possible values are: InvalidFree free/delete/delete[] on an invalid pointer MismatchedFree free/delete/delete[] does not match allocation function (eg doing new[] then free on the result) InvalidRead read of an invalid address InvalidWrite write of an invalid address InvalidJump jump to an invalid address Overlap args overlap other otherwise bogus in eg memcpy InvalidMemPool invalid mem pool specified in client request UninitCondition conditional jump/move depends on undefined value UninitValue other use of undefined value (primarily memory addresses) SyscallParam system call params are undefined or point to undefined/unaddressible memory ClientCheck "error" resulting from a client check request Leak_DefinitelyLost memory leak; the referenced blocks are definitely lost Leak_IndirectlyLost memory leak; the referenced blocks are lost because all pointers to them are also in leaked blocks Leak_PossiblyLost memory leak; only interior pointers to referenced blocks were found Leak_StillReachable memory leak; pointers to un-freed blocks are still available STACK ----- STACK indicates locations in the program being debugged. A STACK is one or more FRAMEs. The first is the innermost frame, the next its caller, etc. one or more FRAME FRAME ----- FRAME records a single program location: HEX64 optionally TEXT optionally TEXT optionally TEXT optionally TEXT optionally INT Only the field is guaranteed to be present. It indicates a code ("instruction pointer") address. The optional fields, if present, appear in the order stated: * obj: gives the name of the ELF object containing the code address * fn: gives the name of the function containing the code address * dir: gives the source directory associated with the name specified by . Note the current implementation often does not put anything useful in this field. * file: gives the name of the source file containing the code address * line: gives the line number in the source file ORIGIN ------ ORIGIN shows the origin of uninitialised data in errors that involve uninitialised data. STACK shows the origin of the uninitialised value. TEXT gives a human-understandable hint as to the meaning of the information in STACK. TEXT STACK ERRORCOUNTS ----------- This specifies, for each error that has been so far presented, the number of occurrences of that error. zero or more of INT HEX64 Each gives the current error count for the error with unique tag . The counts do not have to give a count for each error so far presented - partial information is allowable. As at Valgrind rev 3793, error counts are only emitted at program termination. However, it is perfectly acceptable to periodically emit error counts as the program is running. Doing so would facilitate a GUI to dynamically update its error-count display as the program runs. SUPPCOUNTS ---------- A SUPPCOUNTS block appears exactly once, after the program terminates. It specifies the number of times each error-suppression was used. Suppressions not mentioned were used zero times. zero or more of INT TEXT The is as specified in the suppression name fields in .supp files. Test-Valgrind-1.19/lib/Test/000755 000765 000024 00000000000 12747731467 016447 5ustar00vincentstaff000000 000000 Test-Valgrind-1.19/lib/Test/Valgrind/000755 000765 000024 00000000000 12747731467 020215 5ustar00vincentstaff000000 000000 Test-Valgrind-1.19/lib/Test/Valgrind.pm000644 000765 000024 00000027374 12747731265 020564 0ustar00vincentstaff000000 000000 package Test::Valgrind; use strict; use warnings; =head1 NAME Test::Valgrind - Generate suppressions, analyse and test any command with valgrind. =head1 VERSION Version 1.19 =cut our $VERSION = '1.19'; =head1 SYNOPSIS # From the command-line perl -MTest::Valgrind leaky.pl # From the command-line, snippet style perl -MTest::Valgrind -e 'leaky()' # In a test file use Test::More; eval 'use Test::Valgrind'; plan skip_all => 'Test::Valgrind is required to test your distribution with valgrind' if $@; leaky(); # In all the test files of a directory prove --exec 'perl -Iblib/lib -Iblib/arch -MTest::Valgrind' t/*.t =head1 DESCRIPTION This module is a front-end to the C API that lets you run Perl code through the C tool of the C memory debugger, to test for memory errors and leaks. If they aren't available yet, it will first generate suppressions for the current C interpreter and store them in the portable flavour of F<~/.perl/Test-Valgrind/suppressions/$VERSION>. The actual run will then take place, and tests will be passed or failed according to the result of the analysis. The complete API is much more versatile than this. By declaring an appropriate L 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. 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 class. Due to the nature of perl's memory allocator, this module can't track leaks of Perl objects. This includes non-mortalized scalars and memory cycles. However, it can track leaks of chunks of memory allocated in XS extensions with C and friends or C. As such, it's complementary to the other very good leak detectors listed in the L section. =head1 METHODS =head2 C Test::Valgrind->analyse(%options); Run a C analysis configured by C<%options> : =over 4 =item * C<< command => $command >> The L object (or class name) to use. Defaults to L. =item * C<< tool => $tool >> The L object (or class name) to use. Defaults to L. =item * C<< action => $action >> The L object (or class name) to use. Defaults to L. =item * C<< file => $file >> The file name of the script to analyse. Ignored if you supply your own custom C, but mandatory otherwise. =item * C<< callers => $number >> Specify the maximum stack depth studied when valgrind encounters an error. Raising this number improves granularity. Ignored if you supply your own custom C, otherwise defaults to C<24> (the maximum allowed by C). =item * C<< diag => $bool >> If true, print the output of the test script as diagnostics. Ignored if you supply your own custom C, otherwise defaults to false. =item * C<< regen_def_supp => $bool >> If true, forcefully regenerate the default suppression file. Defaults to false. =item * C<< no_def_supp => $bool >> If true, do not use the default suppression file. Defaults to false. =item * C<< allow_no_supp => $bool >> If true, force running the analysis even if the suppression files do not refer to any C-related symbol. Defaults to false. =item * C<< extra_supps => \@files >> Also use suppressions from C<@files> besides C's. Defaults to empty. =back =cut sub _croak { require Carp; Carp::croak(@_); } my %skippable_errors = ( session => [ 'Empty valgrind candidates list', 'No appropriate valgrind executable could be found', ], action => [ ], tool => [ ], command => [ ], run => [ 'No compatible suppressions available', ], ); my %filter_errors; for my $obj (keys %skippable_errors) { my @errors = @{$skippable_errors{$obj} || []}; if (@errors) { my $rxp = join '|', @errors; $rxp = qr/($rxp)\s+at.*/; $filter_errors{$obj} = sub { my ($err) = @_; if ($err =~ /$rxp/) { return ($1, 1); } else { return ($err, 0); } }; } else { $filter_errors{$obj} = sub { return ($_[0], 0); }; } } sub _default_abort { my ($err) = @_; require Test::Builder; my $tb = Test::Builder->new; my $plan = $tb->has_plan; if (defined $plan) { $tb->BAIL_OUT($err); return 255; } else { $tb->skip_all($err); return 0; } } sub analyse { shift; my %args = @_; my $instanceof = sub { require Scalar::Util; Scalar::Util::blessed($_[0]) && $_[0]->isa($_[1]); }; my $tool = delete $args{tool}; unless ($tool->$instanceof('Test::Valgrind::Tool')) { my $callers = delete $args{callers} || 24; $callers = 24 if $callers <= 0; require Test::Valgrind::Tool; local $@; $tool = eval { Test::Valgrind::Tool->new( tool => $tool || 'memcheck', callers => $callers, ); }; unless ($tool) { my ($err, $skippable) = $filter_errors{tool}->($@); _croak($err) unless $skippable; return _default_abort($err); } } require Test::Valgrind::Session; my $sess = eval { Test::Valgrind::Session->new( min_version => $tool->requires_version, map { $_ => delete $args{$_} } qw< regen_def_supp no_def_supp allow_no_supp extra_supps > ); }; unless ($sess) { my ($err, $skippable) = $filter_errors{session}->($@); _croak($err) unless $skippable; return _default_abort($err); } my $action = delete $args{action}; unless ($action->$instanceof('Test::Valgrind::Action')) { require Test::Valgrind::Action; local $@; $action = eval { Test::Valgrind::Action->new( action => $action || 'Test', diag => delete $args{diag}, ); }; unless ($action) { my ($err, $skippable) = $filter_errors{action}->($@); _croak($err) unless $skippable; return _default_abort($err); } } my $cmd = delete $args{command}; unless ($cmd->$instanceof('Test::Valgrind::Command')) { require Test::Valgrind::Command; local $@; $cmd = eval { Test::Valgrind::Command->new( command => $cmd || 'PerlScript', file => delete $args{file}, args => [ '-MTest::Valgrind=run,1' ], ); }; unless ($cmd) { my ($err, $skippable) = $filter_errors{command}->($@); _croak($err) unless $skippable; $action->abort($sess, $err); return $action->status($sess); } } { local $@; eval { $sess->run( command => $cmd, tool => $tool, action => $action, ); 1 } or do { my ($err, $skippable) = $filter_errors{run}->($@); if ($skippable) { $action->abort($sess, $err); return $action->status($sess); } else { require Test::Valgrind::Report; $action->report($sess, Test::Valgrind::Report->new_diag($@)); } } } my $status = $sess->status; $status = 255 unless defined $status; return $status; } =head2 C use Test::Valgrind %options; In the parent process, L calls L with the arguments it received itself - except that if no C option was supplied, it tries to pick the first caller context that looks like a script. 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). In the child process, it just Cs so that the calling code is actually run under C, albeit two side-effects : =over 4 =item * L is loaded and the destruction level is set to C<3>. =item * Autoflush on C is turned on. =back =cut # We use as little modules as possible in run mode so that they don't pollute # the analysis. Hence all the requires. my $run; sub import { my $class = shift; $class = ref($class) || $class; _croak('Optional arguments must be passed as key => value pairs') if @_ % 2; my %args = @_; if (defined delete $args{run} or $run) { require Perl::Destruct::Level; Perl::Destruct::Level::set_destruct_level(3); { my $oldfh = select STDOUT; $|++; select $oldfh; } $run = 1; return; } my $file = delete $args{file}; unless (defined $file) { my ($next, $last_pm); for (my $l = 0; 1; ++$l) { $next = (caller $l)[1]; last unless defined $next; next if $next =~ /^\s*\(\s*eval\s*\d*\s*\)\s*$/; if ($next =~ /\.pmc?$/) { $last_pm = $next; } else { $file = $next; last; } } $file = $last_pm unless defined $file; } unless (defined $file) { require Test::Builder; Test::Builder->new->diag('Couldn\'t find a valid source file'); return; } if ($file ne '-e') { exit $class->analyse( file => $file, %args, ); } require File::Temp; my $tmp = File::Temp->new; require Filter::Util::Call; Filter::Util::Call::filter_add(sub { my $status = Filter::Util::Call::filter_read(); if ($status > 0) { print $tmp $_; } elsif ($status == 0) { close $tmp; my $code = $class->analyse( file => $tmp->filename, %args, ); exit $code; } $status; }); } =head1 VARIABLES =head2 C<$dl_unload> When set to true, all dynamic extensions that were loaded during the analysis will be unloaded at C time by L. Since this obfuscates error stack traces, it's disabled by default. =cut our $dl_unload; END { if ($dl_unload and $run and eval { require DynaLoader; 1 }) { my @rest; DynaLoader::dl_unload_file($_) or push @rest, $_ for @DynaLoader::dl_librefs; @DynaLoader::dl_librefs = @rest; } } =head1 CAVEATS Perl 5.8 is notorious for leaking like there's no tomorrow, so the suppressions are very likely not to be complete on it. You also have a better chance to get more accurate results if your perl is built with debugging enabled. Using the latest C available will also help. This module is not really secure. It's definitely not taint safe. That shouldn't be a problem for test files. What your tests output to C and C is eaten unless you pass the C option, in which case it will be reprinted as diagnostics. =head1 DEPENDENCIES L, L, L, L. =head1 SEE ALSO All the C API, including L, L, L and L. The C man page. L. L, L, L. =head1 AUTHOR Vincent Pit, C<< >>, L. You can contact me by mail or on C (vincent). =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc Test::Valgrind =head1 ACKNOWLEDGEMENTS RafaEl Garcia-Suarez, for writing and instructing me about the existence of L (Elizabeth Mattijsen is a close second). H.Merijn Brand, for daring to test this thing. David Cantrell, for providing shell access to one of his smokers where the tests were failing. The Debian-perl team, for offering all the feedback they could regarding the build issues they met. All you people that showed interest in this module, which motivated me into completely rewriting it. =head1 COPYRIGHT & LICENSE Copyright 2008,2009,2010,2011,2013,2015,2016 Vincent Pit, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; # End of Test::Valgrind Test-Valgrind-1.19/lib/Test/Valgrind/Action/000755 000765 000024 00000000000 12747731467 021432 5ustar00vincentstaff000000 000000 Test-Valgrind-1.19/lib/Test/Valgrind/Action.pm000644 000765 000024 00000006542 12747731265 021773 0ustar00vincentstaff000000 000000 package Test::Valgrind::Action; use strict; use warnings; =head1 NAME Test::Valgrind::Action - Base class for Test::Valgrind actions. =head1 VERSION Version 1.19 =cut our $VERSION = '1.19'; =head1 DESCRIPTION This class is the base for L actions. Actions are called each time a tool encounter an error and decide what to do with it (for example passing or failing tests). =cut use Test::Valgrind::Util; use base qw; =head1 METHODS =head2 C my $tva = Test::Valgrind::Action->new(action => $action); Creates a new action object of type C<$action> by requiring and redispatching the method call to the module named C<$action> if it contains C<'::'> or to C otherwise. The class represented by C<$action> must inherit this class. =cut sub new { my $class = shift; $class = ref($class) || $class; my %args = @_; if ($class eq __PACKAGE__) { my ($action, $msg) = Test::Valgrind::Util::validate_subclass( $args{action} || 'Test', ); $class->_croak($msg) unless defined $action; return $action->new(%args); } $class->SUPER::new(@_); } =head2 C Indicates if the action wants C to run in suppression-generating mode or in analysis mode. =cut sub do_suppressions { 0 } =head2 C $tva->start($session); Called when the C<$session> starts. Defaults to set L. =head2 C $tva->report($session, $report); Invoked each time the C process attached to the C<$session> spots an error. C<$report> is a L object describing the error. Defaults to check L. =cut sub report { my ($self) = @_; $self->_croak('Action isn\'t started') unless $self->started; return; } =head2 C $tva->abort($session, $msg); Triggered when the C<$session> has to interrupt the action. Defaults to croak. =cut sub abort { $_[0]->_croak($_[2]) } =head2 C $tva->finish($session); Called when the C<$session> finishes. Defaults to clear L. =head2 C $tva->status($session); Returns the status code corresponding to the last run of the action. =cut sub status { my ($self, $sess) = @_; my $started = $self->started; $self->_croak("Action was never started") unless defined $started; $self->_croak("Action is still running") if $started; return; } =head1 SEE ALSO L, L, L. =head1 AUTHOR Vincent Pit, C<< >>, L. You can contact me by mail or on C (vincent). =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc Test::Valgrind::Action =head1 COPYRIGHT & LICENSE Copyright 2009,2010,2011,2013,2015,2016 Vincent Pit, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; # End of Test::Valgrind::Action Test-Valgrind-1.19/lib/Test/Valgrind/Carp.pm000644 000765 000024 00000002613 12747731265 021436 0ustar00vincentstaff000000 000000 package Test::Valgrind::Carp; use strict; use warnings; =head1 NAME Test::Valgrind::Carp - Carp-like private methods for Test::Valgrind objects. =head1 VERSION Version 1.19 =cut our $VERSION = '1.19'; =head1 DESCRIPTION This class only provides a C<_croak> method that lazily requires L and then croaks with the supplied message. The class should not be used outside from L and may be removed without notice. =cut sub _croak { shift; require Carp; local $Carp::CarpLevel = ($Carp::CarpLevel || 0) + 1; Carp::croak(@_); } =head1 SEE ALSO L. =head1 AUTHOR Vincent Pit, C<< >>, L. You can contact me by mail or on C (vincent). =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc Test::Valgrind::Carp =head1 COPYRIGHT & LICENSE Copyright 2009,2010,2011,2013,2015,2016 Vincent Pit, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; # End of Test::Valgrind::Carp Test-Valgrind-1.19/lib/Test/Valgrind/Command/000755 000765 000024 00000000000 12747731467 021573 5ustar00vincentstaff000000 000000 Test-Valgrind-1.19/lib/Test/Valgrind/Command.pm000644 000765 000024 00000007715 12747731265 022137 0ustar00vincentstaff000000 000000 package Test::Valgrind::Command; use strict; use warnings; =head1 NAME Test::Valgrind::Command - Base class for Test::Valgrind commands. =head1 VERSION Version 1.19 =cut our $VERSION = '1.19'; =head1 DESCRIPTION This class is the base for L commands. Commands gather information about the target of the analysis. They should also provide a default setup for generating suppressions. =cut use Test::Valgrind::Util; use base qw; =head1 METHODS =head2 C my $tvc = Test::Valgrind::Command->new( command => $command, args => \@args, ); Creates a new command object of type C<$command> by requiring and redispatching the method call to the module named C<$command> if it contains C<'::'> or to C otherwise. The class represented by C<$command> must inherit this class. The C key is used to initialize the L accessor. =cut sub new { my $class = shift; $class = ref($class) || $class; my %args = @_; my $cmd = delete $args{command}; if ($class eq __PACKAGE__ and defined $cmd) { ($cmd, my $msg) = Test::Valgrind::Util::validate_subclass($cmd); $class->_croak($msg) unless defined $cmd; return $cmd->new(%args); } my $args = delete $args{args}; $class->_croak('Invalid argument list') if $args and ref $args ne 'ARRAY'; bless { args => $args, }, $class; } =head2 C Creates a new command object suitable for generating suppressions. Defaults to return C, which skips suppression generation. =cut sub new_trainer { } =head2 C my @args = $tvc->args($session); Returns the list of command-specific arguments that are to be passed to C. Defaults to return the contents of the C option. =cut sub args { @{$_[0]->{args} || []} } =head2 C my $env = $tvc->env($session); This event is called in scalar context before the command is ran, and the returned value goes out of scope when the analysis ends. It's useful for e.g. setting up C<%ENV> for the child process by returning an L object, hence the name. Defaults to void. =cut sub env { } =head2 C my $tag = $tvc->suppressions_tag($session); Returns a identifier that will be used to pick up the right suppressions for running the command, or C to indicate that no special suppressions are needed. This method must be implemented when subclassing. =cut sub suppressions_tag; =head2 C my $supp_ok = $tvc->check_suppressions_file($file); Returns a boolean indicating whether the suppressions contained in C<$file> are compatible with the command. Defaults to true. =cut sub check_suppressions_file { 1 } =head2 C my $filtered_report = $tvc->filter($session, $report); The C<$session> calls this method after receiving a report from the tool and before forwarding it to the action. You can either return a mangled C<$report> (which does not need to be a clone of the original) or C if you want the action to ignore it completely. Defaults to the identity function. =cut sub filter { $_[2] } =head1 SEE ALSO L, L. =head1 AUTHOR Vincent Pit, C<< >>, L. You can contact me by mail or on C (vincent). =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc Test::Valgrind::Command =head1 COPYRIGHT & LICENSE Copyright 2009,2010,2011,2013,2015,2016 Vincent Pit, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; # Test::Valgrind::Command Test-Valgrind-1.19/lib/Test/Valgrind/Component.pm000644 000765 000024 00000004545 12747731265 022521 0ustar00vincentstaff000000 000000 package Test::Valgrind::Component; use strict; use warnings; =head1 NAME Test::Valgrind::Component - Base class for Test::Valgrind components. =head1 VERSION Version 1.19 =cut our $VERSION = '1.19'; =head1 DESCRIPTION This class is the base for all others that act as components that can be started and stopped. =cut use Scalar::Util (); use base qw; =head1 METHODS =head2 C my $tvc = Test::Valgrind::Component->new; Basic constructor. =cut sub new { my $self = shift; my $class = $self; if (Scalar::Util::blessed($self)) { $class = ref $self; if ($self->isa(__PACKAGE__)) { $self->{started} = undef; return $self; } } bless { started => undef, }, $class; } =head2 C $tvc->started($bool); Specifies whether the component is running (C<1>), stopped (C<0>) or was never started (C). =cut sub started { @_ <= 1 ? $_[0]->{started} : ($_[0]->{started} = $_[1] ? 1 : 0) } =head2 C $tvc->start; Marks the component as started, and throws an exception if it was already. Returns its self object. =cut sub start { my ($self) = @_; $self->_croak(ref($self) . ' component already started') if $self->started; $self->started(1); $self; } =head2 C $tvc->finish; Marks the component as stopped, and throws an exception if it wasn't started. Returns its self object. =cut sub finish { my ($self) = @_; $self->_croak(ref($self) . ' component is not started') unless $self->started; $self->started(0); $self; } =head1 SEE ALSO L. =head1 AUTHOR Vincent Pit, C<< >>, L. You can contact me by mail or on C (vincent). =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc Test::Valgrind::Component =head1 COPYRIGHT & LICENSE Copyright 2009,2010,2011,2013,2015,2016 Vincent Pit, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; # End of Test::Valgrind::Component Test-Valgrind-1.19/lib/Test/Valgrind/Parser/000755 000765 000024 00000000000 12747731467 021451 5ustar00vincentstaff000000 000000 Test-Valgrind-1.19/lib/Test/Valgrind/Parser.pm000644 000765 000024 00000004442 12747731265 022007 0ustar00vincentstaff000000 000000 package Test::Valgrind::Parser; use strict; use warnings; =head1 NAME Test::Valgrind::Parser - Base class for Test::Valgrind parsers. =head1 VERSION Version 1.19 =cut our $VERSION = '1.19'; =head1 DESCRIPTION This class is the base for L parsers. =cut use base qw; =head1 METHODS =head2 C my $tvp = Test::Valgrind::Parser->new; The parser constructor, called without arguments. Defaults to L. =head2 C $tvp->start($session); Called when the C<$session> starts. Defaults to set L. =head2 C my @args = $tvp->args($session, $fh); Returns the list of parser-specific arguments that are to be passed to the C process spawned by the session C<$session> and whose output will be captured by the filehandle C<$fh>. Defaults to the empty list. =cut sub args { } =head2 C my $aborted = $tvp->parse($session, $fh); Parses the output of the C process attached to the session C<$session> received through the filehandle C<$fh>. Returns true when the output indicates that C has aborted. This method must be implemented when subclassing. =cut sub parse; =head2 C $tvp->finish($session); Called when the C<$session> finishes. Defaults to clear L. =head1 SEE ALSO L, L, L. =head1 AUTHOR Vincent Pit, C<< >>, L. You can contact me by mail or on C (vincent). =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc Test::Valgrind::Parser =head1 COPYRIGHT & LICENSE Copyright 2009,2010,2011,2013,2015,2016 Vincent Pit, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; # End of Test::Valgrind::Parser Test-Valgrind-1.19/lib/Test/Valgrind/Report.pm000644 000765 000024 00000006511 12747731265 022025 0ustar00vincentstaff000000 000000 package Test::Valgrind::Report; use strict; use warnings; =head1 NAME Test::Valgrind::Report - Base class for Test::Valgrind error reports. =head1 VERSION Version 1.19 =cut our $VERSION = '1.19'; =head1 DESCRIPTION This class provides a generic API for messages (the so-called I) generated by the parser, filtered by the tool and the command, and handled by the action. The tool has authority for deciding in which subclass of this one reports should be blessed. Reports are classified by I. The C kind is reserved for diagnostics. =cut use base qw; =head2 C my $tvr = Test::Valgrind::Report->new( kind => $kind, id => $id, data => $data, ); Your usual constructor. All options are mandatory : =over 4 =item * C is the category of the report. =item * C is an unique identifier for the report. =item * C is the content. =back =cut sub new { my $class = shift; $class = ref($class) || $class; my %args = @_; my $kind = delete $args{kind}; $class->_croak("Invalid kind $kind for $class") unless $class->valid_kind($kind); my $id = delete $args{id}; $class->_croak("Invalid identifier $id") unless defined $id and not ref $id; my $data = delete $args{data}; bless { kind => $kind, id => $id, data => $data, }, $class; } =head2 C my $diag_report = Test::Valgrind::Report->new_diag($data); Constructs a report with kind C<'Diag'>, an auto-incremented identifier and the given C<$data>. =cut my $diag_id = 0; sub new_diag { shift->new(kind => 'Diag', id => ++$diag_id, data => $_[0]) } =head2 C my $kind = $tvr->kind; Read-only accessor for the C option. =cut sub kind { $_[0]->{kind} } =head2 C my $id = $tvr->id; Read-only accessor for the C option. =cut sub id { $_[0]->{id} } =head2 C my $data = $tvr->data; Read-only accessor for the C option. =cut sub data { $_[0]->{data} } =head2 C $tvr->is_diag; Tells if a report has the C<'Diag'> kind, i.e. is a diagnostic. =cut sub is_diag { $_[0]->kind eq 'Diag' } =head2 C my @kinds = $tvr->kinds; Returns the list of valid kinds for this report class. Defaults to C<'Diag'>. =cut sub kinds { 'Diag' } =head2 C $tvr->valid_kind($kind); Tells whether C<$kind> is a valid kind for this report class. Defaults to true iff C<$kind eq 'Diag'>. =cut sub valid_kind { $_[1] eq 'Diag' } =head1 SEE ALSO L. =head1 AUTHOR Vincent Pit, C<< >>, L. You can contact me by mail or on C (vincent). =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc Test::Valgrind::Report =head1 COPYRIGHT & LICENSE Copyright 2009,2010,2011,2013,2015,2016 Vincent Pit, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; # End of Test::Valgrind::Report Test-Valgrind-1.19/lib/Test/Valgrind/Session.pm000644 000765 000024 00000035547 12747731265 022210 0ustar00vincentstaff000000 000000 package Test::Valgrind::Session; use strict; use warnings; =head1 NAME Test::Valgrind::Session - Test::Valgrind session object. =head1 VERSION Version 1.19 =cut our $VERSION = '1.19'; =head1 DESCRIPTION This class supervises the execution of the C process. It also acts as a dispatcher between the different components. =cut use Config (); use File::Spec (); use ExtUtils::MM (); # MM->maybe_command() use Scalar::Util (); use Fcntl (); # F_SETFD use IO::Select; use POSIX (); # SIGKILL, _exit() use base qw; use Test::Valgrind::Version; =head1 METHODS =head2 C my $tvs = Test::Valgrind::Session->new( search_dirs => \@search_dirs, valgrind => $valgrind, # One candidate valgrind => \@valgrind, # Several candidates min_version => $min_version, regen_def_supp => $regen_def_supp, no_def_supp => $no_def_supp, allow_no_supp => $allow_no_supp, extra_supps => \@extra_supps, ); The package constructor, which takes several options : =over 4 =item * All the directories from C<@search_dirs> will have F appended to create a list of candidates for the C executable. Defaults to the current C environment variable. =item * If a simple scalar C<$valgrind> is passed as the value to C<'valgrind'>, it will be the only candidate. C<@search_dirs> will then be ignored. If an array refernce C<\@valgrind> is passed, its values will be I to the list of the candidates resulting from C<@search_dirs>. =item * C<$min_version> specifies the minimal C version required. The constructor will croak if it's not able to find an adequate C from the supplied candidates list and search path. Defaults to none. =item * If C<$regen_def_supp> is true, the default suppression file associated with the tool and the command will be forcefully regenerated. Defaults to false. =item * If C<$no_def_supp> is true, C won't read the default suppression file associated with the tool and the command. Defaults to false. =item * If C<$allow_no_supp> is true, the command will always be run into C even if no appropriate suppression file is available. Defaults to false. =item * C<$extra_supps> is a reference to an array of optional suppression files that will be passed to C. Defaults to none. =back =cut sub new { my $class = shift; $class = ref($class) || $class; my %args = @_; my @paths; my $vg = delete $args{valgrind}; if (defined $vg and not ref $vg) { @paths = ($vg); } else { push @paths, @$vg if defined $vg and ref $vg eq 'ARRAY'; my $dirs = delete $args{search_dirs}; $dirs = [ File::Spec->path ] unless defined $dirs; my $exe_name = 'valgrind'; $exe_name .= $Config::Config{exe_ext} if defined $Config::Config{exe_ext}; push @paths, map File::Spec->catfile($_, $exe_name), @$dirs if ref $dirs eq 'ARRAY'; } $class->_croak('Empty valgrind candidates list') unless @paths; my $min_version = delete $args{min_version}; if (defined $min_version) { $min_version = Test::Valgrind::Version->new(string => $min_version); } my ($valgrind, $version); for my $path (@paths) { next unless defined($path) and MM->maybe_command($path); my $output = qx/$path --version/; my $ver = do { local $@; eval { Test::Valgrind::Version->new(command_output => $output) }; }; if (defined $ver) { next if defined $min_version and $ver < $min_version; $valgrind = $path; $version = $ver; last; } } $class->_croak('No appropriate valgrind executable could be found') unless defined $valgrind; my $extra_supps = delete $args{extra_supps}; $extra_supps = [ ] unless $extra_supps and ref $extra_supps eq 'ARRAY'; @$extra_supps = grep { defined && -f $_ && -r _ } @$extra_supps; bless { valgrind => $valgrind, version => $version, regen_def_supp => delete($args{regen_def_supp}), no_def_supp => delete($args{no_def_supp}), allow_no_supp => delete($args{allow_no_supp}), extra_supps => $extra_supps, }, $class; } =head2 C my $valgrind_path = $tvs->valgrind; The path to the selected C executable. =head2 C my $valgrind_version = $tvs->version; The L object associated to the selected C. =head2 C my $regen_def_supp = $tvs->regen_def_supp; Read-only accessor for the C option. =cut =head2 C my $no_def_supp = $tvs->no_def_supp; Read-only accessor for the C option. =head2 C my $allow_no_supp = $tvs->allow_no_supp; Read-only accessor for the C option. =cut eval "sub $_ { \$_[0]->{$_} }" for qw< valgrind version regen_def_supp no_def_supp allow_no_supp >; =head2 C my @extra_supps = $tvs->extra_supps; Read-only accessor for the C option. =cut sub extra_supps { @{$_[0]->{extra_supps} || []} } =head2 C $tvs->run( action => $action, tool => $tool, command => $command, ); Runs the command C<$command> through C with the tool C<$tool>, which will report to the action C<$action>. If the command is a L object, the action and the tool will be initialized once before running all the aggregated commands. =cut sub run { my ($self, %args) = @_; for (qw) { my $base = 'Test::Valgrind::' . ucfirst; my $value = $args{$_}; $self->_croak("Invalid $_") unless Scalar::Util::blessed($value) and $value->isa($base); $self->$_($args{$_}) } my $cmd = $self->command; if ($cmd->isa('Test::Valgrind::Command::Aggregate')) { for my $subcmd ($cmd->commands) { $args{command} = $subcmd; $self->run(%args); } return; } $self->report($self->report_class->new_diag( 'Using valgrind ' . $self->version . ' located at ' . $self->valgrind )); my $env = $self->command->env($self); my @supp_args; if ($self->do_suppressions) { push @supp_args, '--gen-suppressions=all'; } else { if (!$self->no_def_supp) { my $def_supp = $self->def_supp_file; my $forced; if ($self->regen_def_supp and -e $def_supp) { 1 while unlink $def_supp; $forced = 1; } if (defined $def_supp and not -e $def_supp) { $self->report($self->report_class->new_diag( 'Generating suppressions' . ($forced ? ' (forced)' : '') . '...' )); require Test::Valgrind::Suppressions; Test::Valgrind::Suppressions->generate( tool => $self->tool, command => $self->command, target => $def_supp, ); $self->_croak('Couldn\'t generate suppressions') unless -e $def_supp; $self->report($self->report_class->new_diag( "Suppressions for this perl stored in $def_supp" )); } } my @supp_files = grep { -e $_ and $self->command->check_suppressions_file($_) } $self->suppressions; if (@supp_files > 1) { my $files_list = join "\n", map " $_", @supp_files; $self->report($self->report_class->new_diag( "Using suppressions from:\n$files_list" )); } elsif (@supp_files) { $self->report($self->report_class->new_diag( "Using suppressions from $supp_files[0]" )); } elsif ($self->allow_no_supp) { $self->report($self->report_class->new_diag("No suppressions used")); } else { $self->_croak("No compatible suppressions available"); } @supp_args = map "--suppressions=$_", @supp_files; } my $error; GUARDED: { my $guard = Test::Valgrind::Session::Guard->new(sub { $self->finish }); $self->start; pipe my $vrdr, my $vwtr or $self->_croak("pipe(\$vrdr, \$vwtr): $!"); { my $oldfh = select $vrdr; $|++; select $oldfh; } pipe my $erdr, my $ewtr or $self->_croak("pipe(\$erdr, \$ewtr): $!"); { my $oldfh = select $erdr; $|++; select $oldfh; } my $pid = fork; $self->_croak("fork(): $!") unless defined $pid; if ($pid == 0) { { local $@; eval { setpgrp(0, 0) }; } close $erdr or POSIX::_exit(255); local $@; eval { close $vrdr or $self->_croak("close(\$vrdr): $!"); fcntl $vwtr, Fcntl::F_SETFD(), 0 or $self->_croak("fcntl(\$vwtr, F_SETFD, 0): $!"); my @args = ( $self->valgrind, $self->tool->args($self), @supp_args, $self->parser->args($self, $vwtr), $self->command->args($self), ); { no warnings 'exec'; exec { $args[0] } @args; } $self->_croak("exec @args: $!"); }; print $ewtr $@; close $ewtr; POSIX::_exit(255); } local $@; eval { local $SIG{INT} = sub { die 'valgrind analysis was interrupted'; }; close $vwtr or $self->_croak("close(\$vwtr): $!"); close $ewtr or $self->_croak("close(\$ewtr): $!"); SEL: { my $sel = IO::Select->new($vrdr, $erdr); my $child_err; while (my @ready = $sel->can_read) { last SEL if @ready == 1 and fileno $ready[0] == fileno $vrdr; my $buf; my $bytes_read = sysread $erdr, $buf, 4096; if (not defined $bytes_read) { $self->_croak("sysread(\$erdr): $!"); } elsif ($bytes_read) { $sel->remove($vrdr) unless $child_err; $child_err .= $buf; } else { $sel->remove($erdr); die $child_err if $child_err; } } } my $aborted = $self->parser->parse($self, $vrdr); if ($aborted) { $self->report($self->report_class->new_diag("valgrind has aborted")); return 0; } 1; } or do { $error = $@; kill -(POSIX::SIGKILL()) => $pid if kill 0 => $pid; close $erdr; close $vrdr; waitpid $pid, 0; # Force the guard destructor to trigger now so that old perls don't lose $@ last GUARDED; }; $self->{exit_code} = (waitpid($pid, 0) == $pid) ? $? >> 8 : 255; close $erdr or $self->_croak("close(\$erdr): $!"); close $vrdr or $self->_croak("close(\$vrdr): $!"); return; } die $error if $error; return; } sub Test::Valgrind::Session::Guard::new { bless \($_[1]), $_[0] } sub Test::Valgrind::Session::Guard::DESTROY { ${$_[0]}->() } =head2 C Read-only accessor for the C associated to the current run. =head2 C Read-only accessor for the C associated to the current run. =head2 C Read-only accessor for the C associated to the current tool. =head2 C Read-only accessor for the C associated to the current run. =cut my @members; BEGIN { @members = qw; for (@members) { eval "sub $_ { \@_ <= 1 ? \$_[0]->{$_} : (\$_[0]->{$_} = \$_[1]) }"; die if $@; } } =head2 C Forwards to C<< ->action->do_suppressions >>. =cut sub do_suppressions { $_[0]->action->do_suppressions } =head2 C Calls C<< ->tool->parser_class >> with the current session object as the unique argument. =cut sub parser_class { $_[0]->tool->parser_class($_[0]) } =head2 C Calls C<< ->tool->report_class >> with the current session object as the unique argument. =cut sub report_class { $_[0]->tool->report_class($_[0]) } =head2 C Returns an absolute path to the default suppression file associated to the current session. C will be returned as soon as any of C<< ->command->suppressions_tag >> or C<< ->tool->suppressions_tag >> are also C. Otherwise, the file part of the name is builded by joining those two together, and the directory part is roughly F<< File::HomeDir->my_home / .perl / Test-Valgrind / suppressions / $VERSION >>. =cut sub def_supp_file { my ($self) = @_; my $tool_tag = $self->tool->suppressions_tag($self); return unless defined $tool_tag; my $cmd_tag = $self->command->suppressions_tag($self); return unless defined $cmd_tag; require File::HomeDir; # So that it's not needed at configure time. return File::Spec->catfile( File::HomeDir->my_home, '.perl', 'Test-Valgrind', 'suppressions', $VERSION, "$tool_tag-$cmd_tag.supp", ); } =head2 C my @suppressions = $tvs->suppressions; Returns the list of all the suppressions that will be passed to C. Honors L and L. =cut sub suppressions { my ($self) = @_; my @supps; unless ($self->no_def_supp) { my $def_supp = $self->def_supp_file; push @supps, $def_supp if defined $def_supp; } push @supps, $self->extra_supps; return @supps; } =head2 C $tvs->start; Starts the action and tool associated to the current run. It's automatically called at the beginning of L. =cut sub start { my $self = shift; delete @{$self}{qw}; $self->tool->start($self); $self->parser($self->parser_class->new)->start($self); $self->action->start($self); return; } =head2 C $tvs->abort($msg); Forwards to C<< ->action->abort >> after unshifting the session object to the argument list. =cut sub abort { my $self = shift; $self->action->abort($self, @_); } =head2 C $tvs->report($report); Forwards to C<< ->action->report >> after unshifting the session object to the argument list. =cut sub report { my ($self, $report) = @_; return unless defined $report; for my $handler (qw) { $report = $self->$handler->filter($self, $report); return unless defined $report; } $self->action->report($self, $report); } =head2 C $tvs->finish; Finishes the action and tool associated to the current run. It's automatically called at the end of L. =cut sub finish { my ($self) = @_; my $action = $self->action; $action->finish($self); $self->parser->finish($self); $self->tool->finish($self); my $status = $action->status($self); $self->{last_status} = defined $status ? $status : $self->{exit_code}; $self->$_(undef) for @members; return; } =head2 C my $status = $tvs->status; Returns the status code of the last run of the session. =cut sub status { $_[0]->{last_status} } =head1 SEE ALSO L, L, L, L, L. L. =head1 AUTHOR Vincent Pit, C<< >>, L. You can contact me by mail or on C (vincent). =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc Test::Valgrind::Session =head1 COPYRIGHT & LICENSE Copyright 2009,2010,2011,2013,2015,2016 Vincent Pit, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; # End of Test::Valgrind::Session Test-Valgrind-1.19/lib/Test/Valgrind/Suppressions.pm000644 000765 000024 00000011763 12747731265 023274 0ustar00vincentstaff000000 000000 package Test::Valgrind::Suppressions; use strict; use warnings; =head1 NAME Test::Valgrind::Suppressions - Generate suppressions for given tool and command. =head1 VERSION Version 1.19 =cut our $VERSION = '1.19'; =head1 DESCRIPTION This module is an helper for generating suppressions. =cut use base qw; =head1 METHODS =head2 C Test::Valgrind::Suppressions->generate( tool => $tool, command => $command, target => $target, ); Generates suppressions for the command C<< $command->new_trainer >> and the tool C<< $tool->new_trainer >>, and writes them in the file specified by C<$target>. The action used behind the scenes is L. Returns the status code. =cut sub generate { my $self = shift; my %args = @_; my $cmd = delete $args{command}; unless (ref $cmd) { require Test::Valgrind::Command; $cmd = Test::Valgrind::Command->new( command => $cmd, args => [ ], ); } $cmd = $cmd->new_trainer; return unless defined $cmd; my $tool = delete $args{tool}; unless (ref $tool) { require Test::Valgrind::Tool; $tool = Test::Valgrind::Tool->new(tool => $tool); } $tool = $tool->new_trainer; return unless defined $tool; my $target = delete $args{target}; $self->_croak('Invalid target') unless $target and not ref $target; require Test::Valgrind::Action; my $action = Test::Valgrind::Action->new( action => 'Suppressions', target => $target, name => 'PerlSuppression', ); require Test::Valgrind::Session; my $sess = Test::Valgrind::Session->new( min_version => $tool->requires_version, ); eval { $sess->run( command => $cmd, tool => $tool, action => $action, ); }; $self->_croak($@) if $@; my $status = $sess->status; $status = 255 unless defined $status; return $status; } =head2 C my $mangled_suppression = Test::Valgrind::Suppressions->maybe_generalize( $session, $suppression, ); Removes all wildcard frames at the end of the suppression. It also replaces sequences of wildcard frames by C<'...'> when C C<3.4.0> or higher is used. Returns the mangled suppression. =cut sub maybe_generalize { shift; my ($sess, $supp) = @_; 1 while $supp =~ s/[^\r\n]*:\s*\*\s*$//; # With valgrind 3.4.0, we can replace unknown series of frames by '...' my $can_ellipsis = $sess->version >= '3.4.0'; my $did_length_check; ELLIPSIS: { if ($can_ellipsis) { $supp .= "...\n"; $supp =~ s/(?:^\s*(?:\.{3}|\*:\S*|obj:\*)\s*(?:\n|\z))+/...\n/mg; } last if $did_length_check++; my $frames_count =()= $supp =~ m/^(?:(?:obj|fun|\*):|\.{3}\s*$)/mg; if ($frames_count > 24) { # Keep only 24 frames, and even sacrifice one more if we can do ellipsis. my $last = $can_ellipsis ? 23 : 24; my $len = length $supp; $supp =~ m/^(?:(?:obj|fun|\*):\S*|\.{3})\s*\n/mg for 1 .. $last; my $p = pos $supp; substr $supp, $p, $len - $p, ''; redo ELLIPSIS if $can_ellipsis; } } $supp; } =head2 C my $demangled_symbol = Test::Valgrind::Suppressions->maybe_z_demangle( $symbol, ); If C<$symbol> is Z-encoded as described in C's F, extract and decode its function name part. Otherwise, C<$symbol> is returned as is. This routine follows C's F. =cut my %z_escapes = ( a => '*', c => ':', d => '.', h => '-', p => '+', s => ' ', u => '_', A => '@', D => '$', L => '(', R => ')', Z => 'Z', ); sub maybe_z_demangle { my ($self, $sym) = @_; $sym =~ s/^_vg[rwn]Z([ZU])_// or return $sym; my $fn_is_encoded = $1 eq 'Z'; $sym =~ /^VG_Z_/ and $self->_croak('Symbol with a "VG_Z_" prefix is invalid'); $sym =~ s/^[^_]*_// or $self->_croak('Symbol doesn\'t contain a function name'); if ($fn_is_encoded) { $sym =~ s/Z(.)/ my $c = $z_escapes{$1}; $self->_croak('Invalid escape sequence') unless defined $c; $c; /ge; } $self->_croak('Empty symbol') unless length $sym; return $sym; } =head1 SEE ALSO L, L, L, L. =head1 AUTHOR Vincent Pit, C<< >>, L. You can contact me by mail or on C (vincent). =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc Test::Valgrind::Suppressions =head1 COPYRIGHT & LICENSE Copyright 2008,2009,2010,2011,2013,2015,2016 Vincent Pit, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; # End of Test::Valgrind::Suppressions Test-Valgrind-1.19/lib/Test/Valgrind/Tool/000755 000765 000024 00000000000 12747731467 021132 5ustar00vincentstaff000000 000000 Test-Valgrind-1.19/lib/Test/Valgrind/Tool.pm000644 000765 000024 00000010355 12747731265 021470 0ustar00vincentstaff000000 000000 package Test::Valgrind::Tool; use strict; use warnings; =head1 NAME Test::Valgrind::Tool - Base class for Test::Valgrind tools. =head1 VERSION Version 1.19 =cut our $VERSION = '1.19'; =head1 DESCRIPTION This class is the base for L tools. They wrap around C tools by parsing its output and sending reports to the parent session whenever an error occurs. They are expected to function both in suppressions generation and in analysis mode. =cut use Test::Valgrind::Util; use base qw; =head1 METHODS =head2 C my $required_version = $tvt->requires_version; The minimum C version needed to run this tool. Defaults to C<3.1.0>. =cut sub requires_version { '3.1.0' } =head2 C my $tvt = Test::Valgrind::Tool->new(tool => $tool); Creates a new tool object of type C<$tool> by requiring and redispatching the method call to the module named C<$tool> if it contains C<'::'> or to C otherwise. The class represented by C<$tool> must inherit this class. =cut sub new { my $class = shift; $class = ref($class) || $class; my %args = @_; if ($class eq __PACKAGE__) { my ($tool, $msg) = Test::Valgrind::Util::validate_subclass( delete $args{tool} || 'memcheck', ); $class->_croak($msg) unless defined $tool; return $tool->new(%args); } $class->SUPER::new(@_); } =head2 C my $tvt_train = Test::Valgrind::Tool->new_trainer; Creates a new tool object suitable for generating suppressions. Defaults to return C, which skips suppression generation. =cut sub new_trainer { } =head2 C my $parser_class = $tvt->parser_class($session); Returns the class from which the parser for this tool output will be instanciated. This method must be implemented when subclassing. =cut sub parser_class; =head2 C my $report_class = $tvt->report_class($session); Returns the class in which suppression reports generated by this tool will be blessed. This method must be implemented when subclassing. =cut sub report_class; =head2 C my @args = $tvt->args($session); Returns the list of tool-specific arguments that are to be passed to C. All the suppression arguments are already handled by the session. Defaults to the empty list. =cut sub args { } =head2 C my $tag = $tvt->suppressions_tag($session); Returns a identifier that will be used to pick up the right suppressions for running the tool, or C to indicate that no special suppressions are needed. This method must be implemented when subclassing. =cut sub suppressions_tag; =head2 C $tvt->start($session); Called when the C<$session> starts. Defaults to set L. =head2 C my $filtered_report = $tvt->filter($session, $report); The C<$session> calls this method after receiving a report from the parser and before letting the command filter it. You can either return a mangled C<$report> (which does not need to be a clone of the original) or C if you want the action to ignore it completely. Defaults to the identity function. =cut sub filter { $_[2] } =head2 C $tvt->finish($session); Called when the C<$session> finishes. Defaults to clear L. =head1 SEE ALSO L, L, L. =head1 AUTHOR Vincent Pit, C<< >>, L. You can contact me by mail or on C (vincent). =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc Test::Valgrind::Tool =head1 COPYRIGHT & LICENSE Copyright 2009,2010,2011,2013,2015,2016 Vincent Pit, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; # End of Test::Valgrind::Tool Test-Valgrind-1.19/lib/Test/Valgrind/Util.pm000644 000765 000024 00000003734 12747731265 021473 0ustar00vincentstaff000000 000000 package Test::Valgrind::Util; use strict; use warnings; =head1 NAME Test::Valgrind::Util - Utility routines for Test::Valgrind. =head1 VERSION Version 1.19 =cut our $VERSION = '1.19'; =head1 DESCRIPTION This module contains some helpers used by Test::Valgrind. It is not really designed to be used anywhere else. =head1 FUNCTIONS =head2 C my ($validated_type, $error_msg) = validate_subclass($type); Try to interpret C<$type> as a subclass of the caller package, and load it if its C<@ISA> is empty. Returns the validated type, or C and the relevant error message. =cut sub validate_subclass { my ($type) = @_; my $base = (caller 0)[0]; $type =~ s/[^A-Za-z0-9_:]//g; $type = "${base}::$type" if $type !~ /::/; my $stash = do { no strict 'refs'; \%{"${type}::"} }; my $ISA = ($stash && $stash->{ISA}) ? *{$stash->{ISA}}{ARRAY} : undef; unless ($ISA and @$ISA >= 1) { local $@; eval "require $type; 1" or return (undef, "Could not load subclass: $@"); } return (undef, "$type is not a subclass of $base") unless $type->isa($base); return $type; } =head1 EXPORT This module does not export anything. =head1 SEE ALSO L. =head1 AUTHOR Vincent Pit, C<< >>, L. You can contact me by mail or on C (vincent). =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc Test::Valgrind::Component =head1 COPYRIGHT & LICENSE Copyright 2015,2016 Vincent Pit, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; # End of Test::Valgrind::Util Test-Valgrind-1.19/lib/Test/Valgrind/Version.pm000644 000765 000024 00000007071 12747731265 022201 0ustar00vincentstaff000000 000000 package Test::Valgrind::Version; use strict; use warnings; =head1 NAME Test::Valgrind::Version - Object class for valgrind versions. =head1 VERSION Version 1.19 =cut our $VERSION = '1.19'; =head1 DESCRIPTION This class is used to parse, store and compare C versions. =cut use base 'Test::Valgrind::Carp'; use Scalar::Util (); my $instanceof = sub { Scalar::Util::blessed($_[0]) && $_[0]->isa($_[1]); }; =head1 METHODS =head2 C my $vg_version = Test::Valgrind::Version->new( command_output => qx{valgrind --version}, ); my $vg_version = Test::Valgrind::Version->new( string => '1.2.3', ); Creates a new L object representing a C version from one of these two sources : =over 4 =item * if the C option is specified, then C will try to parse it as the output of C. =item * otherwise the C option must be passed, and its value will be parsed as a 'dotted-integer' version number. =back An exception is raised if the version number cannot be inferred from the supplied data. =cut sub new { my ($class, %args) = @_; my $output = $args{command_output}; my $string; if (defined $output) { ($string) = $output =~ /^valgrind-([0-9]+(?:\.[0-9]+)*)/; } else { $string = $args{string}; return $string if $string->$instanceof(__PACKAGE__); if (defined $string and $string =~ /^([0-9]+(?:\.[0-9]+)*)/) { $string = $1; } else { $string = undef; } } $class->_croak('Invalid argument') unless defined $string; my @digits = map int, split /\./, $string; my $last = $#digits; for my $i (reverse 0 .. $#digits) { last if $digits[$i]; --$last; } bless { _digits => [ @digits[0 .. $last] ], _last => $last, }, $class; } BEGIN { local $@; eval "sub $_ { \$_[0]->{$_} }" for qw<_digits _last>; die $@ if $@; } =head1 OVERLOADING This class overloads numeric comparison operators (C<< <=> >>, C<< < >>, C<< <= >>, C< == >, C<< => >> and C<< > >>), as well as stringification. =cut sub _spaceship { my ($left, $right, $swap) = @_; unless ($right->$instanceof(__PACKAGE__)) { $right = __PACKAGE__->new(string => $right); } ($right, $left) = ($left, $right) if $swap; my $left_digits = $left->_digits; my $right_digits = $right->_digits; my $last_cmp = $left->_last <=> $right->_last; my $last = ($last_cmp < 0) ? $left->_last : $right->_last; for my $i (0 .. $last) { my $cmp = $left_digits->[$i] <=> $right_digits->[$i]; return $cmp if $cmp; } return $last_cmp; } sub _stringify { my $self = shift; my @digits = @{ $self->_digits }; push @digits, 0 until @digits >= 3; join '.', @digits; } use overload ( '<=>' => \&_spaceship, '""' => \&_stringify, fallback => 1, ); =head1 SEE ALSO L. =head1 AUTHOR Vincent Pit, C<< >>, L. You can contact me by mail or on C (vincent). =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc Test::Valgrind::Component =head1 COPYRIGHT & LICENSE Copyright 2015,2016 Vincent Pit, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; # End of Test::Valgrind::Version Test-Valgrind-1.19/lib/Test/Valgrind/Tool/memcheck.pm000644 000765 000024 00000012544 12747731265 023246 0ustar00vincentstaff000000 000000 package Test::Valgrind::Tool::memcheck; use strict; use warnings; =head1 NAME Test::Valgrind::Tool::memcheck - Run an analysis through the memcheck tool. =head1 VERSION Version 1.19 =cut our $VERSION = '1.19'; =head1 DESCRIPTION This class contains the information required by the session for running the C tool. =cut use Scalar::Util (); use base qw; =head1 METHODS This class inherits L. =head2 C my $required_version = $tvt->requires_version; This tool requires C C<3.1.0>. =cut sub requires_version { '3.1.0' } =head2 C my $tvtm = Test::Valgrind::Tool::memcheck->new( callers => $callers, %extra_args, ); Your usual constructor. C<$callers> specifies the number of stack frames to inspect for errors : the bigger you set it, the more granular the analysis is. Other arguments are passed straight to C<< Test::Valgrind::Tool->new >>. =cut sub new { my $class = shift; $class = ref($class) || $class; my %args = @_; my $callers = delete $args{callers}; $callers = 24 unless $callers; die 'Invalid number of callers' unless Scalar::Util::looks_like_number($callers) and $callers > 0 and $callers <= 24; my $self = bless $class->Test::Valgrind::Tool::new(%args), $class; $self->{callers} = $callers; $self; } sub new_trainer { shift->new(callers => 24) } =head2 C my $callers = $tvtm->callers; Read-only accessor for the C option. =cut sub callers { $_[0]->{callers} } sub suppressions_tag { 'memcheck-' . $_[1]->version } =head2 C my $parser_class = $tvtm->parser_class($session); This tool uses a L parser in analysis mode, and a L parser in suppressions mode. =cut sub parser_class { my ($self, $session) = @_; my $class = $session->do_suppressions ? 'Test::Valgrind::Parser::Suppressions::Text' : 'Test::Valgrind::Parser::XML::Twig'; { local $@; eval "require $class; 1" or die $@; } return $class; } =head2 C my $report_class = $tvtm->report_class($session); This tool emits C object reports in analysis mode, and C object reports in suppressions mode. =cut sub report_class { my ($self, $session) = @_; if ($session->do_suppressions) { require Test::Valgrind::Parser::Suppressions::Text; return 'Test::Valgrind::Report::Suppressions'; } else { return 'Test::Valgrind::Tool::memcheck::Report'; } } sub args { my $self = shift; my ($sess) = @_; my @args = ( '--tool=memcheck', '--leak-check=full', '--leak-resolution=high', '--show-reachable=yes', '--num-callers=' . $self->callers, '--error-limit=yes', ); push @args, '--track-origins=yes' if $sess->version >= '3.4.0' and not $sess->do_suppressions; push @args, $self->SUPER::args(@_); return @args; } =head1 SEE ALSO L, L. =head1 AUTHOR Vincent Pit, C<< >>, L. You can contact me by mail or on C (vincent). =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc Test::Valgrind::Tool::memcheck =head1 COPYRIGHT & LICENSE Copyright 2009,2010,2011,2013,2015,2016 Vincent Pit, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut # End of Test::Valgrind::Tool::memcheck package Test::Valgrind::Tool::memcheck::Report; use base qw; our $VERSION = '1.19'; my @kinds = qw< InvalidFree MismatchedFree InvalidRead InvalidWrite InvalidJump Overlap InvalidMemPool UninitCondition UninitValue SyscallParam ClientCheck Leak_DefinitelyLost Leak_IndirectlyLost Leak_PossiblyLost Leak_StillReachable >; push @kinds, __PACKAGE__->SUPER::kinds(); my %kinds_hashed = map { $_ => 1 } @kinds; sub kinds { @kinds } sub valid_kind { exists $kinds_hashed{$_[1]} } sub is_leak { $_[0]->kind =~ /^Leak_/ ? 1 : '' } my $pad; BEGIN { require Config; $pad = 2 * ($Config::Config{ptrsize} || 4); } sub dump { my ($self) = @_; my $data = $self->data; my $desc = ''; for ([ '', 2, 4 ], [ 'aux', 4, 6 ], [ 'orig', 4, 6 ]) { my ($prefix, $wind, $sind) = @$_; my ($what, $stack) = @{$data}{"${prefix}what", "${prefix}stack"}; next unless defined $what and defined $stack; $_ = ' ' x $_ for $wind, $sind; $desc .= "$wind$what\n"; for (@$stack) { my ($ip, $obj, $fn, $dir, $file, $line) = map { (defined) ? $_ : '?' } @$_; my $frame; if ($fn eq '?' and $obj eq '?') { $ip =~ s/^0x//gi; my $l = length $ip; $frame = '0x' . ($l < $pad ? ('0' x ($pad - $l)) : '') . uc($ip); } else { $frame = sprintf '%s (%s) [%s:%s]', $fn, $obj, $file, $line; } $desc .= "$sind$frame\n"; } } return $desc; } # End of Test::Valgrind::Tool::memcheck::Report Test-Valgrind-1.19/lib/Test/Valgrind/Parser/Suppressions/000755 000765 000024 00000000000 12747731467 024166 5ustar00vincentstaff000000 000000 Test-Valgrind-1.19/lib/Test/Valgrind/Parser/Text.pm000644 000765 000024 00000003062 12747731265 022730 0ustar00vincentstaff000000 000000 package Test::Valgrind::Parser::Text; use strict; use warnings; =head1 NAME Test::Valgrind::Parser::Text - Parse valgrind output as a text stream. =head1 VERSION Version 1.19 =cut our $VERSION = '1.19'; =head1 DESCRIPTION This is a L object that can extract suppressions from C's text output. =cut use base qw; =head1 METHODS =head2 C my @args = $tvp->args($session, $fh); Returns the arguments needed to tell C to print in text to the filehandle C<$fh>. =cut sub args { my $self = shift; my ($session, $fh) = @_; return ( $self->SUPER::args(@_), '--log-fd=' . fileno($fh), ); } =head1 SEE ALSO L, L. =head1 AUTHOR Vincent Pit, C<< >>, L. You can contact me by mail or on C (vincent). =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc Test::Valgrind::Parser::Text =head1 COPYRIGHT & LICENSE Copyright 2009,2010,2011,2013,2015,2016 Vincent Pit, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; # End of Test::Valgrind::Parser::Text Test-Valgrind-1.19/lib/Test/Valgrind/Parser/XML/000755 000765 000024 00000000000 12747731467 022111 5ustar00vincentstaff000000 000000 Test-Valgrind-1.19/lib/Test/Valgrind/Parser/XML.pm000644 000765 000024 00000003174 12747731265 022450 0ustar00vincentstaff000000 000000 package Test::Valgrind::Parser::XML; use strict; use warnings; =head1 NAME Test::Valgrind::Parser::XML - Parse valgrind output as an XML stream. =head1 VERSION Version 1.19 =cut our $VERSION = '1.19'; =head1 DESCRIPTION This is a base class for L objects that can parse C's XML output. =cut use base qw; =head1 METHODS =head2 C my @args = $tvp->args($session, $fh); Returns the arguments needed to tell C to print in XML to the filehandle C<$fh>. =cut sub args { my $self = shift; my ($session, $fh) = @_; my $fd_opt = $session->version >= '3.5.0' ? '--xml-fd=' : '--log-fd='; return ( $self->SUPER::args(@_), '--xml=yes', $fd_opt . fileno($fh), ); } =head1 SEE ALSO L, L. =head1 AUTHOR Vincent Pit, C<< >>, L. You can contact me by mail or on C (vincent). =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc Test::Valgrind::Parser::XML =head1 COPYRIGHT & LICENSE Copyright 2009,2010,2011,2013,2015,2016 Vincent Pit, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; # End of Test::Valgrind::Parser::XML Test-Valgrind-1.19/lib/Test/Valgrind/Parser/XML/Twig.pm000644 000765 000024 00000011556 12747731265 023365 0ustar00vincentstaff000000 000000 package Test::Valgrind::Parser::XML::Twig; use strict; use warnings; =head1 NAME Test::Valgrind::Parser::XML::Twig - Parse valgrind XML output with XML::Twig. =head1 VERSION Version 1.19 =cut our $VERSION = '1.19'; =head1 DESCRIPTION This subclass of L and L encapsulates an L parser inside the L framework. It is able to parse the XML output from C up to protocol version 4 and to generate the appropriate reports accordingly. =cut use Scalar::Util (); use base qw; BEGIN { XML::Twig->add_options('Stash'); } my %handlers = ( '/valgrindoutput/protocolversion' => \&handle_version, '/valgrindoutput/error' => \&handle_error, ); =head1 METHODS =cut sub new { my $class = shift; $class = ref($class) || $class; my %args = @_; my $stash = delete $args{stash} || { }; bless $class->XML::Twig::new( elt_class => __PACKAGE__ . '::Elt', stash => $stash, twig_roots => { map { $_ => 1 } keys %handlers }, twig_handlers => { map { $_ => $handlers{$_} } keys %handlers }, ), $class; } sub stash { shift->{Stash} } =head2 C The version of the protocol that the current stream is conforming to. It is reset before and after the parsing phase, so it's effectively only available from inside C. =cut eval "sub $_ { \@_ <= 1 ? \$_[0]->{$_} : (\$_[0]->{$_} = \$_[1]) }" for qw<_session protocol_version>; # We must store the session in ourselves because it's only possible to pass # arguments to XML::Twig objects by a global stash. sub start { my ($self, $sess) = @_; $self->SUPER::start($sess); $self->_session($sess); return; } sub parse { my ($self, $sess, $fh) = @_; $self->protocol_version(undef); $self->XML::Twig::parse($fh); $self->purge; $self->protocol_version(undef); return 0; } sub finish { my ($self, $sess) = @_; $self->_session(undef); $self->SUPER::finish($sess); return; } sub handle_version { my ($twig, $node) = @_; $twig->protocol_version($node->text); $twig->purge; } sub handle_error { my ($twig, $node) = @_; my $id = $node->kid('unique')->text; my $kind = $node->kid('kind')->text; my $data; my ($what, $xwhat); if ($twig->protocol_version >= 4) { $xwhat = $node->first_child('xwhat'); $what = $xwhat->kid('text')->text if defined $xwhat; } $what = $node->kid('what')->text unless defined $what; $data->{what} = $what; $data->{stack} = [ map $_->listify_frame, $node->kid('stack')->children('frame') ]; for (qw) { my $kid = ($xwhat || $node)->first_child($_); next unless $kid; $data->{$_} = int $kid->text; } if (my $auxwhat = $node->first_child('auxwhat')) { if (my $stack = $auxwhat->next_sibling('stack')) { $data->{auxstack} = [ map $_->listify_frame, $stack->children('frame') ]; } $data->{auxwhat} = $auxwhat->text; } if (my $origin = $node->first_child('origin')) { $data->{origwhat} = $origin->kid('what')->text; $data->{origstack} = [ map $_->listify_frame, $origin->kid('stack')->children('frame') ]; } my $sess = $twig->_session; $sess->report($sess->report_class($sess)->new( kind => $kind, id => $id, data => $data, )); $twig->purge; } =head1 SEE ALSO L, L, L. L. =head1 AUTHOR Vincent Pit, C<< >>, L. You can contact me by mail or on C (vincent). =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc Test::Valgrind::Parser::XML::Twig =head1 COPYRIGHT & LICENSE Copyright 2009,2010,2011,2013,2015,2016 Vincent Pit, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut # End of Test::Valgrind::Parser::XML::Twig package Test::Valgrind::Parser::XML::Twig::Elt; our $VERSION = '1.19'; BEGIN { require XML::Twig; } use base qw; sub kid { my ($self, $what) = @_; my $node = $self->first_child($what); $self->_croak("Couldn't get first $what child node") unless $node; return $node; } sub listify_frame { my ($frame) = @_; return unless $frame->tag eq 'frame'; return [ map { my $x = $frame->first_child($_); $x ? $x->text : undef } qw ]; } 1; # End of Test::Valgrind::Parser::XML::Twig::Elt Test-Valgrind-1.19/lib/Test/Valgrind/Parser/Suppressions/Text.pm000644 000765 000024 00000007461 12747731265 025454 0ustar00vincentstaff000000 000000 package Test::Valgrind::Parser::Suppressions::Text; use strict; use warnings; =head1 NAME Test::Valgrind::Parser::Suppressions::Text - Parse valgrind suppressions output as text blocks. =head1 VERSION Version 1.19 =cut our $VERSION = '1.19'; =head1 DESCRIPTION This is a L object that can extract suppressions from C's text output. =cut use Test::Valgrind::Suppressions; use base qw; =head1 METHODS =head2 C Generated reports are C objects. Their C member contains the raw text of the suppression. =cut sub report_class { 'Test::Valgrind::Report::Suppressions' } sub parse { my ($self, $sess, $fh) = @_; my ($s, $in) = ('', 0); my @supps; while (<$fh>) { s/^\s*#\s//; # Strip comments if (/^==/) { # Valgrind info line if (/Signal 11 being dropped from thread/) { # This might loop endlessly return 1; } next; } s/^\s*//; # Strip leading spaces s/<[^>]+>//; # Strip tags s/\s*$//; # Strip trailing spaces next unless length; if ($_ eq '{') { # A suppression block begins $in = 1; } elsif ($_ eq '}') { # A suppression block ends push @supps, $s; # Add the suppression that just ended to the list $s = ''; # Reset the state $in = 0; } elsif ($in) { # We're inside a suppresion block if (/^fun\s*:\s*(.*)/) { # Sometimes valgrind seems to forget to Z-demangle the symbol names. # Make sure it's done and append the result to the state. my $sym = $1; $s .= 'fun:' . Test::Valgrind::Suppressions->maybe_z_demangle($sym) . "\n"; } else { $s .= "$_\n"; } } } my @extra; for (@supps) { if (/\bfun:(m|c|re)alloc\b/) { my $t = $1; my %call; # Frames to append (if the value is 1) or to prepend (if it's 0) if ($t eq 'm') { # malloc can also be called by calloc or realloc $call{$_} = 1 for qw; } elsif ($t eq 're') { # realloc can also call malloc or free $call{$_} = 0 for qw; } elsif ($t eq 'c') { # calloc can also call malloc $call{$_} = 0 for qw; } my $c = $_; for (keys %call) { my $d = $c; $d =~ s/\b(fun:${t}alloc)\b/$call{$_} ? "$1\nfun:$_" : "fun:$_\n$1"/e; # Remove one line for each line added or valgrind will hate us $d =~ s/\n(.+?)\s*$/\n/; push @extra, $d; } } } my $num; $sess->report($self->report_class($sess)->new( id => ++$num, kind => 'Suppression', data => $_, )) for @supps, @extra; return 0; } =head1 SEE ALSO L, L. =head1 AUTHOR Vincent Pit, C<< >>, L. You can contact me by mail or on C (vincent). =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc Test::Valgrind::Parser::Suppressions::Text =head1 COPYRIGHT & LICENSE Copyright 2009,2010,2011,2013,2015,2016 Vincent Pit, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut # End of Test::Valgrind::Parser::Suppressions::Text package Test::Valgrind::Report::Suppressions; use base qw; sub kinds { shift->SUPER::kinds(), 'Suppression' } sub valid_kind { my ($self, $kind) = @_; $self->SUPER::valid_kind($kind) or $kind eq 'Suppression' } 1; # End of Test::Valgrind::Report::Suppressions Test-Valgrind-1.19/lib/Test/Valgrind/Command/Aggregate.pm000644 000765 000024 00000004276 12747731265 024024 0ustar00vincentstaff000000 000000 package Test::Valgrind::Command::Aggregate; use strict; use warnings; =head1 NAME Test::Valgrind::Command::Aggregate - A Test::Valgrind command that aggregates several other commands. =head1 VERSION Version 1.19 =cut our $VERSION = '1.19'; =head1 DESCRIPTION This command groups several commands together, which the session will run under the same action. =cut use Scalar::Util (); use base qw; =head1 METHODS This class inherits L. =head2 C my $tvca = Test::Valgrind::Command::Aggregate->new( commands => \@commands, %extra_args, ); =cut my $all_cmds = sub { for (@{$_[0]}) { return 0 unless Scalar::Util::blessed($_) and $_->isa('Test::Valgrind::Command'); } return 1; }; sub new { my $class = shift; $class = ref($class) || $class; my %args = @_; my $cmds = delete $args{commands}; $class->_croak('Invalid commands list') unless $cmds and ref $cmds eq 'ARRAY' and $all_cmds->($cmds); my $self = bless $class->SUPER::new(), $class; $self->{commands} = [ @$cmds ]; $self; } =head2 C my @commands = $tvca->commands; Read-only accessor for the C option. =cut sub commands { @{$_[0]->{commands} || []} } =head1 SEE ALSO L, L. =head1 AUTHOR Vincent Pit, C<< >>, L. You can contact me by mail or on C (vincent). =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc Test::Valgrind::Command::Aggregate =head1 COPYRIGHT & LICENSE Copyright 2009,2010,2011,2013,2015,2016 Vincent Pit, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; # End of Test::Valgrind::Command::Aggregate Test-Valgrind-1.19/lib/Test/Valgrind/Command/Perl.pm000644 000765 000024 00000015157 12747731265 023040 0ustar00vincentstaff000000 000000 package Test::Valgrind::Command::Perl; use strict; use warnings; =head1 NAME Test::Valgrind::Command::Perl - A Test::Valgrind command that invokes perl. =head1 VERSION Version 1.19 =cut our $VERSION = '1.19'; =head1 DESCRIPTION This command is the base for all C-based commands. It handles the suppression generation and sets the main command-line flags. =cut use List::Util (); use Env::Sanctify (); use Test::Valgrind::Suppressions; use base qw; =head1 METHODS This class inherits L. =head2 C my $tvcp = Test::Valgrind::Command::Perl->new( perl => $^X, inc => \@INC, taint_mode => $taint_mode, %extra_args, ); The package constructor, which takes several options : =over 4 =item * The C option specifies which C executable will run the arugment list given in C. Defaults to C<$^X>. =item * C is a reference to an array of paths that will be passed as C<-I> to the invoked command. Defaults to C<@INC>. =item * C<$taint_mode> is a boolean that specifies if the script should be run under taint mode. Defaults to false. =back Other arguments are passed straight to C<< Test::Valgrind::Command->new >>. =cut sub new { my $class = shift; $class = ref($class) || $class; my %args = @_; my $perl = delete $args{perl} || $^X; my $inc = delete $args{inc} || [ @INC ]; $class->_croak('Invalid INC list') unless ref $inc eq 'ARRAY'; my $taint_mode = delete $args{taint_mode}; my $trainer_file = delete $args{trainer_file}; my $self = bless $class->SUPER::new(%args), $class; $self->{perl} = $perl; $self->{inc} = $inc; $self->{taint_mode} = $taint_mode; $self->{trainer_file} = $trainer_file; return $self; } sub new_trainer { my $self = shift; require File::Temp; my ($fh, $file) = File::Temp::tempfile(UNLINK => 0); { my $curpos = tell DATA; print $fh $_ while ; seek DATA, $curpos, 0; } close $fh or $self->_croak("close(tempscript): $!"); $self->new( args => [ '-MTest::Valgrind=run,1', $file ], trainer_file => $file, @_ ); } =head2 C my $perl = $tvcp->perl; Read-only accessor for the C option. =cut sub perl { $_[0]->{perl} } =head2 C my @inc = $tvcp->inc; Read-only accessor for the C option. =cut sub inc { @{$_[0]->{inc} || []} } =head2 C my $taint_mode = $tvcp->taint_mode; Read-only accessor for the C option. =cut sub taint_mode { $_[0]->{taint_mode} } sub args { my $self = shift; return $self->perl, (('-T') x!! $self->taint_mode), map("-I$_", $self->inc), $self->SUPER::args(@_); } =head2 C my $env = $tvcp->env($session); Returns an L object that sets the environment variables C to C<3> and C to C<1> during the run. =cut sub env { Env::Sanctify->sanctify( env => { PERL_DESTRUCT_LEVEL => 3, PERL_DL_NONLAZY => 1, }, ); } sub suppressions_tag { my ($self) = @_; unless (defined $self->{suppressions_tag}) { my $env = Env::Sanctify->sanctify(sanctify => [ qr/^PERL/ ]); open my $pipe, '-|', $self->perl, '-V' or $self->_croak('open("-| ' . $self->perl . " -V\"): $!"); my $perl_v = do { local $/; <$pipe> }; close $pipe or $self->_croak('close("-| ' . $self->perl . " -V\"): $!"); require Digest::MD5; $self->{suppressions_tag} = Digest::MD5::md5_hex($perl_v); } return $self->{suppressions_tag}; } sub check_suppressions_file { my ($self, $file) = @_; { open my $fh, '<', $file or return 0; local $_; while (<$fh>) { return 1 if /^\s*fun:(Perl|S|XS)_/ or /^\s*obj:.*perl/; } close $fh; } return 0; } sub filter { my ($self, $session, $report) = @_; return $report if $report->is_diag or not $report->isa('Test::Valgrind::Report::Suppressions'); my @frames = grep length, split /\n/, $report->data; # If we see the runloop, match from here. my $top = List::Util::first(sub { $frames[$_] =~ /^\s*fun:Perl_runops_(?:standard|debug)\b/ }, 0 .. $#frames); --$top if $top; unless (defined $top) { # Otherwise, match from the latest Perl_ symbol. $top = List::Util::first(sub { $frames[$_] =~ /^\s*fun:Perl_/ }, reverse 0 .. $#frames); } unless (defined $top) { # Otherwise, match from the latest S_ symbol. $top = List::Util::first(sub { $frames[$_] =~ /^\s*fun:S_/ }, reverse 0 .. $#frames); } unless (defined $top) { # Otherwise, match from the latest XS_ symbol. $top = List::Util::first(sub { $frames[$_] =~ /^\s*fun:XS_/ }, reverse 0 .. $#frames); } $#frames = $top if defined $top; my $data = join "\n", @frames, ''; $data = Test::Valgrind::Suppressions->maybe_generalize($session, $data); $report->new( id => $report->id, kind => $report->kind, data => $data, ); } sub DESTROY { my ($self) = @_; my $file = $self->{trainer_file}; return unless $file and -e $file; 1 while unlink $file; return; } =head1 SEE ALSO L, L. L. =head1 AUTHOR Vincent Pit, C<< >>, L. You can contact me by mail or on C (vincent). =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc Test::Valgrind::Command::Perl =head1 COPYRIGHT & LICENSE Copyright 2009,2010,2011,2013,2015,2016 Vincent Pit, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; # End of Test::Valgrind::Command::Perl __DATA__ use strict; use warnings; BEGIN { require Test::Valgrind; } use Test::More; eval { require XSLoader; XSLoader::load('Test::Valgrind', $Test::Valgrind::VERSION); }; if ($@) { diag $@; *Test::Valgrind::DEBUGGING = sub { 'unknown' }; } else { Test::Valgrind::notleak("valgrind it!"); } plan tests => 1; fail 'should not be seen'; diag 'debbugging flag is ' . Test::Valgrind::DEBUGGING(); eval { require XSLoader; XSLoader::load('Test::Valgrind::Fake', 0); }; diag $@ ? 'Ok' : 'Succeeded to load Test::Valgrind::Fake but should\'t'; require List::Util; my @cards = List::Util::shuffle(0 .. 51); { package Test::Valgrind::Test::Fake; use base qw; } eval 'use Time::HiRes qw'; Test-Valgrind-1.19/lib/Test/Valgrind/Command/PerlScript.pm000644 000765 000024 00000005672 12747731265 024226 0ustar00vincentstaff000000 000000 package Test::Valgrind::Command::PerlScript; use strict; use warnings; =head1 NAME Test::Valgrind::Command::PerlScript - A Test::Valgrind command that invokes a perl script. =head1 VERSION Version 1.19 =cut our $VERSION = '1.19'; =head1 DESCRIPTION This command is meant to abstract the argument list handling of a C script. =cut use base qw; =head1 METHODS This class inherits L. =head2 C my $tvcps = Test::Valgrind::Command::PerlScript->new( file => $file, taint_mode => $taint_mode, %extra_args, ); The package constructor, which takes several options : =over 4 =item * C<$file> is the path to the C script you want to run. This option is mandatory. =item * C<$taint_mode> is actually handled by the parent class L, but it gets special handling in this subclass : if C is passed (which is the default), the constructor will try to infer its right value from the shebang line of the script. =back Other arguments are passed straight to C<< Test::Valgrind::Command::Perl->new >>. =cut sub new { my $class = shift; $class = ref($class) || $class; my %args = @_; my $file = delete $args{file}; $class->_croak('Invalid script file') unless $file and -e $file; my $taint_mode = delete $args{taint_mode}; if (not defined $taint_mode and open my $fh, '<', $file) { my $first = <$fh>; close $fh; if ($first and my ($args) = $first =~ /^\s*#\s*!\s*perl\s*(.*)/) { $taint_mode = 1 if $args =~ /(?:^|\s)-T(?:$|\s)/; } $taint_mode = 0 unless defined $taint_mode; } my $self = bless $class->SUPER::new( taint_mode => $taint_mode, %args, ), $class; $self->{file} = $file; return $self; } sub new_trainer { Test::Valgrind::Command::Perl->new_trainer } =head2 C my $file = $tvcps->file; Read-only accessor for the C option. =cut sub file { $_[0]->{file} } sub args { my $self = shift; return $self->SUPER::args(@_), $self->file } =head1 SEE ALSO L, L. =head1 AUTHOR Vincent Pit, C<< >>, L. You can contact me by mail or on C (vincent). =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc Test::Valgrind::Command::PerlScript =head1 COPYRIGHT & LICENSE Copyright 2009,2010,2011,2013,2015,2016 Vincent Pit, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; # End of Test::Valgrind::Command::PerlScript Test-Valgrind-1.19/lib/Test/Valgrind/Action/Captor.pm000644 000765 000024 00000006061 12747731265 023217 0ustar00vincentstaff000000 000000 package Test::Valgrind::Action::Captor; use strict; use warnings; =head1 NAME Test::Valgrind::Action::Captor - Mock Test::Valgrind::Action for capturing output. =head1 VERSION Version 1.19 =cut our $VERSION = '1.19'; =head1 DESCRIPTION This class provides helpers for saving, redirecting and restoring filehandles. It's not meant to be used directly as an action. =cut use File::Spec (); use base qw; =head1 METHODS =head2 C Just a croaking stub to remind you not to use this class as a real action. =cut sub new { shift->_croak('This mock action isn\'t meant to be used directly') } # Widely inspired from Capture::Tiny sub _redirect_fh { open $_[1], $_[2], $_[3] or $_[0]->_croak('open(' . fileno($_[1]) . ", '$_[2]', '$_[3]'): $!"); } sub _dup_fh { my $fd = fileno $_[3]; open $_[1], $_[2] . '&' . $fd or $_[0]->_croak('open(' . fileno($_[1]) . ", '$_[2]&', $fd): $!"); } =head2 C $tva->save_fh($from, $mode); $tva->save_fh($from, $mode, $to); Save the original filehandle C<$from> opened with mode C<$mode>, and redirect it to C<$to> if it's defined or to F otherwise. =cut sub save_fh { my ($self, $from, $mode, $to) = @_; unless (defined fileno $from) { $self->_redirect_fh($from, $mode, File::Spec->devnull); push @{$self->{proxies}}, $from; } $self->_dup_fh(my $save, $mode, $from); push @{$self->{saves}}, [ $save, $mode, $from ]; if ($to and ref $to eq 'GLOB') { $self->_dup_fh($from, $mode, $to); } else { $self->_redirect_fh($from, $mode, defined $to ? $to : File::Spec->devnull); } return; } =head2 C $tva->restore_all_fh; Restore all the filehandles that were saved with L to their original state. The redirections aren't closed. =cut sub restore_all_fh { my ($self) = @_; for (@{$self->{saves}}) { my ($save, $mode, $from) = @$_; $self->_dup_fh($from, $mode, $save); close $save or $self->_croak('close(saved[' . fileno($save) . "]): $!"); } delete $self->{saves}; for (@{$self->{proxies}}) { close $_ or $self->_croak('close(proxy[' . fileno($_) . "]): $!"); } delete $self->{proxies}; return; } =head1 SEE ALSO L, L. L. =head1 AUTHOR Vincent Pit, C<< >>, L. You can contact me by mail or on C (vincent). =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc Test::Valgrind::Action::Captor =head1 COPYRIGHT & LICENSE Copyright 2009,2010,2011,2013,2015,2016 Vincent Pit, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; # End of Test::Valgrind::Action::Captor Test-Valgrind-1.19/lib/Test/Valgrind/Action/Suppressions.pm000644 000765 000024 00000010004 12747731265 024474 0ustar00vincentstaff000000 000000 package Test::Valgrind::Action::Suppressions; use strict; use warnings; =head1 NAME Test::Valgrind::Action::Suppressions - Generate suppressions for a given tool. =head1 VERSION Version 1.19 =cut our $VERSION = '1.19'; =head1 DESCRIPTION This action just writes the contents of the suppressions reports received into the suppression file. =cut use base qw; =head1 METHODS This class inherits L. =head2 C my $tvas = Test::Valgrind::Action::Suppressions->new( name => $name, target => $target, %extra_args, ); Your usual constructor. You need to specify the suppression prefix as the value of C, and the target file as C. Other arguments are passed straight to C<< Test::Valgrind::Action->new >>. =cut sub new { my $class = shift; $class = ref($class) || $class; my %args = @_; my %validated; for (qw) { my $arg = delete $args{$_}; $class->_croak("'$_' is expected to be a plain scalar") unless $arg and not ref $arg; $validated{$_} = $arg; } my $self = $class->SUPER::new(%args); $self->{$_} = $validated{$_} for qw; $self; } sub do_suppressions { 1 } =head2 C my $name = $tvas->name; Read-only accessor for the C option. =cut sub name { $_[0]->{name} } =head2 C my $target = $tvas->target; Read-only accessor for the C option. =cut sub target { $_[0]->{target} } sub start { my ($self, $sess) = @_; $self->SUPER::start($sess); delete @{$self}{qw}; $self->save_fh(\*STDOUT => '>' => undef); $self->save_fh(\*STDERR => '>' => undef); return; } sub abort { my $self = shift; $self->restore_all_fh; print $self->{diagnostics} if defined $self->{diagnostics}; delete $self->{diagnostics}; $self->{status} = 255; $self->SUPER::abort(@_); } sub report { my ($self, $sess, $report) = @_; if ($report->is_diag) { my $data = $report->data; 1 while chomp $data; $self->{diagnostics} .= "$data\n"; return; } $self->SUPER::report($sess, $report); push @{$self->{supps}}, $report; return; } sub finish { my ($self, $sess) = @_; $self->SUPER::finish($sess); $self->restore_all_fh; print $self->{diagnostics} if defined $self->{diagnostics}; delete $self->{diagnostics}; my $target = $self->target; require File::Spec; my ($vol, $dir, $file) = File::Spec->splitpath($target); my $base = File::Spec->catpath($vol, $dir, ''); if (-e $base) { 1 while unlink $target; } else { require File::Path; File::Path::mkpath([ $base ]); } open my $fh, '>', $target or $self->_croak("open(\$fh, '>', \$self->target): $!"); my $id = 0; my %seen; for (sort { $a->data cmp $b->data } grep !$seen{$_->data}++, @{$self->{supps}}) { print $fh "{\n" . $self->name . ++$id . "\n" . $_->data . "}\n"; } close $fh or $self->_croak("close(\$fh): $!"); print "Found $id distinct suppressions\n"; $self->{status} = 0; return; } sub status { $_[0]->{status} } =head1 SEE ALSO L, L. =head1 AUTHOR Vincent Pit, C<< >>, L. You can contact me by mail or on C (vincent). =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc Test::Valgrind::Action::Suppressions =head1 COPYRIGHT & LICENSE Copyright 2009,2010,2011,2013,2015,2016 Vincent Pit, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; # End of Test::Valgrind::Action::Supressions Test-Valgrind-1.19/lib/Test/Valgrind/Action/Test.pm000644 000765 000024 00000010760 12747731265 022707 0ustar00vincentstaff000000 000000 package Test::Valgrind::Action::Test; use strict; use warnings; =head1 NAME Test::Valgrind::Action::Test - Test that an analysis didn't generate any error report. =head1 VERSION Version 1.19 =cut our $VERSION = '1.19'; =head1 DESCRIPTION This action uses C to plan and pass or fail tests according to the reports received. =cut use Test::Builder; use base qw; =head1 METHODS This class inherits L and L. =head2 C my $tvat = Test::Valgrind::Action::Test->new( diag => $diag, extra_tests => $extra_tests, %extra_args, ); Your usual constructor. When C<$diag> is true, the original output of the command and the error reports are intermixed as diagnostics. C<$extra_tests> specifies how many extraneous tests you want to plan in addition to the default ones. Other arguments are passed straight to C<< Test::Valgrind::Action->new >>. =cut sub new { my $class = shift; $class = ref($class) || $class; my %args = @_; my $diag = delete $args{diag}; my $extra_tests = delete $args{extra_tests} || 0; my $self = bless $class->SUPER::new(%args), $class; $self->{diag} = $diag; $self->{extra_tests} = $extra_tests; $self; } =head2 C my $diag = $tvat->diag; Read-only accessor for the C option. =cut sub diag { $_[0]->{diag} } =head2 C my @kinds = $tvat->kinds; Returns the list of all the monitored report kinds. =cut sub kinds { @{$_[0]->{kinds} || []} } sub start { my ($self, $sess) = @_; $self->SUPER::start($sess); my @kinds = grep $_ ne 'Diag', $sess->report_class->kinds; $self->{kinds} = \@kinds; $self->{status} = 0; my $tb = Test::Builder->new; $tb->plan(tests => $self->{extra_tests} + scalar @kinds); $self->restore_all_fh; delete $self->{capture}; if ($self->diag) { require File::Temp; $self->{capture} = File::Temp::tempfile(); $self->{capture_pos} = 0; } $self->save_fh(\*STDOUT => '>' => $self->{capture}); $self->save_fh(\*STDERR => '>' => $self->{capture}); return; } sub abort { my ($self, $sess, $msg) = @_; $self->restore_all_fh; my $tb = Test::Builder->new; my $plan = $tb->has_plan; if (defined $plan) { $tb->BAIL_OUT($msg); $self->{status} = 255; } else { $tb->skip_all($msg); $self->{status} = 0; } return; } sub report { my ($self, $sess, $report) = @_; if ($report->is_diag) { my $tb = Test::Builder->new; $tb->diag($report->data); return; } $self->SUPER::report($sess, $report); $self->{reports}->{$report->kind}->{$report->id} = $report; if ($self->diag) { my $tb = Test::Builder->new; my $fh = $self->{capture}; seek $fh, $self->{capture_pos}, 0; $tb->diag($_) while <$fh>; $self->{capture_pos} = tell $fh; $tb->diag($report->dump); } return; } sub finish { my ($self, $sess) = @_; $self->SUPER::finish($sess); my $tb = Test::Builder->new; $self->restore_all_fh; if (my $fh = $self->{capture}) { seek $fh, $self->{capture_pos}, 0; $tb->diag($_) while <$fh>; close $fh or $self->_croak('close(capture[' . fileno($fh) . "]): $!"); delete @{$self}{qw}; } my $failed = 0; for my $kind ($self->kinds) { my $reports = $self->{reports}->{$kind} || { }; my $errors = keys %$reports; $tb->is_num($errors, 0, $kind); if ($errors) { ++$failed; unless ($self->diag) { $tb->diag("\n" . $_->dump) for values %$reports; } } } $self->{status} = $failed < 255 ? $failed : 254; return; } sub status { my ($self, $sess) = @_; $self->SUPER::status($sess); $self->{status}; } =head1 SEE ALSO L, L. =head1 AUTHOR Vincent Pit, C<< >>, L. You can contact me by mail or on C (vincent). =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc Test::Valgrind::Action::Test =head1 COPYRIGHT & LICENSE Copyright 2009,2010,2011,2013,2015,2016 Vincent Pit, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; # End of Test::Valgrind::Action::Test