--- test/html-webhacc/cc.cgi 2007/06/27 12:35:24 1.2
+++ test/html-webhacc/cc.cgi 2008/02/10 02:42:01 1.33
@@ -1,13 +1,12 @@
#!/usr/bin/perl
use strict;
+use utf8;
use lib qw[/home/httpd/html/www/markup/html/whatpm
- /home/wakaba/work/manakai/lib
- /home/wakaba/public_html/-temp/wiki/lib];
+ /home/wakaba/work/manakai2/lib];
use CGI::Carp qw[fatalsToBrowser];
use Scalar::Util qw[refaddr];
-
-use SuikaWiki::Input::HTTP; ## TODO: Use some better CGI module
+use Time::HiRes qw/time/;
sub htescape ($) {
my $s = $_[0];
@@ -15,208 +14,388 @@
$s =~ s//>/g;
$s =~ s/"/"/g;
- $s =~ s!([\x00-\x09\x0B-\x1F\x7F-\x80])!sprintf 'U+%04X', ord $1!ge;
+ $s =~ s{([\x00-\x09\x0B-\x1F\x7F-\xA0\x{FEFF}\x{FFFC}-\x{FFFF}])}{
+ sprintf 'U+%04X', ord $1;
+ }ge;
return $s;
} # htescape
-my $http = SuikaWiki::Input::HTTP->new;
-
-## TODO: _charset_
+ use Message::CGI::HTTP;
+ my $http = Message::CGI::HTTP->new;
- my $input_format = $http->parameter ('i') || 'text/html';
- my $inner_html_element = $http->parameter ('e');
- my $input_uri = 'thismessage:/';
-
- my $s = $http->parameter ('s');
- if (length $s > 1000_000) {
- print STDOUT "Status: 400 Document Too Long\nContent-Type: text/plain; charset=us-ascii\n\nToo long";
+ if ($http->get_meta_variable ('PATH_INFO') ne '/') {
+ print STDOUT "Status: 404 Not Found\nContent-Type: text/plain; charset=us-ascii\n\n400";
exit;
}
+ binmode STDOUT, ':utf8';
+ $| = 1;
+
+ require Message::DOM::DOMImplementation;
+ my $dom = Message::DOM::DOMImplementation->new;
+
+ load_text_catalog ('en'); ## TODO: conneg
+
+ my @nav;
print STDOUT qq[Content-Type: text/html; charset=utf-8
Web Document Conformance Checker (BETA)
-
-
+
-Web Document Conformance Checker (beta)
+
+];
+
+ $| = 0;
+ my $input = get_input_document ($http, $dom);
+ my $char_length = 0;
+ my %time;
+ print qq[
+
+- Request URI
+ <@{[htescape $input->{request_uri}]}>- Document URI
- <@{[htescape $input_uri]}>- Internet Media Type
- @{[htescape $input_format]}<@{[htescape $input->{uri}]}>
+
yet
+ push @nav, ['#document-info' => 'Information'];
+
+if (defined $input->{s}) {
+ $char_length = length $input->{s};
+
+ print STDOUT qq[
+
Base URI
+
<@{[htescape $input->{base_uri}]}>
+
Internet Media Type
+
@{[htescape $input->{media_type}]}
+ @{[$input->{media_type_overridden} ? '(overridden)' : defined $input->{official_type} ? $input->{media_type} eq $input->{official_type} ? '' : '(sniffed; official type is: '.htescape ($input->{official_type}).')' : '(sniffed)']}
+
Character Encoding
+
@{[defined $input->{charset} ? ''.htescape ($input->{charset}).'' : '(none)']}
+ @{[$input->{charset_overridden} ? '(overridden)' : '']}
+
Length
+
$char_length byte@{[$char_length == 1 ? '' : 's']}
+
+
+];
+
+ my $result = {conforming_min => 1, conforming_max => 1};
+ check_and_print ($input => $result);
+ print_result_section ($result);
+} else {
+ print STDOUT qq[];
+ print_result_input_error_section ($input);
+}
+
+ print STDOUT qq[
+
+];
+ for (@nav) {
+ print STDOUT qq[- $_->[1]
];
+ }
+ print STDOUT qq[
+
+
+
+];
+
+ for (qw/decode parse parse_html parse_xml parse_manifest
+ check check_manifest/) {
+ next unless defined $time{$_};
+ open my $file, '>>', ".cc-$_.txt" or die ".cc-$_.txt: $!";
+ print $file $char_length, "\t", $time{$_}, "\n";
+ }
+
+exit;
+
+sub add_error ($$$) {
+ my ($layer, $err, $result) = @_;
+ if (defined $err->{level}) {
+ if ($err->{level} eq 's') {
+ $result->{$layer}->{should}++;
+ $result->{$layer}->{score_min} -= 2;
+ $result->{conforming_min} = 0;
+ } elsif ($err->{level} eq 'w' or $err->{level} eq 'g') {
+ $result->{$layer}->{warning}++;
+ } elsif ($err->{level} eq 'u' or $err->{level} eq 'unsupported') {
+ $result->{$layer}->{unsupported}++;
+ $result->{unsupported} = 1;
+ } else {
+ $result->{$layer}->{must}++;
+ $result->{$layer}->{score_max} -= 2;
+ $result->{$layer}->{score_min} -= 2;
+ $result->{conforming_min} = 0;
+ $result->{conforming_max} = 0;
+ }
+ } else {
+ $result->{$layer}->{must}++;
+ $result->{$layer}->{score_max} -= 2;
+ $result->{$layer}->{score_min} -= 2;
+ $result->{conforming_min} = 0;
+ $result->{conforming_max} = 0;
+ }
+} # add_error
+
+sub check_and_print ($$) {
+ my ($input, $result) = @_;
+ $input->{id_prefix} = '';
+ #$input->{nested} = 1/0;
+
+ print_http_header_section ($input, $result);
- require Message::DOM::DOMImplementation;
- my $dom = Message::DOM::DOMImplementation->____new;
my $doc;
my $el;
+ my $manifest;
- if ($input_format eq 'text/html') {
- require Encode;
- require Whatpm::HTML;
-
- $s = Encode::decode ('utf-8', $s);
+ if ($input->{media_type} eq 'text/html') {
+ ($doc, $el) = print_syntax_error_html_section ($input, $result);
+ print_source_string_section
+ (\($input->{s}), $input->{charset} || $doc->input_encoding);
+ } elsif ({
+ 'text/xml' => 1,
+ 'application/atom+xml' => 1,
+ 'application/rss+xml' => 1,
+ 'application/svg+xml' => 1,
+ 'application/xhtml+xml' => 1,
+ 'application/xml' => 1,
+ }->{$input->{media_type}}) {
+ ($doc, $el) = print_syntax_error_xml_section ($input, $result);
+ print_source_string_section (\($input->{s}), $doc->input_encoding);
+ } elsif ($input->{media_type} eq 'text/cache-manifest') {
+## TODO: MUST be text/cache-manifest
+ $manifest = print_syntax_error_manifest_section ($input, $result);
+ print_source_string_section (\($input->{s}), 'utf-8');
+ } else {
+ ## TODO: Change HTTP status code??
+ print_result_unknown_type_section ($input, $result);
+ }
- print STDOUT qq[
-Character Encoding
- (none)
-
+ if (defined $doc or defined $el) {
+ print_structure_dump_dom_section ($input, $doc, $el);
+ my $elements = print_structure_error_dom_section
+ ($input, $doc, $el, $result);
+ print_table_section ($input, $elements->{table}) if @{$elements->{table}};
+ print_listing_section ({
+ id => 'identifiers', label => 'IDs', heading => 'Identifiers',
+ }, $input, $elements->{id}) if keys %{$elements->{id}};
+ print_listing_section ({
+ id => 'terms', label => 'Terms', heading => 'Terms',
+ }, $input, $elements->{term}) if keys %{$elements->{term}};
+ print_listing_section ({
+ id => 'classes', label => 'Classes', heading => 'Classes',
+ }, $input, $elements->{class}) if keys %{$elements->{class}};
+ } elsif (defined $manifest) {
+ print_structure_dump_manifest_section ($input, $manifest);
+ print_structure_error_manifest_section ($input, $manifest, $result);
+ }
+} # check_and_print
-
+sub print_http_header_section ($$) {
+ my ($input, $result) = @_;
+ return unless defined $input->{header_status_code} or
+ defined $input->{header_status_text} or
+ @{$input->{header_field}};
+
+ push @nav, ['#source-header' => 'HTTP Header'] unless $input->{nested};
+ print STDOUT qq[];
+} # print_http_header_section
+
+sub print_syntax_error_html_section ($$) {
+ my ($input, $result) = @_;
+
+ require Encode;
+ require Whatpm::HTML;
+
+ print STDOUT qq[
+
];
+
+ return ($doc, $el);
+} # print_syntax_error_html_section
+
+sub print_syntax_error_xml_section ($$) {
+ my ($input, $result) = @_;
+
+ require Message::DOM::XMLParserTemp;
+
print STDOUT qq[
-
-
-];
- print_source_string (\$t);
- print STDOUT qq[
-
-
-
+
-];
- } else {
- print STDOUT qq[
-
-
-
Media type @{[htescape $input_format]} is not supported!
-];
- }
+ my $time1 = time;
+ open my $fh, '<', \($input->{s});
+ my $doc = Message::DOM::XMLParserTemp->parse_byte_stream
+ ($fh => $dom, $onerror, charset => $input->{charset});
+ $time{parse_xml} = time - $time1;
+ $doc->manakai_charset ($input->{official_charset})
+ if defined $input->{official_charset};
+
+ print STDOUT qq[
-
Document Tree
-];
+sub print_syntax_error_manifest_section ($$) {
+ my ($input, $result) = @_;
- print_document_tree ($el || $doc);
+ require Whatpm::CacheManifest;
- print STDOUT qq[
-
+ print STDOUT qq[
+
-