/[suikacvs]/test/html-whatpm/parser-manakai.cgi
Suika

Contents of /test/html-whatpm/parser-manakai.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations) (download)
Thu Jun 21 14:54:14 2007 UTC (17 years, 4 months ago) by wakaba
Branch: MAIN
++ ChangeLog	21 Jun 2007 14:53:51 -0000
2007-06-21  Wakaba  <wakaba@suika.fam.cx>

	* parser-manakai.cgi: New.

	* parser-manakai-interface.en.html: New.

	* time-manakai.plt: New.

1 #!/usr/bin/perl
2 use strict;
3
4 use lib qw[/home/httpd/html/www/markup/html/whatpm
5 /home/wakaba/work/manakai/lib
6 /home/wakaba/public_html/-temp/wiki/lib];
7 use CGI::Carp qw[fatalsToBrowser];
8 use Time::HiRes qw/time/;
9
10 use SuikaWiki::Input::HTTP; ## TODO: Use some better CGI module
11
12 my $http = SuikaWiki::Input::HTTP->new;
13
14 ## TODO: _charset_
15
16 my $mode = $http->meta_variable ('PATH_INFO');
17 ## TODO: decode unreserved characters
18
19 my $s = $http->parameter ('s');
20 if (length $s > 1000_000) {
21 print STDOUT "Status: 400 Document Too Long\nContent-Type: text/plain; charset=us-ascii\n\nToo long";
22 exit;
23 }
24 my $char_length = length $s;
25 my %time;
26 my $time1;
27 my $time2;
28
29 require Message::DOM::DOMImplementation;
30 my $dom = Message::DOM::DOMImplementation->____new;
31 $| = 1;
32 my $doc;
33
34 if ($mode eq '/html/html' or $mode eq '/html/test') {
35 print STDOUT "Content-Type: text/plain; charset=utf-8\n\n";
36
37 require Encode;
38 require Whatpm::HTML;
39
40 $time1 = time;
41 $s = Encode::decode ('utf-8', $s);
42 $time2 = time;
43 $time{decode} = $time2 - $time1;
44
45
46 print STDOUT "#errors\n";
47
48 my $onerror = sub {
49 my (%opt) = @_;
50 print STDOUT "$opt{line},$opt{column},$opt{type}\n";
51 };
52
53 $time1 = time;
54 $doc = Whatpm::HTML->parse_string ($s => $dom->create_document, $onerror);
55 $time2 = time;
56 $time{parse} = $time2 - $time1;
57
58 print "#document\n";
59
60 my $out;
61 $time1 = time;
62 if ($mode eq '/html/html') {
63 $out = Whatpm::HTML->get_inner_html ($doc);
64 } else { # test
65 $out = test_serialize ($doc);
66 }
67 $time2 = time;
68 $time{serialize} = $time2 - $time1;
69 print STDOUT Encode::encode ('utf-8', $$out);
70 print STDOUT "\n";
71 } elsif ($mode eq '/xhtml/html' or $mode eq '/xhtml/test') {
72 print STDOUT "Content-Type: text/plain; charset=utf-8\n\n";
73
74 require Message::DOM::XMLParserTemp;
75 print STDOUT "#errors\n";
76
77 my $onerror = sub {
78 my $err = shift;
79 print STDOUT $err->location->line_number, ",";
80 print STDOUT $err->location->column_number, " ";
81 print STDOUT $err->text, "\n";
82 return 1;
83 };
84
85 open my $fh, '<', \$s;
86 my $time1 = time;
87 $doc = Message::DOM::XMLParserTemp->parse_byte_stream
88 ($fh => $dom, $onerror, charset => 'utf-8');
89 my $time2 = time;
90 $time{parse_xml} = $time2 - $time1;
91
92 print "#document\n";
93
94 my $out;
95 if ($mode eq '/xhtml/html') {
96 ## TODO: Use XHTML serializer
97 #$out = Whatpm::HTML->get_inner_html ($doc);
98 } else { # test
99 $time1 = time;
100 $out = test_serialize ($doc);
101 $time2 = time;
102 $time{serialize_test} = $time2 - $time1;
103 }
104 print STDOUT Encode::encode ('utf-8', $$out);
105 print STDOUT "\n";
106 } else {
107 print STDOUT "Status: 404 Not Found\nContent-Type: text/plain; charset=us-ascii\n\n404";
108 exit;
109 }
110
111 if ($http->parameter ('dom5')) {
112 require Whatpm::ContentChecker;
113 print STDOUT "#domerrors\n";
114 $time1 = time;
115 Whatpm::ContentChecker->check_document ($doc, sub {
116 my %opt = @_;
117 print STDOUT get_node_path ($opt{node}) . ';' . $opt{type} . "\n";
118 });
119 $time2 = time;
120 $time{check} = $time2 - $time1;
121 }
122
123 print STDOUT "#log\n";
124 for (qw/decode parse parse_xml serialize_html serialize_xml serialize_test
125 check/) {
126 next unless defined $time{$_};
127 print STDOUT {
128 decode => 'bytes->chars',
129 parse => 'html5(chars)->dom5',
130 parse_xml => 'xml1(chars)->dom5',
131 serialize_html => 'dom5->html5',
132 serialize_xml => 'dom5->xml',
133 serialize_test => 'dom5->test',
134 check => 'dom5 check',
135 }->{$_};
136 print STDOUT "\t", $time{$_}, "s\n";
137 open my $file, '>>', ".manakai-$_.txt" or die ".manakai-$_.txt: $!";
138 print $file $char_length, "\t", $time{$_}, "\n";
139 }
140
141 exit;
142
143 sub test_serialize ($) {
144 my $node = shift;
145 my $r = '';
146
147 my @node = map { [$_, ''] } @{$node->child_nodes};
148 while (@node) {
149 my $child = shift @node;
150 my $nt = $child->[0]->node_type;
151 if ($nt == $child->[0]->ELEMENT_NODE) {
152 $r .= '| ' . $child->[1] . '<' . $child->[0]->tag_name . ">\x0A"; ## ISSUE: case?
153
154 for my $attr (sort {$a->[0] cmp $b->[0]} map { [$_->name, $_->value] }
155 @{$child->[0]->attributes}) {
156 $r .= '| ' . $child->[1] . ' ' . $attr->[0] . '="'; ## ISSUE: case?
157 $r .= $attr->[1] . '"' . "\x0A";
158 }
159
160 unshift @node,
161 map { [$_, $child->[1] . ' '] } @{$child->[0]->child_nodes};
162 } elsif ($nt == $child->[0]->TEXT_NODE) {
163 $r .= '| ' . $child->[1] . '"' . $child->[0]->data . '"' . "\x0A";
164 } elsif ($nt == $child->[0]->CDATA_SECTION_NODE) {
165 $r .= '| ' . $child->[1] . '<![CDATA[' . $child->[0]->data . "]]>\x0A";
166 } elsif ($nt == $child->[0]->COMMENT_NODE) {
167 $r .= '| ' . $child->[1] . '<!-- ' . $child->[0]->data . " -->\x0A";
168 } elsif ($nt == $child->[0]->DOCUMENT_TYPE_NODE) {
169 $r .= '| ' . $child->[1] . '<!DOCTYPE ' . $child->[0]->name . ">\x0A";
170 } elsif ($nt == $child->[0]->PROCESSING_INSTRUCTION_NODE) {
171 $r .= '| ' . $child->[1] . '<?' . $child->[0]->target . ' ' .
172 $child->[0]->data . "?>\x0A";
173 } else {
174 $r .= '| ' . $child->[1] . $child->[0]->node_type . "\x0A"; # error
175 }
176 }
177
178 return \$r;
179 } # test_serialize
180
181 sub get_node_path ($) {
182 my $node = shift;
183 my @r;
184 while (defined $node) {
185 my $rs;
186 if ($node->node_type == 1) {
187 $rs = $node->manakai_local_name;
188 $node = $node->parent_node;
189 } elsif ($node->node_type == 2) {
190 $rs = '@' . $node->manakai_local_name;
191 $node = $node->owner_element;
192 } elsif ($node->node_type == 3) {
193 $rs = '"' . $node->data . '"';
194 $node = $node->parent_node;
195 } elsif ($node->node_type == 9) {
196 $rs = '';
197 $node = $node->parent_node;
198 } else {
199 $rs = '#' . $node->node_type;
200 $node = $node->parent_node;
201 }
202 unshift @r, $rs;
203 }
204 return join '/', @r;
205 } # get_node_path
206
207 =head1 AUTHOR
208
209 Wakaba <w@suika.fam.cx>.
210
211 =head1 LICENSE
212
213 Copyright 2007 Wakaba <w@suika.fam.cx>
214
215 This library is free software; you can redistribute it
216 and/or modify it under the same terms as Perl itself.
217
218 =cut
219
220 ## $Date: 2007/05/28 14:04:57 $

admin@suikawiki.org
ViewVC Help
Powered by ViewVC 1.1.24