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

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

Parent Directory Parent Directory | Revision Log Revision Log

Revision 1.28 - (hide annotations) (download)
Fri Nov 23 06:36:19 2007 UTC (18 years, 11 months ago) by wakaba
Branch: MAIN
Changes since 1.27: +2 -1 lines 
++ ChangeLog	23 Nov 2007 06:36:14 -0000
2007-11-23  Wakaba  <wakaba@suika.fam.cx>

	* error-description-source.xml: New error descriptions.

	* cc.cgi: |Accept-Encoding: *; q=0| is a request for server to send
	a 406 page!  |identity| encoding is added.
1 wakaba 1.1 #!/usr/bin/perl
2     use strict;
3 wakaba 1.23 use utf8;
4 wakaba 1.1
5     use lib qw[/home/httpd/html/www/markup/html/whatpm
6 wakaba 1.16 /home/wakaba/work/manakai2/lib];
7 wakaba 1.1 use CGI::Carp qw[fatalsToBrowser];
8 wakaba 1.2 use Scalar::Util qw[refaddr];
9 wakaba 1.16 use Time::HiRes qw/time/;
10 wakaba 1.1
11 wakaba 1.2 sub htescape ($) {
12     my $s = $_[0];
13     $s =~ s/&/&amp;/g;
14     $s =~ s/</&lt;/g;
15     $s =~ s/>/&gt;/g;
16     $s =~ s/"/&quot;/g;
17 wakaba 1.12 $s =~ s{([\x00-\x09\x0B-\x1F\x7F-\xA0\x{FEFF}\x{FFFC}-\x{FFFF}])}{
18     sprintf '<var>U+%04X</var>', ord $1;
19     }ge;
20 wakaba 1.2 return $s;
21     } # htescape
22    
23 wakaba 1.16 use Message::CGI::HTTP;
24     my $http = Message::CGI::HTTP->new;
25 wakaba 1.1
26 wakaba 1.16 if ($http->get_meta_variable ('PATH_INFO') ne '/') {
27 wakaba 1.8 print STDOUT "Status: 404 Not Found\nContent-Type: text/plain; charset=us-ascii\n\n400";
28     exit;
29     }
30    
31 wakaba 1.12 binmode STDOUT, ':utf8';
32 wakaba 1.14 $| = 1;
33 wakaba 1.12
34 wakaba 1.9 require Message::DOM::DOMImplementation;
35     my $dom = Message::DOM::DOMImplementation->new;
36    
37 wakaba 1.7 load_text_catalog ('en'); ## TODO: conneg
38    
39 wakaba 1.3 my @nav;
40 wakaba 1.2 print STDOUT qq[Content-Type: text/html; charset=utf-8
41    
42     <!DOCTYPE html>
43     <html lang="en">
44     <head>
45     <title>Web Document Conformance Checker (BETA)</title>
46 wakaba 1.3 <link rel="stylesheet" href="../cc-style.css" type="text/css">
47 wakaba 1.2 </head>
48     <body>
49 wakaba 1.13 <h1><a href="../cc-interface">Web Document Conformance Checker</a>
50     (<em>beta</em>)</h1>
51 wakaba 1.14 ];
52 wakaba 1.2
53 wakaba 1.14 $| = 0;
54     my $input = get_input_document ($http, $dom);
55 wakaba 1.16 my $char_length = 0;
56     my %time;
57 wakaba 1.14
58     print qq[
59 wakaba 1.4 <div id="document-info" class="section">
60 wakaba 1.2 <dl>
61 wakaba 1.9 <dt>Request URI</dt>
62     <dd><code class="URI" lang="">&lt;<a href="@{[htescape $input->{request_uri}]}">@{[htescape $input->{request_uri}]}</a>&gt;</code></dd>
63 wakaba 1.2 <dt>Document URI</dt>
64 wakaba 1.25 <dd><code class="URI" lang="">&lt;<a href="@{[htescape $input->{uri}]}" id=anchor-document-uri>@{[htescape $input->{uri}]}</a>&gt;</code>
65     <script>
66     document.title = '<'
67     + document.getElementById ('anchor-document-uri').href + '> \\u2014 '
68     + document.title;
69     </script></dd>
70 wakaba 1.2 ]; # no </dl> yet
71 wakaba 1.3 push @nav, ['#document-info' => 'Information'];
72 wakaba 1.1
73 wakaba 1.9 if (defined $input->{s}) {
74 wakaba 1.16 $char_length = length $input->{s};
75 wakaba 1.9
76     print STDOUT qq[
77     <dt>Base URI</dt>
78     <dd><code class="URI" lang="">&lt;<a href="@{[htescape $input->{base_uri}]}">@{[htescape $input->{base_uri}]}</a>&gt;</code></dd>
79     <dt>Internet Media Type</dt>
80     <dd><code class="MIME" lang="en">@{[htescape $input->{media_type}]}</code>
81 wakaba 1.25 @{[$input->{media_type_overridden} ? '<em>(overridden)</em>' : defined $input->{official_type} ? $input->{media_type} eq $input->{official_type} ? '' : '<em>(sniffed; official type is: <code class=MIME lang=en>'.htescape ($input->{official_type}).'</code>)' : '<em>(sniffed)</em>']}</dd>
82 wakaba 1.9 <dt>Character Encoding</dt>
83     <dd>@{[defined $input->{charset} ? '<code class="charset" lang="en">'.htescape ($input->{charset}).'</code>' : '(none)']}
84     @{[$input->{charset_overridden} ? '<em>(overridden)</em>' : '']}</dd>
85 wakaba 1.16 <dt>Length</dt>
86     <dd>$char_length byte@{[$char_length == 1 ? '' : 's']}</dd>
87 wakaba 1.9 </dl>
88     </div>
89     ];
90    
91 wakaba 1.20 my $result = {conforming_min => 1, conforming_max => 1};
92 wakaba 1.19 print_http_header_section ($input, $result);
93 wakaba 1.9
94 wakaba 1.1 my $doc;
95     my $el;
96 wakaba 1.22 my $manifest;
97 wakaba 1.1
98 wakaba 1.9 if ($input->{media_type} eq 'text/html') {
99 wakaba 1.19 ($doc, $el) = print_syntax_error_html_section ($input, $result);
100 wakaba 1.25 print_source_string_section
101     (\($input->{s}), $input->{charset} || $doc->input_encoding);
102 wakaba 1.9 } elsif ({
103     'text/xml' => 1,
104 wakaba 1.16 'application/atom+xml' => 1,
105     'application/rss+xml' => 1,
106     'application/svg+xml' => 1,
107 wakaba 1.9 'application/xhtml+xml' => 1,
108     'application/xml' => 1,
109     }->{$input->{media_type}}) {
110 wakaba 1.19 ($doc, $el) = print_syntax_error_xml_section ($input, $result);
111 wakaba 1.9 print_source_string_section (\($input->{s}), $doc->input_encoding);
112 wakaba 1.22 } elsif ($input->{media_type} eq 'text/cache-manifest') {
113     ## TODO: MUST be text/cache-manifest
114     $manifest = print_syntax_error_manifest_section ($input, $result);
115     print_source_string_section (\($input->{s}), 'utf-8');
116 wakaba 1.2 } else {
117 wakaba 1.9 ## TODO: Change HTTP status code??
118 wakaba 1.24 print_result_unknown_type_section ($input, $result);
119 wakaba 1.2 }
120    
121     if (defined $doc or defined $el) {
122 wakaba 1.22 print_structure_dump_dom_section ($doc, $el);
123     my $elements = print_structure_error_dom_section ($doc, $el, $result);
124 wakaba 1.18 print_table_section ($elements->{table}) if @{$elements->{table}};
125     print_id_section ($elements->{id}) if keys %{$elements->{id}};
126     print_term_section ($elements->{term}) if keys %{$elements->{term}};
127     print_class_section ($elements->{class}) if keys %{$elements->{class}};
128 wakaba 1.22 } elsif (defined $manifest) {
129     print_structure_dump_manifest_section ($manifest);
130     print_structure_error_manifest_section ($manifest, $result);
131 wakaba 1.1 }
132    
133 wakaba 1.19 print_result_section ($result);
134 wakaba 1.9 } else {
135 wakaba 1.18 print STDOUT qq[</dl></div>];
136     print_result_input_error_section ($input);
137 wakaba 1.9 }
138 wakaba 1.3
139 wakaba 1.2 print STDOUT qq[
140 wakaba 1.3 <ul class="navigation" id="nav-items">
141     ];
142     for (@nav) {
143     print STDOUT qq[<li><a href="$_->[0]">$_->[1]</a></li>];
144     }
145     print STDOUT qq[
146     </ul>
147 wakaba 1.2 </body>
148     </html>
149     ];
150 wakaba 1.1
151 wakaba 1.24 for (qw/decode parse parse_html parse_xml parse_manifest
152     check check_manifest/) {
153 wakaba 1.16 next unless defined $time{$_};
154     open my $file, '>>', ".cc-$_.txt" or die ".cc-$_.txt: $!";
155     print $file $char_length, "\t", $time{$_}, "\n";
156     }
157    
158 wakaba 1.1 exit;
159    
160 wakaba 1.19 sub add_error ($$$) {
161