--- test/html-webhacc/cc.cgi 2008/02/10 07:35:23 1.36 +++ test/html-webhacc/cc.cgi 2008/07/18 14:44:16 1.52 @@ -86,6 +86,8 @@
$char_length byte@{[$char_length == 1 ? '' : 's']}
+ + ]; $input->{id_prefix} = ''; @@ -132,6 +134,8 @@ } 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; @@ -157,6 +161,7 @@ my $el; my $cssom; my $manifest; + my $idl; my @subdoc; if ($input->{media_type} eq 'text/html') { @@ -169,9 +174,13 @@ 'text/xml' => 1, 'application/atom+xml' => 1, 'application/rss+xml' => 1, - 'application/svg+xml' => 1, + 'image/svg+xml' => 1, 'application/xhtml+xml' => 1, 'application/xml' => 1, + ## TODO: Should we make all XML MIME Types fall + ## into this category? + + 'application/rdf+xml' => 1, ## NOTE: This type has different model. }->{$input->{media_type}}) { ($doc, $el) = print_syntax_error_xml_section ($input, $result); print_source_string_section ($input, @@ -187,6 +196,10 @@ $manifest = print_syntax_error_manifest_section ($input, $result); print_source_string_section ($input, \($input->{s}), 'utf-8'); + } elsif ($input->{media_type} eq 'text/x-webidl') { ## TODO: type + $idl = print_syntax_error_webidl_section ($input, $result); + print_source_string_section ($input, \($input->{s}), + 'utf-8'); ## TODO: charset } else { ## TODO: Change HTTP status code?? print_result_unknown_type_section ($input, $result); @@ -210,6 +223,8 @@ print_listing_section ({ id => 'classes', label => 'Classes', heading => 'Classes', }, $input, $elements->{class}) if keys %{$elements->{class}}; + print_uri_section ($input, $elements->{uri}) if keys %{$elements->{uri}}; + print_rdf_section ($input, $elements->{rdf}) if @{$elements->{rdf}}; } elsif (defined $cssom) { print_structure_dump_cssom_section ($input, $cssom); ## TODO: CSSOM validation @@ -217,6 +232,9 @@ } elsif (defined $manifest) { print_structure_dump_manifest_section ($input, $manifest); print_structure_error_manifest_section ($input, $manifest, $result); + } elsif (defined $idl) { + print_structure_dump_webidl_section ($input, $idl); + print_structure_error_webidl_section ($input, $idl, $result); } my $id_prefix = 0; @@ -290,18 +308,14 @@

Parse Errors

-
]; +
]; push @nav, ['#parse-errors' => 'Parse Error'] unless $input->{nested}; my $onerror = sub { my (%opt) = @_; my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level}); - if ($opt{column} > 0) { - print STDOUT qq[
Line $opt{line} column $opt{column}
\n]; - } else { - $opt{line} = $opt{line} - 1 || 1; - print STDOUT qq[
Line $opt{line}
\n]; - } + print STDOUT qq[
], get_error_label ($input, \%opt), + qq[
]; $type =~ tr/ /-/; $type =~ s/\|/%7C/g; $msg .= qq[ [Description]]; @@ -317,18 +331,25 @@ if (defined $inner_html_element and length $inner_html_element) { $input->{charset} ||= 'windows-1252'; ## TODO: for now. my $time1 = time; - my $t = Encode::decode ($input->{charset}, $input->{s}); + my $t = \($input->{s}); + unless ($input->{is_char_string}) { + $t = \(Encode::decode ($input->{charset}, $$t)); + } $time{decode} = time - $time1; $el = $doc->create_element_ns ('http://www.w3.org/1999/xhtml', [undef, $inner_html_element]); $time1 = time; - Whatpm::HTML->set_inner_html ($el, $t, $onerror); + Whatpm::HTML->set_inner_html ($el, $$t, $onerror); $time{parse} = time - $time1; } else { my $time1 = time; - Whatpm::HTML->parse_byte_string - ($input->{charset}, $input->{s} => $doc, $onerror); + if ($input->{is_char_string}) { + Whatpm::HTML->parse_char_string ($input->{s} => $doc, $onerror); + } else { + Whatpm::HTML->parse_byte_string + ($input->{charset}, $input->{s} => $doc, $onerror); + } $time{parse_html} = time - $time1; } $doc->manakai_charset ($input->{official_charset}) @@ -348,7 +369,7 @@

Parse Errors

-
]; +
]; push @nav, ['#parse-errors' => 'Parse Error'] unless $input->{prefix}; my $onerror = sub { @@ -368,8 +389,15 @@ return 1; }; + my $t = \($input->{s}); + if ($input->{is_char_string}) { + require Encode; + $t = \(Encode::encode ('utf8', $$t)); + $input->{charset} = 'utf-8'; + } + my $time1 = time; - open my $fh, '<', \($input->{s}); + open my $fh, '<', $t; my $doc = Message::DOM::XMLParserTemp->parse_byte_stream ($fh => $dom, $onerror, charset => $input->{charset}); $time{parse_xml} = time - $time1; @@ -388,12 +416,8 @@ require Whatpm::CSS::Parser; my $p = Whatpm::CSS::Parser->new; -# if ($parse_mode eq 'q') { -# $p->{unitless_px} = 1; -# $p->{hashless_color} = 1; -# } - $p->{prop}->{$_} = 1 for qw/ + alignment-baseline background background-attachment background-color background-image background-position background-position-x background-position-y background-repeat border border-bottom border-bottom-color @@ -405,7 +429,7 @@ border-style border-top border-top-color border-top-style border-top-width border-width bottom caption-side clear clip color content counter-increment counter-reset - cursor direction display empty-cells float font + cursor direction display dominant-baseline empty-cells float font font-family font-size font-size-adjust font-stretch font-style font-variant font-weight height left letter-spacing line-height @@ -417,9 +441,9 @@ padding padding-bottom padding-left padding-right padding-top page page-break-after page-break-before page-break-inside position quotes right size table-layout - text-align text-decoration text-indent text-transform + text-align text-anchor text-decoration text-indent text-transform top unicode-bidi vertical-align visibility white-space width widows - word-spacing z-index + word-spacing writing-mode z-index /; $p->{prop_value}->{display}->{$_} = 1 for qw/ block clip inline inline-block inline-table list-item none @@ -496,6 +520,21 @@ $p->{prop_value}->{'white-space'}->{$_} = 1 for qw/ normal pre nowrap pre-line pre-wrap -moz-pre-wrap /; + $p->{prop_value}->{'writing-mode'}->{$_} = 1 for qw/ + lr rl tb lr-tb rl-tb tb-rl + /; + $p->{prop_value}->{'text-anchor'}->{$_} = 1 for qw/ + start middle end + /; + $p->{prop_value}->{'dominant-baseline'}->{$_} = 1 for qw/ + auto use-script no-change reset-size ideographic alphabetic + hanging mathematical central middle text-after-edge text-before-edge + /; + $p->{prop_value}->{'alignment-baseline'}->{$_} = 1 for qw/ + auto baseline before-edge text-before-edge middle central + after-edge text-after-edge ideographic alphabetic hanging + mathematical + /; $p->{prop_value}->{'text-decoration'}->{$_} = 1 for qw/ none blink underline overline line-through /; @@ -548,10 +587,11 @@

Parse Errors

-
]; +
]; push @nav, ['#parse-errors' => 'Parse Error'] unless $input->{nested}; my $p = get_css_parser (); + $p->init; $p->{onerror} = sub { my (%opt) = @_; my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level}); @@ -576,6 +616,13 @@ $p->{href} = $input->{uri}; $p->{base_uri} = $input->{base_uri}; +# if ($parse_mode eq 'q') { +# $p->{unitless_px} = 1; +# $p->{hashless_color} = 1; +# } + +## TODO: Make $input->{s} a ref. + my $s = \$input->{s}; my $charset; unless ($input->{is_char_string}) { @@ -606,7 +653,7 @@

Parse Errors

-
]; +
]; push @nav, ['#parse-errors' => 'Parse Error'] unless $input->{nested}; my $onerror = sub { @@ -623,8 +670,9 @@ add_error ('syntax', \%opt => $result); }; + my $m = $input->{is_char_string} ? 'parse_char_string' : 'parse_byte_string'; my $time1 = time; - my $manifest = Whatpm::CacheManifest->parse_byte_string + my $manifest = Whatpm::CacheManifest->$m ($input->{s}, $input->{uri}, $input->{base_uri}, $onerror); $time{parse_manifest} = time - $time1; @@ -633,15 +681,68 @@ return $manifest; } # print_syntax_error_manifest_section +sub print_syntax_error_webidl_section ($$) { + my ($input, $result) = @_; + + require Whatpm::WebIDL; + + print STDOUT qq[ +
+

Parse Errors

+ +
]; + push @nav, ['#parse-errors' => 'Parse Error'] unless $input->{nested}; + + my $onerror = sub { + my (%opt) = @_; + my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level}); + print STDOUT qq[
], get_error_label ($input, \%opt), + qq[
]; + $type =~ tr/ /-/; + $type =~ s/\|/%7C/g; + $msg .= qq[ [Description]]; + print STDOUT qq[
], get_error_level_label (\%opt); + print STDOUT qq[$msg
\n]; + + add_error ('syntax', \%opt => $result); + }; + + require Encode; + my $s = $input->{is_char_string} ? $input->{s} : Encode::decode ($input->{charset} || 'utf-8', $input->{s}); ## TODO: charset + my $parser = Whatpm::WebIDL::Parser->new; + my $idl = $parser->parse_char_string ($input->{s}, $onerror); + + print STDOUT qq[
]; + + return $idl; +} # print_syntax_error_webidl_section + sub print_source_string_section ($$$) { my $input = shift; my $s; unless ($input->{is_char_string}) { - require Encode; - my $enc = Encode::find_encoding ($_[1]); ## TODO: charset name -> Perl name - return unless $enc; + open my $byte_stream, '<', $_[0]; + require Message::Charset::Info; + my $charset = Message::Charset::Info->get_by_iana_name ($_[1]); + my ($char_stream, $e_status) = $charset->get_decode_handle + ($byte_stream, allow_error_reporting => 1, allow_fallback => 1); + return unless $char_stream; + + $char_stream->onerror (sub { + my (undef, $type, %opt) = @_; + if ($opt{octets}) { + ${$opt{octets}} = "\x{FFFD}"; + } + }); - $s = \($enc->decode (${$_[0]})); + my $t = ''; + while (1) { + my $c = $char_stream->getc; + last unless defined $c; + $t .= $c; + } + $s = \$t; + ## TODO: Output for each line, don't concat all of lines. } else { $s = $_[0]; } @@ -652,19 +753,22 @@

Document Source

    \n]; if (length $$s) { - while ($$s =~ /\G([^\x0A]*?)\x0D?\x0A/gc) { + while ($$s =~ /\G([^\x0D\x0A]*?)(?>\x0D\x0A?|\x0A)/gc) { print STDOUT qq[
  1. ], htescape $1, "
    2. \n"; $i++; } - if ($$s =~ /\G([^\x0A]+)/gc) { + if ($$s =~ /\G([^\x0D\x0A]+)/gc) { print STDOUT qq[
  2. ], htescape $1, "
    3. \n"; } } else { print STDOUT q[
  3. ]; } - print STDOUT "
"; + print STDOUT "
+"; } # print_input_string_section sub print_document_tree ($$) { @@ -802,9 +906,10 @@ unless $input->{nested}; print STDOUT qq[
Explicit entries
]; + my $i = 0; for my $uri (@{$manifest->[0]}) { my $euri = htescape ($uri); - print STDOUT qq[
<$euri>
]; + print STDOUT qq[
<$euri>
]; } print STDOUT qq[
Fallback entries
@@ -813,26 +918,43 @@ for my $uri (sort {$a cmp $b} keys %{$manifest->[1]}) { my $euri = htescape ($uri); my $euri2 = htescape ($manifest->[1]->{$uri}); - print STDOUT qq[<$euri> - <$euri2>]; + print STDOUT qq[<$euri> + <$euri2>]; } print STDOUT qq[
Online whitelist
]; for my $uri (@{$manifest->[2]}) { my $euri = htescape ($uri); - print STDOUT qq[
<$euri>
]; + print STDOUT qq[
<$euri>
]; } print STDOUT qq[
]; } # print_structure_dump_manifest_section +sub print_structure_dump_webidl_section ($$) { + my ($input, $idl) = @_; + + print STDOUT qq[ +
+

WebIDL

+]; + push @nav, [qq[#$input->{id_prefix}dump-webidl] => 'WebIDL'] + unless $input->{nested}; + + print STDOUT "
";
+  print STDOUT htescape ($idl->idl_text);
+  print STDOUT "
"; + + print STDOUT qq[
]; +} # print_structure_dump_webidl_section + sub print_structure_error_dom_section ($$$$$) { my ($input, $doc, $el, $result, $onsubdoc) = @_; print STDOUT qq[

Document Errors

-
]; +
]; push @nav, [qq[#$input->{id_prefix}document-errors] => 'Document Error'] unless $input->{nested}; @@ -860,7 +982,10 @@ } $time{check} = time - $time1; - print STDOUT qq[
]; + print STDOUT qq[
+
]; return $elements; } # print_structure_error_dom_section @@ -890,6 +1015,21 @@ print STDOUT qq[]; } # print_structure_error_manifest_section +sub print_structure_error_webidl_section ($$$) { + my ($input, $idl, $result) = @_; + + print STDOUT qq[
+

Document Errors

+ +
]; + push @nav, [qq[#$input->{id_prefix}document-errors] => 'Document Error'] + unless $input->{nested}; + +## TODO: + + print STDOUT qq[
]; +} # print_structure_error_webidl_section + sub print_table_section ($$) { my ($input, $tables) = @_; @@ -909,16 +1049,15 @@ require JSON; my $i = 0; - for my $table_el (@$tables) { + for my $table (@$tables) { $i++; print STDOUT qq[

] . - get_node_link ($input, $table_el) . q[

]; + get_node_link ($input, $table->{element}) . 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}) { + delete $table->{element}; + + for (@{$table->{column_group}}, @{$table->{column}}, $table->{caption}, + @{$table->{row}}) { next unless $_; delete $_->{element}; } @@ -971,6 +1110,106 @@ print STDOUT qq[
]; } # print_listing_section +sub print_uri_section ($$$) { + my ($input, $uris) = @_; + + ## NOTE: URIs contained in the DOM (i.e. in HTML or XML documents), + ## except for those in RDF triples. + ## TODO: URIs in CSS + + push @nav, ['#' . $input->{id_prefix} . 'uris' => 'URIs'] + unless $input->{nested}; + print STDOUT qq[ +
+

URIs

+ +
]; + for my $uri (sort {$a cmp $b} keys %$uris) { + my $euri = htescape ($uri); + print STDOUT qq[
<$euri>]; + my $eccuri = htescape (get_cc_uri ($uri)); + print STDOUT qq[
Check conformance of this document]; + print STDOUT qq[
Found at:
    ]; + for my $entry (@{$uris->{$uri}}) { + print STDOUT qq[
  • ], get_node_link ($input, $entry->{node}); + if (keys %{$entry->{type} or {}}) { + print STDOUT ' ('; + print STDOUT join ', ', map { + { + hyperlink => 'Hyperlink', + resource => 'Link to an external resource', + namespace => 'Namespace URI', + cite => 'Citation or link to a long description', + embedded => 'Link to an embedded content', + base => 'Base URI', + action => 'Submission URI', + }->{$_} + or + htescape ($_) + } keys %{$entry->{type}}; + print STDOUT ')'; + } + } + print STDOUT qq[
]; + } + print STDOUT qq[
]; +} # print_uri_section + +sub print_rdf_section ($$$) { + my ($input, $rdfs) = @_; + + push @nav, ['#' . $input->{id_prefix} . 'rdf' => 'RDF'] + unless $input->{nested}; + print STDOUT qq[ +
+

RDF Triples

+ +
]; + my $i = 0; + for my $rdf (@$rdfs) { + print STDOUT qq[
]; + print STDOUT get_node_link ($input, $rdf->[0]); + print STDOUT qq[
]; + for my $triple (@{$rdf->[1]}) { + print STDOUT '
' . get_node_link ($input, $triple->[0]) . '
'; + print STDOUT get_rdf_resource_html ($triple->[1]); + print STDOUT ' '; + print STDOUT get_rdf_resource_html ($triple->[2]); + print STDOUT ' '; + print STDOUT get_rdf_resource_html ($triple->[3]); + } + print STDOUT qq[
]; + } + 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; @@ -1036,24 +1275,25 @@ print STDOUT qq[$label$result->{$_->[1]}->{must}$uncertain$result->{$_->[1]}->{should}$uncertain$result->{$_->[1]}->{warning}$uncertain]; if ($uncertain) { - print qq[−∞..$result->{$_->[1]}->{score_max}]; + 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}]; + print qq[$result->{$_->[1]}->{score_min}..$result->{$_->[1]}->{score_max}]; } else { - print qq[$result->{$_->[1]}->{score_min}]; + print qq[$result->{$_->[1]}->{score_min}]; } + print qq[ / 20]; } $score_max += $score_base; print STDOUT qq[ -Semantics0?0?0?−∞..$score_base +Semantics0?0?0?−∞..$score_base / 20 Total $must_error? $should_error? $warning? -−∞..$score_max +−∞..$score_max / 100

Important: This conformance checking service @@ -1100,23 +1340,58 @@ my $r = ''; - if (defined $err->{line}) { - if ($err->{column} > 0) { - $r = qq[Line $err->{line} column $err->{column}]; + my $line; + my $column; + + if (defined $err->{node}) { + $line = $err->{node}->get_user_data ('manakai_source_line'); + if (defined $line) { + $column = $err->{node}->get_user_data ('manakai_source_column'); + } else { + if ($err->{node}->node_type == $err->{node}->ATTRIBUTE_NODE) { + my $owner = $err->{node}->owner_element; + $line = $owner->get_user_data ('manakai_source_line'); + $column = $owner->get_user_data ('manakai_source_column'); + } else { + my $parent = $err->{node}->parent_node; + if ($parent) { + $line = $parent->get_user_data ('manakai_source_line'); + $column = $parent->get_user_data ('manakai_source_column'); + } + } + } + } + unless (defined $line) { + if (defined $err->{token} and defined $err->{token}->{line}) { + $line = $err->{token}->{line}; + $column = $err->{token}->{column}; + } elsif (defined $err->{line}) { + $line = $err->{line}; + $column = $err->{column}; + } + } + + if (defined $line) { + if (defined $column and $column > 0) { + $r = qq[Line $line column $column]; } else { - $err->{line} = $err->{line} - 1 || 1; - $r = qq[Line $err->{line}]; + $line = $line - 1 || 1; + $r = qq[Line $line]; } } if (defined $err->{node}) { $r .= ' ' if length $r; - $r = get_node_link ($input, $err->{node}); + $r .= get_node_link ($input, $err->{node}); } if (defined $err->{index}) { - $r .= ' ' if length $r; - $r .= 'Index ' . (0+$err->{index}); + if (length $r) { + $r .= ', Index ' . (0+$err->{index}); + } else { + $r .= "Index " + . (0+$err->{index}) . ''; + } } if (defined $err->{value}) { @@ -1144,6 +1419,8 @@ } elsif ($err->{level} eq 'u' or $err->{level} eq 'unsupported') { $r = qq[Not supported: ]; + } elsif ($err->{level} eq 'i') { + $r = qq[Information: ]; } else { my $elevel = htescape ($err->{level}); $r = qq[$elevel: @@ -1159,10 +1436,10 @@ while (defined $node) { my $rs; if ($node->node_type == 1) { - $rs = $node->manakai_local_name; + $rs = $node->node_name; $node = $node->parent_node; } elsif ($node->node_type == 2) { - $rs = '@' . $node->manakai_local_name; + $rs = '@' . $node->node_name; $node = $node->owner_element; } elsif ($node->node_type == 3) { $rs = '"' . $node->data . '"'; @@ -1240,6 +1517,17 @@ } +sub encode_uri_component ($) { + require Encode; + my $s = Encode::encode ('utf8', shift); + $s =~ s/([^0-9A-Za-z_.~-])/sprintf '%%%02X', ord $1/ge; + return $s; +} # encode_uri_component + +sub get_cc_uri ($) { + return './?uri=' . encode_uri_component ($_[0]); +} # get_cc_uri + sub get_input_document ($$) { my ($http, $dom) = @_; @@ -1429,4 +1717,4 @@ =cut -## $Date: 2008/02/10 07:35:23 $ +## $Date: 2008/07/18 14:44:16 $