];
-} # print_id_section
+} # print_listing_section
-sub print_term_section ($) {
- my $terms = shift;
-
- push @nav, ['#terms' => 'Terms'];
- print STDOUT qq[
-
];
-} # print_term_section
-
-sub print_class_section ($) {
- my $classes = shift;
+sub print_rdf_section ($$$) {
+ my ($input, $rdfs) = @_;
- push @nav, ['#classes' => 'Classes'];
+# push @nav, ['#' . $input->{id_prefix} . 'rdf' => 'RDF']
+# unless $input->{nested};
print STDOUT qq[
-
-
Classes
+
];
-} # print_class_section
-
-sub print_result_section ($) {
- my $result = shift;
-
- print STDOUT qq[
-
-
Result
];
+} # print_rdf_section
- if ($result->{unsupported}) {
- print STDOUT qq[
The conformance
- checker cannot decide whether the document is conforming or
- not, since the document contains one or more unsupported
- features.
];
- } 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;
- 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_base);
- $score_max += ($result->{$_->[1]}->{score_max} += $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} + $score_base |
|---|
];
- } else {
- print qq[$result->{$_->[1]}->{score_min} | ];
+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 '??';
}
-
- $score_max += $score_base;
-
- print STDOUT qq[
-| Semantics | 0? | 0? | 0? | −∞..$score_base |
|---|
-
-| Total | $must_error? | $should_error? | $warning? | −∞..$score_max |
|---|
-
-
-
Important: This conformance checking service
-is under development. The result above might be wrong.
-
];
- push @nav, ['#result-summary' => 'Result'];
-} # print_result_section
-
-sub print_result_unknown_type_section ($) {
- my $input = shift;
-
- print STDOUT qq[
-
-
Media type @{[htescape $input->{media_type}]} is not supported!
-
-];
- push @nav, ['#result-summary' => 'Result'];
-} # print_result_unknown_type_section
-
-sub print_result_input_error_section ($) {
- my $input = shift;
- print STDOUT qq[
-
Input Error: @{[htescape ($input->{error_status_text})]}
-
];
- push @nav, ['#result-summary' => 'Result'];
-} # print_Result_input_error_section
-
-sub get_node_path ($) {
- my $node = shift;
- my @r;
- while (defined $node) {
- my $rs;
- if ($node->node_type == 1) {
- $rs = $node->manakai_local_name;
- $node = $node->parent_node;
- } elsif ($node->node_type == 2) {
- $rs = '@' . $node->manakai_local_name;
- $node = $node->owner_element;
- } elsif ($node->node_type == 3) {
- $rs = '"' . $node->data . '"';
- $node = $node->parent_node;
- } elsif ($node->node_type == 9) {
- @r = ('') unless @r;
- $rs = '';
- $node = $node->parent_node;
- } else {
- $rs = '#' . $node->node_type;
- $node = $node->parent_node;
- }
- unshift @r, $rs;
- }
- return join '/', @r;
-} # get_node_path
-
-sub get_node_link ($) {
- return qq[
] .
- htescape (get_node_path ($_[0])) . qq[];
-} # get_node_link
+} # get_rdf_resource_html
{
my $Msg = {};
sub load_text_catalog ($) {
+# my $self = shift;
my $lang = shift; # MUST be a canonical lang name
- open my $file, '<', "cc-msg.$lang.txt" or die "$0: cc-msg.$lang.txt: $!";
+ 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, $_);
@@ -713,40 +307,43 @@
}
} # load_text_catalog
-sub get_text ($) {
+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] ? htescape ($arg[$1]) : '(undef)';
- }ge;
+ defined $arg[$1] ? ($arg[$1]) : '(undef)';
+ }ge; ##BUG: ^ must be escaped
$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) : ''
+ ? ($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')
- ? htescape ($node->manakai_local_name) : ''
- }ge;
+ ? ($node->manakai_local_name) : ''
+ }ge; ## BUG: ^ must be escaped
$msg =~ s{
{element-local-name}}{
(UNIVERSAL::can ($node, 'owner_element') and
$node->owner_element)
- ? htescape ($node->owner_element->manakai_local_name)
- : ''
+ ? ($node->owner_element->manakai_local_name)
+ : '' ## BUG: ^ must be escaped
}ge;
- return ($type, $Msg->{$type}->[0], $msg);
+ return ($type, 'level-' . $level . ' ' . $Msg->{$type}->[0], $msg);
} elsif ($type =~ s/:([^:]*)$//) {
unshift @arg, $1;
redo;
}
}
- return ($type, '', htescape ($_[0]));
+ return ($type, 'level-'.$level, ($_[0]));
+ ## BUG: ^ must be escaped
} # get_text
}
@@ -754,15 +351,18 @@
sub get_input_document ($$) {
my ($http, $dom) = @_;
- my $request_uri = $http->get_parameter ('uri');
- my $r = {};
+ 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;
@@ -789,8 +389,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;
@@ -802,6 +405,7 @@
$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')) {
@@ -811,12 +415,10 @@
## TODO: More strict parsing...
my $ct = $res->header ('Content-Type');
- if (defined $ct and $ct =~ m#^([0-9A-Za-z._+-]+/[0-9A-Za-z._+-]+)#) {
- $r->{media_type} = lc $1;
- }
- if (defined $ct and $ct =~ /;\s*charset\s*=\s*"?(\S+)"?/i) {
+ 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');
@@ -824,9 +426,22 @@
$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;
@@ -847,7 +462,18 @@
$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');
@@ -864,6 +490,7 @@
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;
}
@@ -875,6 +502,8 @@
return $r;
}
+ $r->{inner_html_element} = $http->get_parameter ('e');
+
return $r;
} # get_input_document
@@ -907,11 +536,11 @@
=head1 LICENSE
-Copyright 2007 Wakaba
+Copyright 2007-2008 Wakaba
This library is free software; you can redistribute it
and/or modify it under the same terms as Perl itself.
=cut
-## $Date: 2007/09/10 12:09:34 $
+## $Date: 2008/07/21 05:24:32 $