1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
|
#!/usr/bin/perl -w
use strict;
use strict;
use Carp;
use File::Spec;
use lib File::Spec->catdir( File::Spec->curdir, "t" );
use tools;
$| = 1;
my $DEBUG = 0;
use XML::Twig;
# only display warnings, test is too unreliable (especially under Devel::Cover) to trust
my $mem_size = mem_size();
unless ($mem_size) {
print "1..1\nok 1\n";
warn "skipping: memory size not available\n";
exit;
}
if ( !XML::Twig::_weakrefs() ) {
print "1..1\nok 1\n";
warn "skipping: weaken not available\n";
exit;
}
my $long_test = $ARGV[0] && $ARGV[0] eq '-L';
my $conf
= $long_test
? { iter => 10, p => 1000 }
: { iter => 5, p => 500 };
$conf->{normal} = $conf->{p} * $conf->{iter};
$conf->{normal_html} = $conf->{normal} * 2;
my $TMAX = 3;
print "1..$TMAX\n";
my $warn = 0;
my $test_nb = 0;
my $paras = join '', map {qq{<p>lorem ipsus whatever <i id="i$_">(clever latin stuff) no $_</i></p>}} 1 .. $conf->{p};
my $xml = qq{<doc>$paras</doc>};
XML::Twig->new->parse($xml);
my $before = mem_size();
for ( 1 .. $conf->{iter} ) {
my $t = XML::Twig->new->parse($xml);
really_clear($t);
}
my $after = mem_size();
if ( $after - $before > $conf->{normal} ) {
warn "test $test_nb: possible memory leak parsing xml ($after > $before)";
$warn++;
} elsif ($long_test) {
warn "$before => $after\n";
}
ok( 1, "testing memory leaks for xml parsing" );
$test_nb++;
{
if ( XML::Twig::_use( 'HTML::TreeBuilder', 3.13 ) ) {
my $html = qq{<html><head><title>with HTB</title></head><body>$paras</body></html>};
XML::Twig->new->parse_html($html);
my $before = mem_size();
for ( 1 .. $conf->{iter} ) { XML::Twig->new->parse_html($html); }
my $after = mem_size();
if ( $after - $before > $conf->{normal_html} ) {
warn "test $test_nb: possible memory leak parsing html ($after > $before)";
$warn++;
} elsif ($long_test) {
warn "$before => $after\n";
}
ok( 1, "testing memory leaks for html parsing" );
} else {
skip( 1, "need HTML::TreeBuilder 3.13+" );
}
$test_nb++;
}
{
if ( XML::Twig::_use('HTML::Tidy') ) {
my $html = qq{<html><head><title>with tidy</title></head><body>$paras</body></html>};
XML::Twig->new( use_tidy => 1 )->parse_html($html);
my $before = mem_size();
for ( 1 .. $conf->{iter} ) { XML::Twig->new( use_tidy => 1 )->parse_html($html); }
my $after = mem_size();
if ( $after - $before > $conf->{normal_html} ) {
warn "test $test_nb: possible memory leak parsing html ($after > $before)";
$warn++;
} elsif ($long_test) {
warn "$before => $after\n";
}
ok( 1, "testing memory leaks for html parsing using HTML::Tidy" );
} else {
skip( 1, "need HTML::Tidy" );
}
$test_nb++;
}
if ($warn) {
warn "\nnote that memory leaks can happen even if the module itself doesn't leak, if running",
"\ntests under Devel::Cover for example. So do not panic if you get a warning here.\n";
}
sub mem_size {
open( STATUS, "/proc/$$/status" ) or return;
my ($size) = map {m{^VmSize:\s+(\d+\s+\w+)}} <STATUS>;
$size =~ s{ kB}{};
#warn "data size found: $size\n";
return $size;
}
sub really_clear {
my ($t) = shift;
my $elt = $t->root;
delete $t->{twig_dtd};
delete $t->{twig_doctype};
delete $t->{twig_xmldecl};
delete $t->{twig_root};
delete $t->{twig_parser};
return;
local $SIG{__WARN__} = sub { };
while ($elt) {
my $nelt = nelt($elt);
$elt->del_id($t);
foreach (qw(gi att empty former)) { undef $elt->{$_}; delete $elt->{$_}; }
$elt->delete;
$elt = $nelt;
}
$t->dispose;
}
sub nelt {
my ($elt) = @_;
if ( $elt->_first_child ) { return deepest_child($elt); }
if ( $elt->_next_sibling ) { return deepest_child( $elt->_next_sibling ); }
return $elt->parent;
}
sub deepest_child {
my ($elt) = @_;
while ( $elt->_first_child ) { $elt = $elt->_first_child; }
return $elt;
}
|
