#!/usr/bin/perl -w
# -*- perl -*-
#
# $Id: leak.t,v 1.3 2002/03/07 23:04:54 eserte Exp $
# Author: Slaven Rezic
#
# Some leak tests. You need Devel::Leak installed.
use strict;
use Config;
use Devel::Peek;
BEGIN {
if (!eval q{
use Test::More;
use Devel::Leak;
1;
}) {
print "# tests only work with installed Test and Devel::Leak modules\n";
print "1..0 # skip need Devel::Leak\n";
CORE::exit;
}
}
use Tk;
use Tk::Button;
use Tk::Canvas;
plan tests => 15;
my $mw = new MainWindow;
$mw->optionAdd("*Button.Background",'#dcdcdc');
my $handle;
my($c1,$c2);
# Tests for leaking subroutine set
# first binding always creates some SVs
my $N = 100;
$mw->bind("<Motion>" => [sub { warn }]);
$c1 = Devel::Leak::NoteSV($handle);
for(1..100) {
$mw->bind("<Motion>" => [sub { warn }]);
}
$c2 = Devel::Leak::NoteSV($handle);
cmp_ok($c2-$c1, "<=", 1, "Array reference with subroutine to bind");
$c1 = Devel::Leak::NoteSV($handle);
for(1..100) {
$mw->bind("<Motion>" => sub { warn });
}
$c2 = Devel::Leak::NoteSV($handle);
is($c2, $c1, "Anonymous subroutine to bind");
$c1 = Devel::Leak::NoteSV($handle);
for(1..100) {
$mw->bind("<Motion>" => \&test);
}
$c2 = Devel::Leak::NoteSV($handle);
is($c2, $c1, "Subroutine reference to bind");
my $btn = $mw->Button(-command => sub { warn });
$c1 = Devel::Leak::NoteSV($handle);
for(1..100) {
$btn->configure(-command => sub { warn });
}
$c2 = Devel::Leak::NoteSV($handle);
cmp_ok($c2-$c1, "<", 10, "configure -command multiple times (got " . ($c2-$c1) . " leaked scalars)");
# Tests for leaking Tk_GetUid (e.g. canvas items)
my $c = $mw->Canvas->pack;
$c->delete($c->createLine(10,10,100,100, -tags => "a"));
$c1 = Devel::Leak::NoteSV($handle);
for(1..1000) {
$c->createLine(10,10,100,100,-tags => "a");
$c->delete("a");
}
$c2 = Devel::Leak::NoteSV($handle);
cmp_ok(($c2-$c1), "<", 10, "Leaking Tk_GetUid, e.g. canvas items");
$c1 = Devel::Leak::NoteSV($handle);
for(1..100) {
my $id = $c->createLine(10,10,100,100);
$c->delete($id);
}
$c2 = Devel::Leak::NoteSV($handle);
cmp_ok(($c2-$c1), "<", 10, "Canvas createLine");
# Tests for leaking widget destroys
my $btn2 = $mw->Button;
$btn2->destroy;
undef $btn2;
$c1 = Devel::Leak::NoteSV($handle);
for(1..100) {
$btn2 = $mw->Button;
$btn2->destroy;
}
$c2 = Devel::Leak::CheckSV($handle);
print "# was $c1 now $c2 ",($c2-$c1)/100," per iter\n";
cmp_ok(($c2-$c1), "<", 10, "Creating and destroying buttons");
# Tests for leaking fileevent callbacks
$mw->fileevent(\*STDIN, 'readable', sub { });
$mw->fileevent(\*STDIN, 'readable','');
$c1 = Devel::Leak::NoteSV($handle);
for (1..100)
{
$mw->fileevent(\*STDIN, 'readable', sub { });
$mw->fileevent(\*STDIN, 'readable','');
}
$c2 = Devel::Leak::CheckSV($handle);
cmp_ok(($c2-$c1), "<", 10, "Fileevent callbacks");
require Tk::After;
$mw->withdraw;
$mw->update;
my $count = 0;
Tk->after(cancel => Tk->after(10,sub { $count-- }));
$c1 = Devel::Leak::NoteSV($handle);
for (1..$N)
{
Tk->after(cancel => Tk->after($_*10,sub { $count-- }));
}
$c2 = Devel::Leak::CheckSV($handle);
diag "was $c1 now $c2 ",($c2-$c1)/$N," per iter\n";
cmp_ok(($c2-$c1), "<", $N, "after");
$mw->repeat(30,sub {})->cancel;
my $id;
$c1 = Devel::Leak::NoteSV($handle);
$id = $mw->repeat(2, sub { $id->cancel if ($count++ == $N)});
Tk::DoOneEvent(0) while $id->[1];
undef $id;
$c2 = Devel::Leak::CheckSV($handle);
diag "was $c1 now $c2 ",($c2-$c1)/$N," per iter\n";
cmp_ok(($c2-$c1), "<", $N, "repeat");
sub test { warn }
{
# Tk::Listbox::insert leak
my $lb = $mw->Listbox;
$lb->insert("end", 1);
$c1 = Devel::Leak::NoteSV($handle);
$lb->insert("end", 2);
$c2 = Devel::Leak::CheckSV($handle);
cmp_ok($c2-$c1, "<=", 1, "Insert one listbox element");
for (1..100) { $lb->insert("end", $_+2) }
$c1 = Devel::Leak::NoteSV($handle);
$lb->insert("end", 9999);
$c2 = Devel::Leak::CheckSV($handle);
cmp_ok($c2-$c1, "<=", 1, "Insert one listbox element at end");
$lb->delete(0, "end");
$c1 = Devel::Leak::NoteSV($handle);
$lb->insert("end", 1..10);
$lb->delete(0, "end");
$c2 = Devel::Leak::CheckSV($handle);
is($c2-$c1, 0, "Inserting and deleting listbox elements");
$lb->delete(0, 'end');
$c1 = Devel::Leak::NoteSV($handle);
for(1..10) {
$lb->insert('end', $_);
}
$lb->delete(0, 'end');
$c2 = Devel::Leak::CheckSV($handle);
is($c2-$c1, 0, "Inserting and deleting individual listbox elements");
}
{
$mw->afterIdle(sub {});
$mw->idletasks;
$c1 = Devel::Leak::NoteSV($handle);
$mw->afterIdle(sub {});
$mw->idletasks;
$c2 = Devel::Leak::CheckSV($handle);
is($c2-$c1, 0, "afterIdle callback");
}
__END__