manakai/t/markup-xml-nodetree.t

#!/usr/bin/perl -w
use strict;
require Test::Simple;
use Message::Markup::XML::NodeTree qw/construct_xml_tree/;
use Message::Markup::XML::Node qw(SGML_GENERAL_ENTITY SGML_PARAM_ENTITY
                                  SGML_DOCTYPE
                                  SGML_NCR SGML_HEX_CHAR_REF);
use Message::Markup::XML::QName qw/:prefix :special-uri/;
my $NODEMOD = 'Message::Markup::XML';
sub OK ($$;$) {
  my ($result, $expect, $testname) = @_;
  my @expect = ref $expect ?@ $expect : ($expect);
  for (@expect) {
    if ($_ eq $result) {
      ok (1);
      return;
    }
  }
  my $e = sub {
    my $s = shift;
    $s =~ s/\t/\\t/g;
    $s;
  };
  ok (0, sprintf '%s: "%s" ("%s" expected)', ($testname || 'Node'),
                 $e->($result), join '" or "', map {$e->($_)} @expect);
}

my $tests = 0;

my @s = (
         {
          main => sub {
            my $n = $NODEMOD->new
              (type => '#element', local_name => 'foo');
            $n->append_text ('text');
            my $ref = $n->append_new_node
              (type => '#reference', namespace_uri => SGML_GENERAL_ENTITY,
               local_name => 'ent');
            $ref->append_text ('other_text');
            OK $n->outer_xml,
               q<<foo xmlns="">text&ent;</foo>>,
               'First, serialization of reference-containing-tree work as expected?';
          },
         },
         {
          main => sub {
            my $n = $NODEMOD->new
              (type => '#element', local_name => 'foo');
            $n->append_text ('text');
            my $ref = $n->append_new_node
              (type => '#reference', namespace_uri => SGML_GENERAL_ENTITY,
               local_name => 'ent');
            $ref->append_text ('other_text');
            $ref->flag (smxp__ref_expanded => 1);
            $n->remove_references;
            OK $n->outer_xml,
               q<<foo xmlns="">textother_text</foo>>,
               'Simple removing of #reference';
          },
         },
         {
          main => sub {
            my $n = $NODEMOD->new
              (type => '#element', local_name => 'foo');
            $n->append_text ('text');
            my $ref = $n->append_new_node
              (type => '#reference', namespace_uri => SGML_GENERAL_ENTITY,
               local_name => 'ent');
            $ref->append_text ('other_text');
            $ref->flag (smxp__ref_expanded => 0);
            $n->remove_references;
            OK $n->outer_xml,
               q<<foo xmlns="">text&ent;</foo>>,
               q(Don't remove unexpanded #reference);
          },
         },
         {
          main => sub {
            my $e = new $NODEMOD (type => '#fragment');
            my $ent = $e->append_new_node (type => '#reference', 
                                           namespace_uri => SGML_PARAM_ENTITY,
                                           local_name => 'ent');
            $ent->append_new_node (type => '#comment');
            $ent->flag (smxp__ref_expanded => 1);
            $e->remove_references;
            OK $e->outer_xml,
               q<<!---->>,
               'Derefering parameter entity reference in declaration subset';
          },
         },
         {
          main => sub {
            my $e = new $NODEMOD (type => '#declaration',
                                  namespace_uri => SGML_PARAM_ENTITY);
            $e->flag (smxp__defined_with_param_ref => 1);
            my $ent = $e->append_new_node (type => '#reference',
                                           namespace_uri => SGML_PARAM_ENTITY,
                                           local_name => 'ent');
            $ent->append_new_node (type => '#xml',
                                   value => '% name SYSTEM "somewhere"');
            $ent->flag (smxp__ref_expanded => 1);
            $e->remove_references;
            OK $e->outer_xml,
               q<<!ENTITY % name SYSTEM "somewhere">>,
               'Derefering parameter entity reference in ps';
          },
         },
         {
          main => sub {
            my $e = new $NODEMOD (type => '#declaration',
                                  namespace_uri => SGML_PARAM_ENTITY);
            $e->flag (smxp__defined_with_param_ref => 1);
            my $ent = $e->append_new_node (type => '#reference',
                                           namespace_uri => SGML_PARAM_ENTITY,
                                           local_name => 'ent');
            $ent->append_new_node (type => '#xml',
                                   value => '% name SYSTEM "somewhere"');
            $ent->flag (smxp__ref_expanded => 1);
            $ent->flag (smxp__non_processed_declaration => 1);
            $e->remove_references;
            OK $e->outer_xml,
               [q<<!ENTITY %ent;>>,
                q<<!ENTITY % name SYSTEM "somewhere">>],
               'Derefering parameter entity reference in ps : ENTITY declaration is not processed';
          },
         },  
         {
          main => sub {
            my $e = new $NODEMOD (type => '#fragment');
            $e->append_text ('text1');
            $e->append_new_node (type => '#reference', 
                                 namespace_uri => SGML_NCR,
                                 value => 0x00004E00);
            $e->append_text ('text2');
            $e->remove_references;
            OK $e->outer_xml,
               qq<text1\x{4E00}text2>,
               'Derefering NCR';
          },
         },
         {
          main => sub {
            my $e = new $NODEMOD (type => '#fragment');
            $e->append_text ('text1');
            $e->append_new_node (type => '#reference',
                                 namespace_uri => SGML_HEX_CHAR_REF,
                                 value => 0x00004E00);
            $e->append_text ('text2');
            $e->remove_references;
            OK $e->outer_xml,
               qq<text1\x{4E00}text2>,
               'Derefering HCR';
          },
         },
);
$tests += @s + 1;

Test::Simple->import (tests => $tests);

for (@s) {
  $_->{main}->() if ref $_;
}

sub NS_XHTML1 { q<http://www.w3.org/1999/xhtml> }
sub NS_XHTML2 { q<http://www.w3.org/2002/06/xhtml2> }
my $tree = construct_xml_tree
  type => '#element',
  local_name => 'html',
  namespace_uri => NS_XHTML1,
  -child =>
  [
   {
    type => '#element',
    local_name => 'head',
    namespace_uri => NS_XHTML1,
    -child =>
    [
     {
      type => '#element',
      local_name => 'title',
      namespace_uri => NS_XHTML1,
      -child =>
      [
       {
        type => '#text',
        value => 'An Example Document',
       },
      ],
     },
    ],
   },
   {
    type => '#element',
    local_name => 'body',
    namespace_uri => NS_XHTML1,
    -attr =>
    {
     class => 'example',
    },
    -child => 
    [
     {
      type => '#comment',
      value => '===== main =====',
     },
     {
      type => '#element',
      local_name => 'p',
      namespace_uri => q<http://www.w3.org/2002/06/xhtml2>,
      -attr => 
      {
        class => 'introduction',
      },
      -child =>
      [
       {
        type => '#text',
        value => 'foo',
       },
      ],
      -ns =>
      {
       h2 => q<http://www.w3.org/2002/06/xhtml2>,
      },
     },
    ],
   },
  ],
  -ns => 
  {
   (DEFAULT_PFX) => q<http://www.w3.org/1999/xhtml>,
  };

OK $tree->stringify, q<<html xmlns="http://www.w3.org/1999/xhtml"><head><title>An Example Document</title></head><body class="example"><!--===== main =====--><h2:p class="introduction" xmlns:h2="http://www.w3.org/2002/06/xhtml2">foo</h2:p></body></html>>;
1	wakaba	1.1	#!/usr/bin/perl -w
2			use strict;
3			require Test::Simple;
4			use Message::Markup::XML::NodeTree qw/construct_xml_tree/;
5			use Message::Markup::XML::Node qw(SGML_GENERAL_ENTITY SGML_PARAM_ENTITY
6			SGML_DOCTYPE
7			SGML_NCR SGML_HEX_CHAR_REF);
8			use Message::Markup::XML::QName qw/:prefix :special-uri/;
9			my $NODEMOD = 'Message::Markup::XML';
10			sub OK ($$;$) {
11			my ($result, $expect, $testname) = @_;
12			my @expect = ref $expect ?@ $expect : ($expect);
13			for (@expect) {
14			if ($_ eq $result) {
15			ok (1);
16			return;
17			}
18			}
19			my $e = sub {
20			my $s = shift;
21			$s =~ s/\t/\\t/g;
22			$s;
23			};
24			ok (0, sprintf '%s: "%s" ("%s" expected)', ($testname \|\| 'Node'),
25			$e->($result), join '" or "', map {$e->($_)} @expect);
26			}
27
28			my $tests = 0;
29
30			my @s = (
31			{
32			main => sub {
33			my $n = $NODEMOD->new
34			(type => '#element', local_name => 'foo');
35			$n->append_text ('text');
36			my $ref = $n->append_new_node
37			(type => '#reference', namespace_uri => SGML_GENERAL_ENTITY,
38			local_name => 'ent');
39			$ref->append_text ('other_text');
40			OK $n->outer_xml,
41			q<<foo xmlns="">text&ent;</foo>>,
42			'First, serialization of reference-containing-tree work as expected?';
43			},
44			},
45			{
46			main => sub {
47			my $n = $NODEMOD->new
48			(type => '#element', local_name => 'foo');
49			$n->append_text ('text');
50			my $ref = $n->append_new_node
51			(type => '#reference', namespace_uri => SGML_GENERAL_ENTITY,
52			local_name => 'ent');
53			$ref->append_text ('other_text');
54			$ref->flag (smxp__ref_expanded => 1);
55			$n->remove_references;
56			OK $n->outer_xml,
57			q<<foo xmlns="">textother_text</foo>>,
58			'Simple removing of #reference';
59			},
60			},
61			{
62			main => sub {
63			my $n = $NODEMOD->new
64			(type => '#element', local_name => 'foo');
65			$n->append_text ('text');
66			my $ref = $n->append_new_node
67			(type => '#reference', namespace_uri => SGML_GENERAL_ENTITY,
68			local_name => 'ent');
69			$ref->append_text ('other_text');
70			$ref->flag (smxp__ref_expanded => 0);
71			$n->remove_references;
72			OK $n->outer_xml,
73			q<<foo xmlns="">text&ent;</foo>>,
74			q(Don't remove unexpanded #reference);
75			},
76			},
77			{
78			main => sub {
79			my $e = new $NODEMOD (type => '#fragment');
80			my $ent = $e->append_new_node (type => '#reference',
81			namespace_uri => SGML_PARAM_ENTITY,
82			local_name => 'ent');
83			$ent->append_new_node (type => '#comment');
84			$ent->flag (smxp__ref_expanded => 1);
85			$e->remove_references;
86			OK $e->outer_xml,
87			q<<!---->>,
88			'Derefering parameter entity reference in declaration subset';
89			},
90			},
91			{
92			main => sub {
93			my $e = new $NODEMOD (type => '#declaration',
94			namespace_uri => SGML_PARAM_ENTITY);
95			$e->flag (smxp__defined_with_param_ref => 1);
96			my $ent = $e->append_new_node (type => '#reference',
97			namespace_uri => SGML_PARAM_ENTITY,
98			local_name => 'ent');
99			$ent->append_new_node (type => '#xml',
100			value => '% name SYSTEM "somewhere"');
101			$ent->flag (smxp__ref_expanded => 1);
102			$e->remove_references;
103			OK $e->outer_xml,
104			q<<!ENTITY % name SYSTEM "somewhere">>,
105			'Derefering parameter entity reference in ps';
106			},
107			},
108			{
109			main => sub {
110			my $e = new $NODEMOD (type => '#declaration',
111			namespace_uri => SGML_PARAM_ENTITY);
112			$e->flag (smxp__defined_with_param_ref => 1);
113			my $ent = $e->append_new_node (type => '#reference',
114			namespace_uri => SGML_PARAM_ENTITY,
115			local_name => 'ent');
116			$ent->append_new_node (type => '#xml',
117			value => '% name SYSTEM "somewhere"');
118			$ent->flag (smxp__ref_expanded => 1);
119			$ent->flag (smxp__non_processed_declaration => 1);
120			$e->remove_references;
121			OK $e->outer_xml,
122			[q<<!ENTITY %ent;>>,
123			q<<!ENTITY % name SYSTEM "somewhere">>],
124			'Derefering parameter entity reference in ps : ENTITY declaration is not processed';
125			},
126			},
127			{
128			main => sub {
129			my $e = new $NODEMOD (type => '#fragment');
130			$e->append_text ('text1');
131			$e->append_new_node (type => '#reference',
132			namespace_uri => SGML_NCR,
133			value => 0x00004E00);
134			$e->append_text ('text2');
135			$e->remove_references;
136			OK $e->outer_xml,
137			qq<text1\x{4E00}text2>,
138			'Derefering NCR';
139			},
140			},
141			{
142			main => sub {
143			my $e = new $NODEMOD (type => '#fragment');
144			$e->append_text ('text1');
145			$e->append_new_node (type => '#reference',
146			namespace_uri => SGML_HEX_CHAR_REF,
147			value => 0x00004E00);
148			$e->append_text ('text2');
149			$e->remove_references;
150			OK $e->outer_xml,
151			qq<text1\x{4E00}text2>,
152			'Derefering HCR';
153			},
154			},
155			);
156			$tests += @s + 1;
157
158			Test::Simple->import (tests => $tests);
159
160			for (@s) {
161			$_->{main}->() if ref $_;
162			}
163
164			sub NS_XHTML1 { q<http://www.w3.org/1999/xhtml> }
165			sub NS_XHTML2 { q<http://www.w3.org/2002/06/xhtml2> }
166			my $tree = construct_xml_tree
167			type => '#element',
168			local_name => 'html',
169			namespace_uri => NS_XHTML1,
170			-child =>
171			[
172			{
173			type => '#element',
174			local_name => 'head',
175			namespace_uri => NS_XHTML1,
176			-child =>
177			[
178			{
179			type => '#element',
180			local_name => 'title',
181			namespace_uri => NS_XHTML1,
182			-child =>
183			[
184			{
185			type => '#text',
186			value => 'An Example Document',
187			},
188			],
189			},
190			],
191			},
192			{
193			type => '#element',
194			local_name => 'body',
195			namespace_uri => NS_XHTML1,
196			-attr =>
197			{
198			class => 'example',
199			},
200			-child =>
201			[
202			{
203			type => '#comment',
204			value => '===== main =====',
205			},
206			{
207			type => '#element',
208			local_name => 'p',
209			namespace_uri => q<http://www.w3.org/2002/06/xhtml2>,
210			-attr =>
211			{
212			class => 'introduction',
213			},
214			-child =>
215			[
216			{
217			type => '#text',
218			value => 'foo',
219			},
220			],
221			-ns =>
222			{
223			h2 => q<http://www.w3.org/2002/06/xhtml2>,
224			},
225			},
226			],
227			},
228			],
229			-ns =>
230			{
231			(DEFAULT_PFX) => q<http://www.w3.org/1999/xhtml>,
232			};
233
234			OK $tree->stringify, q<<html xmlns="http://www.w3.org/1999/xhtml"><head><title>An Example Document</title></head><body class="example"><!--===== main =====--><h2:p class="introduction" xmlns:h2="http://www.w3.org/2002/06/xhtml2">foo</h2:p></body></html>>;