--- test/html-webhacc/cc.cgi 2008/07/20 14:58:24 1.53
+++ test/html-webhacc/cc.cgi 2008/07/20 16:53:10 1.54
@@ -106,14 +106,22 @@
$out->end_section;
my $result = WebHACC::Result->new;
+ $result->output ($out);
$result->{conforming_min} = 1;
$result->{conforming_max} = 1;
check_and_print ($input => $result => $out);
- print_result_section ($result);
+ $result->generate_result_section;
} else {
$out->html ('');
$out->end_section;
- print_result_input_error_section ($input);
+
+ my $result = WebHACC::Result->new;
+ $result->output ($out);
+ $result->{conforming_min} = 0;
+ $result->{conforming_max} = 1;
+
+ $input->generate_transfer_sections ($result);
+ $result->generate_result_section;
}
$out->nav_list;
@@ -121,42 +129,12 @@
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_transfer_sections ($result);
my @subdoc;
@@ -249,43 +227,6 @@
$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) = @_;
@@ -422,104 +363,6 @@
}
} # 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 +424,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 +462,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 +616,4 @@
=cut
-## $Date: 2008/07/20 14:58:24 $
+## $Date: 2008/07/20 16:53:10 $