--- test/html-webhacc/cc.cgi 2007/06/27 14:36:45 1.4
+++ test/html-webhacc/cc.cgi 2007/09/11 08:25:23 1.21
@@ -2,12 +2,10 @@
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
+use Time::HiRes qw/time/;
sub htescape ($) {
my $s = $_[0];
@@ -15,24 +13,28 @@
$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
@@ -43,98 +45,228 @@
-Web Document Conformance Checker (beta)
+
+];
+ $| = 0;
+ my $input = get_input_document ($http, $dom);
+ my $inner_html_element = $http->get_parameter ('e');
+ 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'];
- 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);
+if (defined $input->{s}) {
+ $char_length = length $input->{s};
- print STDOUT qq[
+ print STDOUT qq[
+
Base URI
+
<@{[htescape $input->{base_uri}]}>
+
Internet Media Type
+
@{[htescape $input->{media_type}]}
+ @{[$input->{media_type_overridden} ? '(overridden)' : '']}
Character Encoding
-
(none)
+
@{[defined $input->{charset} ? ''.htescape ($input->{charset}).'' : '(none)']}
+ @{[$input->{charset_overridden} ? '(overridden)' : '']}
+
Length
+
$char_length byte@{[$char_length == 1 ? '' : 's']}
+];
-
-
Document Source
+ my $result = {conforming_min => 1, conforming_max => 1};
+ print_http_header_section ($input, $result);
+
+ my $doc;
+ my $el;
+
+ if ($input->{media_type} eq 'text/html') {
+ ($doc, $el) = print_syntax_error_html_section ($input, $result);
+ print_source_string_section (\($input->{s}), $input->{charset});
+ } 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);
+ } else {
+ ## TODO: Change HTTP status code??
+ print_result_unknown_type_section ($input);
+ }
+
+ if (defined $doc or defined $el) {
+ print_structure_dump_section ($doc, $el);
+ my $elements = print_structure_error_section ($doc, $el, $result);
+ print_table_section ($elements->{table}) if @{$elements->{table}};
+ print_id_section ($elements->{id}) if keys %{$elements->{id}};
+ print_term_section ($elements->{term}) if keys %{$elements->{term}};
+ print_class_section ($elements->{class}) if keys %{$elements->{class}};
+ }
+
+ print_result_section ($result);
+} else {
+ print STDOUT qq[];
+ print_result_input_error_section ($input);
+}
+
+ print STDOUT qq[
+
];
- push @nav, ['#source-string' => 'Source'];
- print_source_string (\$s);
- print STDOUT qq[
-
+ for (@nav) {
+ print STDOUT qq[- $_->[1]
];
+ }
+ print STDOUT qq[
+
+
+