/[pub]/test/html-webhacc/cc.cgi
Suika

Diff of /test/html-webhacc/cc.cgi

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

revision 1.18 by wakaba, Sun Sep 2 08:40:49 2007 UTC revision 1.21 by wakaba, Tue Sep 11 08:25:23 2007 UTC
# Line 83  if (defined $input->{s}) { Line 83  if (defined $input->{s}) {
83  </div>  </div>
84  ];  ];
85    
86    print_http_header_section ($input);    my $result = {conforming_min => 1, conforming_max => 1};
87      print_http_header_section ($input, $result);
88    
89    my $doc;    my $doc;
90    my $el;    my $el;
91    
92    if ($input->{media_type} eq 'text/html') {    if ($input->{media_type} eq 'text/html') {
93      ($doc, $el) = print_syntax_error_html_section ($input);      ($doc, $el) = print_syntax_error_html_section ($input, $result);
94      print_source_string_section (\($input->{s}), $input->{charset});      print_source_string_section (\($input->{s}), $input->{charset});
95    } elsif ({    } elsif ({
96              'text/xml' => 1,              'text/xml' => 1,
# Line 99  if (defined $input->{s}) { Line 100  if (defined $input->{s}) {
100              'application/xhtml+xml' => 1,              'application/xhtml+xml' => 1,
101              'application/xml' => 1,              'application/xml' => 1,
102             }->{$input->{media_type}}) {             }->{$input->{media_type}}) {
103      ($doc, $el) = print_syntax_error_xml_section ($input);      ($doc, $el) = print_syntax_error_xml_section ($input, $result);
104      print_source_string_section (\($input->{s}), $doc->input_encoding);      print_source_string_section (\($input->{s}), $doc->input_encoding);
105    } else {    } else {
106      ## TODO: Change HTTP status code??      ## TODO: Change HTTP status code??
# Line 108  if (defined $input->{s}) { Line 109  if (defined $input->{s}) {
109    
110    if (defined $doc or defined $el) {    if (defined $doc or defined $el) {
111      print_structure_dump_section ($doc, $el);      print_structure_dump_section ($doc, $el);
112      my $elements = print_structure_error_section ($doc, $el);      my $elements = print_structure_error_section ($doc, $el, $result);
113      print_table_section ($elements->{table}) if @{$elements->{table}};      print_table_section ($elements->{table}) if @{$elements->{table}};
114      print_id_section ($elements->{id}) if keys %{$elements->{id}};      print_id_section ($elements->{id}) if keys %{$elements->{id}};
115      print_term_section ($elements->{term}) if keys %{$elements->{term}};      print_term_section ($elements->{term}) if keys %{$elements->{term}};
116      print_class_section ($elements->{class}) if keys %{$elements->{class}};      print_class_section ($elements->{class}) if keys %{$elements->{class}};
117    }    }
118    
119    ## TODO: Show result    print_result_section ($result);
120  } else {  } else {
121    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
122    print_result_input_error_section ($input);    print_result_input_error_section ($input);
# Line 141  if (defined $input->{s}) { Line 142  if (defined $input->{s}) {
142    
143  exit;  exit;
144    
145  sub print_http_header_section ($) {  sub add_error ($$$) {
146    my $input = shift;    my ($layer, $err, $result) = @_;
147      if (defined $err->{level}) {
148        if ($err->{level} eq 's') {
149          $result->{$layer}->{should}++;
150          $result->{$layer}->{score_min} -= 2;
151          $result->{conforming_min} = 0;
152        } elsif ($err->{level} eq 'w' or $err->{level} eq 'g') {
153          $result->{$layer}->{warning}++;
154        } elsif ($err->{level} eq 'unsupported') {
155          $result->{$layer}->{unsupported}++;
156          $result->{unsupported} = 1;
157        } else {
158          $result->{$layer}->{must}++;
159          $result->{$layer}->{score_max} -= 2;
160          $result->{$layer}->{score_min} -= 2;
161          $result->{conforming_min} = 0;
162          $result->{conforming_max} = 0;
163        }
164      } else {
165        $result->{$layer}->{must}++;
166        $result->{$layer}->{score_max} -= 2;
167        $result->{$layer}->{score_min} -= 2;
168        $result->{conforming_min} = 0;
169        $result->{conforming_max} = 0;
170      }
171    } # add_error
172    
173    sub print_http_header_section ($$) {
174      my ($input, $result) = @_;
175    return unless defined $input->{header_status_code} or    return unless defined $input->{header_status_code} or
176        defined $input->{header_status_text} or        defined $input->{header_status_text} or
177        @{$input->{header_field}};        @{$input->{header_field}};
# Line 175  not be the real header.</p> Line 204  not be the real header.</p>
204    print STDOUT qq[</tbody></table></div>];    print STDOUT qq[</tbody></table></div>];
205  } # print_http_header_section  } # print_http_header_section
206    
207  sub print_syntax_error_html_section ($) {  sub print_syntax_error_html_section ($$) {
208    my $input = shift;    my ($input, $result) = @_;
209        
210    require Encode;    require Encode;
211    require Whatpm::HTML;    require Whatpm::HTML;
# Line 207  sub print_syntax_error_html_section ($) Line 236  sub print_syntax_error_html_section ($)
236      $type =~ s/\|/%7C/g;      $type =~ s/\|/%7C/g;
237      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
238      print STDOUT qq[<dd class="$cls">$msg</dd>\n];      print STDOUT qq[<dd class="$cls">$msg</dd>\n];
239    
240        add_error ('syntax', \%opt => $result);
241    };    };
242    
243    my $doc = $dom->create_document;    my $doc = $dom->create_document;
# Line 226  sub print_syntax_error_html_section ($) Line 257  sub print_syntax_error_html_section ($)
257    return ($doc, $el);    return ($doc, $el);
258  } # print_syntax_error_html_section  } # print_syntax_error_html_section
259    
260  sub print_syntax_error_xml_section ($) {  sub print_syntax_error_xml_section ($$) {
261    my $input = shift;    my ($input, $result) = @_;
262        
263    require Message::DOM::XMLParserTemp;    require Message::DOM::XMLParserTemp;
264        
# Line 244  sub print_syntax_error_xml_section ($) { Line 275  sub print_syntax_error_xml_section ($) {
275      print STDOUT qq[<dt><a href="#line-$line">Line $line</a> column ];      print STDOUT qq[<dt><a href="#line-$line">Line $line</a> column ];
276      print STDOUT $err->location->column_number, "</dt><dd>";      print STDOUT $err->location->column_number, "</dt><dd>";
277      print STDOUT htescape $err->text, "</dd>\n";      print STDOUT htescape $err->text, "</dd>\n";
278    
279        add_error ('syntax', {type => $err->text,
280                    level => [
281                              $err->SEVERITY_FATAL_ERROR => 'm',
282                              $err->SEVERITY_ERROR => 'm',
283                              $err->SEVERITY_WARNING => 's',
284                             ]->[$err->severity]} => $result);
285    
286      return 1;      return 1;
287    };    };
288    
# Line 374  sub print_structure_dump_section ($$) { Line 413  sub print_structure_dump_section ($$) {
413    print STDOUT qq[</div>];    print STDOUT qq[</div>];
414  } # print_structure_dump_section  } # print_structure_dump_section
415    
416  sub print_structure_error_section ($$) {  sub print_structure_error_section ($$$) {
417    my ($doc, $el) = @_;    my ($doc, $el, $result) = @_;
418    
419    print STDOUT qq[<div id="document-errors" class="section">    print STDOUT qq[<div id="document-errors" class="section">
420  <h2>Document Errors</h2>  <h2>Document Errors</h2>
# Line 392  sub print_structure_error_section ($$) { Line 431  sub print_structure_error_section ($$) {
431      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
432      print STDOUT qq[<dt class="$cls">] . get_node_link ($opt{node}) .      print STDOUT qq[<dt class="$cls">] . get_node_link ($opt{node}) .
433          qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";          qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";
434        add_error ('structure', \%opt => $result);
435    };    };
436    
437    my $elements;    my $elements;
# Line 524  sub print_class_section ($) { Line 564  sub print_class_section ($) {
564    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
565  } # print_class_section  } # print_class_section
566    
567    sub print_result_section ($) {
568      my $result = shift;
569    
570      print STDOUT qq[
571    <div id="result-summary" class="section">
572    <h2>Result</h2>];
573    
574      if ($result->{unsupported} and $result->{conforming_max}) {  
575        print STDOUT qq[<p class=uncertain id=result-para>The conformance
576            checker cannot decide whether the document is conforming or
577            not, since the document contains one or more unsupported
578            features.  The document might or might not be conforming.</p>];
579      } elsif ($result->{conforming_min}) {
580        print STDOUT qq[<p class=PASS id=result-para>No conformance-error is
581            found in this document.</p>];
582      } elsif ($result->{conforming_max}) {
583        print STDOUT qq[<p class=SEE-RESULT id=result-para>This document
584            is <strong>likely <em>non</em>-conforming</strong>, but in rare case
585            it might be conforming.</p>];
586      } else {
587        print STDOUT qq[<p class=FAIL id=result-para>This document is
588            <strong><em>non</em>-conforming</strong>.</p>];
589      }
590    
591      print STDOUT qq[<table>
592    <colgroup><col><colgroup><col><col><col><colgroup><col>
593    <thead>
594    <tr><th scope=col></th><th scope=col><em class=rfc2119>MUST</em>-level
595    Errors</th><th scope=col><em class=rfc2119>SHOULD</em>-level
596    Errors</th><th scope=col>Warnings</th><th scope=col>Score</th></tr>
597    </thead><tbody>];
598    
599      my $must_error = 0;
600      my $should_error = 0;
601      my $warning = 0;
602      my $score_min = 0;
603      my $score_max = 0;
604      my $score_base = 20;
605      my $score_unit = $score_base / 100;
606      for (
607        [Transfer => 'transfer', ''],
608        [Character => 'char', ''],
609        [Syntax => 'syntax', '#parse-errors'],
610        [Structure => 'structure', '#document-errors'],
611      ) {
612        $must_error += ($result->{$_->[1]}->{must} += 0);
613        $should_error += ($result->{$_->[1]}->{should} += 0);
614        $warning += ($result->{$_->[1]}->{warning} += 0);
615        $score_min += (($result->{$_->[1]}->{score_min} *= $score_unit) += $score_base);
616        $score_max += (($result->{$_->[1]}->{score_max} *= $score_unit) += $score_base);
617    
618        my $uncertain = $result->{$_->[1]}->{unsupported} ? '?' : '';
619        my $label = $_->[0];
620        if ($result->{$_->[1]}->{must} or
621            $result->{$_->[1]}->{should} or
622            $result->{$_->[1]}->{warning} or
623            $result->{$_->[1]}->{unsupported}) {
624          $label = qq[<a href="$_->[2]">$label</a>];
625        }
626    
627        print STDOUT 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>];
628        if ($uncertain) {
629          print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : $result->{$_->[1]}->{should} ? 'SEE-RESULT' : '']}">&#x2212;&#x221E;..$result->{$_->[1]}->{score_max}</td>];
630        } elsif ($result->{$_->[1]}->{score_min} != $result->{$_->[1]}->{score_max}) {
631          print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : 'SEE-RESULT']}">$result->{$_->[1]}->{score_min}..$result->{$_->[1]}->{score_max}</td></tr>];
632        } else {
633          print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : '']}">$result->{$_->[1]}->{score_min}</td></tr>];
634        }
635      }
636    
637      $score_max += $score_base;
638    
639      print STDOUT qq[
640    <tr class=uncertain><th scope=row>Semantics</th><td>0?</td><td>0?</td><td>0?</td><td>&#x2212;&#x221E;..$score_base</td></tr>
641    </tbody>
642    <tfoot><tr class=uncertain><th scope=row>Total</th>
643    <td class="@{[$must_error ? 'FAIL' : '']}">$must_error?</td>
644    <td class="@{[$should_error ? 'SEE-RESULT' : '']}">$should_error?</td>
645    <td>$warning?</td>
646    <td class="@{[$must_error ? 'FAIL' : $should_error ? 'SEE-RESULT' : '']}"><strong>&#x2212;&#x221E;..$score_max</strong></td></tr></tfoot>
647    </table>
648    
649    <p><strong>Important</strong>: This conformance checking service
650    is <em>under development</em>.  The result above might be <em>wrong</em>.</p>
651    </div>];
652      push @nav, ['#result-summary' => 'Result'];
653    } # print_result_section
654    
655  sub print_result_unknown_type_section ($) {  sub print_result_unknown_type_section ($) {
656    my $input = shift;    my $input = shift;
657    
Legend:
Removed from v.1.18  
changed lines
  Added in v.1.21
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24