use Test;
use constant PLAN => 26;
use constant TIMES_THROUGH => $ENV{MEMORY_TIMES} || 100_000;
BEGIN {
plan tests => PLAN;
if ($^O ne 'linux' ) {
skip "linux platform only\n" for 1..PLAN;
} elsif (not $ENV{MEMORY_TEST}) {
skip "developers only (set MEMORY_TEST=1 to run these tests)\n" for 1..PLAN;
}
}
use XML::LibXML;
use XML::LibXML::SAX::Builder;
{
if ($^O eq 'linux' && $ENV{MEMORY_TEST}) {
# require Devel::Peek;
my $peek = 0;
ok(1);
print("# BASELINE\n");
check_mem(1);
print("# MAKE DOC IN SUB\n");
{
my $doc = make_doc();
ok($doc);
ok($doc->toString);
}
check_mem();
print("# MAKE DOC IN SUB II\n");
# same test as the first one. if this still leaks, it's
# our problem, otherwise it's perl :/
{
my $doc = make_doc();
ok($doc);
ok($doc->toString);
}
check_mem();
{
my $elem = XML::LibXML::Element->new("foo");
my $elem2= XML::LibXML::Element->new("bar");
$elem->appendChild($elem2);
ok( $elem->toString );
}
check_mem();
print("# SET DOCUMENT ELEMENT\n");
{
my $doc2 = XML::LibXML::Document->new();
make_doc_elem( $doc2 );
ok( $doc2 );
ok( $doc2->documentElement );
}
check_mem();
# multiple parsers:
print("# MULTIPLE PARSERS\n");
XML::LibXML->new(); # first parser
check_mem(1);
for (1..TIMES_THROUGH) {
my $parser = XML::LibXML->new();
}
ok(1);
check_mem();
# multiple parses
print("# MULTIPLE PARSES\n");
for (1..TIMES_THROUGH) {
my $parser = XML::LibXML->new();
my $dom = $parser->parse_string("<sometag>foo</sometag>");
}
ok(1);
check_mem();
# multiple failing parses
print("# MULTIPLE FAILURES\n");
for (1..TIMES_THROUGH) {
# warn("$_\n") unless $_ % 100;
my $parser = XML::LibXML->new();
eval {
my $dom = $parser->parse_string("<sometag>foo</somtag>"); # Thats meant to be an error, btw!
};
}
ok(1);
check_mem();
# building custom docs
print("# CUSTOM DOCS\n");
my $doc = XML::LibXML::Document->new();
for (1..TIMES_THROUGH) {
my $elem = $doc->createElement('x');
if($peek) {
warn("Doc before elem\n");
# Devel::Peek::Dump($doc);
warn("Elem alone\n");
# Devel::Peek::Dump($elem);
}
$doc->setDocumentElement($elem);
if ($peek) {
warn("Elem after attaching\n");
# Devel::Peek::Dump($elem);
warn("Doc after elem\n");
# Devel::Peek::Dump($doc);
}
}
if ($peek) {
warn("Doc should be freed\n");
# Devel::Peek::Dump($doc);
}
ok(1);
check_mem();
{
my $doc = XML::LibXML->createDocument;
for (1..TIMES_THROUGH) {
make_doc2( $doc );
}
}
ok(1);
check_mem();
print("# DTD string parsing\n");
my $dtdstr;
{
local $/; local *DTD;
open(DTD, 'example/test.dtd') || die $!;
$dtdstr = <DTD>;
$dtdstr =~ s/\r//g;
$dtdstr =~ s/[\r\n]*$//;
close DTD;
}
ok($dtdstr);
for ( 1..TIMES_THROUGH ) {
my $dtd = XML::LibXML::Dtd->parse_string($dtdstr);
}
ok(1);
check_mem();
print( "# DTD URI parsing \n");
# parse a DTD from a SYSTEM ID
for ( 1..TIMES_THROUGH ) {
my $dtd = XML::LibXML::Dtd->new('ignore', 'example/test.dtd');
}
ok(1);
check_mem();
print("# Document validation\n");
{
print "# is_valid()\n";
my $dtd = XML::LibXML::Dtd->parse_string($dtdstr);
my $xml;
eval {
local $SIG{'__WARN__'} = sub { };
$xml = XML::LibXML->new->parse_file('example/article_bad.xml');
};
for ( 1..TIMES_THROUGH ) {
my $good;
eval {
local $SIG{'__WARN__'} = sub { };
$good = $xml->is_valid($dtd);
};
}
ok(1);
check_mem();
print "# validate() \n";
for ( 1..TIMES_THROUGH ) {
eval {
local $SIG{'__WARN__'} = sub { };
$xml->validate($dtd);
};
}
ok(1);
check_mem();
}
print "# FIND NODES \n";
my $xml=<<'dromeds.xml';
<?xml version="1.0" encoding="UTF-8"?>
<dromedaries>
<species name="Camel">
<humps>1 or 2</humps>
<disposition>Cranky</disposition>
</species>
<species name="Llama">
<humps>1 (sort of)</humps>
<disposition>Aloof</disposition>
</species>
<species name="Alpaca">
<humps>(see Llama)</humps>
<disposition>Friendly</disposition>
</species>
</dromedaries>
dromeds.xml
{
# my $str = "<foo><bar><foo/></bar></foo>";
my $str = $xml;
my $doc = XML::LibXML->new->parse_string( $str );
for ( 1..TIMES_THROUGH ) {
processMessage($xml, '/dromedaries/species' );
# my @nodes = $doc->findnodes("/foo/bar/foo");
}
ok(1);
check_mem();
}
{
my $str = "<foo><bar><foo/></bar></foo>";
my $doc = XML::LibXML->new->parse_string( $str );
for ( 1..TIMES_THROUGH ) {
my $nodes = $doc->find("/foo/bar/foo");
}
ok(1);
check_mem();
}
# {
# print "# ENCODING TESTS \n";
# my $string = "test ä ø is a test string to test iso encoding";
# my $encstr = encodeToUTF8( "iso-8859-1" , $string );
# for ( 1..TIMES_THROUGH ) {
# my $str = encodeToUTF8( "iso-8859-1" , $string );
# }
# ok(1);
# check_mem();
# for ( 1..TIMES_THROUGH ) {
# my $str = encodeToUTF8( "iso-8859-2" , "abc" );
# }
# ok(1);
# check_mem();
#
# for ( 1..TIMES_THROUGH ) {
# my $str = decodeFromUTF8( "iso-8859-1" , $encstr );
# }
# ok(1);
# check_mem();
# }
{
print "# NAMESPACE TESTS \n";
my $string = '<foo:bar xmlns:foo="bar"><foo:a/><foo:b/></foo:bar>';
my $doc = XML::LibXML->new()->parse_string( $string );
for (1..TIMES_THROUGH) {
my @ns = $doc->documentElement()->getNamespaces();
# warn "ns : " . $_->localname . "=>" . $_->href foreach @ns;
my $prefix = $_->localname foreach @ns;
my $name = $doc->documentElement->nodeName;
}
check_mem();
ok(1);
}
{
print "# SAX PARSER\n";
my %xmlStrings = (
"SIMPLE" => "<xml1><xml2><xml3></xml3></xml2></xml1>",
"SIMPLE TEXT" => "<xml1> <xml2>some text some text some text </xml2> </xml1>",
"SIMPLE COMMENT" => "<xml1> <xml2> <!-- some text --> <!-- some text --> <!--some text--> </xml2> </xml1>",
"SIMPLE CDATA" => "<xml1> <xml2><![CDATA[some text some text some text]]></xml2> </xml1>",
"SIMPLE ATTRIBUTE" => '<xml1 attr0="value0"> <xml2 attr1="value1"></xml2> </xml1>',
"NAMESPACES SIMPLE" => '<xm:xml1 xmlns:xm="foo"><xm:xml2/></xm:xml1>',
"NAMESPACES ATTRIBUTE" => '<xm:xml1 xmlns:xm="foo"><xm:xml2 xm:foo="bar"/></xm:xml1>',
);
my $handler = sax_null->new;
my $parser = XML::LibXML->new;
$parser->set_handler( $handler );
check_mem();
foreach my $key ( keys %xmlStrings ) {
print "# $key \n";
for (1..TIMES_THROUGH) {
my $doc = $parser->parse_string( $xmlStrings{$key} );
}
check_mem();
}
ok(1);
}
{
print "# PUSH PARSER\n";
my %xmlStrings = (
"SIMPLE" => ["<xml1>","<xml2><xml3></xml3></xml2>","</xml1>"],
"SIMPLE TEXT" => ["<xml1> ","<xml2>some text some text some text"," </xml2> </xml1>"],
"SIMPLE COMMENT" => ["<xml1","> <xml2> <!","-- some text --> <!-- some text --> <!--some text-","-> </xml2> </xml1>"],
"SIMPLE CDATA" => ["<xml1> ","<xml2><!","[CDATA[some text some text some text]","]></xml2> </xml1>"],
"SIMPLE ATTRIBUTE" => ['<xml1 ','attr0="value0"> <xml2 attr1="value1"></xml2>',' </xml1>'],
"NAMESPACES SIMPLE" => ['<xm:xml1 xmlns:x','m="foo"><xm:xml2','/></xm:xml1>'],
"NAMESPACES ATTRIBUTE" => ['<xm:xml1 xmlns:xm="foo">','<xm:xml2 xm:foo="bar"/></xm',':xml1>'],
);
my $handler = sax_null->new;
my $parser = XML::LibXML->new;
check_mem();
if(0) {
foreach my $key ( keys %xmlStrings ) {
print "# $key \n";
for (1..TIMES_THROUGH) {
map { $parser->push( $_ ) } @{$xmlStrings{$key}};
my $doc = $parser->finish_push();
}
check_mem();
}
ok(1);
}
my %xmlBadStrings = (
"SIMPLE" => ["<xml1>"],
"SIMPLE2" => ["<xml1>","</xml2>", "</xml1>"],
"SIMPLE TEXT" => ["<xml1> ","some text some text some text","</xml2>"],
"SIMPLE CDATA"=> ["<xml1> ","<!","[CDATA[some text some text some text]","</xml1>"],
"SIMPLE JUNK" => ["<xml1/> ","junk"],
);
print "# BAD PUSHED DATA\n";
foreach my $key ( "SIMPLE","SIMPLE2", "SIMPLE TEXT","SIMPLE CDATA","SIMPLE JUNK" ) {
print "# $key \n";
for (1..TIMES_THROUGH) {
eval {map { $parser->push( $_ ) } @{$xmlBadStrings{$key}};};
eval {my $doc = $parser->finish_push();};
}
check_mem();
}
ok(1);
}
{
print "# SAX PUSH PARSER\n";
my $handler = sax_null->new;
my $parser = XML::LibXML->new;
$parser->set_handler( $handler );
check_mem();
my %xmlStrings = (
"SIMPLE" => ["<xml1>","<xml2><xml3></xml3></xml2>","</xml1>"],
"SIMPLE TEXT" => ["<xml1> ","<xml2>some text some text some text"," </xml2> </xml1>"],
"SIMPLE COMMENT" => ["<xml1","> <xml2> <!","-- some text --> <!-- some text --> <!--some text-","-> </xml2> </xml1>"],
"SIMPLE CDATA" => ["<xml1> ","<xml2><!","[CDATA[some text some text some text]","]></xml2> </xml1>"],
"SIMPLE ATTRIBUTE" => ['<xml1 ','attr0="value0"> <xml2 attr1="value1"></xml2>',' </xml1>'],
"NAMESPACES SIMPLE" => ['<xm:xml1 xmlns:x','m="foo"><xm:xml2','/></xm:xml1>'],
"NAMESPACES ATTRIBUTE" => ['<xm:xml1 xmlns:xm="foo">','<xm:xml2 xm:foo="bar"/></xm',':xml1>'],
);
foreach my $key ( keys %xmlStrings ) {
print "# $key \n";
for (1..TIMES_THROUGH) {
eval {map { $parser->push( $_ ) } @{$xmlStrings{$key}};};
eval {my $doc = $parser->finish_push();};
}
check_mem();
}
ok(1);
print "# BAD PUSHED DATA\n";
my %xmlBadStrings = (
"SIMPLE " => ["<xml1>"],
"SIMPLE2" => ["<xml1>","</xml2>", "</xml1>"],
"SIMPLE TEXT" => ["<xml1> ","some text some text some text","</xml2>"],
"SIMPLE CDATA" => ["<xml1> ","<!","[CDATA[some text some text some text]","</xml1>"],
"SIMPLE JUNK" => ["<xml1/> ","junk"],
);
foreach my $key ( keys %xmlBadStrings ) {
print "# $key \n";
for (1..TIMES_THROUGH) {
eval {map { $parser->push( $_ ) } @{$xmlBadStrings{$key}};};
eval {my $doc = $parser->finish_push();};
}
check_mem();
}
ok(1);
}
}
}
sub processMessage {
my ($msg, $xpath) = @_;
my $parser = XML::LibXML->new();
my $doc = $parser->parse_string($msg);
my $elm = $doc->getDocumentElement;
my $node = $doc->findnodes($xpath);
my $text = $node->to_literal->value;
# undef $doc; # comment this line to make memory leak much worse
# undef $parser;
}
sub make_doc {
# code taken from an AxKit XSP generated page
my ($r, $cgi) = @_;
my $document = XML::LibXML::Document->createDocument("1.0", "UTF-8");
# warn("document: $document\n");
my ($parent);
{
my $elem = $document->createElement(q(p));
$document->setDocumentElement($elem);
$parent = $elem;
}
$parent->setAttribute("xmlns:" . q(param), q(http://axkit.org/XSP/param));
{
my $elem = $document->createElementNS(q(http://axkit.org/XSP/param),q(param:foo),);
$parent->appendChild($elem);
$parent = $elem;
}
$parent = $parent->parentNode;
# warn("parent now: $parent\n");
$parent = $parent->parentNode;
# warn("parent now: $parent\n");
return $document
}
sub make_doc2 {
my $docA = shift;
my $docB = XML::LibXML::Document->new;
my $e1 = $docB->createElement( "A" );
my $e2 = $docB->createElement( "B" );
$e1->appendChild( $e2 );
$docA->setDocumentElement( $e1 );
}
sub check_mem {
my $initialise = shift;
# Log Memory Usage
local $^W;
my %mem;
if (open(FH, "/proc/self/status")) {
my $units;
while (<FH>) {
if (/^VmSize.*?(\d+)\W*(\w+)$/) {
$mem{Total} = $1;
$units = $2;
}
if (/^VmRSS:.*?(\d+)/) {
$mem{Resident} = $1;
}
}
close FH;
if ($LibXML::TOTALMEM != $mem{Total}) {
warn("LEAK! : ", $mem{Total} - $LibXML::TOTALMEM, " $units\n") unless $initialise;
$LibXML::TOTALMEM = $mem{Total};
}
print("# Mem Total: $mem{Total} $units, Resident: $mem{Resident} $units\n");
}
}
# some tests for document fragments
sub make_doc_elem {
my $doc = shift;
my $dd = XML::LibXML::Document->new();
my $node1 = $doc->createElement('test1');
my $node2 = $doc->createElement('test2');
$doc->setDocumentElement( $node1 );
}
package sax_null;
# require Devel::Peek;
# use Data::Dumper;
sub new {
my $class = shift;
bless {}, $class;
}
sub start_document {
my $self = shift;
my $dummy = shift;
}
sub xml_decl {
my $self = shift;
my $dummy = shift;
}
sub start_element {
my $self = shift;
my $dummy = shift;
# warn Dumper( $dummy );
}
sub end_element {
my $self = shift;
my $dummy = shift;
}
sub start_cdata {
my $self = shift;
my $dummy = shift;
}
sub end_cdata {
my $self = shift;
my $dummy = shift;
}
sub start_prefix_mapping {
my $self = shift;
my $dummy = shift;
}
sub end_prefix_mapping {
my $self = shift;
my $dummy = shift;
}
sub characters {
my $self = shift;
my $dummy = shift;
}
sub comment {
my $self = shift;
my $dummy = shift;
}
sub end_document {
my $self = shift;
my $dummy = shift;
}
sub error {
my $self = shift;
my $msg = shift;
die( $msg );
}
1;