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	#!/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>>;