(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']}
-
+ my $result = WebHACC::Result->new;
+ $result->output ($out);
+ $result->{conforming_min} = 1;
+ $result->{conforming_max} = 1;
-
-]);
- $out->end_section;
+ $out->html ('');
- 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);
- }
+ check_and_print ($input => $result => $out);
+
+ $result->generate_result_section;
$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}) {
+ $result->{conforming_min} = 0;
+ return;
+ }
my $checker_class = {
'text/cache-manifest' => 'WebHACC::Language::CacheManifest',
@@ -191,6 +109,7 @@
$checker->generate_syntax_error_section;
$checker->generate_source_string_section;
+ my @subdoc;
$checker->onsubdoc (sub {
push @subdoc, shift;
});
@@ -199,326 +118,22 @@
$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} .= '-';
+ $subinput->start_section ($result);
check_and_print ($subinput => $result => $out);
-
- $out->end_section;
+ $subinput->end_section ($result);
}
$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 = {};
@@ -581,15 +196,18 @@
sub get_input_document ($$) {
my ($http, $dom) = @_;
- my $request_uri = $http->get_parameter ('uri');
+ require Encode;
+ my $request_uri = Encode::decode ('utf-8', $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'};
+ $r = WebHACC::Input::Error->new;
+ $r->{uri} = $request_uri;
+ $r->{request_uri} = $request_uri;
+ $r->{error_status_text} = 'URL scheme not allowed';
}
require Message::Util::HostPermit;
@@ -616,8 +234,11 @@
Allow host=*
EOH
unless ($host_permit->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'};
+ my $r = WebHACC::Input::Error->new;
+ $r->{uri} = $request_uri;
+ $r->{request_uri} = $request_uri;
+ $r->{error_status_text} = 'Connection to the host is forbidden';
+ return $r;
}
require LWP::UserAgent;
@@ -767,4 +388,4 @@
=cut
-## $Date: 2008/07/20 14:58:24 $
+## $Date: 2008/07/21 09:15:55 $