html-webhacc/WebHACC/Result.pm

package WebHACC::Result;
use strict;

sub new ($) {
  return bless {}, shift;
} # new

sub output ($;$) {
  if (@_ > 1) {
    if (defined $_[1]) {
      $_[0]->{output} = $_[1];
    } else {
      delete $_[0]->{output};
    }
  }

  return $_[0]->{output};
} # output

sub add_error ($%) {
  my ($self, %opt) = @_;

  my $out = $self->output;

  my $error_level = $opt{level};
  if (not defined $error_level) {
    $error_level = 'm'; ## NOTE: Unknown - an error of the implementation
  } elsif ({
    m => 1, s => 1, w => 1, i => 1, u => 1,
  }->{$error_level}) {
    #
  } else {
    $error_level = 'm'; ## NOTE: Unknown - an error of the implementation
  }

  my $error_layer = $opt{layer};
  if (not defined $error_layer) {
    $error_layer = 'syntax'; ## NOTE: Unknown - an error of the implementation
  } elsif ({
    transfer => 1,
    encode => 1,
    charset => 1,
    syntax => 1,
    structure => 1,
    semantics => 1,
  }->{$error_layer}) {
    #
  } else {
    $error_layer = 'syntax'; ## NOTE: Unknown - an error of the implementation
  }

  my $error_type_text = $opt{type};

  my $class = qq[level-$error_level layer-$error_layer];
 
  $out->start_tag ('dt', class => $class);
  my $has_location;

  ## URL
  
  if (defined $opt{url}) {
    $out->url ($opt{url});
    $has_location = 1;
  }

  ## Line & column number

  my $line;
  my $column;
    
  if (defined $opt{node}) {
    $line = $opt{node}->get_user_data ('manakai_source_line');
    if (defined $line) {
      $column = $opt{node}->get_user_data ('manakai_source_column');
    } else {
      if ($opt{node}->node_type == $opt{node}->ATTRIBUTE_NODE) {
        my $owner = $opt{node}->owner_element;
        if ($owner) {
          $line = $owner->get_user_data ('manakai_source_line');
          $column = $owner->get_user_data ('manakai_source_column');
        }
      } else {
        my $parent = $opt{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 $opt{token} and defined $opt{token}->{line}) {
      $line = $opt{token}->{line};
      $column = $opt{token}->{column};
    } elsif (defined $opt{line}) {
      $line = $opt{line};
      $column = $opt{column};
    }
  }
 
  if (defined $line) {
    if (defined $column and $column > 0) {
      $out->xref ('Line ' . $line, target => 'line-' . $line);
      $out->text (' column ' . $column);
    } else {
      $line = $line - 1 || 1;
      $out->xref ('Line ' . $line, target => 'line-' . $line);
    }
    $has_location = 1;
  }

  ## Node path

  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}),
                  target => 'index-' . (0+$opt{index}));
    } else {
      $out->text (' Index ' . (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);

  ## Error level
  
  if ($error_level eq 'm') {
    $out->html (qq[<strong><a href="../error-description#level-m"><em class=rfc2119>MUST</em>-level
        error</a></strong>: ]);
  } elsif ($error_level eq 's') {
    $out->html (qq[<strong><a href="../error-description#level-s"><em class=rfc2119>SHOULD</em>-level
        error</a></strong>: ]);
  } elsif ($error_level eq 'w') {
    $out->html (qq[<strong><a href="../error-description#level-w">Warning</a></strong>: ]);
  } elsif ($error_level eq 'u') {
    $out->html (qq[<strong><a href="../error-description#level-u">Not
        supported</a></strong>: ]);
  } elsif ($error_level eq 'i') {
    $out->html (qq[<strong><a href="../error-description#level-i">Information</a></strong>: ]);
  }

  ## Error message

  $out->text ($error_type_text);

  ## Additional error description

  if (defined $opt{text}) {
    $out->html (' (<q>');
    $out->text ($opt{text});
    $out->html ('</q>)');
  }
  
  ## 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,
              rel => 'help');
  $out->text (']');


#    my ($type, $cls, $msg) = main::get_text ($opt{type}, $opt{level});
#    $out->html (qq[<dt class="$cls">] . $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;
  } elsif ($error_level eq 'w') {
    $self->{$error_layer}->{warning}++;
  } elsif ($error_level eq 'u') {
    $self->{$error_layer}->{unsupported}++;
    $self->{unsupported} = 1;
  } 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;
  }
} # add_error

sub generate_result_section ($) {
  my $result = shift;

  my $out = $result->output;

  $out->start_section (id => 'result-summary',
                       title => 'Result');

  if ($result->{unsupported} and $result->{conforming_max}) {  
    $out->html (qq[<p class=uncertain id=result-para>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.</p>]);
  } elsif ($result->{conforming_min}) {
    $out->html (qq[<p class=PASS id=result-para>No conformance-error is
        found in this document.</p>]);
  } elsif ($result->{conforming_max}) {
    $out->html (qq[<p class=SEE-RESULT id=result-para>This document
        is <strong>likely <em>non</em>-conforming</strong>, but in rare case
        it might be conforming.</p>]);
  } else {
    $out->html (qq[<p class=FAIL id=result-para>This document is 
        <strong><em>non</em>-conforming</strong>.</p>]);
  }

  $out->html (qq[<table>
<colgroup><col><colgroup><col><col><col><colgroup><col>
<thead>
<tr><th scope=col></th>
<th scope=col><a href="../error-description#level-m"><em class=rfc2119>MUST</em>-level
Errors</a></th>
<th scope=col><a href="../error-description#level-s"><em class=rfc2119>SHOULD</em>-level
Errors</a></th>
<th scope=col><a href="../error-description#level-w">Warnings</a></th>
<th scope=col>Score</th></tr></thead><tbody>]);

  ## 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[<a href="$_->[2]">$label</a>];
    }

    $out->html (qq[<tr class="@{[$uncertain ? 'uncertain' : '']}"><th scope=row>$label</th><td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : '']}">$result->{$_->[1]}->{must}$uncertain</td><td class="@{[$result->{$_->[1]}->{should} ? 'SEE-RESULT' : '']}">$result->{$_->[1]}->{should}$uncertain</td><td>$result->{$_->[1]}->{warning}$uncertain</td>]);
    if ($uncertain) {
      $out->html (qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : $result->{$_->[1]}->{should} ? 'SEE-RESULT' : '']}">&#x2212;&#x221E;..$result->{$_->[1]}->{score_max}]);
    } elsif ($result->{$_->[1]}->{score_min} != $result->{$_->[1]}->{score_max}) {
      $out->html (qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : 'SEE-RESULT']}">$result->{$_->[1]}->{score_min}..$result->{$_->[1]}->{score_max}]);
    } else {
      $out->html (qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : '']}">$result->{$_->[1]}->{score_min}]);
    }
    $out->html (qq[ / 20]);
  }

  $score_max += $score_base;

  $out->html (qq[
<tr class=uncertain><th scope=row>Semantics</th><td>0?</td><td>0?</td><td>0?</td><td>&#x2212;&#x221E;..$score_base / 20
</tbody>
<tfoot><tr class=uncertain><th scope=row>Total</th>
<td class="@{[$must_error ? 'FAIL' : '']}">$must_error?</td>
<td class="@{[$should_error ? 'SEE-RESULT' : '']}">$should_error?</td>
<td>$warning?</td>
<td class="@{[$must_error ? 'FAIL' : $should_error ? 'SEE-RESULT' : '']}"><strong>&#x2212;&#x221E;..$score_max</strong> / 100
</table>

<p><strong>Important</strong>: This conformance checking service
is <em>under development</em>.  The result above might be <em>wrong</em>.</p>]);
  $out->end_section;
} # generate_result_section

1;
1	wakaba	1.1	package WebHACC::Result;
2			use strict;
3
4			sub new ($) {
5			return bless {}, shift;
6			} # new
7
8	wakaba	1.2	sub output ($;$) {
9			if (@_ > 1) {
10			if (defined $_[1]) {
11			$_[0]->{output} = $_[1];
12			} else {
13			delete $_[0]->{output};
14			}
15			}
16
17			return $_[0]->{output};
18			} # output
19
20			sub add_error ($%) {
21			my ($self, %opt) = @_;
22
23			my $out = $self->output;
24
25			my $error_level = $opt{level};
26			if (not defined $error_level) {
27			$error_level = 'm'; ## NOTE: Unknown - an error of the implementation
28			} elsif ({
29			m => 1, s => 1, w => 1, i => 1, u => 1,
30			}->{$error_level}) {
31			#
32			} else {
33			$error_level = 'm'; ## NOTE: Unknown - an error of the implementation
34			}
35
36			my $error_layer = $opt{layer};
37			if (not defined $error_layer) {
38			$error_layer = 'syntax'; ## NOTE: Unknown - an error of the implementation
39			} elsif ({
40			transfer => 1,
41			encode => 1,
42			charset => 1,
43			syntax => 1,
44			structure => 1,
45			semantics => 1,
46			}->{$error_layer}) {
47			#
48			} else {
49			$error_layer = 'syntax'; ## NOTE: Unknown - an error of the implementation
50			}
51
52			my $error_type_text = $opt{type};
53
54			my $class = qq[level-$error_level layer-$error_layer];
55
56			$out->start_tag ('dt', class => $class);
57	wakaba	1.3	my $has_location;
58	wakaba	1.1
59	wakaba	1.2	## URL
60
61			if (defined $opt{url}) {
62			$out->url ($opt{url});
63	wakaba	1.3	$has_location = 1;
64	wakaba	1.2	}
65	wakaba	1.1
66	wakaba	1.2	## Line & column number
67	wakaba	1.1
68			my $line;
69			my $column;
70
71	wakaba	1.2	if (defined $opt{node}) {
72			$line = $opt{node}->get_user_data ('manakai_source_line');
73	wakaba	1.1	if (defined $line) {
74	wakaba	1.2	$column = $opt{node}->get_user_data ('manakai_source_column');
75	wakaba	1.1	} else {
76	wakaba	1.2	if ($opt{node}->node_type == $opt{node}->ATTRIBUTE_NODE) {
77			my $owner = $opt{node}->owner_element;
78			if ($owner) {
79			$line = $owner->get_user_data ('manakai_source_line');
80			$column = $owner->get_user_data ('manakai_source_column');
81			}
82	wakaba	1.1	} else {
83	wakaba	1.2	my $parent = $opt{node}->parent_node;
84	wakaba	1.1	if ($parent) {
85			$line = $parent->get_user_data ('manakai_source_line');
86			$column = $parent->get_user_data ('manakai_source_column');
87			}
88			}
89			}
90			}
91			unless (defined $line) {
92	wakaba	1.2	if (defined $opt{token} and defined $opt{token}->{line}) {
93			$line = $opt{token}->{line};
94			$column = $opt{token}->{column};
95			} elsif (defined $opt{line}) {
96			$line = $opt{line};
97			$column = $opt{column};
98	wakaba	1.1	}
99			}
100
101			if (defined $line) {
102			if (defined $column and $column > 0) {
103	wakaba	1.2	$out->xref ('Line ' . $line, target => 'line-' . $line);
104			$out->text (' column ' . $column);
105	wakaba	1.1	} else {
106			$line = $line - 1 \|\| 1;
107	wakaba	1.2	$out->xref ('Line ' . $line, target => 'line-' . $line);
108	wakaba	1.1	}
109	wakaba	1.3	$has_location = 1;
110	wakaba	1.1	}
111
112	wakaba	1.2	## Node path
113
114			if (defined $opt{node}) {
115			$out->html (' ');
116			$out->node_link ($opt{node});
117	wakaba	1.3	$has_location = 1;
118	wakaba	1.1	}
119
120	wakaba	1.2	if (defined $opt{index}) {
121			if ($opt{index_has_link}) {
122			$out->html (' ');
123			$out->xref ('Index ' . (0+$opt{index}),
124			target => 'index-' . (0+$opt{index}));
125	wakaba	1.1	} else {
126	wakaba	1.2	$out->text (' Index ' . (0+$opt{index}));
127	wakaba	1.1	}
128	wakaba	1.3	$has_location = 1;
129	wakaba	1.1	}
130
131	wakaba	1.2	if (defined $opt{value}) {
132			$out->html (' ');
133			$out->code ($opt{value});
134	wakaba	1.3	$has_location = 1;
135			}
136
137			unless ($has_location) {
138			if (defined $opt{input}) {
139			if (defined $opt{input}->{container_node}) {
140			my $original_input = $out->input;
141			$out->input ($opt{input}->{parent_input});
142			$out->node_link ($opt{input}->{container_node});
143			$out->input ($original_input);
144			$has_location = 1;
145			} elsif (defined $opt{input}->{request_uri}) {
146			$out->url ($opt{input}->{request_uri});
147			$has_location = 1;
148			} elsif (defined $opt{input}->{uri}) {
149			$out->url ($opt{input}->{uri});
150			$has_location = 1;
151			}
152			}
153
154			unless ($has_location) {
155	wakaba	1.5	$out->text ('Unknown location');
156	wakaba	1.3	}
157	wakaba	1.1	}
158	wakaba	1.2
159			$out->start_tag ('dd', class => $class);
160	wakaba	1.4
161			## Error level
162
163			if ($error_level eq 'm') {
164			$out->html (qq[<strong><a href="../error-description#level-m"><em class=rfc2119>MUST</em>-level
165			error</a></strong>: ]);
166			} elsif ($error_level eq 's') {
167			$out->html (qq[<strong><a href="../error-description#level-s"><em class=rfc2119>SHOULD</em>-level
168			error</a></strong>: ]);
169			} elsif ($error_level eq 'w') {
170			$out->html (qq[<strong><a href="../error-description#level-w">Warning</a></strong>: ]);
171			} elsif ($error_level eq 'u') {
172			$out->html (qq[<strong><a href="../error-description#level-u">Not
173			supported</a></strong>: ]);
174			} elsif ($error_level eq 'i') {
175			$out->html (qq[<strong><a href="../error-description#level-i">Information</a></strong>: ]);
176			}
177
178			## Error message
179
180	wakaba	1.2	$out->text ($error_type_text);
181
182	wakaba	1.4	## Additional error description
183
184	wakaba	1.2	if (defined $opt{text}) {
185			$out->html (' (<q>');
186			$out->text ($opt{text});
187			$out->html ('</q>)');
188			}
189	wakaba	1.4
190			## Link to a long description
191	wakaba	1.2
192			my $fragment = $opt{type};
193			$fragment =~ tr/ /-/;
194			$fragment = $out->encode_url_component ($fragment);
195			$out->text (' [');
196	wakaba	1.4	$out->link ('Description', url => '../error-description#' . $fragment,
197			rel => 'help');
198	wakaba	1.2	$out->text (']');
199
200
201			# my ($type, $cls, $msg) = main::get_text ($opt{type}, $opt{level});
202			# $out->html (qq[<dt class="$cls">] . $result->get_error_label ($input, \%opt));
203
204			$error_layer = 'char'
205			if $error_layer eq 'charset' or $error_layer eq 'encode';
206			if ($error_level eq 's') {
207			$self->{$error_layer}->{should}++;
208			$self->{$error_layer}->{score_min} -= 2;
209			$self->{conforming_min} = 0;
210			} elsif ($error_level eq 'w') {
211			$self->{$error_layer}->{warning}++;
212			} elsif ($error_level eq 'u') {
213			$self->{$error_layer}->{unsupported}++;
214			$self->{unsupported} = 1;
215			} elsif ($error_level eq 'i') {
216			#
217			} else {
218			$self->{$error_layer}->{must}++;
219			$self->{$error_layer}->{score_max} -= 2;
220			$self->{$error_layer}->{score_min} -= 2;
221			$self->{conforming_min} = 0;
222			$self->{conforming_max} = 0;
223			}
224			} # add_error
225
226			sub generate_result_section ($) {
227			my $result = shift;
228
229			my $out = $result->output;
230
231			$out->start_section (id => 'result-summary',
232			title => 'Result');
233
234			if ($result->{unsupported} and $result->{conforming_max}) {
235			$out->html (qq[<p class=uncertain id=result-para>The conformance
236			checker cannot decide whether the document is conforming or
237			not, since the document contains one or more unsupported
238			features. The document might or might not be conforming.</p>]);
239			} elsif ($result->{conforming_min}) {
240			$out->html (qq[<p class=PASS id=result-para>No conformance-error is
241			found in this document.</p>]);
242			} elsif ($result->{conforming_max}) {
243			$out->html (qq[<p class=SEE-RESULT id=result-para>This document
244			is <strong>likely <em>non</em>-conforming</strong>, but in rare case
245			it might be conforming.</p>]);
246			} else {
247			$out->html (qq[<p class=FAIL id=result-para>This document is
248			<strong><em>non</em>-conforming</strong>.</p>]);
249			}
250
251			$out->html (qq[<table>
252			<colgroup><col><colgroup><col><col><col><colgroup><col>
253			<thead>
254			<tr><th scope=col></th>
255			<th scope=col><a href="../error-description#level-m"><em class=rfc2119>MUST</em>-level
256			Errors</a></th>
257			<th scope=col><a href="../error-description#level-s"><em class=rfc2119>SHOULD</em>-level
258			Errors</a></th>
259			<th scope=col><a href="../error-description#level-w">Warnings</a></th>
260			<th scope=col>Score</th></tr></thead><tbody>]);
261
262			## TODO: Introduce "N/A" value (e.g. Character layer is not applicable
263			## to binary formats)
264
265			my $must_error = 0;
266			my $should_error = 0;
267			my $warning = 0;
268			my $score_min = 0;
269			my $score_max = 0;
270			my $score_base = 20;
271			my $score_unit = $score_base / 100;
272			for (
273			[Transfer => 'transfer', ''],
274			[Character => 'char', ''],
275			[Syntax => 'syntax', '#parse-errors'],
276			[Structure => 'structure', '#document-errors'],
277			) {
278			$must_error += ($result->{$_->[1]}->{must} += 0);
279			$should_error += ($result->{$_->[1]}->{should} += 0);
280			$warning += ($result->{$_->[1]}->{warning} += 0);
281			$score_min += (($result->{$_->[1]}->{score_min} *= $score_unit) += $score_base);
282			$score_max += (($result->{$_->[1]}->{score_max} *= $score_unit) += $score_base);
283
284			my $uncertain = $result->{$_->[1]}->{unsupported} ? '?' : '';
285			my $label = $_->[0];
286			if ($result->{$_->[1]}->{must} or
287			$result->{$_->[1]}->{should} or
288			$result->{$_->[1]}->{warning} or
289			$result->{$_->[1]}->{unsupported}) {
290			$label = qq[<a href="$_->[2]">$label</a>];
291			}
292
293			$out->html (qq[<tr class="@{[$uncertain ? 'uncertain' : '']}"><th scope=row>$label</th><td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : '']}">$result->{$_->[1]}->{must}$uncertain</td><td class="@{[$result->{$_->[1]}->{should} ? 'SEE-RESULT' : '']}">$result->{$_->[1]}->{should}$uncertain</td><td>$result->{$_->[1]}->{warning}$uncertain</td>]);
294			if ($uncertain) {
295			$out->html (qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : $result->{$_->[1]}->{should} ? 'SEE-RESULT' : '']}">−∞..$result->{$_->[1]}->{score_max}]);
296			} elsif ($result->{$_->[1]}->{score_min} != $result->{$_->[1]}->{score_max}) {
297			$out->html (qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : 'SEE-RESULT']}">$result->{$_->[1]}->{score_min}..$result->{$_->[1]}->{score_max}]);
298			} else {
299			$out->html (qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : '']}">$result->{$_->[1]}->{score_min}]);
300			}
301			$out->html (qq[ / 20]);
302			}
303
304			$score_max += $score_base;
305
306			$out->html (qq[
307			<tr class=uncertain><th scope=row>Semantics</th><td>0?</td><td>0?</td><td>0?</td><td>−∞..$score_base / 20
308			</tbody>
309			<tfoot><tr class=uncertain><th scope=row>Total</th>
310			<td class="@{[$must_error ? 'FAIL' : '']}">$must_error?</td>
311			<td class="@{[$should_error ? 'SEE-RESULT' : '']}">$should_error?</td>
312			<td>$warning?</td>
313			<td class="@{[$must_error ? 'FAIL' : $should_error ? 'SEE-RESULT' : '']}"><strong>−∞..$score_max</strong> / 100
314			</table>
315
316			<p><strong>Important</strong>: This conformance checking service
317			is <em>under development</em>. The result above might be <em>wrong</em>.</p>]);
318			$out->end_section;
319			} # generate_result_section
320	wakaba	1.1
321			1;