--- test/html-webhacc/cc.cgi 2007/06/27 11:08:03 1.1
+++ test/html-webhacc/cc.cgi 2007/06/27 12:35:24 1.2
@@ -5,197 +5,280 @@
/home/wakaba/work/manakai/lib
/home/wakaba/public_html/-temp/wiki/lib];
use CGI::Carp qw[fatalsToBrowser];
-use Time::HiRes qw/time/;
+use Scalar::Util qw[refaddr];
use SuikaWiki::Input::HTTP; ## TODO: Use some better CGI module
+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 @mode = split m#/#, scalar $http->meta_variable ('PATH_INFO'), -1;
-shift @mode if @mode and $mode[0] == '';
-## TODO: decode unreserved characters
+ 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;
}
- my $char_length = length $s;
- my %time;
- my $time1;
- my $time2;
+
+ 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;
-# $| = 1;
my $doc;
my $el;
-if (@mode == 3 and $mode[0] eq 'html' and
- ($mode[2] eq 'html' or $mode[2] eq 'test')) {
- print STDOUT "Content-Type: text/plain; charset=utf-8\n\n";
-
- require Encode;
- require Whatpm::HTML;
-
- $time1 = time;
- $s = Encode::decode ('utf-8', $s);
- $time2 = time;
- $time{decode} = $time2 - $time1;
-
+ 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[
+
- print STDOUT "#errors\n";
+
+
Parse Errors
+
+
+];
my $onerror = sub {
my (%opt) = @_;
- print STDOUT "$opt{line},$opt{column},$opt{type}\n";
+ 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;
- $time1 = time;
- if (length $mode[1]) {
+ if (defined $inner_html_element and length $inner_html_element) {
$el = $doc->create_element_ns
- ('http://www.w3.org/1999/xhtml', [undef, $mode[1]]);
+ ('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);
}
- $time2 = time;
- $time{parse} = $time2 - $time1;
- print "#document\n";
+ print STDOUT qq[
+
+
+];
+ print_source_string (\$t);
+ print STDOUT qq[
+
- my $out;
- if ($mode[2] eq 'html') {
- $time1 = time;
- $out = Whatpm::HTML->get_inner_html ($el || $doc);
- $time2 = time;
- $time{serialize_html} = $time2 - $time1;
- } else { # test
- $time1 = time;
- $out = test_serialize ($el || $doc);
- $time2 = time;
- $time{serialize_test} = $time2 - $time1;
- }
- print STDOUT Encode::encode ('utf-8', $$out);
- print STDOUT "\n";
-} elsif (@mode == 3 and $mode[0] eq 'xhtml' and
- ($mode[2] eq 'html' or $mode[2] eq 'test')) {
- print STDOUT "Content-Type: text/plain; charset=utf-8\n\n";
+
+
Parse Errors
- require Message::DOM::XMLParserTemp;
- print STDOUT "#errors\n";
+
+];
my $onerror = sub {
my $err = shift;
- print STDOUT $err->location->line_number, ",";
- print STDOUT $err->location->column_number, ",";
- print STDOUT $err->text, "\n";
+ 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;
- my $time1 = time;
$doc = Message::DOM::XMLParserTemp->parse_byte_stream
($fh => $dom, $onerror, charset => 'utf-8');
- my $time2 = time;
- $time{parse_xml} = $time2 - $time1;
- print "#document\n";
+ print STDOUT qq[
+
+
Media type @{[htescape $input_format]} is not supported!
+];
+ }
+
+
+ if (defined $doc or defined $el) {
+ print STDOUT qq[
+
+
Document Tree
+];
+
+ print_document_tree ($el || $doc);
+
+ print STDOUT qq[
+
- my $out;
- if ($mode[2] eq 'html') {
- ## TODO: Use XHTML serializer
- #$out = Whatpm::HTML->get_inner_html ($doc);
- } else { # test
- $time1 = time;
- $out = test_serialize ($doc);
- $time2 = time;
- $time{serialize_test} = $time2 - $time1;
- }
- print STDOUT Encode::encode ('utf-8', $$out);
- print STDOUT "\n";
-} else {
- print STDOUT "Status: 404 Not Found\nContent-Type: text/plain; charset=us-ascii\n\n404";
- exit;
-}
+
+
Document Errors
+
+
+];
- if ($http->parameter ('dom5')) {
require Whatpm::ContentChecker;
my $onerror = sub {
my %opt = @_;
- print STDOUT get_node_path ($opt{node}) . ';' . $opt{type} . "\n";
+ print STDOUT qq[- ],
+ htescape get_node_path ($opt{node}),
+ ": ", htescape $opt{type}, "
\n";
};
- print STDOUT "#domerrors\n";
- $time1 = time;
+
if ($el) {
Whatpm::ContentChecker->check_element ($el, $onerror);
} else {
Whatpm::ContentChecker->check_document ($doc, $onerror);
}
- $time2 = time;
- $time{check} = $time2 - $time1;
- }
- print STDOUT "#log\n";
- for (qw/decode parse parse_xml serialize_html serialize_xml serialize_test
- check/) {
- next unless defined $time{$_};
- print STDOUT {
- decode => 'bytes->chars',
- parse => 'html5(chars)->dom5',
- parse_xml => 'xml1(chars)->dom5',
- serialize_html => 'dom5->html5(char)',
- serialize_xml => 'dom5->xml1(char)',
- serialize_test => 'dom5->test(char)',
- check => 'dom5 check',
- }->{$_};
- print STDOUT "\t", $time{$_}, "s\n";
- open my $file, '>>', ".manakai-$_.txt" or die ".manakai-$_.txt: $!";
- print $file $char_length, "\t", $time{$_}, "\n";
+ print STDOUT qq[
+
+
\n];
+ while ($$s =~ /\G([^\x0A]*?)\x0D?\x0A/gc) {
+ print STDOUT qq[- ], htescape $1, "
\n";
+ $i++;
+ }
+ 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 $r = '';
- my @node = map { [$_, ''] } @{$node->child_nodes};
+ my @node = ($node);
while (@node) {
my $child = shift @node;
- my $nt = $child->[0]->node_type;
- if ($nt == $child->[0]->ELEMENT_NODE) {
- $r .= '| ' . $child->[1] . '<' . $child->[0]->tag_name . ">\x0A"; ## ISSUE: case?
-
- for my $attr (sort {$a->[0] cmp $b->[0]} map { [$_->name, $_->value] }
- @{$child->[0]->attributes}) {
- $r .= '| ' . $child->[1] . ' ' . $attr->[0] . '="'; ## ISSUE: case?
- $r .= $attr->[1] . '"' . "\x0A";
+ 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}, '
';
}
-
- unshift @node,
- map { [$_, $child->[1] . ' '] } @{$child->[0]->child_nodes};
- } elsif ($nt == $child->[0]->TEXT_NODE) {
- $r .= '| ' . $child->[1] . '"' . $child->[0]->data . '"' . "\x0A";
- } elsif ($nt == $child->[0]->CDATA_SECTION_NODE) {
- $r .= '| ' . $child->[1] . '[0]->data . "]]>\x0A";
- } elsif ($nt == $child->[0]->COMMENT_NODE) {
- $r .= '| ' . $child->[1] . '\x0A";
- } elsif ($nt == $child->[0]->DOCUMENT_TYPE_NODE) {
- $r .= '| ' . $child->[1] . '[0]->name . ">\x0A";
- } elsif ($nt == $child->[0]->PROCESSING_INSTRUCTION_NODE) {
- $r .= '| ' . $child->[1] . '[0]->target . ' ' .
- $child->[0]->data . "?>\x0A";
+ } 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
}
}
-
- return \$r;
-} # test_serialize
+
+ $r .= '
';
+ print STDOUT $r;
+} # print_document_tree
sub get_node_path ($) {
my $node = shift;
@@ -236,4 +319,4 @@
=cut
-## $Date: 2007/06/27 11:08:03 $
+## $Date: 2007/06/27 12:35:24 $