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

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

Parent Directory Parent Directory | Revision Log Revision Log

Revision 1.24 - (hide annotations) (download)
Sun Nov 11 06:57:16 2007 UTC (19 years ago) by wakaba
Branch: MAIN
Changes since 1.23: +34 -18 lines 
++ ChangeLog	11 Nov 2007 06:57:02 -0000
	* cc-style.css: Rules for "unsupported" parse errors.

	* cc.cgi (print_syntax_error_html_section): Use HTML
	parser for byte string.
	(print_result_unknown_type_section): Make output
	more consistent with other media types.

2007-11-11  Wakaba  <wakaba@suika.fam.cx>
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 $inner_html_element = $http->get_parameter ('e');
56     my $char_length = 0;
57     my %time;
58 wakaba 1.14
59     print qq[
60 wakaba 1.4 <div id="document-info" class="section">
61 wakaba 1.2 <dl>
62 wakaba 1.9 <dt>Request URI</dt>
63     <dd><code class="URI" lang="">&lt;<a href="@{[htescape $input->{request_uri}]}">@{[htescape $input->{request_uri}]}</a>&gt;</code></dd>
64 wakaba 1.2 <dt>Document URI</dt>
65 wakaba 1.9 <dd><code class="URI" lang="">&lt;<a href="@{[htescape $input->{uri}]}">@{[htescape $input->{uri}]}</a>&gt;</code></dd>
66 wakaba 1.2 ]; # no </dl> yet
67 wakaba 1.3 push @nav, ['#document-info' => 'Information'];
68 wakaba 1.1
69 wakaba 1.9 if (defined $input->{s}) {
70 wakaba 1.16 $char_length = length $input->{s};
71 wakaba 1.9
72     print STDOUT qq[
73     <dt>Base URI</dt>
74     <dd><code class="URI" lang="">&lt;<a href="@{[htescape $input->{base_uri}]}">@{[htescape $input->{base_uri}]}</a>&gt;</code></dd>
75     <dt>Internet Media Type</dt>
76     <dd><code class="MIME" lang="en">@{[htescape $input->{media_type}]}</code>
77     @{[$input->{media_type_overridden} ? '<em>(overridden)</em>' : '']}</dd>
78     <dt>Character Encoding</dt>
79     <dd>@{[defined $input->{charset} ? '<code class="charset" lang="en">'.htescape ($input->{charset}).'</code>' : '(none)']}
80     @{[$input->{charset_overridden} ? '<em>(overridden)</em>' : '']}</dd>
81 wakaba 1.16 <dt>Length</dt>
82     <dd>$char_length byte@{[$char_length == 1 ? '' : 's']}</dd>
83 wakaba 1.9 </dl>
84     </div>
85     ];
86    
87 wakaba 1.20 my $result = {conforming_min => 1, conforming_max => 1};
88 wakaba 1.19 print_http_header_section ($input, $result);
89 wakaba 1.9
90 wakaba 1.1 my $doc;
91     my $el;
92 wakaba 1.22 my $manifest;
93 wakaba 1.1
94 wakaba 1.9 if ($input->{media_type} eq 'text/html') {
95 wakaba 1.19 ($doc, $el) = print_syntax_error_html_section ($input, $result);
96 wakaba 1.9 print_source_string_section (\($input->{s}), $input->{charset});
97     } elsif ({
98     'text/xml' => 1,
99 wakaba 1.16 'application/atom+xml' => 1,
100     'application/rss+xml' => 1,
101     'application/svg+xml' => 1,
102 wakaba 1.9 'application/xhtml+xml' => 1,
103     'application/xml' => 1,
104     }->{$input->{media_type}}) {
105 wakaba 1.19 ($doc, $el) = print_syntax_error_xml_section ($input, $result);
106 wakaba 1.9 print_source_string_section (\($input->{s}), $doc->input_encoding);
107 wakaba 1.22 } elsif ($input->{media_type} eq 'text/cache-manifest') {
108     ## TODO: MUST be text/cache-manifest
109     $manifest = print_syntax_error_manifest_section ($input, $result);
110     print_source_string_section (\($input->{s}), 'utf-8');
111 wakaba 1.2 } else {
112 wakaba 1.9 ## TODO: Change HTTP status code??
113 wakaba 1.24 print_result_unknown_type_section ($input, $result);
114 wakaba 1.2 }
115    
116     if (defined $doc or defined $el) {
117 wakaba 1.22 print_structure_dump_dom_section ($doc, $el);
118     my $elements = print_structure_error_dom_section ($doc, $el, $result);
119 wakaba 1.18 print_table_section ($elements->{table}) if @{$elements->{table}};
120     print_id_section ($elements->{id}) if keys %{$elements->{id}};
121     print_term_section ($elements->{term}) if keys %{$elements->{term}};
122     print_class_section ($elements->{class}) if keys %{$elements->{class}};
123 wakaba 1.22 } elsif (defined $manifest) {
124     print_structure_dump_manifest_section ($manifest);
125     print_structure_error_manifest_section ($manifest, $result);
126 wakaba 1.1 }
127    
128 wakaba 1.19 print_result_section ($result);
129 wakaba 1.9 } else {
130 wakaba 1.18 print STDOUT qq[</dl></div>];
131     print_result_input_er