BEGIN {print "1..23\n";}
END {print "not ok 1\n" unless $loaded;}
use XML::DOM;
use CheckAncestors;
use CmpDOM;
$loaded = 1;
print "ok 1\n";
my $test = 1;
sub assert_ok
{
my $ok = shift;
print "not " unless $ok;
++$test;
print "ok $test\n";
$ok;
}
sub charRef2U8{
my $charRef = shift;
my $u8;
$charRef = pack("H*",sprintf("%x",$charRef));
for (my $iLen = 0;$charRef ne "";$charRef = substr($charRef,$iLen)){
if($charRef =~ /^\x00([\x00-\x7F])/){
$iLen = 2;
$u8 .= $1;
}elsif($charRef =~ /^\x00([\x80-\xFF])/){
$iLen = 2;
$u8 .= pack("v@",
(ord("\xC0")|
((ord($1) & 192) >> 6)));
$u8 .= pack("v@",(ord("\x80")| (ord($2) & 63)));
}elsif($charRef =~ /^([\x01-\x07])([\x00-\xFF])/){
$iLen = 2;
$u8 .= pack("v@",
(ord("\xC0")|
((ord($1) & 7) << 2) |
((ord($2) & 192) >> 6)));
$u8 .= pack("v@",(ord("\x80")| (ord($2) & 63)));
}elsif($charRef =~ /^([\x08-\xD7])([\x00-\xFF])/){
$iLen = 2;
$u8 .= pack("v@",(ord("\xE0") | ((ord($1) & 240) >> 4)));
$u8 .= pack("v@",(ord("\x80") |
((ord($1) & 15) << 2) |
((ord($2) & 192) >> 6)));
$u8 .= pack("v@",(ord("\x80")| (ord($2) & 63)));
}elsif($charRef =~ /^([\xD8-\xDB])([\x00-\xFF])([\xDC-\xDF])([\x00-\xFF])/){
$iLen = 4;
$u8 .= pack("v@",(ord("\xF4") |ord($1) & 3));
$u8 .= pack("v@",(ord("\x80") |((ord($2) & 252)>> 2)));
$u8 .= pack("v@",(ord("\x80") |
((ord($2) & 3) << 4) |
((ord($3) & 3) << 2) |
((ord($4) & 192) >> 6)));
$u8 .= pack("v@",(ord("\x80") | (ord($4) & 63)));
}elsif($charRef =~ /^([\xE0-\xFF])([\x00-\xFF])/){
$iLen = 2;
$u8 .= pack("v@",(ord("\xE0") | ((ord($1) & 240) >> 4)));
$u8 .= pack("v@",(ord("\x80") |
((ord($1) & 15) << 2) |
((ord($2) & 192) >> 6)));
$u8 .= pack("v@",(ord("\x80")| (ord($2) & 63)));
}else{
die "can\'t convert!\n";
}
}
return $u8;
}
#Test 2
my $str = <<END;
<!DOCTYPE シンプソンズ [
<!ELEMENT 人物 (#PCDATA)>
<!ATTLIST 人物
名前 CDATA #REQUIRED
髪 (なし | 青色 | 黄色) "黄色"
性別 CDATA #REQUIRED>
]>
<シンプソンズ>
<人物 名前="ホーマー" 髪="なし" 性別="男性"/>
<人物 名前="マージ" 髪="青色" 性別="女性"/>
<人物 名前="バート" 性別="まだ気にしない"/>
<人物 名前="リサ" 性別="全然気にしない"/>
</シンプソンズ>
END
my $parser = new XML::DOM::Parser;
my $doc = $parser->parse ($str);
assert_ok (not $@);
my $out = $doc->toString;
$out =~ tr/\012/\n/;
$out =~ s/(\&\#(\d+);)/sprintf("%s",charRef2U8($2))/eg;
assert_ok ($out eq $str);
my $root = $doc->getDocumentElement;
my $bart = $root->getElementsByTagName("人物")->item(2);
assert_ok (defined $bart);
my $lisa = $root->getElementsByTagName("人物")->item(3);
assert_ok (defined $lisa);
my $battr = $bart->getAttributes;
assert_ok ($battr->getLength == 3);
my $lattr = $lisa->getAttributes;
assert_ok ($lattr->getLength == 3);
# Use getValues in list context
my @attrList = $lattr->getValues;
assert_ok (@attrList == 3);
my $hair = $battr->getNamedItem ("髪");
assert_ok ($hair->getValue eq "黄色");
assert_ok (not $hair->isSpecified);
my $hair2 = $bart->removeAttributeNode ($hair);
# we're not returning default attribute nodes
assert_ok (not defined $hair2);
# check if hair is still defaulted
$hair2 = $battr->getNamedItem ("髪");
assert_ok ($hair2->getValue eq "黄色");
assert_ok (not $hair2->isSpecified);
# replace default hair with pointy hair
$battr->setNamedItem ($doc->createAttribute ("髪", "つんつん"));
assert_ok ($bart->getAttribute("髪") eq "つんつん");
$hair2 = $battr->getNamedItem ("髪");
assert_ok ($hair2->isSpecified);
# exception - can't share Attr nodes
eval {
$lisa->setAttributeNode ($hair2);
};
assert_ok ($@);
# add it again - it replaces itself
$bart->setAttributeNode ($hair2);
assert_ok ($battr->getLength == 3);
# (cloned) hair transplant from bart to lisa
$lisa->setAttributeNode ($hair2->cloneNode);
$hair = $lattr->getNamedItem ("髪");
assert_ok ($hair->isSpecified);
assert_ok ($hair->getValue eq "つんつん");
my $doc2 = $doc->cloneNode(1);
my $cmp = new CmpDOM;
unless (assert_ok ($doc->equals ($doc2, $cmp)))
{
# This shouldn't happen
print "Context: ", $cmp->context, "\n";
}
assert_ok ($hair->getNodeTypeName eq "ATTRIBUTE_NODE");
$bart->removeAttribute ("髪");
# check if hair is still defaulted
$hair2 = $battr->getNamedItem ("髪");
assert_ok ($hair2->getValue eq "黄色");
assert_ok (not $hair2->isSpecified);