(sniffed; official type is: ');
- $out->text ($input->{official_type});
- $out->html (')');
- }
- } else {
- $out->html ('(sniffed)');
- }
- $out->html (q[Character Encoding]);
- if (defined $input->{charset}) {
- $out->html ('');
- $out->text ($input->{charset});
- $out->html ('');
- } else {
- $out->text ('(none)');
- }
- $out->html (' overridden') if $input->{charset_overridden};
- $out->html (qq[
-Length
- $char_length byte@{[$char_length == 1 ? '' : 's']}
-
-
-
-]);
- $out->end_section;
-
- my $result = WebHACC::Result->new;
- $result->{conforming_min} = 1;
- $result->{conforming_max} = 1;
- check_and_print ($input => $result => $out);
- print_result_section ($result);
- } else {
- $out->html ('');
- $out->end_section;
- print_result_input_error_section ($input);
+ my $u = $http->get_parameter ('uri');
+ my $s = $http->get_parameter ('s');
+ if ((not defined $u or not length $u) and
+ (not defined $s or not length $s)) {
+ exit;
}
+ 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 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, $out) = @_;
my $original_input = $out->input;
$out->input ($input);
- print_http_header_section ($input, $result);
+ $input->generate_info_section ($result);
- my @subdoc;
+ $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',
@@ -191,6 +107,7 @@
$checker->generate_syntax_error_section;
$checker->generate_source_string_section;
+ my @subdoc;
$checker->onsubdoc (sub {
push @subdoc, shift;
});
@@ -199,561 +116,28 @@
$checker->generate_structure_error_section;
$checker->generate_additional_sections;
-=pod
-
- if (defined $doc or defined $el) {
-
- 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}};
-
- print_rdf_section ($input, $elements->{rdf}) if @{$elements->{rdf}};
- }
-
-=cut
-
my $id_prefix = 0;
for my $_subinput (@subdoc) {
- my $subinput = WebHACC::Input->new;
+ my $subinput = WebHACC::Input::Subdocument->new (++$id_prefix);
$subinput->{$_} = $_subinput->{$_} for keys %$_subinput;
- $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});
- $out->start_section (id => $subinput->id_prefix,
- title => qq[Subdocument #$id_prefix]);
- print STDOUT qq[
-
- - Internet Media Type
- @{[htescape $subinput->{media_type}]}
- - Container Node
- - @{[get_node_link ($input, $subinput->{container_node})]}
- - Base URI
- <$ebaseuri>
];
+ $subinput->{parent_input} = $input;
- $subinput->{id_prefix} .= '-';
- check_and_print ($subinput => $result => $out);
+ my $subresult = WebHACC::Result->new;
+ $subresult->output ($out);
+ $subresult->parent_result ($result);
- $out->end_section;
+ $subinput->start_section ($subresult);
+ check_and_print ($subinput => $subresult => $out);
+ $subinput->end_section ($subresult);
}
+ $result->generate_result_section;
+
$out->input ($original_input);
} # check_and_print
-sub print_http_header_section ($$) {
- my ($input, $result) = @_;
- return unless defined $input->{header_status_code} or
- defined $input->{header_status_text} or
- @{$input->{header_field} or []};
-
- $out->start_section (id => 'source-header', title => 'HTTP Header');
- print STDOUT qq[Note: Due to the limitation of the
-network library in use, the content of this section might
-not be the real header.
-
-
-];
-
- if (defined $input->{header_status_code}) {
- print STDOUT qq[| Status code | ];
- print STDOUT qq[];
- $out->code ($input->{header_status_code});
- }
- if (defined $input->{header_status_text}) {
- print STDOUT qq[ |
|---|
| Status text | ];
- print STDOUT qq[];
- $out->code ($input->{header_status_text});
- }
-
- for (@{$input->{header_field}}) {
- print STDOUT qq[ |
|---|
| ];
- $out->code ($_->[0]);
- print STDOUT qq[ | ];
- $out->code ($_->[1]);
- }
-
- print STDOUT qq[ |
|---|
];
-
- $out->end_section;
-} # print_http_header_section
-
-sub print_table_section ($$) {
- my ($input, $tables) = @_;
-
-# push @nav, [qq[#$input->{id_prefix}tables] => 'Tables']
-# unless $input->{nested};
- print STDOUT qq[
-];
-} # print_table_section
-
-sub print_listing_section ($$$) {
- my ($opt, $input, $ids) = @_;
-
-# push @nav, ['#' . $input->{id_prefix} . $opt->{id} => $opt->{label}]
-# unless $input->{nested};
- print STDOUT qq[
-];
-} # print_listing_section
-
-
-sub print_rdf_section ($$$) {
- my ($input, $rdfs) = @_;
-
-# push @nav, ['#' . $input->{id_prefix} . 'rdf' => 'RDF']
-# unless $input->{nested};
- print STDOUT qq[
-];
-} # print_rdf_section
-
-sub get_rdf_resource_html ($) {
- my $resource = shift;
- if (defined $resource->{uri}) {
- my $euri = htescape ($resource->{uri});
- return '<' . $euri .
- '>';
- } elsif (defined $resource->{bnodeid}) {
- return htescape ('_:' . $resource->{bnodeid});
- } elsif ($resource->{nodes}) {
- return '(rdf:XMLLiteral)';
- } elsif (defined $resource->{value}) {
- my $elang = htescape (defined $resource->{language}
- ? $resource->{language} : '');
- my $r = qq[] . htescape ($resource->{value}) . '
';
- if (defined $resource->{datatype}) {
- my $euri = htescape ($resource->{datatype});
- $r .= '^^<' . $euri .
- '>';
- } elsif (length $resource->{language}) {
- $r .= '@' . htescape ($resource->{language});
- }
- return $r;
- } else {
- return '??';
- }
-} # get_rdf_resource_html
-
-sub print_result_section ($) {
- my $result = shift;
-
- $out->start_section (id => 'result-summary',
- title => 'Result');
-
- if ($result->{unsupported} and $result->{conforming_max}) {
- print STDOUT qq[The conformance
- checker cannot decide whether the document is conforming or
- not, since the document contains one or more unsupported
- features. The document might or might not be conforming.
];
- } elsif ($result->{conforming_min}) {
- print STDOUT qq[No conformance-error is
- found in this document.
];
- } elsif ($result->{conforming_max}) {
- print STDOUT qq[This document
- is likely non-conforming, but in rare case
- it might be conforming.
];
- } else {
- print STDOUT qq[This document is
- non-conforming.
];
- }
-
- print STDOUT qq[
-
-
- |
-MUST‐level
-Errors |
-SHOULD‐level
-Errors |
-Warnings |
-Score |
|---|
];
-
- my $must_error = 0;
- my $should_error = 0;
- my $warning = 0;
- my $score_min = 0;
- my $score_max = 0;
- my $score_base = 20;
- my $score_unit = $score_base / 100;
- for (
- [Transfer => 'transfer', ''],
- [Character => 'char', ''],
- [Syntax => 'syntax', '#parse-errors'],
- [Structure => 'structure', '#document-errors'],
- ) {
- $must_error += ($result->{$_->[1]}->{must} += 0);
- $should_error += ($result->{$_->[1]}->{should} += 0);
- $warning += ($result->{$_->[1]}->{warning} += 0);
- $score_min += (($result->{$_->[1]}->{score_min} *= $score_unit) += $score_base);
- $score_max += (($result->{$_->[1]}->{score_max} *= $score_unit) += $score_base);
-
- my $uncertain = $result->{$_->[1]}->{unsupported} ? '?' : '';
- my $label = $_->[0];
- if ($result->{$_->[1]}->{must} or
- $result->{$_->[1]}->{should} or
- $result->{$_->[1]}->{warning} or
- $result->{$_->[1]}->{unsupported}) {
- $label = qq[$label];
- }
-
- print STDOUT qq[| $label | $result->{$_->[1]}->{must}$uncertain | $result->{$_->[1]}->{should}$uncertain | $result->{$_->[1]}->{warning}$uncertain | ];
- if ($uncertain) {
- print qq[−∞..$result->{$_->[1]}->{score_max}];
- } elsif ($result->{$_->[1]}->{score_min} != $result->{$_->[1]}->{score_max}) {
- print qq[ | $result->{$_->[1]}->{score_min}..$result->{$_->[1]}->{score_max}];
- } else {
- print qq[ | $result->{$_->[1]}->{score_min}];
- }
- print qq[ / 20];
- }
-
- $score_max += $score_base;
-
- print STDOUT qq[
- |
|---|
| Semantics | 0? | 0? | 0? | −∞..$score_base / 20
- |
|---|
-| Total |
-$must_error? |
-$should_error? |
-$warning? |
-−∞..$score_max / 100
- |
|---|
-
-Important: This conformance checking service
-is under development. The result above might be wrong.
];
- $out->end_section;
-} # print_result_section
-
-sub print_result_input_error_section ($) {
- my $input = shift;
- $out->start_section (id => 'result-summary', title => 'Result');
- print STDOUT qq[
-Input Error: @{[htescape ($input->{error_status_text})]}
];
- $out->end_section;
-} # print_result_input_error_section
-
-{
- my $Msg = {};
-
-sub load_text_catalog ($) {
-# my $self = shift;
- my $lang = shift; # MUST be a canonical lang name
- open my $file, '<:utf8', "cc-msg.$lang.txt"
- or die "$0: cc-msg.$lang.txt: $!";
- while (<$file>) {
- if (s/^([^;]+);([^;]*);//) {
- my ($type, $cls, $msg) = ($1, $2, $_);
- $msg =~ tr/\x0D\x0A//d;
- $Msg->{$type} = [$cls, $msg];
- }
- }
-} # load_text_catalog
-
-sub get_text ($;$$) {
-# my $self = shift;
- my ($type, $level, $node) = @_;
- $type = $level . ':' . $type if defined $level;
- $level = 'm' unless defined $level;
- my @arg;
- {
- if (defined $Msg->{$type}) {
- my $msg = $Msg->{$type}->[1];
- $msg =~ s{\$([0-9]+)}{
- defined $arg[$1] ? ($arg[$1]) : '(undef)';
- }ge; ##BUG: ^ must be escaped
- $msg =~ s{{\@([A-Za-z0-9:_.-]+)}}{
- UNIVERSAL::can ($node, 'get_attribute_ns')
- ? ($node->get_attribute_ns (undef, $1)) : ''
- }ge; ## BUG: ^ must be escaped
- $msg =~ s{{\@}}{ ## BUG: v must be escaped
- UNIVERSAL::can ($node, 'value') ? ($node->value) : ''
- }ge;
- $msg =~ s{{local-name}}{
- UNIVERSAL::can ($node, 'manakai_local_name')
- ? ($node->manakai_local_name) : ''
- }ge; ## BUG: ^ must be escaped
- $msg =~ s{{element-local-name}}{
- (UNIVERSAL::can ($node, 'owner_element') and
- $node->owner_element)
- ? ($node->owner_element->manakai_local_name)
- : '' ## BUG: ^ must be escaped
- }ge;
- return ($type, 'level-' . $level . ' ' . $Msg->{$type}->[0], $msg);
- } elsif ($type =~ s/:([^:]*)$//) {
- unshift @arg, $1;
- redo;
- }
- }
- return ($type, 'level-'.$level, ($_[0]));
- ## BUG: ^ must be escaped
-} # get_text
-
-}
-
-sub get_input_document ($$) {
- my ($http, $dom) = @_;
-
- my $request_uri = $http->get_parameter ('uri');
- my $r = WebHACC::Input->new;
- 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);
- $req->header ('Accept-Encoding' => 'identity, *; q=0');
- my $res = $ua->request ($req);
- ## TODO: 401 sets |is_success| true.
- if ($res->is_success or $http->get_parameter ('error-page')) {
- $r->{base_uri} = $res->base; ## NOTE: It does check |Content-Base|, |Content-Location|, and . ## TODO: Use our own code!
- $r->{uri} = $res->request->uri;
- $r->{request_uri} = $request_uri;
-
- ## TODO: More strict parsing...
- my $ct = $res->header ('Content-Type');
- if (defined $ct and $ct =~ /;\s*charset\s*=\s*"?([^\s;"]+)"?/i) {
- $r->{charset} = lc $1;
- $r->{charset} =~ tr/\\//d;
- $r->{official_charset} = $r->{charset};
- }
-
- my $input_charset = $http->get_parameter ('charset');
- if (defined $input_charset and length $input_charset) {
- $r->{charset_overridden}
- = (not defined $r->{charset} or $r->{charset} ne $input_charset);
- $r->{charset} = $input_charset;
- }
-
- ## TODO: Support for HTTP Content-Encoding
-
- $r->{s} = ''.$res->content;
-
- require Whatpm::ContentType;
- ($r->{official_type}, $r->{media_type})
- = Whatpm::ContentType->get_sniffed_type
- (get_file_head => sub {
- return substr $r->{s}, 0, shift;
- },
- http_content_type_byte => $ct,
- has_http_content_encoding =>
- defined $res->header ('Content-Encoding'),
- supported_image_types => {});
- } else {
- $r->{uri} = $res->request->uri;
- $r->{request_uri} = $request_uri;
- $r->{error_status_text} = $res->status_line;
- }
-
- $r->{header_field} = [];
- $res->scan (sub {
- push @{$r->{header_field}}, [$_[0], $_[1]];
- });
- $r->{header_status_code} = $res->code;
- $r->{header_status_text} = $res->message;
- } else {
- $r->{s} = ''.$http->get_parameter ('s');
- $r->{uri} = q;
- $r->{request_uri} = q;
- $r->{base_uri} = q;
- $r->{charset} = ''.$http->get_parameter ('_charset_');
- $r->{charset} =~ s/\s+//g;
- $r->{charset} = 'utf-8' if $r->{charset} eq '';
- $r->{official_charset} = $r->{charset};
- $r->{header_field} = [];
-
- require Whatpm::ContentType;
- ($r->{official_type}, $r->{media_type})
- = Whatpm::ContentType->get_sniffed_type
- (get_file_head => sub {
- return substr $r->{s}, 0, shift;
- },
- http_content_type_byte => undef,
- has_http_content_encoding => 0,
- supported_image_types => {});
- }
-
- my $input_format = $http->get_parameter ('i');
- if (defined $input_format and length $input_format) {
- $r->{media_type_overridden}
- = (not defined $r->{media_type} or $input_format ne $r->{media_type});
- $r->{media_type} = $input_format;
- }
- if (defined $r->{s} and not defined $r->{media_type}) {
- $r->{media_type} = 'text/html';
- $r->{media_type_overridden} = 1;
- }
-
- if ($r->{media_type} eq 'text/xml') {
- unless (defined $r->{charset}) {
- $r->{charset} = 'us-ascii';
- $r->{official_charset} = $r->{charset};
- } elsif ($r->{charset_overridden} and $r->{charset} eq 'us-ascii') {
- $r->{charset_overridden} = 0;
- }
- }
-
- if (length $r->{s} > 1000_000) {
- $r->{error_status_text} = 'Entity-body too large';
- delete $r->{s};
- return $r;
- }
-
- $r->{inner_html_element} = $http->get_parameter ('e');
-
- return $r;
-} # get_input_document
-
-package WDCC::LWPUA;
-BEGIN { push our @ISA, 'LWP::UserAgent'; }
-
-sub redirect_ok {
- my $ua = shift;
- unless ($ua->SUPER::redirect_ok (@_)) {
- return 0;
- }
-
- my $uris = $_[1]->header ('Location');
- return 0 unless $uris;
- my $uri = $ua->{wdcc_dom}->create_uri_reference ($uris);
- unless ({
- http => 1,
- }->{lc $uri->uri_scheme}) {
- return 0;
- }
- unless ($ua->{wdcc_host_permit}->check ($uri->uri_host, $uri->uri_port || 80)) {
- return 0;
- }
- return 1;
-} # redirect_ok
-
=head1 AUTHOR
Wakaba .
@@ -767,4 +151,4 @@
=cut
-## $Date: 2008/07/20 14:58:24 $
+## $Date: 2008/09/15 14:34:58 $