/[suikacvs]/test/html-webhacc/cc.cgi
Suika

Contents of /test/html-webhacc/cc.cgi

Parent Directory Parent Directory | Revision Log Revision Log

Revision 1.6 - (hide annotations) (download)
Sat Jun 30 14:51:10 2007 UTC (19 years, 4 months ago) by wakaba
Branch: MAIN
Changes since 1.5: +31 -11 lines 
++ ChangeLog	30 Jun 2007 14:51:07 -0000
	* cc.cgi: "Terms" section.  "Tree" was sometimes
	non-conforming to HTML5.
	(get_node_link): New function.

2007-06-30  Wakaba  <wakaba@suika.fam.cx>
1 wakaba 1.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 wakaba 1.2 use Scalar::Util qw[refaddr];
9 wakaba 1.1
10     use SuikaWiki::Input::HTTP; ## TODO: Use some better CGI module
11    
12 wakaba 1.2 sub htescape ($) {
13     my $s = $_[0];
14     $s =~ s/&/&amp;/g;
15     $s =~ s/</&lt;/g;
16     $s =~ s/>/&gt;/g;
17     $s =~ s/"/&quot;/g;
18     $s =~ s!([\x00-\x09\x0B-\x1F\x7F-\x80])!sprintf '<var>U+%04X</var>', ord $1!ge;
19     return $s;
20     } # htescape
21    
22 wakaba 1.1 my $http = SuikaWiki::Input::HTTP->new;
23    
24     ## TODO: _charset_
25    
26 wakaba 1.2 my $input_format = $http->parameter ('i') || 'text/html';
27     my $inner_html_element = $http->parameter ('e');
28     my $input_uri = 'thismessage:/';
29 wakaba 1.1
30     my $s = $http->parameter ('s');
31     if (length $s > 1000_000) {
32     print STDOUT "Status: 400 Document Too Long\nContent-Type: text/plain; charset=us-ascii\n\nToo long";
33     exit;
34     }
35 wakaba 1.2
36 wakaba 1.3 my @nav;
37 wakaba 1.2 print STDOUT qq[Content-Type: text/html; charset=utf-8
38    
39     <!DOCTYPE html>
40     <html lang="en">
41     <head>
42     <title>Web Document Conformance Checker (BETA)</title>
43 wakaba 1.3 <link rel="stylesheet" href="../cc-style.css" type="text/css">
44 wakaba 1.2 </head>
45     <body>
46     <h1>Web Document Conformance Checker (<em>beta</em>)</h1>
47    
48 wakaba 1.4 <div id="document-info" class="section">
49 wakaba 1.2 <dl>
50     <dt>Document URI</dt>
51     <dd><code class="URI" lang="">&lt;<a href="@{[htescape $input_uri]}">@{[htescape $input_uri]}</a>&gt;</code></dd>
52     <dt>Internet Media Type</dt>
53     <dd><code class="MIME" lang="en">@{[htescape $input_format]}</code></dd>
54     ]; # no </dl> yet
55 wakaba 1.3 push @nav, ['#document-info' => 'Information'];
56 wakaba 1.1
57     require Message::DOM::DOMImplementation;
58     my $dom = Message::DOM::DOMImplementation->____new;
59     my $doc;
60     my $el;
61    
62 wakaba 1.2 if ($input_format eq 'text/html') {
63     require Encode;
64     require Whatpm::HTML;
65    
66     $s = Encode::decode ('utf-8', $s);
67    
68     print STDOUT qq[
69     <dt>Character Encoding</dt>
70     <dd>(none)</dd>
71     </dl>
72 wakaba 1.3 </div>
73 wakaba 1.2
74     <div id="source-string" class="section">
75 wakaba 1.3 <h2>Document Source</h2>
76 wakaba 1.2 ];
77 wakaba 1.3 push @nav, ['#source-string' => 'Source'];
78 wakaba 1.2 print_source_string (\$s);
79     print STDOUT qq[
80     </div>
81 wakaba 1.1
82 wakaba 1.2 <div id="parse-errors" class="section">
83     <h2>Parse Errors</h2>
84    
85 wakaba 1.4 <dl>
86 wakaba 1.2 ];
87 wakaba 1.3 push @nav, ['#parse-errors' => 'Parse Error'];
88 wakaba 1.1
89     my $onerror = sub {
90     my (%opt) = @_;
91 wakaba 1.2 if ($opt{column} > 0) {
92 wakaba 1.4 print STDOUT qq[<dt><a href="#line-$opt{line}">Line $opt{line}</a> column $opt{column}</dt>\n];
93 wakaba 1.2 } else {
94     $opt{line}--;
95 wakaba 1.4 print STDOUT qq[<dt><a href="#line-$opt{line}">Line $opt{line}</a></dt>\n];
96 wakaba 1.2 }
97 wakaba 1.4 print STDOUT qq[<dd>@{[htescape $opt{type}]}</dd>\n];
98 wakaba 1.1 };
99    
100     $doc = $dom->create_document;
101 wakaba 1.2 if (defined $inner_html_element and length $inner_html_element) {
102 wakaba 1.1 $el = $doc->create_element_ns
103 wakaba 1.2 ('http://www.w3.org/1999/xhtml', [undef, $inner_html_element]);
104 wakaba 1.1 Whatpm::HTML->set_inner_html ($el, $s, $onerror);
105     } else {
106     Whatpm::HTML->parse_string ($s => $doc, $onerror);
107     }
108    
109 wakaba 1.2 print STDOUT qq[
110 wakaba 1.4 </dl>
111 wakaba 1.2 </div>
112     ];
113     } elsif ($input_format eq 'application/xhtml+xml') {
114     require Message::DOM::XMLParserTemp;
115     require Encode;
116    
117     my $t = Encode::decode ('utf-8', $s);
118    
119     print STDOUT qq[
120     <dt>Character Encoding</dt>
121     <dd>(none)</dd>
122     </dl>
123 wakaba 1.3 </div>
124 wakaba 1.2
125     <div id="source-string" class="section">
126 wakaba 1.3 <h2>Document Source</h2>
127 wakaba 1.2 ];
128 wakaba 1.3 push @nav, ['#source-string' => 'Source'];
129 wakaba 1.2 print_source_string (\$t);
130     print STDOUT qq[
131     </div>
132 wakaba 1.1
133 wakaba 1.2 <div id="parse-errors" class="section">
134     <h2>Parse Errors</h2>
135 wakaba 1.1
136 wakaba 1.4 <dl>
137 wakaba 1.2 ];
138 wakaba 1.3 push @nav, ['#parse-errors' => 'Parse Error'];
139 wakaba 1.1
140     my $onerror = sub {
141     my $err = shift;
142 wakaba 1.2 my $line = $err->location->line_number;
143 wakaba 1.4 print STDOUT qq[<dt><a href="#line-$line">Line $line</a> column ];
144     print STDOUT $err->location->column_number, "</dt><dd>";
145     print STDOUT htescape $err->text, "</dd>\n";
146 wakaba 1.1 return 1;
147     };
148    
149     open my $fh, '<', \$s;
150     $doc = Message::DOM::XMLParserTemp->parse_byte_stream
151     ($fh => $dom, $onerror, charset => 'utf-8');
152    
153 wakaba 1.2 print STDOUT qq[
154 wakaba 1.4 </dl>
155 wakaba 1.2 </div>
156     ];
157     } else {
158     print STDOUT qq[
159     </dl>
160 wakaba 1.4 </div>
161 wakaba 1.2
162 wakaba 1.3 <div id="result-summary" class="section">
163 wakaba 1.2 <p><em>Media type <code class="MIME" lang="en">@{[htescape $input_format]}</code> is not supported!</em></p>
164 wakaba 1.3 </div>
165 wakaba 1.2 ];
166 wakaba 1.3 push @nav, ['#result-summary' => 'Result'];
167 wakaba 1.2 }
168    
169    
170     if (defined $doc or defined $el) {
171     print STDOUT qq[
172     <div id="document-tree" class="section">
173     <h2>Document Tree</h2>
174     ];
175 wakaba 1.3 push @nav, ['#document-tree' => 'Tree'];
176 wakaba 1.2
177     print_document_tree ($el || $doc);
178    
179     print STDOUT qq[
180     </div>
181 wakaba 1.1
182 wakaba 1.2 <div id="document-errors" class="section">
183     <h2>Document Errors</h2>
184    
185 wakaba 1.4 <dl>
186 wakaba 1.2 ];
187 wakaba 1.3 push @nav, ['#document-errors' => 'Document Error'];
188 wakaba 1.1
189     require Whatpm::ContentChecker;
190     my $onerror = sub {
191     my %opt = @_;
192 wakaba 1.6 print STDOUT qq[<dt>] . get_node_link ($opt{node}) .
193     "</dt>\n<dd>", htescape $opt{type}, "</dd>\n";
194 wakaba 1.1 };
195 wakaba 1.2
196 wakaba 1.5 my $elements;
197 wakaba 1.1 if ($el) {
198 wakaba 1.5 $elements = Whatpm::ContentChecker->check_element ($el, $onerror);
199 wakaba 1.1 } else {
200 wakaba 1.5 $elements = Whatpm::ContentChecker->check_document ($doc, $onerror);
201 wakaba 1.1 }
202 wakaba 1.2
203     print STDOUT qq[
204 wakaba 1.4 </dl>
205 wakaba 1.2 </div>
206     ];
207 wakaba 1.5
208     if (@{$elements->{table}}) {
209     require JSON;
210    
211     print STDOUT qq[
212     <div id="tables" class="section">
213     <h2>Tables</h2>
214    
215     <!--[if IE]><script type="text/javascript" src="../excanvas.js"></script><![endif]-->
216     <script src="../table-script.js" type="text/javascript"></script>
217     <noscript>
218     <p><em>Structure of tables are visualized here if scripting is enabled.</em></p>
219     </noscript>
220     ];
221    
222     my $i = 0;
223     for my $table_el (@{$elements->{table}}) {
224     $i++;
225 wakaba 1.6 print STDOUT qq[<div class="section" id="table-$i"><h3>] .
226     get_node_link ($table_el) . q[</h3>];
227 wakaba 1.5
228     my $table = Whatpm::HTMLTable->form_table ($table_el);
229    
230     for (@{$table->{column_group}}, @{$table->{column}}, $table->{caption}) {
231     next unless $_;
232     delete $_->{element};
233     }
234    
235     for (@{$table->{row_group}}) {
236     next unless $_;
237     next unless $_->{element};
238     $_->{type} = $_->{element}->manakai_local_name;
239     delete $_->{element};
240     }
241    
242     for (@{$table->{cell}}) {
243     next unless $_;
244     for (@{$_}) {
245     next unless $_;
246     for (@$_) {
247     $_->{id} = refaddr $_->{element} if defined $_->{element};
248     delete $_->{element};
249     }
250     }
251     }
252    
253     print STDOUT '</div><script type="text/javascript">tableToCanvas (';
254     print STDOUT JSON::objToJson ($table);
255     print STDOUT qq[, document.getElementById ('table-$i'));</script>];
256     }
257    
258     print STDOUT qq[</div>];
259     }
260 wakaba 1.6
261     if (keys %{$elements->{term}}) {
262     print STDOUT qq[
263     <div id="terms" class="section">
264     <h2>Terms</h2>
265    
266 &