/[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.6 by wakaba, Mon Jul 21 12:56:34 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      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  sub get_error_label ($$) {    my $error_type_text = $opt{type};
   my $self = shift;  
   my ($input, $err) = @_;  
53    
54    my $r = '';    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 {      } else {
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      unless ($has_location) {
148        if (defined $opt{input}) {
149          if (defined $opt{input}->{container_node}) {
150            my $original_input = $out->input;
151            $out->input ($opt{input}->{parent_input});
152            $out->node_link ($opt{input}->{container_node});
153            $out->input ($original_input);
154            $has_location = 1;
155          } elsif (defined $opt{input}->{request_uri}) {
156            $out->url ($opt{input}->{request_uri});
157            $has_location = 1;
158          } elsif (defined $opt{input}->{uri}) {
159            $out->url ($opt{input}->{uri});
160            $has_location = 1;
161          }
162        }
163        
164        unless ($has_location) {
165          $out->text ('Unknown location');
166      }      }
167    }    }
168    
169      $out->start_tag ('dd', class => $class);
170    
171      ## Error level
172      
173      if ($error_level eq 'm') {
174        $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    if (defined $err->{value}) {    $out->start_section (id => 'result-summary',
242      $r .= ' ' if length $r; ## BUG: v must be escaped                         title => 'Result');
243      $r .= '<q><code>' . ($err->{value}) . '</code></q>';  
244    }    if ($result->{unsupported} and $result->{conforming_max}) {  
245        $out->html (qq[<p class=uncertain id=result-para>The conformance
246    return $r;          checker cannot decide whether the document is conforming or
247  } # get_error_label          not, since the document contains one or more unsupported
248            features.  The document might or might not be conforming.</p>]);
249  sub get_error_level_label ($) {    } elsif ($result->{conforming_min}) {
250    my $self = shift;      $out->html (qq[<p class=PASS id=result-para>No conformance-error is
251    my $err = shift;          found in this document.</p>]);
252      } elsif ($result->{conforming_max}) {
253    my $r = '';      $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    if (not defined $err->{level} or $err->{level} eq 'm') {          it might be conforming.</p>]);
     $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>: ];  
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', ''],
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.6
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24