--- test/html-webhacc/WebHACC/Result.pm 2008/07/20 16:53:10 1.2 +++ test/html-webhacc/WebHACC/Result.pm 2008/08/14 15:50:42 1.9 @@ -2,7 +2,11 @@ use strict; sub new ($) { - return bless {}, shift; + return bless { + global_status => 'conforming', + # or, 'should-error', 'non-conforming', 'uncertain' + subdoc_results => [], + }, shift; } # new sub output ($;$) { @@ -17,6 +21,33 @@ return $_[0]->{output}; } # output +sub parent_result ($;$) { + if (@_ > 1) { + if (defined $_[1]) { + $_[0]->{parent_result} = $_[1]; + } else { + delete $_[0]->{parent_result}; + } + } + + return $_[0]->{parent_result}; +} # parent_result + +sub layer_applicable ($$) { + my $self = shift; + my $layer = shift; + $self->{layers}->{$layer}->{applicable} = 1; +} # layer_applicable + +sub layer_uncertain ($$) { + my $self = shift; + my $layer = shift; + $self->{layers}->{$layer}->{uncertain} ||= 1; + $self->{layers}->{$layer}->{applicable} = 1; + $self->{global_status} = 'uncertain' + unless $self->{global_status} eq 'non-conforming'; +} # layer_uncertain + sub add_error ($%) { my ($self, %opt) = @_; @@ -53,15 +84,7 @@ my $class = qq[level-$error_level layer-$error_layer]; - $out->start_tag ('dt', class => $class); - - ## URL - - if (defined $opt{url}) { - $out->url ($opt{url}); - } - - ## Line & column number + ## Line & column numbers (prepare values) my $line; my $column; @@ -70,7 +93,7 @@ $line = $opt{node}->get_user_data ('manakai_source_line'); if (defined $line) { $column = $opt{node}->get_user_data ('manakai_source_column'); - } else { + } elsif ($opt{node}->isa ('Message::IF::Node')) { if ($opt{node}->node_type == $opt{node}->ATTRIBUTE_NODE) { my $owner = $opt{node}->owner_element; if ($owner) { @@ -95,15 +118,35 @@ $column = $opt{column}; } } + $line = $line - 1 || 1 + if defined $line and not (defined $column and $column > 0); + + $out->start_tag ('dt', class => $class, + 'data-type' => $opt{type}, + 'data-level' => $error_level, + 'data-layer' => $error_layer, + ($line ? ('data-line' => $line) : ()), + ($column ? ('data-column' => $column) : ())); + my $has_location; + + ## URL + + if (defined $opt{url}) { + $out->url ($opt{url}); + $has_location = 1; + } + + ## Line & column numbers (real output) if (defined $line) { if (defined $column and $column > 0) { - $out->xref ('Line ' . $line, target => 'line-' . $line); - $out->text (' column ' . $column); + $out->xref ('Line #', text => $line, target => 'line-' . $line); + $out->text (' '); + $out->nl_text ('column #', text => $column); } else { - $line = $line - 1 || 1; - $out->xref ('Line ' . $line, target => 'line-' . $line); + $out->xref ('Line #', text => $line, target => 'line-' . $line); } + $has_location = 1; } ## Node path @@ -111,231 +154,292 @@ if (defined $opt{node}) { $out->html (' '); $out->node_link ($opt{node}); + $has_location = 1; } if (defined $opt{index}) { if ($opt{index_has_link}) { $out->html (' '); - $out->xref ('Index ' . (0+$opt{index}), + $out->xref ('Index #', text => (0+$opt{index}), target => 'index-' . (0+$opt{index})); } else { - $out->text (' Index ' . (0+$opt{index})); + $out->html (' '); + $out->nl_text ('Index #', text => (0+$opt{index})); } + $has_location = 1; } if (defined $opt{value}) { $out->html (' '); $out->code ($opt{value}); + $has_location = 1; + } + + unless ($has_location) { + if (defined $opt{input}) { + if (defined $opt{input}->{container_node}) { + my $original_input = $out->input; + $out->input ($opt{input}->{parent_input}); + $out->node_link ($opt{input}->{container_node}); + $out->input ($original_input); + $has_location = 1; + } elsif (defined $opt{input}->{request_uri}) { + $out->url ($opt{input}->{request_uri}); + $has_location = 1; + } elsif (defined $opt{input}->{uri}) { + $out->url ($opt{input}->{uri}); + $has_location = 1; + } + } + + unless ($has_location) { + $out->text ('Unknown location'); + } } $out->start_tag ('dd', class => $class); - $out->text ($error_type_text); + ## Error level + $out->nl_text ('Error level ' . $error_level); + $out->text (': '); + + ## Error message + $out->nl_text ($error_type_text, node => $opt{node}, text => $opt{text}); + + ## Additional error description if (defined $opt{text}) { $out->html (' ('); $out->text ($opt{text}); $out->html (')'); } + + ## Link to a long description my $fragment = $opt{type}; $fragment =~ tr/ /-/; $fragment = $out->encode_url_component ($fragment); $out->text (' ['); - $out->link ('Description', url => '../error-description#' . $fragment); + $out->link ('Description', url => '../error-description#' . $fragment, + rel => 'help'); $out->text (']'); - -# my ($type, $cls, $msg) = main::get_text ($opt{type}, $opt{level}); -# $out->html (qq[
] . $result->get_error_label ($input, \%opt)); - - $error_layer = 'char' - if $error_layer eq 'charset' or $error_layer eq 'encode'; - if ($error_level eq 's') { - $self->{$error_layer}->{should}++; - $self->{$error_layer}->{score_min} -= 2; - $self->{conforming_min} = 0; + if ($error_level eq 'm') { + $self->{layers}->{$error_layer}->{must}++; + $self->{global_status} = 'non-conforming'; + } elsif ($error_level eq 's') { + $self->{layers}->{$error_layer}->{should}++; + $self->{global_status} = 'should-error' + unless {'non-conforming' => 1, + uncertain => 1}->{$self->{global_status}}; } elsif ($error_level eq 'w') { - $self->{$error_layer}->{warning}++; + $self->{layers}->{$error_layer}->{warning}++; } elsif ($error_level eq 'u') { - $self->{$error_layer}->{unsupported}++; - $self->{unsupported} = 1; + $self->{layers}->{$error_layer}->{uncertain}++; + $self->{global_status} = 'uncertain' + unless $self->{global_status} eq 'non-conforming'; } elsif ($error_level eq 'i') { - # - } else { - $self->{$error_layer}->{must}++; - $self->{$error_layer}->{score_max} -= 2; - $self->{$error_layer}->{score_min} -= 2; - $self->{conforming_min} = 0; - $self->{conforming_max} = 0; + $self->{layers}->{$error_layer}->{info}++; } } # add_error sub generate_result_section ($) { - my $result = shift; + my $self = shift; + + my $result = $self; my $out = $result->output; - $out->start_section (id => 'result-summary', - title => 'Result'); + $out->start_section (role => 'result'); - if ($result->{unsupported} and $result->{conforming_max}) { - $out->html (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}) { - $out->html (qq[

No conformance-error is - found in this document.

]); - } elsif ($result->{conforming_max}) { - $out->html (qq[

This document - is likely non-conforming, but in rare case - it might be conforming.

]); - } else { - $out->html (qq[

This document is - non-conforming.

]); - } + my $para_class = { + 'conforming' => 'result-para no-error', + 'should-error' => 'result-para should-errors', + 'non-conforming' => 'result-para must-errors', + 'uncertain' => 'result-para uncertain', + }->{$self->{global_status}}; + $out->start_tag ('p', class => $para_class); + $out->nl_text ('Conformance is ' . $self->{global_status}); + $out->end_tag ('p'); $out->html (qq[ -+ - - - - -]); - - ## TODO: Introduce "N/A" value (e.g. Character layer is not applicable - ## to binary formats) - - 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]; - } - - $out->html (qq[]); - if ($uncertain) { - $out->html (qq[ - - - - -
MUST-level -ErrorsSHOULD-level -ErrorsWarningsScore
$label$result->{$_->[1]}->{must}$uncertain$result->{$_->[1]}->{should}$uncertain$result->{$_->[1]}->{warning}$uncertain−∞..$result->{$_->[1]}->{score_max}]); - } elsif ($result->{$_->[1]}->{score_min} != $result->{$_->[1]}->{score_max}) { - $out->html (qq[$result->{$_->[1]}->{score_min}..$result->{$_->[1]}->{score_max}]); - } else { - $out->html (qq[$result->{$_->[1]}->{score_min}]); +
]); + for ('Error level m', 'Error level s', 'Error level w', + 'Error level i', 'Score') { + $out->start_tag ('th'); + $out->nl_text ($_); + } + + my $maindoc_status = {must => 0, should => 0, warning => 0, info => 0, + uncertain => 0, applicable => 1}; + my $subdocs_status = {must => 0, should => 0, warning => 0, info => 0, + uncertain => 0, applicable => 1}; + my $global_status = {must => 0, should => 0, warning => 0, info => 0, + uncertain => 0, applicable => 1}; + + my $score_unit = 2; + + my @row = ( + sub { + $out->start_tag ('tbody'); + $out->start_tag ('tr'); + $out->start_tag ('th', colspan => 7, scope => 'col'); + $out->nl_text ('Main document'); + }, + {label => 'Transfer', status => $self->{layers}->{transfer}, + target => 'transfer-errors', score_base => 20, + parent_status => $maindoc_status}, + {label => 'Encode', status => $self->{layers}->{encode}, + score_base => 10, + parent_status => $maindoc_status}, + {label => 'Charset', status => $self->{layers}->{charset}, + score_base => 10, + parent_status => $maindoc_status}, + {label => 'Syntax', status => $self->{layers}->{syntax}, + target => 'parse-errors', score_base => 20, + parent_status => $maindoc_status}, + {label => 'Structure', status => $self->{layers}->{structure}, + target => 'document-errors', score_base => 20, + parent_status => $maindoc_status}, + {label => 'Semantics', status => $self->{layers}->{semantics}, + score_base => 20, + parent_status => $maindoc_status}, + ); + + if (@{$self->{subdoc_results}}) { + push @row, {label => 'Subtotal', status => $maindoc_status, + score_base => 100, + parent_status => $global_status, is_total => 1}; + push @row, sub { + $out->start_tag ('tbody'); + $out->start_tag ('tr'); + $out->start_tag ('th', colspan => 7, scope => 'col'); + $out->nl_text ('Subdocuments'); + }; + for (@{$self->{subdoc_results}}) { + push @row, {label => '#' . $_->{input}->full_subdocument_index, + status => $_, + target => $_->{input}->id_prefix . 'result-summary', + score_base => 100, parent_status => $subdocs_status}; } - $out->html (qq[ / 20]); + push @row, {label => 'Subtotal', status => $subdocs_status, + score_base => 100 * @{$self->{subdoc_results}}, + parent_status => $global_status, is_total => 1}; + } else { + $global_status = $maindoc_status; } - $score_max += $score_base; - - $out->html (qq[ -
Semantics0?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; -} # generate_result_section - -sub _get_error_label ($$) { - my $self = shift; - my ($input, $err) = @_; + push @row, sub { + $out->start_tag ('tfoot'); + }; + push @row, {label => 'Total', status => $global_status, + score_base => 100 * (@{$self->{subdoc_results}} + 1), + parent_status => {}, is_total => 1}; + + for my $x (@row) { + if (ref $x eq 'CODE') { + $x->(); + next; + } + $x->{parent_status}->{$_} += $x->{status}->{$_} + for qw/must should warning info uncertain/; -} # get_error_label + my $row_class = $x->{status}->{uncertain} ? 'uncertain' : ''; + $row_class .= ' total' if $x->{is_total}; + $out->start_tag ('tr', class => $row_class); + my $uncertain = $x->{status}->{uncertain} ? '?' : ''; + + $out->start_tag ('td', class => 'subrow') unless $x->{is_total}; + + ## Layer name + $out->start_tag ('th', colspan => $x->{is_total} ? 2 : 1, + scope => 'row'); + if (defined $x->{target} and + ($x->{status}->{must} or $x->{status}->{should} or + $x->{status}->{warning} or $x->{status}->{info} or + $x->{status}->{uncertain})) { + $out->xref ($x->{label}, target => $x->{target}); + } else { + $out->nl_text ($x->{label}); + } -sub get_error_level_label ($) { - my $self = shift; - my $err = shift; + ## MUST-level errors + $out->start_tag ('td', class => $x->{status}->{must} ? 'must-errors' : ''); + if ($x->{status}->{applicable}) { + $out->text (($x->{status}->{must} or 0) . $uncertain); + } else { + $out->nl_text ('N/A'); + } - my $r = ''; + ## SHOULD-level errors + $out->start_tag ('td', + class => $x->{status}->{should} ? 'should-errors' : ''); + if ($x->{status}->{applicable}) { + $out->text (($x->{status}->{should} or 0) . $uncertain); + } else { + $out->nl_text ('N/A'); + } - if (not defined $err->{level} or $err->{level} eq 'm') { - $r = qq[MUST-level - error: ]; - } elsif ($err->{level} eq 's') { - $r = qq[SHOULD-level - error: ]; - } elsif ($err->{level} eq 'w') { - $r = qq[Warning: - ]; - } 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: - ]; - } + ## Warnings + $out->start_tag ('td', class => $x->{status}->{warning} ? 'warnings' : ''); + if ($x->{status}->{applicable}) { + $out->text (($x->{status}->{warning} or 0) . $uncertain); + } else { + $out->nl_text ('N/A'); + } - return $r; -} # get_error_level_label + ## Informations + $out->start_tag ('td', class => $x->{status}->{info} ? 'infos' : ''); + if ($x->{status}->{applicable}) { + $out->text (($x->{status}->{info} or 0) . $uncertain); + } else { + $out->nl_text ('N/A'); + } -sub get_node_path ($) { - my $self = shift; - my $node = shift; - my @r; - while (defined $node) { - my $rs; - if ($node->node_type == 1) { - $rs = $node->node_name; - $node = $node->parent_node; - } elsif ($node->node_type == 2) { - $rs = '@' . $node->node_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; + ## Score + $out->start_tag ('td', + class => $x->{status}->{must} ? 'score must-errors' : + $x->{status}->{should} ? 'score should-errors' : + 'score'); + + my $max_score = $x->{score_base}; + $max_score -= $x->{status}->{must} * $score_unit; + my $min_score = $max_score; + $min_score -= $x->{status}->{should} * $score_unit; + + $out->start_tag ('strong'); + if ($x->{status}->{uncertain}) { + $out->html ('−∞ '); # negative inifinity + $out->nl_text ('...'); + $out->html ($max_score < 0 ? + ' −' . substr ($max_score, 1) : ' ' . $max_score); + } elsif ($min_score != $max_score) { + $out->html ($min_score < 0 ? + '−' . substr ($min_score, 1) . ' ': $min_score . ' '); + $out->nl_text ('...'); + $out->html ($max_score < 0 ? + ' −' . substr ($max_score, 1) : ' ' . $max_score); } else { - $rs = '#' . $node->node_type; - $node = $node->parent_node; + $out->html ($max_score < 0 ? + '−' . substr ($max_score, 1) : $max_score); } - unshift @r, $rs; + $out->end_tag ('strong'); + + $out->text (' / ' . $x->{score_base}); } - return join '/', @r; -} # get_node_path + + $out->end_tag ('table'); -use Scalar::Util qw/refaddr/; + my $parent = $self->parent_result; + if ($parent) { + $global_status->{input} = $out->input; + push @{$parent->{subdoc_results}}, $global_status; + } -sub get_node_link ($$) { - my $self = shift; - return qq[] . - ($self->get_node_path ($_[1])) . qq[]; - ## BUG: ^ must be escaped -} # get_node_link + $out->nl_text ('This checker is work in progress.'); + $out->end_section; +} # generate_result_section 1;