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 ('No location information available');
    }
  }
 
  $out->start_tag ('dd', class => $class);
  $out->text ($error_type_text);

  if (defined $opt{text}) {
    $out->html (' (<q>');
    $out->text ($opt{text});
    $out->html ('</q>)');
  }

  my $fragment = $opt{type};
  $fragment =~ tr/ /-/;
  $fragment = $out->encode_url_component ($fragment);
  $out->text (' [');
  $out->link ('Description', url => '../error-description#' . $fragment);
  $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

sub get_error_level_label ($) {
  my $self = shift;
  my $err = shift;

  my $r = '';

  if (not defined $err->{level} or $err->{level} eq 'm') {
    $r = qq[<strong><a href="../error-description#level-m"><em class=rfc2119>MUST</em>-level
        error</a></strong>: ];
  } elsif ($err->{level} eq 's') {
    $r = qq[<strong><a href="../error-description#level-s"><em class=rfc2119>SHOULD</em>-level
        error</a></strong>: ];
  } elsif ($err->{level} eq 'w') {
    $r = qq[<strong><a href="../error-description#level-w">Warning</a></strong>:
        ];
  } elsif ($err->{level} eq 'u' or $err->{level} eq 'unsupported') {
    $r = qq[<strong><a href="../error-description#level-u">Not
        supported</a></strong>: ];
  } elsif ($err->{level} eq 'i') {
    $r = qq[<strong><a href="../error-description#level-i">Information</a></strong>: ];
  } else {
    my $elevel = htescape ($err->{level});
    $r = qq[<strong><a href="../error-description#level-$elevel">$elevel</a></strong>:
        ];
  }

  return $r;
} # get_error_level_label

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			$out->text ('No location information available');
156			}
157	wakaba	1.1	}
158	wakaba	1.2
159			$out->start_tag ('dd', class => $class);
160			$out->text ($error_type_text);
161
162			if (defined $opt{text}) {
163			$out->html (' (<q>');
164			$out->text ($opt{text});
165			$out->html ('</q>)');
166			}
167
168			my $fragment = $opt{type};
169			$fragment =~ tr/ /-/;
170			$fragment = $out->encode_url_component ($fragment);
171			$out->text (' [');
172			$out->link ('Description', url => '../error-description#' . $fragment);
173			$out->text (']');
174
175
176			# my ($type, $cls, $msg) = main::get_text ($opt{type}, $opt{level});
177			# $out->html (qq[<dt class="$cls">] . $result->get_error_label ($input, \%opt));
178
179			$error_layer = 'char'
180			if $error_layer eq 'charset' or $error_layer eq 'encode';
181			if ($error_level eq 's') {
182			$self->{$error_layer}->{should}++;
183			$self->{$error_layer}->{score_min} -= 2;
184			$self->{conforming_min} = 0;
185			} elsif ($error_level eq 'w') {
186			$self->{$error_layer}->{warning}++;
187			} elsif ($error_level eq 'u') {
188			$self->{$error_layer}->{unsupported}++;
189			$self->{unsupported} = 1;
190			} elsif ($error_level eq 'i') {
191			#
192			} else {
193			$self->{$error_layer}->{must}++;
194			$self->{$error_layer}->{score_max} -= 2;
195			$self->{$error_layer}->{score_min} -= 2;
196			$self->{conforming_min} = 0;
197			$self->{conforming_max} = 0;
198			}
199			} # add_error
200
201			sub generate_result_section ($) {
202			my $result = shift;
203
204			my $out = $result->output;
205
206			$out->start_section (id => 'result-summary',
207			title => 'Result');
208
209			if ($result->{unsupported} and $result->{conforming_max}) {
210			$out->html (qq[<p class=uncertain id=result-para>The conformance
211			checker cannot decide whether the document is conforming or
212			not, since the document contains one or more unsupported
213			features. The document might or might not be conforming.</p>]);
214			} elsif ($result->{conforming_min}) {
215			$out->html (qq[<p class=PASS id=result-para>No conformance-error is
216			found in this document.</p>]);
217			} elsif ($result->{conforming_max}) {
218			$out->html (qq[<p class=SEE-RESULT id=result-para>This document
219			is <strong>likely <em>non</em>-conforming</strong>, but in rare case
220			it might be conforming.</p>]);
221			} else {
222			$out->html (qq[<p class=FAIL id=result-para>This document is
223			<strong><em>non</em>-conforming</strong>.</p>]);
224			}
225
226			$out->html (qq[<table>
227			<colgroup><col><colgroup><col><col><col><colgroup><col>
228			<thead>
229			<tr><th scope=col></th>
230			<th scope=col><a href="../error-description#level-m"><em class=rfc2119>MUST</em>-level
231			Errors</a></th>
232			<th scope=col><a href="../error-description#level-s"><em class=rfc2119>SHOULD</em>-level
233			Errors</a></th>
234			<th scope=col><a href="../error-description#level-w">Warnings</a></th>
235			<th scope=col>Score</th></tr></thead><tbody>]);
236
237			## TODO: Introduce "N/A" value (e.g. Character layer is not applicable
238			## to binary formats)
239
240			my $must_error = 0;
241			my $should_error = 0;
242			my $warning = 0;
243			my $score_min = 0;
244			my $score_max = 0;
245			my $score_base = 20;
246			my $score_unit = $score_base / 100;
247			for (
248			[Transfer => 'transfer', ''],
249			[Character => 'char', ''],
250			[Syntax => 'syntax', '#parse-errors'],
251			[Structure => 'structure', '#document-errors'],
252			) {
253			$must_error += ($result->{$_->[1]}->{must} += 0);
254			$should_error += ($result->{$_->[1]}->{should} += 0);
255			$warning += ($result->{$_->[1]}->{warning} += 0);
256			$score_min += (($result->{$_->[1]}->{score_min} *= $score_unit) += $score_base);
257			$score_max += (($result->{$_->[1]}->{score_max} *= $score_unit) += $score_base);
258
259			my $uncertain = $result->{$_->[1]}->{unsupported} ? '?' : '';
260			my $label = $_->[0];
261			if ($result->{$_->[1]}->{must} or
262			$result->{$_->[1]}->{should} or
263			$result->{$_->[1]}->{warning} or
264			$result->{$_->[1]}->{unsupported}) {
265			$label = qq[<a href="$_->[2]">$label</a>];
266			}
267
268			$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>]);
269			if ($uncertain) {
270			$out->html (qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : $result->{$_->[1]}->{should} ? 'SEE-RESULT' : '']}">−∞..$result->{$_->[1]}->{score_max}]);
271			} elsif ($result->{$_->[1]}->{score_min} != $result->{$_->[1]}->{score_max}) {
272			$out->html (qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : 'SEE-RESULT']}">$result->{$_->[1]}->{score_min}..$result->{$_->[1]}->{score_max}]);
273			} else {
274			$out->html (qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : '']}">$result->{$_->[1]}->{score_min}]);
275			}
276			$out->html (qq[ / 20]);
277			}
278
279			$score_max += $score_base;
280
281			$out->html (qq[
282			<tr class=uncertain><th scope=row>Semantics</th><td>0?</td><td>0?</td><td>0?</td><td>−∞..$score_base / 20
283			</tbody>
284			<tfoot><tr class=uncertain><th scope=row>Total</th>
285			<td class="@{[$must_error ? 'FAIL' : '']}">$must_error?</td>
286			<td class="@{[$should_error ? 'SEE-RESULT' : '']}">$should_error?</td>
287			<td>$warning?</td>
288			<td class="@{[$must_error ? 'FAIL' : $should_error ? 'SEE-RESULT' : '']}"><strong>−∞..$score_max</strong> / 100
289			</table>
290
291			<p><strong>Important</strong>: This conformance checking service
292			is <em>under development</em>. The result above might be <em>wrong</em>.</p>]);
293			$out->end_section;
294			} # generate_result_section
295
296	wakaba	1.1	sub get_error_level_label ($) {
297			my $self = shift;
298			my $err = shift;
299
300			my $r = '';
301
302			if (not defined $err->{level} or $err->{level} eq 'm') {
303			$r = qq[<strong><a href="../error-description#level-m"><em class=rfc2119>MUST</em>-level
304			error</a></strong>: ];
305			} elsif ($err->{level} eq 's') {
306			$r = qq[<strong><a href="../error-description#level-s"><em class=rfc2119>SHOULD</em>-level
307			error</a></strong>: ];
308			} elsif ($err->{level} eq 'w') {
309			$r = qq[<strong><a href="../error-description#level-w">Warning</a></strong>:
310			];
311			} elsif ($err->{level} eq 'u' or $err->{level} eq 'unsupported') {
312			$r = qq[<strong><a href="../error-description#level-u">Not
313			supported</a></strong>: ];
314			} elsif ($err->{level} eq 'i') {
315			$r = qq[<strong><a href="../error-description#level-i">Information</a></strong>: ];
316			} else {
317			my $elevel = htescape ($err->{level});
318			$r = qq[<strong><a href="../error-description#level-$elevel">$elevel</a></strong>:
319			];
320			}
321
322			return $r;
323			} # get_error_level_label
324
325			1;