--- test/html-webhacc/cc.cgi 2007/06/27 12:35:24 1.2
+++ test/html-webhacc/cc.cgi 2008/03/16 11:38:47 1.41
@@ -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,211 +14,682 @@
$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_
-
- my $input_format = $http->parameter ('i') || 'text/html';
- my $inner_html_element = $http->parameter ('e');
- my $input_uri = 'thismessage:/';
+ my @nav;
+ my %time;
+ require Message::DOM::DOMImplementation;
+ my $dom = Message::DOM::DOMImplementation->new;
+{
+ use Message::CGI::HTTP;
+ my $http = Message::CGI::HTTP->new;
- 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;
+
+ load_text_catalog ('en'); ## TODO: conneg
+
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;
+ 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']}
+
+
+
+
+];
+
+ $input->{id_prefix} = '';
+ #$input->{nested} = 0;
+ 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;
+ } elsif ($err->{level} eq 'i') {
+ #
+ } 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) = @_;
+
+ print_http_header_section ($input, $result);
- require Message::DOM::DOMImplementation;
- my $dom = Message::DOM::DOMImplementation->____new;
my $doc;
my $el;
+ my $cssom;
+ my $manifest;
+ my @subdoc;
+
+ if ($input->{media_type} eq 'text/html') {
+ ($doc, $el) = print_syntax_error_html_section ($input, $result);
+ print_source_string_section
+ ($input,
+ \($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,
+ \($input->{s}),
+ $doc->input_encoding);
+ } elsif ($input->{media_type} eq 'text/css') {
+ $cssom = print_syntax_error_css_section ($input, $result);
+ print_source_string_section
+ ($input, \($input->{s}),
+ $cssom->manakai_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, \($input->{s}),
+ 'utf-8');
+ } else {
+ ## TODO: Change HTTP status code??
+ print_result_unknown_type_section ($input, $result);
+ }
- if ($input_format eq 'text/html') {
- require Encode;
- require Whatpm::HTML;
-
- $s = Encode::decode ('utf-8', $s);
+ if (defined $doc or defined $el) {
+ $doc->document_uri ($input->{uri});
+ $doc->manakai_entity_base_uri ($input->{base_uri});
+ print_structure_dump_dom_section ($input, $doc, $el);
+ my $elements = print_structure_error_dom_section
+ ($input, $doc, $el, $result, sub {
+ push @subdoc, shift;
+ });
+ 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 $cssom) {
+ print_structure_dump_cssom_section ($input, $cssom);
+ ## TODO: CSSOM validation
+ add_error ('structure', {level => 'u'} => $result);
+ } elsif (defined $manifest) {
+ print_structure_dump_manifest_section ($input, $manifest);
+ print_structure_error_manifest_section ($input, $manifest, $result);
+ }
- print STDOUT qq[
-Character Encoding
- (none)
-
+ my $id_prefix = 0;
+ for my $subinput (@subdoc) {
+ $subinput->{id_prefix} = 'subdoc-' . ++$id_prefix;
+ $subinput->{nested} = 1;
+ $subinput->{base_uri} = $subinput->{container_node}->base_uri
+ unless defined $subinput->{base_uri};
+ my $ebaseuri = htescape ($subinput->{base_uri});
+ push @nav, ['#' . $subinput->{id_prefix} => 'Sub #' . $id_prefix];
+ print STDOUT qq[
-];
- } elsif ($input_format eq 'application/xhtml+xml') {
- require Message::DOM::XMLParserTemp;
- require Encode;
-
- my $t = Encode::decode ('utf-8', $s);
-
- print STDOUT qq[
-Character Encoding
- (none)
-
-
-
-];
- 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
-];
-
- print_document_tree ($el || $doc);
+sub print_syntax_error_css_section ($$) {
+ my ($input, $result) = @_;
- print STDOUT qq[
-
+ print STDOUT qq[
+];
+
+ return $cssom;
+} # print_syntax_error_css_section
+
+sub print_syntax_error_manifest_section ($$) {
+ my ($input, $result) = @_;
+
+ require Whatpm::CacheManifest;
- ## TODO: Show result
print STDOUT qq[
-
-