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	package WebHACC::Result;
2	use strict;
3
4	sub new ($) {
5	return bless {}, shift;
6	} # new
7
8	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	my $has_location;
58
59	## URL
60
61	if (defined $opt{url}) {
62	$out->url ($opt{url});
63	$has_location = 1;
64	}
65
66	## Line & column number
67
68	my $line;
69	my $column;
70
71	if (defined $opt{node}) {
72	$line = $opt{node}->get_user_data ('manakai_source_line');
73	if (defined $line) {
74	$column = $opt{node}->get_user_data ('manakai_source_column');
75	} else {
76	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	} else {
83	my $parent = $opt{node}->parent_node;
84	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	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	}
99	}
100
101	if (defined $line) {
102	if (defined $column and $column > 0) {
103	$out->xref ('Line ' . $line, target => 'line-' . $line);
104	$out->text (' column ' . $column);
105	} else {
106	$line = $line - 1 \|\| 1;
107	$out->xref ('Line ' . $line, target => 'line-' . $line);
108	}
109	$has_location = 1;
110	}
111
112	## Node path
113
114	if (defined $opt{node}) {
115	$out->html (' ');
116	$out->node_link ($opt{node});
117	$has_location = 1;
118	}
119
120	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	} else {
126	$out->text (' Index ' . (0+$opt{index}));
127	}
128	$has_location = 1;
129	}
130
131	if (defined $opt{value}) {
132	$out->html (' ');
133	$out->code ($opt{value});
134	$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	$out->text ('Unknown location');
156	}
157	}
158
159	$out->start_tag ('dd', class => $class);
160
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	$out->text ($error_type_text);
181
182	## Additional error description
183
184	if (defined $opt{text}) {
185	$out->html (' (<q>');
186	$out->text ($opt{text});
187	$out->html ('</q>)');
188	}
189
190	## Link to a long description
191
192	my $fragment = $opt{type};
193	$fragment =~ tr/ /-/;
194	$fragment = $out->encode_url_component ($fragment);
195	$out->text (' [');
196	$out->link ('Description', url => '../error-description#' . $fragment,
197	rel => 'help');
198	$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
321	1;