--- test/html-webhacc/cc.cgi 2007/07/01 06:21:46 1.7
+++ test/html-webhacc/cc.cgi 2007/07/21 04:58:17 1.15
@@ -15,7 +15,9 @@
$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
@@ -23,16 +25,17 @@
## 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";
+ if ($http->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;
@@ -45,58 +48,71 @@
Web Document Conformance Checker (beta )
+
+];
+
+ $| = 0;
+ my $input = get_input_document ($http, $dom);
+ my $inner_html_element = $http->parameter ('e');
+ 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;
+if (defined $input->{s}) {
+
+ print STDOUT qq[
+
Base URI
+
<@{[htescape $input->{base_uri}]} >
+
Internet Media Type
+
@{[htescape $input->{media_type}]}
+ @{[$input->{media_type_overridden} ? '(overridden) ' : '']}
+
Character Encoding
+
@{[defined $input->{charset} ? ''.htescape ($input->{charset}).'' : '(none)']}
+ @{[$input->{charset_overridden} ? '(overridden) ' : '']}
+
+
+];
+
+ print_http_header_section ($input);
+
my $doc;
my $el;
- if ($input_format eq 'text/html') {
+ if ($input->{media_type} eq 'text/html') {
require Encode;
require Whatpm::HTML;
-
- $s = Encode::decode ('utf-8', $s);
- print STDOUT qq[
-Character Encoding
- (none)
-
-
+ $input->{charset} ||= 'ISO-8859-1'; ## TODO: for now.
+
+ my $t = Encode::decode ($input->{charset}, $input->{s});
-
-
Document Source
-];
- push @nav, ['#source-string' => 'Source'];
- print_source_string (\$s);
print STDOUT qq[
-
-
Parse Errors
-
-];
+];
push @nav, ['#parse-errors' => 'Parse Error'];
my $onerror = sub {
my (%opt) = @_;
- my ($cls, $msg) = get_text ($opt{type}, $opt{level});
+ my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level});
if ($opt{column} > 0) {
print STDOUT qq[Line $opt{line} column $opt{column}Line $opt{line} Description ]];
print STDOUT qq[$msg \n];
};
@@ -104,35 +120,24 @@
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);
+ Whatpm::HTML->set_inner_html ($el, $t, $onerror);
} else {
- Whatpm::HTML->parse_string ($s => $doc, $onerror);
+ Whatpm::HTML->parse_string ($t => $doc, $onerror);
}
- print STDOUT qq[
-
+ 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_section (\($input->{s}), $input->{charset});
+ } elsif ({
+ 'text/xml' => 1,
+ 'application/xhtml+xml' => 1,
+ 'application/xml' => 1,
+ }->{$input->{media_type}}) {
+ require Message::DOM::XMLParserTemp;
-
-
Document Source
-];
- push @nav, ['#source-string' => 'Source'];
- print_source_string (\$t);
print STDOUT qq[
-
-
Parse Errors
@@ -148,20 +153,20 @@
return 1;
};
- open my $fh, '<', \$s;
+ open my $fh, '<', \($input->{s});
$doc = Message::DOM::XMLParserTemp->parse_byte_stream
- ($fh => $dom, $onerror, charset => 'utf-8');
+ ($fh => $dom, $onerror, charset => $input->{charset});
print STDOUT qq[
+
];
+ print_source_string_section (\($input->{s}), $doc->input_encoding);
} else {
+ ## TODO: Change HTTP status code??
print STDOUT qq[
-
-
-
-
Media type @{[htescape $input_format]} is not supported!
+
Media type @{[htescape $input->{media_type}]} is not supported!
Description ]];
print STDOUT qq[] . get_node_link ($opt{node}) .
qq[ \n], $msg, " \n";
};
@@ -208,6 +216,7 @@
if (@{$elements->{table}}) {
require JSON;
+ push @nav, ['#tables' => 'Tables'];
print STDOUT qq[
Tables
@@ -224,7 +233,9 @@
$i++;
print STDOUT qq[
] .
get_node_link ($table_el) . q[ ];
-
+
+ ## TODO: Make |ContentChecker| return |form_table| result
+ ## so that this script don't have to run the algorithm twice.
my $table = Whatpm::HTMLTable->form_table ($table_el);
for (@{$table->{column_group}}, @{$table->{column}}, $table->{caption}) {
@@ -246,6 +257,7 @@
for (@$_) {
$_->{id} = refaddr $_->{element} if defined $_->{element};
delete $_->{element};
+ $_->{is_header} = $_->{is_header} ? 1 : 0;
}
}
}
@@ -258,7 +270,25 @@
print STDOUT qq[];
}
+ if (keys %{$elements->{id}}) {
+ push @nav, ['#identifiers' => 'IDs'];
+ print STDOUT qq[
+
+
Identifiers
+
+
+];
+ for my $id (sort {$a cmp $b} keys %{$elements->{id}}) {
+ print STDOUT qq[@{[htescape $id]}].get_node_link ($_).qq[ ];
+ }
+ }
+ print STDOUT qq[ ];
+ }
+
if (keys %{$elements->{term}}) {
+ push @nav, ['#terms' => 'Terms'];
print STDOUT qq[
Terms
@@ -273,9 +303,38 @@
}
print STDOUT qq[];
}
+
+ if (keys %{$elements->{class}}) {
+ push @nav, ['#classes' => 'Classes'];
+ print STDOUT qq[
+
+
Classes
+
+
+];
+ for my $class (sort {$a cmp $b} keys %{$elements->{class}}) {
+ print STDOUT qq[@{[htescape $class]}].get_node_link ($_).qq[ ];
+ }
+ }
+ print STDOUT qq[ ];
+ }
}
## TODO: Show result
+} else {
+ print STDOUT qq[
+
+
+
+
+
Input Error : @{[htescape ($input->{error_status_text})]}
+
@@ -291,10 +350,51 @@
exit;
-sub print_source_string ($) {
- my $s = $_[0];
- my $i = 1;
- print STDOUT qq[\n];
+sub print_http_header_section ($) {
+ my $input = shift;
+ return unless defined $input->{header_status_code} or
+ defined $input->{header_status_text} or
+ @{$input->{header_field}};
+
+ push @nav, ['#source-header' => 'HTTP Header'];
+ print STDOUT qq[];
+} # print_http_header_section
+
+sub print_source_string_section ($$) {
+ require Encode;
+ my $enc = Encode::find_encoding ($_[1]); ## TODO: charset name -> Perl name
+ return unless $enc;
+
+ my $s = \($enc->decode (${$_[0]}));
+ my $i = 1;
+ push @nav, ['#source-string' => 'Source'];
+ print STDOUT qq[
+
Document Source
+
\n];
if (length $$s) {
while ($$s =~ /\G([^\x0A]*?)\x0D?\x0A/gc) {
print STDOUT qq[], htescape $1, " \n";
@@ -306,8 +406,8 @@
} else {
print STDOUT q[ ";
-} # print_input_string
+ print STDOUT "
];
$r .= qq[@{[scalar get_text ('manakaiIsHTML:'.($child->manakai_is_html?1:0))]} ];
$r .= qq[@{[scalar get_text ('manakaiCompatMode:'.$child->manakai_compat_mode)]} ];
+ unless ($child->manakai_is_html) {
+ $r .= qq[XML version = @{[htescape ($child->xml_version)]} ];
+ if (defined $child->xml_encoding) {
+ $r .= qq[XML encoding = @{[htescape ($child->xml_encoding)]} ];
+ } else {
+ $r .= qq[XML encoding = (null) ];
+ }
+ $r .= qq[XML standalone = @{[$child->xml_standalone ? 'true' : 'false']} ];
+ }
$r .= qq[ ];
if ($child->has_child_nodes) {
$r .= '';
@@ -392,6 +501,7 @@
$rs = '"' . $node->data . '"';
$node = $node->parent_node;
} elsif ($node->node_type == 9) {
+ @r = ('') unless @r;
$rs = '';
$node = $node->parent_node;
} else {
@@ -424,24 +534,182 @@
} # load_text_catalog
sub get_text ($) {
- my ($type, $level) = @_;
+ my ($type, $level, $node) = @_;
$type = $level . ':' . $type if defined $level;
my @arg;
{
if (defined $Msg->{$type}) {
my $msg = $Msg->{$type}->[1];
- $msg =~ s/\$([0-9]+)/defined $arg[$1] ? htescape ($arg[$1]) : '(undef)'/ge;
- return ($Msg->{$type}->[0], $msg);
+ $msg =~ s{\$([0-9]+) }{
+ defined $arg[$1] ? htescape ($arg[$1]) : '(undef)';
+ }ge;
+ $msg =~ s{{\@([A-Za-z0-9:_.-]+)} }{
+ UNIVERSAL::can ($node, 'get_attribute_ns')
+ ? htescape ($node->get_attribute_ns (undef, $1)) : ''
+ }ge;
+ $msg =~ s{{\@} }{
+ UNIVERSAL::can ($node, 'value') ? htescape ($node->value) : ''
+ }ge;
+ return ($type, $Msg->{$type}->[0], $msg);
} elsif ($type =~ s/:([^:]*)$//) {
unshift @arg, $1;
redo;
}
}
- return ('', htescape ($_[0]));
+ return ($type, '', htescape ($_[0]));
} # get_text
}
+sub get_input_document ($$) {
+ my ($http, $dom) = @_;
+
+ my $request_uri = $http->parameter ('uri');
+ my $r = {};
+ if (defined $request_uri and length $request_uri) {
+ my $uri = $dom->create_uri_reference ($request_uri);
+ unless ({
+ http => 1,
+ }->{lc $uri->uri_scheme}) {
+ return {uri => $request_uri, request_uri => $request_uri,
+ error_status_text => 'URI scheme not allowed'};
+ }
+
+ require Message::Util::HostPermit;
+ my $host_permit = new Message::Util::HostPermit;
+ $host_permit->add_rule (<check ($uri->uri_host, $uri->uri_port || 80)) {
+ return {uri => $request_uri, request_uri => $request_uri,
+ error_status_text => 'Connection to the host is forbidden'};
+ }
+
+ require LWP::UserAgent;
+ my $ua = WDCC::LWPUA->new;
+ $ua->{wdcc_dom} = $dom;
+ $ua->{wdcc_host_permit} = $host_permit;
+ $ua->agent ('Mozilla'); ## TODO: for now.
+ $ua->parse_head (0);
+ $ua->protocols_allowed ([qw/http/]);
+ $ua->max_size (1000_000);
+ my $req = HTTP::Request->new (GET => $request_uri);
+ my $res = $ua->request ($req);
+ if ($res->is_success or $http->parameter ('error-page')) {
+ $r->{base_uri} = $res->base; ## NOTE: It does check |Content-Base|, |Content-Location|, and .
@@ -455,4 +723,4 @@
=cut
-## $Date: 2007/07/01 06:21:46 $
+## $Date: 2007/07/21 04:58:17 $