/[suikacvs]/test/html-webhacc/WebHACC/Result.pm
Suika

Diff of /test/html-webhacc/WebHACC/Result.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

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