/[suikacvs]/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.19 by wakaba, Mon Sep 10 11:51:09 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 = {};
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}) {  
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.</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      for (
606        [Transfer => 'transfer', ''],
607        [Character => 'char', ''],
608        [Syntax => 'syntax', '#parse-errors'],
609        [Structure => 'structure', '#document-errors'],
610      ) {
611        $must_error += ($result->{$_->[1]}->{must} += 0);
612        $should_error += ($result->{$_->[1]}->{should} += 0);
613        $warning += ($result->{$_->[1]}->{warning} += 0);
614        $score_min += ($result->{$_->[1]}->{score_min} += $score_base);
615        $score_max += ($result->{$_->[1]}->{score_max} += $score_base);
616    
617        my $uncertain = $result->{$_->[1]}->{unsupported} ? '?' : '';
618        my $label = $_->[0];
619        if ($result->{$_->[1]}->{must} or
620            $result->{$_->[1]}->{should} or
621            $result->{$_->[1]}->{warning} or
622            $result->{$_->[1]}->{unsupported}) {
623          $label = qq[<a href="$_->[2]">$label</a>];
624        }
625    
626        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>];
627        if ($uncertain) {
628          print qq[<td class="@{[$score_max < $score_base ? $score_min < $score_max ? 'FAIL' : 'SEE-RESULT' : '']}">&#x2212;&#x221E;..$result->{$_->[1]}->{score_max}</td>];
629        } elsif ($result->{$_->[1]}->{score_min} != $result->{$_->[1]}->{score_max}) {
630          print qq[<td class="@{[$score_max < $score_base ? 'FAIL' : 'SEE-RESULT']}">$result->{$_->[1]}->{score_min}..$result->{$_->[1]}->{score_max} + $score_base</td></tr>];
631        } else {
632          print qq[<td class="@{[$score_max < $score_base ? 'FAIL' : '']}">$result->{$_->[1]}->{score_min}</td></tr>];
633        }
634      }
635    
636      $score_max += $score_base;
637    
638      print STDOUT qq[
639    <tr class=uncertain><th scope=row>Semantics</th><td>0?</td><td>0?</td><td>0?</td><td>&#x2212;&#x221E;..$score_base</td></tr>
640    </tbody>
641    <tfoot><tr class=uncertain><th scope=row>Total</th><td>$must_error?</td><td>$should_error?</td><td>$warning?</td><td><strong>&#x2212;&#x221E;..$score_max</strong></td></tr></tfoot>
642    </table>
643    
644    <p><strong>Important</strong>: This conformance checking service
645    is <em>under development</em>.  The result above might be <em>wrong</em>.</p>
646    </div>];
647      push @nav, ['#result-summary' => 'Result'];
648    } # print_result_section
649    
650  sub print_result_unknown_type_section ($) {  sub print_result_unknown_type_section ($) {
651    my $input = shift;    my $input = shift;
652    
Legend:
Removed from v.1.18  
changed lines
  Added in v.1.19
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24