--- test/html-webhacc/cc.cgi 2007/06/27 12:35:24 1.2
+++ test/html-webhacc/cc.cgi 2008/09/14 14:36:12 1.65
@@ -1,310 +1,142 @@
#!/usr/bin/perl
+# -d:DProf
use strict;
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
+ require WebHACC::Input;
-sub htescape ($) {
- my $s = $_[0];
- $s =~ s/&/&/g;
- $s =~ s//>/g;
- $s =~ s/"/"/g;
- $s =~ s!([\x00-\x09\x0B-\x1F\x7F-\x80])!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 $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";
- exit;
- }
-
- print STDOUT qq[Content-Type: text/html; charset=utf-8
-
-
-
-
-Web Document Conformance Checker (BETA)
-
-
-
-
-Web Document Conformance Checker (beta)
-
-
-- Document URI
- <@{[htescape $input_uri]}>- Internet Media Type
- @{[htescape $input_format]}
yet
-
- require Message::DOM::DOMImplementation;
- my $dom = Message::DOM::DOMImplementation->____new;
- my $doc;
- my $el;
-
- if ($input_format eq 'text/html') {
- require Encode;
- require Whatpm::HTML;
-
- $s = Encode::decode ('utf-8', $s);
-
- print STDOUT qq[
-Character Encoding
- (none)
-
-
-
-];
- print_source_string (\$s);
- print STDOUT qq[
-
-
-
-
Parse Errors
-
-
-];
-
- my $onerror = sub {
- my (%opt) = @_;
- if ($opt{column} > 0) {
- print STDOUT qq[- Line $opt{line} column $opt{column}: ];
- } else {
- $opt{line}--;
- print STDOUT qq[
- Line $opt{line}: ];
- }
- print STDOUT qq[@{[htescape $opt{type}]}
\n];
- };
-
- $doc = $dom->create_document;
- if (defined $inner_html_element and length $inner_html_element) {
- $el = $doc->create_element_ns
- ('http://www.w3.org/1999/xhtml', [undef, $inner_html_element]);
- Whatpm::HTML->set_inner_html ($el, $s, $onerror);
- } else {
- Whatpm::HTML->parse_string ($s => $doc, $onerror);
- }
-
- print STDOUT qq[
-
-
-];
- print_source_string (\$t);
- print STDOUT qq[
-
-
-
-
Parse Errors
-
-
-];
-
- my $onerror = sub {
- my $err = shift;
- my $line = $err->location->line_number;
- print STDOUT qq[- Line $line column ];
- print STDOUT $err->location->column_number, ": ";
- print STDOUT htescape $err->text, "
\n";
- return 1;
- };
-
- open my $fh, '<', \$s;
- $doc = Message::DOM::XMLParserTemp->parse_byte_stream
- ($fh => $dom, $onerror, charset => 'utf-8');
-
- print STDOUT qq[
-
-
Media type @{[htescape $input_format]} is not supported!
-];
+ if ($http->get_meta_variable ('PATH_INFO') ne '/') {
+ $out->http_error (404);
+ exit;
}
-
- if (defined $doc or defined $el) {
- print STDOUT qq[
-
-
Document Tree
-];
-
- print_document_tree ($el || $doc);
-
- print STDOUT qq[
-
-
-
-
Document Errors
-
-
-];
-
- require Whatpm::ContentChecker;
- my $onerror = sub {
- my %opt = @_;
- print STDOUT qq[- ],
- htescape get_node_path ($opt{node}),
- ": ", htescape $opt{type}, "
\n";
- };
-
- if ($el) {
- Whatpm::ContentChecker->check_element ($el, $onerror);
- } else {
- Whatpm::ContentChecker->check_document ($doc, $onerror);
- }
-
- print STDOUT qq[
-
-
\n];
- while ($$s =~ /\G([^\x0A]*?)\x0D?\x0A/gc) {
- print STDOUT qq[- ], htescape $1, "
\n";
- $i++;
+ require WebHACC::Result;
+ my $result = WebHACC::Result->new;
+ $result->output ($out);
+
+ require WebHACC::Input;
+ my $input = WebHACC::Input->get_document ($http => $result => $out);
+
+ check_and_print ($input => $result => $out);
+
+ $out->nav_list;
+
+ exit;
+}
+
+sub check_and_print ($$$) {
+ my ($input, $result, $out) = @_;
+ my $original_input = $out->input;
+ $out->input ($input);
+
+ $input->generate_info_section ($result);
+
+ $input->generate_transfer_sections ($result);
+
+ unless (defined $input->{s}) {
+ ## NOTE: This is an error of the implementation.
+ $result->layer_uncertain ('transfer');
+ $result->generate_result_section;
+
+ $out->input ($original_input);
+ return;
+ }
+
+ my $checker_class = {
+ 'text/cache-manifest' => 'WebHACC::Language::CacheManifest',
+ 'text/css' => 'WebHACC::Language::CSS',
+ 'text/html' => 'WebHACC::Language::HTML',
+ 'text/x-h2h' => 'WebHACC::Language::H2H',
+ 'text/x-webidl' => 'WebHACC::Language::WebIDL',
+
+ 'text/xml' => 'WebHACC::Language::XML',
+ 'application/atom+xml' => 'WebHACC::Language::XML',
+ 'application/rss+xml' => 'WebHACC::Language::XML',
+ 'image/svg+xml' => 'WebHACC::Language::XML',
+ 'application/xhtml+xml' => 'WebHACC::Language::XML',
+ 'application/xml' => 'WebHACC::Language::XML',
+ ## TODO: Should we make all XML MIME Types fall
+ ## into this category?
+
+ ## NOTE: This type has different model from normal XML types.
+ 'application/rdf+xml' => 'WebHACC::Language::XML',
+ }->{$input->{media_type}} || 'WebHACC::Language::Default';
+
+ eval qq{ require $checker_class } or die "$0: Loading $checker_class: $@";
+ my $checker = $checker_class->new;
+ $checker->input ($input);
+ $checker->output ($out);
+ $checker->result ($result);
+
+ ## TODO: A cache manifest MUST be text/cache-manifest
+ ## TODO: WebIDL media type "text/x-webidl"
+
+ $checker->generate_syntax_error_section;
+ $checker->generate_source_string_section;
+
+ my @subdoc;
+ $checker->onsubdoc (sub {
+ push @subdoc, shift;
+ });
+
+ $checker->generate_structure_dump_section;
+ $checker->generate_structure_error_section;
+ $checker->generate_additional_sections;
+
+ my $id_prefix = 0;
+ for my $_subinput (@subdoc) {
+ my $subinput = WebHACC::Input::Subdocument->new (++$id_prefix);
+ $subinput->{$_} = $_subinput->{$_} for keys %$_subinput;
+ $subinput->{base_uri} = $subinput->{container_node}->base_uri
+ unless defined $subinput->{base_uri};
+ $subinput->{parent_input} = $input;
+
+ my $subresult = WebHACC::Result->new;
+ $subresult->output ($out);
+ $subresult->parent_result ($result);
+
+ $subinput->start_section ($subresult);
+ check_and_print ($subinput => $subresult => $out);
+ $subinput->end_section ($subresult);
}
- if ($$s =~ /\G([^\x0A]+)/gc) {
- print STDOUT qq[- ], htescape $1, "
\n";
- }
- print STDOUT "
";
-} # print_input_string
-sub print_document_tree ($) {
- my $node = shift;
- my $r = '';
-
- my @node = ($node);
- while (@node) {
- my $child = shift @node;
- unless (ref $child) {
- $r .= $child;
- next;
- }
-
- my $node_id = 'node-'.refaddr $child;
- my $nt = $child->node_type;
- if ($nt == $child->ELEMENT_NODE) {
- $r .= qq'' . htescape ($child->tag_name) .
- ''; ## ISSUE: case
-
- if ($child->has_attributes) {
- $r .= '';
- for my $attr (sort {$a->[0] cmp $b->[0]} map { [$_->name, $_->value, 'node-'.refaddr $_] }
- @{$child->attributes}) {
- $r .= qq'' . htescape ($attr->[0]) . ' = '; ## ISSUE: case?
- $r .= '' . htescape ($attr->[1]) . '
';
- }
-
- if ($node->has_child_nodes) {
- $r .= '';
- unshift @node, @{$child->child_nodes}, '
';
- }
- } elsif ($nt == $child->TEXT_NODE) {
- $r .= qq'' . htescape ($child->data) . '
<[CDATA[' . htescape ($child->data) . '
]]><!--' . htescape ($child->data) . '
-->- Document
';
- if ($child->has_child_nodes) {
- $r .= '';
- unshift @node, @{$child->child_nodes}, '
';
- }
- } elsif ($nt == $child->DOCUMENT_TYPE_NODE) {
- $r .= qq'<!DOCTYPE>';
- $r .= '- Name =
@{[htescape ($child->name)]}
';
- $r .= '- Public identifier =
@{[htescape ($child->public_id)]}
';
- $r .= '- System identifier =
@{[htescape ($child->system_id)]}
';
- $r .= '
<?@{[htescape ($child->target)]}?>';
- $r .= '- @{[htescape ($child->data)]}
- @{[$child->node_type]} @{[htescape ($child->node_name)]}
'; # error
- }
- }
+ $result->generate_result_section;
- $r .= '
';
- print STDOUT $r;
-} # print_document_tree
-
-sub get_node_path ($) {
- my $node = shift;
- my @r;
- while (defined $node) {
- my $rs;
- if ($node->node_type == 1) {
- $rs = $node->manakai_local_name;
- $node = $node->parent_node;
- } elsif ($node->node_type == 2) {
- $rs = '@' . $node->manakai_local_name;
- $node = $node->owner_element;
- } elsif ($node->node_type == 3) {
- $rs = '"' . $node->data . '"';
- $node = $node->parent_node;
- } elsif ($node->node_type == 9) {
- $rs = '';
- $node = $node->parent_node;
- } else {
- $rs = '#' . $node->node_type;
- $node = $node->parent_node;
- }
- unshift @r, $rs;
- }
- return join '/', @r;
-} # get_node_path
+ $out->input ($original_input);
+} # check_and_print
=head1 AUTHOR
@@ -312,11 +144,11 @@
=head1 LICENSE
-Copyright 2007 Wakaba
+Copyright 2007-2008 Wakaba
This library is free software; you can redistribute it
and/or modify it under the same terms as Perl itself.
=cut
-## $Date: 2007/06/27 12:35:24 $
+## $Date: 2008/09/14 14:36:12 $