← Back to branch summary

~ubuntu-branches/ubuntu/natty/perl-tk/natty

« back to all changes in this revision

Viewing changes to t/leak.t

  • Committer: Bazaar Package Importer
  • Author(s): Stephen Zander
  • Date: 2004-03-14 13:54:44 UTC
  • mfrom: (1.1.1 upstream)
  • Revision ID: james.westby@ubuntu.com-20040314135444-prc09u2or4dbr3to
Tags: 1:800.025-2
http://bugs.debian.org/237942
Add xlibs-dev to Build-Depends:,
Closes: #237942

Show diffs side-by-side

added added

removed removed

Lines of Context:
t/leak.t
 
1
#!/usr/bin/perl -w
 
2
# -*- perl -*-
 
3
 
 
4
#
 
5
# $Id: leak.t,v 1.3 2002/03/07 23:04:54 eserte Exp $
 
6
# Author: Slaven Rezic
 
7
#
 
8
 
 
9
# Some leak tests. You need Devel::Leak installed and a debugging perl.
 
10
# I usually use this arguments to perl's Configure:
 
11
#
 
12
#     -Doptimize='-g -DPERL_DEBUGGING_MSTATS' -Dusemymalloc='y'
 
13
#
 
14
# With the patches for tkGlue.c and pTkCallback.c (see the patches
 
15
# subdirectory), the problems here should get away.
 
16
#
 
17
 
 
18
use strict;
 
19
use Config;
 
20
use Tk;
 
21
use Tk::Button;
 
22
use Tk::Canvas;
 
23
 
 
24
BEGIN {
 
25
    if (!eval q{
 
26
        use Test;
 
27
        use Devel::Leak;
 
28
        die if $Config{optimize} !~ /-DPERL_DEBUGGING_MSTATS/;
 
29
        1;
 
30
    }) {
 
31
        print "# tests only work with installed Test and Devel::Leak modules\n";
 
32
        print "# also -DPERL_DEBUGGING_MSTATS have to be set\n";
 
33
        print "1..1\n";
 
34
        print "ok 1\n";
 
35
        exit;
 
36
    }
 
37
}
 
38
 
 
39
{
 
40
    # gather all todos marked with "TODO: number"
 
41
    my @todos;
 
42
    open(DATA, $0) or die $!;
 
43
    while(<DATA>) {
 
44
        push @todos, $1 if (/^\#\s+TODO:\s+(\d+)/);
 
45
    }
 
46
    close DATA;
 
47
    plan tests => 8, todo => [@todos];
 
48
}
 
49
 
 
50
my $mw = new MainWindow;
 
51
my $handle;
 
52
my($c1,$c2);
 
53
 
 
54
# Tests for leaking subroutine set
 
55
 
 
56
# first binding always creates some SVs
 
57
$mw->bind("<Motion>" => [sub { warn }]);
 
58
 
 
59
$c1 = Devel::Leak::NoteSV($handle);
 
60
for(1..100) {
 
61
    $mw->bind("<Motion>" => [sub { warn }]);
 
62
}
 
63
$c2 = Devel::Leak::NoteSV($handle);
 
64
ok($c1, $c2);
 
65
 
 
66
# TODO: 2
 
67
$c1 = Devel::Leak::NoteSV($handle);
 
68
for(1..100) {
 
69
    $mw->bind("<Motion>" => sub { warn });
 
70
}
 
71
$c2 = Devel::Leak::NoteSV($handle);
 
72
ok($c1, $c2);
 
73
 
 
74
# TODO: 3
 
75
$c1 = Devel::Leak::NoteSV($handle);
 
76
for(1..100) {
 
77
    $mw->bind("<Motion>" => \&test);
 
78
}
 
79
$c2 = Devel::Leak::NoteSV($handle);
 
80
ok($c1, $c2);
 
81
 
 
82
my $btn = $mw->Button(-command => sub { warn });
 
83
# TODO: 4
 
84
$c1 = Devel::Leak::NoteSV($handle);
 
85
for(1..100) {
 
86
    $btn->configure(-command => sub { warn });
 
87
}
 
88
$c2 = Devel::Leak::NoteSV($handle);
 
89
ok($c1, $c2);
 
90
 
 
91
# Tests for leaking Tk_GetUid (e.g. canvas items)
 
92
 
 
93
my $c = $mw->Canvas->pack;
 
94
$c->createLine(10,10,100,100, -tags => "a");
 
95
 
 
96
$c1 = Devel::Leak::NoteSV($handle);
 
97
for(1..100) {
 
98
    $c->createLine(10,10,100,100,-tags => "a");
 
99
    $c->delete("a");
 
100
}
 
101
$c2 = Devel::Leak::NoteSV($handle);
 
102
ok($c1, $c2);
 
103
 
 
104
# TODO: 6
 
105
$c1 = Devel::Leak::NoteSV($handle);
 
106
for(1..100) {
 
107
    my $id = $c->createLine(10,10,100,100);
 
108
    $c->delete($id);
 
109
}
 
110
$c2 = Devel::Leak::NoteSV($handle);
 
111
ok($c1, $c2);
 
112
 
 
113
# Tests for leaking widget destroys
 
114
my $btn2 = $mw->Button;
 
115
$btn2->destroy;
 
116
 
 
117
# TODO: 7
 
118
$c1 = Devel::Leak::NoteSV($handle);
 
119
for(1..100) {
 
120
    my $btn2 = $mw->Button;
 
121
    $btn2->destroy;
 
122
}
 
123
$c2 = Devel::Leak::NoteSV($handle);
 
124
ok($c1, $c2);
 
125
 
 
126
# Tests for leaking fileevent callbacks
 
127
$mw->fileevent(\*STDOUT, 'readable', sub { });
 
128
$mw->fileevent(\*STDOUT, 'readable','');
 
129
 
 
130
# TODO: 8
 
131
$c1 = Devel::Leak::NoteSV($handle);
 
132
$mw->fileevent(\*STDOUT, 'readable', sub { });
 
133
$mw->fileevent(\*STDOUT, 'readable','');
 
134
$c2 = Devel::Leak::CheckSV($handle);
 
135
ok($c1, $c2);
 
136
 
 
137
sub test { warn }
 
138
 
 
139
__END__