340 lines
7.1 KiB
Perl
340 lines
7.1 KiB
Perl
package Test::LeakTrace;
|
|
|
|
use 5.008_001;
|
|
use strict;
|
|
use warnings;
|
|
|
|
our $VERSION = '0.17';
|
|
|
|
use XSLoader;
|
|
XSLoader::load(__PACKAGE__, $VERSION);
|
|
|
|
use Test::Builder::Module;
|
|
our @ISA = qw(Test::Builder::Module);
|
|
|
|
use Exporter qw(import); # use Exporter::import for backward compatibility
|
|
our @EXPORT = qw(
|
|
leaktrace leaked_refs leaked_info leaked_count
|
|
no_leaks_ok leaks_cmp_ok
|
|
count_sv
|
|
);
|
|
|
|
our %EXPORT_TAGS = (
|
|
all => \@EXPORT,
|
|
test => [qw(no_leaks_ok leaks_cmp_ok)],
|
|
util => [qw(leaktrace leaked_refs leaked_info leaked_count count_sv)],
|
|
);
|
|
|
|
|
|
sub _do_leaktrace{
|
|
my($block, $name, $need_stateinfo, $mode) = @_;
|
|
|
|
if(!defined($mode) && !defined wantarray){
|
|
warnings::warnif void => "Useless use of $name() in void context";
|
|
}
|
|
|
|
if($name eq 'leaked_count') {
|
|
my $start;
|
|
$start = count_sv();
|
|
$block->();
|
|
return count_sv() - $start;
|
|
}
|
|
|
|
local $SIG{__DIE__} = 'DEFAULT';
|
|
|
|
_start($need_stateinfo);
|
|
eval{
|
|
$block->();
|
|
};
|
|
if($@){
|
|
_finish(-silent);
|
|
die $@;
|
|
}
|
|
|
|
return _finish($mode);
|
|
}
|
|
|
|
sub leaked_refs(&){
|
|
my($block) = @_;
|
|
return _do_leaktrace($block, 'leaked_refs', 0);
|
|
}
|
|
|
|
sub leaked_info(&){
|
|
my($block) = @_;
|
|
return _do_leaktrace($block, 'leaked_refs', 1);
|
|
}
|
|
|
|
sub leaked_count(&){
|
|
my($block) = @_;
|
|
return scalar _do_leaktrace($block, 'leaked_count', 0);
|
|
}
|
|
|
|
sub leaktrace(&;$){
|
|
my($block, $mode) = @_;
|
|
_do_leaktrace($block, 'leaktrace', 1, defined($mode) ? $mode : -simple);
|
|
return;
|
|
}
|
|
|
|
|
|
sub leaks_cmp_ok(&$$;$){
|
|
my($block, $cmp_op, $expected, $description) = @_;
|
|
|
|
my $Test = __PACKAGE__->builder;
|
|
|
|
if(!_runops_installed()){
|
|
my $mod = exists $INC{'Devel/Cover.pm'} ? 'Devel::Cover' : 'strange runops routines';
|
|
return $Test->ok(1, "skipped (under $mod)");
|
|
}
|
|
|
|
# calls to prepare cache in $block
|
|
$block->();
|
|
|
|
my $got = _do_leaktrace($block, 'leaked_count', 0);
|
|
|
|
my $desc = sprintf 'leaks %s %-2s %s', $got, $cmp_op, $expected;
|
|
if(defined $description){
|
|
$description .= " ($desc)";
|
|
}
|
|
else{
|
|
$description = $desc;
|
|
}
|
|
|
|
my $result = $Test->cmp_ok($got, $cmp_op, $expected, $description);
|
|
|
|
if(!$result){
|
|
open local(*STDERR), '>', \(my $content = '');
|
|
$block->(); # calls it again because opening *STDERR changes the run-time environment
|
|
|
|
_do_leaktrace($block, 'leaktrace', 1, -verbose);
|
|
$Test->diag($content);
|
|
}
|
|
|
|
return $result;
|
|
}
|
|
|
|
sub no_leaks_ok(&;$){
|
|
# ($block, $description)
|
|
splice @_, 1, 0, ('<=', 0); # ($block, '<=', 0, $description);
|
|
goto &leaks_cmp_ok;
|
|
}
|
|
|
|
|
|
1;
|
|
__END__
|
|
|
|
=for stopwords sv gfx
|
|
|
|
=head1 NAME
|
|
|
|
Test::LeakTrace - Traces memory leaks
|
|
|
|
=head1 VERSION
|
|
|
|
This document describes Test::LeakTrace version 0.17.
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use Test::LeakTrace;
|
|
|
|
# simple report
|
|
leaktrace{
|
|
# ...
|
|
};
|
|
|
|
# verbose output
|
|
leaktrace{
|
|
# ...
|
|
} -verbose;
|
|
|
|
# with callback
|
|
leaktrace{
|
|
# ...
|
|
} sub {
|
|
my($ref, $file, $line) = @_;
|
|
warn "leaked $ref from $file line\n";
|
|
};
|
|
|
|
my @refs = leaked_refs{
|
|
# ...
|
|
};
|
|
my @info = leaked_info{
|
|
# ...
|
|
};
|
|
|
|
my $count = leaked_count{
|
|
# ...
|
|
};
|
|
|
|
# standard test interface
|
|
use Test::LeakTrace;
|
|
|
|
no_leaks_ok{
|
|
# ...
|
|
} 'no memory leaks';
|
|
|
|
leaks_cmp_ok{
|
|
# ...
|
|
} '<', 10;
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
C<Test::LeakTrace> provides several functions that trace memory leaks.
|
|
This module scans arenas, the memory allocation system,
|
|
so it can detect any leaked SVs in given blocks.
|
|
|
|
B<Leaked SVs> are SVs which are not released after the end of the scope
|
|
they have been created. These SVs include global variables and internal caches.
|
|
For example, if you call a method in a tracing block, perl might prepare a cache
|
|
for the method. Thus, to trace true leaks, C<no_leaks_ok()> and C<leaks_cmp_ok()>
|
|
executes a block more than once.
|
|
|
|
=head1 INTERFACE
|
|
|
|
=head2 Exported functions
|
|
|
|
=head3 C<< leaked_info { BLOCK } >>
|
|
|
|
Executes I<BLOCK> and returns a list of leaked SVs and places where the SVs
|
|
come from, i.e. C<< [$ref, $file, $line] >>.
|
|
|
|
=head3 C<< leaked_refs { BLOCK } >>
|
|
|
|
Executes I<BLOCK> and returns a list of leaked SVs.
|
|
|
|
=head3 C<< leaked_count { BLOCK } >>
|
|
|
|
Executes I<BLOCK> and returns the number of leaked SVs.
|
|
|
|
=head3 C<< leaktrace { BLOCK } ?($mode | \&callback) >>
|
|
|
|
Executes I<BLOCK> and reports leaked SVs to C<*STDERR>.
|
|
|
|
Defined I<$mode>s are:
|
|
|
|
=over 4
|
|
|
|
=item -simple
|
|
|
|
Default. Reports the leaked SV identity (type and address), file name and line number.
|
|
|
|
=item -sv_dump
|
|
|
|
In addition to B<-simple>, dumps the sv content using C<sv_dump()>,
|
|
which also implements C<Devel::Peek::Dump()>.
|
|
|
|
=item -lines
|
|
|
|
In addition to B<-simple>, prints suspicious source lines.
|
|
|
|
=item -verbose
|
|
|
|
Both B<-sv_dump> and B<-lines>.
|
|
|
|
=back
|
|
|
|
=head3 C<< no_leaks_ok { BLOCK } ?$description >>
|
|
|
|
Tests that I<BLOCK> does not leaks SVs. This is a test function
|
|
using C<Test::Builder>.
|
|
|
|
Note that I<BLOCK> is called more than once. This is because
|
|
I<BLOCK> might prepare caches which are not memory leaks.
|
|
|
|
=head3 C<< leaks_cmp_ok { BLOCK } $cmp_op, $number, ?$description >>
|
|
|
|
Tests that I<BLOCK> leaks a specific number of SVs. This is a test
|
|
function using C<Test::Builder>.
|
|
|
|
Note that I<BLOCK> is called more than once. This is because
|
|
I<BLOCK> might prepare caches which are not memory leaks.
|
|
|
|
=head3 C<< count_sv() >>
|
|
|
|
Counts all the SVs in the arena.
|
|
|
|
=head2 Script interface
|
|
|
|
Like C<Devel::LeakTrace> C<Test::LeakTrace::Script> is provided for whole scripts.
|
|
|
|
The arguments of C<use Test::LeakTrace::Script> directive is the same as C<leaktrace()>.
|
|
|
|
$ TEST_LEAKTRACE=-sv_dump perl -MTest::LeakTrace::Script script.pl
|
|
$ perl -MTest::LeakTrace::Script=-verbose script.pl
|
|
|
|
#!perl
|
|
# ...
|
|
|
|
use Test::LeakTrace::Script sub{
|
|
my($ref, $file, $line) = @_;
|
|
# ...
|
|
};
|
|
|
|
# ...
|
|
|
|
=head1 EXAMPLES
|
|
|
|
=head2 Testing modules
|
|
|
|
Here is a test script template that checks memory leaks.
|
|
|
|
#!perl -w
|
|
use strict;
|
|
use constant HAS_LEAKTRACE => eval{ require Test::LeakTrace };
|
|
use Test::More HAS_LEAKTRACE ? (tests => 1) : (skip_all => 'require Test::LeakTrace');
|
|
use Test::LeakTrace;
|
|
|
|
use Some::Module;
|
|
|
|
leaks_cmp_ok{
|
|
my $o = Some::Module->new();
|
|
$o->something();
|
|
$o->something_else();
|
|
} '<', 1;
|
|
|
|
=head1 DEPENDENCIES
|
|
|
|
Perl 5.8.1 or later, and a C compiler.
|
|
|
|
=head1 CAVEATS
|
|
|
|
C<Test::LeakTrace> does not work with C<Devel::Cover> and modules which install
|
|
their own C<runops> routines, or the perl executor. So if the test functions of
|
|
this module detect strange C<runops> routines, they do nothing and report okay.
|
|
|
|
=head1 BUGS
|
|
|
|
No bugs have been reported.
|
|
|
|
Please report any bugs or feature requests to the author.
|
|
|
|
=head1 SEE ALSO
|
|
|
|
L<Devel::LeakTrace>.
|
|
|
|
L<Devel::LeakTrace::Fast>.
|
|
|
|
L<Test::TraceObject>.
|
|
|
|
L<Test::Weak>.
|
|
|
|
For guts:
|
|
|
|
L<perlguts>.
|
|
|
|
L<perlhack>.
|
|
|
|
F<sv.c>.
|
|
|
|
=head1 AUTHOR
|
|
|
|
Goro Fuji(gfx) E<lt>gfuji(at)cpan.orgE<gt>.
|
|
|
|
=head1 LICENSE AND COPYRIGHT
|
|
|
|
Copyright (c) 2009-2010, Goro Fuji(gfx). All rights reserved.
|
|
|
|
This library is free software; you can redistribute it and/or modify
|
|
it under the same terms as Perl itself.
|
|
|
|
=cut
|