#!/usr/bin/perl -T
use warnings;
use strict;
#Test that we don't leak memory
use Test::More;
my $leak_trace_loaded;
# RECOMMEND PREREQ: Test::LeakTrace
BEGIN { $leak_trace_loaded = eval "use Test::LeakTrace; 1" }
plan skip_all => "Test::LeakTrace required for testing memory leaks"
unless $leak_trace_loaded;
plan tests => 20;
use HTML::TreeBuilder;
my $lacks_weak;
sub first_block {
my $lol = [
'html',
[ 'head', [ 'title', 'I like stuff!' ], ],
[ 'body', { 'lang', 'en-JP' },
'stuff',
[ 'p', 'um, p < 4!', { 'class' => 'par123' } ],
[ 'div', { foo => 'bar' }, ' 1 2 3 ' ], # at 0.1.2
[ 'div', { fu => 'baa' }, " 1 2 \xA0 3 " ], # RT #26436 test
['hr'],
]
];
my $t1 = HTML::Element->new_from_lol($lol);
### added to test ->is_empty() and ->look_up()
my $hr = $t1->find('hr');
my $lookuptag = $hr->look_up( "_tag", "body" );
my %attrs = $lookuptag->all_attr();
my @attrs1 = sort keys %attrs;
my @attrs2 = sort $lookuptag->all_attr_names();
# Test scalar context
my $count = $t1->content_list;
# Test list context
my @list = $t1->content_list;
my $div = $t1->find_by_attribute( 'foo', 'bar' );
my $div2 = $t1->find_by_attribute( 'fu', 'baa' );
my $t2 = HTML::Element->new_from_lol($lol);
$t2->address('0.1.2')->attr( 'snap', 123 );
my $body = $t1->find_by_tag_name('body');
my $cl = join '~', $body->content_list;
my @detached = $body->detach_content;
$body->push_content(@detached);
$t2->delete if $lacks_weak;
$t1->delete if $lacks_weak;
} # end first_block
sub second_block {
# for normalization
my $t1 = HTML::Element->new_from_lol( [ 'p', 'stuff', ['hr'], 'thing' ] );
my @start = $t1->content_list;
my $lr = $t1->content;
# insert some undefs
splice @$lr, 1, 0, undef; # insert an undef between [0] and [1]
push @$lr, undef; # append an undef to the end
unshift @$lr, undef; # prepend an undef to the front
# $lr is [undef, 'stuff', undef, H::E('hr'), 'thing', undef]
{
my $cl_count = $t1->content_list;
my @cl = $t1->content_list;
}
{
$t1->normalize_content;
my @cl = $t1->content_list;
}
$t1->attr( 'foo', 'bar' );
$t1->attr( 'foo', '' );
$t1->attr( 'foo', undef ); # should delete it
$t1->delete if $lacks_weak;
} # end second_block
sub empty_tree {
my $root = HTML::TreeBuilder->new();
$root->implicit_body_p_tag(1);
$root->xml_mode(1);
$root->parse('');
$root->eof();
$root->delete if $lacks_weak;
}
sub br_only {
my $root = HTML::TreeBuilder->new();
$root->implicit_body_p_tag(1);
$root->xml_mode(1);
$root->parse('<br />');
$root->eof();
$root->delete if $lacks_weak;
}
sub text_only {
my $root = HTML::TreeBuilder->new();
$root->implicit_body_p_tag(1);
$root->xml_mode(1);
$root->parse('text');
$root->eof();
$root->delete if $lacks_weak;
}
sub empty_table {
my $root = HTML::TreeBuilder->new();
$root->implicit_body_p_tag(1);
$root->xml_mode(1);
$root->parse('<table></table>');
$root->eof();
$root->delete if $lacks_weak;
}
sub escapes {
my $root = HTML::TreeBuilder->new();
my $escape = 'This ſoftware has ſome bugs';
my $html = $root->parse($escape)->eof->elementify();
$html->delete if $lacks_weak;
}
sub other_languages {
my $root = HTML::TreeBuilder->new();
my $escape = 'Gebühr vor Ort von € 30,- pro Woche'; # RT 14212
my $html = $root->parse($escape)->eof;
$html->delete if $lacks_weak;
}
sub rt_18570 {
my $root = HTML::TreeBuilder->new();
my $escape = 'This ∼ is a twiddle';
my $html = $root->parse($escape)->eof->elementify();
$html->delete if $lacks_weak;
}
sub rt_18571 {
my $root = HTML::TreeBuilder->new();
my $html = $root->parse('<b>$self->escape</b>')->eof->elementify();
$html->delete if $lacks_weak;
}
# Try with weak refs, if available:
SKIP: {
skip('Scalar::Util lacks support for weak references', 10)
unless HTML::Element->Use_Weak_Refs;
no_leaks_ok(\&first_block, 'first block has no leaks with weak refs');
no_leaks_ok(\&second_block, 'second block has no leaks with weak refs');
no_leaks_ok(\&empty_tree, 'empty_tree has no leaks with weak refs');
no_leaks_ok(\&br_only, 'br_only has no leaks with weak refs');
no_leaks_ok(\&text_only, 'text_only has no leaks with weak refs');
no_leaks_ok(\&empty_table, 'empty_table has no leaks with weak refs');
no_leaks_ok(\&escapes, 'escapes has no leaks with weak refs');
no_leaks_ok(\&other_languages, 'other_languages has no leaks with weak refs');
no_leaks_ok(\&rt_18570, 'rt_18570 has no leaks with weak refs');
no_leaks_ok(\&rt_18571, 'rt_18571 has no leaks with weak refs');
}
# Try again without weak refs:
$lacks_weak = 1;
HTML::Element->Use_Weak_Refs(0);
no_leaks_ok(\&first_block, 'first block has no leaks without weak refs');
no_leaks_ok(\&second_block, 'second block has no leaks without weak refs');
no_leaks_ok(\&empty_tree, 'empty_tree has no leaks without weak refs');
no_leaks_ok(\&br_only, 'br_only has no leaks without weak refs');
no_leaks_ok(\&text_only, 'text_only has no leaks without weak refs');
no_leaks_ok(\&empty_table, 'empty_table has no leaks without weak refs');
no_leaks_ok(\&escapes, 'escapes has no leaks without weak refs');
no_leaks_ok(\&other_languages, 'other_languages has no leaks without weak refs');
no_leaks_ok(\&rt_18570, 'rt_18570 has no leaks without weak refs');
no_leaks_ok(\&rt_18571, 'rt_18571 has no leaks without weak refs');