/[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.22 by wakaba, Sun Nov 4 09:15:02 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      my $manifest;
92    
93    if ($input->{media_type} eq 'text/html') {    if ($input->{media_type} eq 'text/html') {
94      ($doc, $el) = print_syntax_error_html_section ($input);      ($doc, $el) = print_syntax_error_html_section ($input, $result);
95      print_source_string_section (\($input->{s}), $input->{charset});      print_source_string_section (\($input->{s}), $input->{charset});
96    } elsif ({    } elsif ({
97              'text/xml' => 1,              'text/xml' => 1,
# Line 99  if (defined $input->{s}) { Line 101  if (defined $input->{s}) {
101              'application/xhtml+xml' => 1,              'application/xhtml+xml' => 1,
102              'application/xml' => 1,              'application/xml' => 1,
103             }->{$input->{media_type}}) {             }->{$input->{media_type}}) {
104      ($doc, $el) = print_syntax_error_xml_section ($input);      ($doc, $el) = print_syntax_error_xml_section ($input, $result);
105      print_source_string_section (\($input->{s}), $doc->input_encoding);      print_source_string_section (\($input->{s}), $doc->input_encoding);
106      } elsif ($input->{media_type} eq 'text/cache-manifest') {
107    ## TODO: MUST be text/cache-manifest
108        $manifest = print_syntax_error_manifest_section ($input, $result);
109        print_source_string_section (\($input->{s}), 'utf-8');
110    } else {    } else {
111      ## TODO: Change HTTP status code??      ## TODO: Change HTTP status code??
112      print_result_unknown_type_section ($input);      print_result_unknown_type_section ($input);
113    }    }
114    
115    if (defined $doc or defined $el) {    if (defined $doc or defined $el) {
116      print_structure_dump_section ($doc, $el);      print_structure_dump_dom_section ($doc, $el);
117      my $elements = print_structure_error_section ($doc, $el);      my $elements = print_structure_error_dom_section ($doc, $el, $result);
118      print_table_section ($elements->{table}) if @{$elements->{table}};      print_table_section ($elements->{table}) if @{$elements->{table}};
119      print_id_section ($elements->{id}) if keys %{$elements->{id}};      print_id_section ($elements->{id}) if keys %{$elements->{id}};
120      print_term_section ($elements->{term}) if keys %{$elements->{term}};      print_term_section ($elements->{term}) if keys %{$elements->{term}};
121      print_class_section ($elements->{class}) if keys %{$elements->{class}};      print_class_section ($elements->{class}) if keys %{$elements->{class}};
122      } elsif (defined $manifest) {
123        print_structure_dump_manifest_section ($manifest);
124        print_structure_error_manifest_section ($manifest, $result);
125    }    }
126    
127    ## TODO: Show result    print_result_section ($result);
128  } else {  } else {
129    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
130    print_result_input_error_section ($input);    print_result_input_error_section ($input);
# Line 133  if (defined $input->{s}) { Line 142  if (defined $input->{s}) {
142  </html>  </html>
143  ];  ];
144    
145    for (qw/decode parse parse_xml check/) {    for (qw/decode parse parse_xml parse_manifest check check_manifest/) {
146      next unless defined $time{$_};      next unless defined $time{$_};
147      open my $file, '>>', ".cc-$_.txt" or die ".cc-$_.txt: $!";      open my $file, '>>', ".cc-$_.txt" or die ".cc-$_.txt: $!";
148      print $file $char_length, "\t", $time{$_}, "\n";      print $file $char_length, "\t", $time{$_}, "\n";
# Line 141  if (defined $input->{s}) { Line 150  if (defined $input->{s}) {
150    
151  exit;  exit;
152    
153  sub print_http_header_section ($) {  sub add_error ($$$) {
154    my $input = shift;    my ($layer, $err, $result) = @_;
155      if (defined $err->{level}) {
156        if ($err->{level} eq 's') {
157          $result->{$layer}->{should}++;
158          $result->{$layer}->{score_min} -= 2;
159          $result->{conforming_min} = 0;
160        } elsif ($err->{level} eq 'w' or $err->{level} eq 'g') {
161          $result->{$layer}->{warning}++;
162        } elsif ($err->{level} eq 'unsupported') {
163          $result->{$layer}->{unsupported}++;
164          $result->{unsupported} = 1;
165        } else {
166          $result->{$layer}->{must}++;
167          $result->{$layer}->{score_max} -= 2;
168          $result->{$layer}->{score_min} -= 2;
169          $result->{conforming_min} = 0;
170          $result->{conforming_max} = 0;
171        }
172      } else {
173        $result->{$layer}->{must}++;
174        $result->{$layer}->{score_max} -= 2;
175        $result->{$layer}->{score_min} -= 2;
176        $result->{conforming_min} = 0;
177        $result->{conforming_max} = 0;
178      }
179    } # add_error
180    
181    sub print_http_header_section ($$) {
182      my ($input, $result) = @_;
183    return unless defined $input->{header_status_code} or    return unless defined $input->{header_status_code} or
184        defined $input->{header_status_text} or        defined $input->{header_status_text} or
185        @{$input->{header_field}};        @{$input->{header_field}};
# Line 175  not be the real header.</p> Line 212  not be the real header.</p>
212    print STDOUT qq[</tbody></table></div>];    print STDOUT qq[</tbody></table></div>];
213  } # print_http_header_section  } # print_http_header_section
214    
215  sub print_syntax_error_html_section ($) {  sub print_syntax_error_html_section ($$) {
216    my $input = shift;    my ($input, $result) = @_;
217        
218    require Encode;    require Encode;
219    require Whatpm::HTML;    require Whatpm::HTML;
# Line 207  sub print_syntax_error_html_section ($) Line 244  sub print_syntax_error_html_section ($)
244      $type =~ s/\|/%7C/g;      $type =~ s/\|/%7C/g;
245      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
246      print STDOUT qq[<dd class="$cls">$msg</dd>\n];      print STDOUT qq[<dd class="$cls">$msg</dd>\n];
247    
248        add_error ('syntax', \%opt => $result);
249    };    };
250    
251    my $doc = $dom->create_document;    my $doc = $dom->create_document;
# Line 226  sub print_syntax_error_html_section ($) Line 265  sub print_syntax_error_html_section ($)
265    return ($doc, $el);    return ($doc, $el);
266  } # print_syntax_error_html_section  } # print_syntax_error_html_section
267    
268  sub print_syntax_error_xml_section ($) {  sub print_syntax_error_xml_section ($$) {
269    my $input = shift;    my ($input, $result) = @_;
270        
271    require Message::DOM::XMLParserTemp;    require Message::DOM::XMLParserTemp;
272        
# Line 244  sub print_syntax_error_xml_section ($) { Line 283  sub print_syntax_error_xml_section ($) {
283      print STDOUT qq[<dt><a href="#line-$line">Line $line</a> column ];      print STDOUT qq[<dt><a href="#line-$line">Line $line</a> column ];
284      print STDOUT $err->location->column_number, "</dt><dd>";      print STDOUT $err->location->column_number, "</dt><dd>";
285      print STDOUT htescape $err->text, "</dd>\n";      print STDOUT htescape $err->text, "</dd>\n";
286    
287        add_error ('syntax', {type => $err->text,
288                    level => [
289                              $err->SEVERITY_FATAL_ERROR => 'm',
290                              $err->SEVERITY_ERROR => 'm',
291                              $err->SEVERITY_WARNING => 's',
292                             ]->[$err->severity]} => $result);
293    
294      return 1;      return 1;
295    };    };
296    
# Line 258  sub print_syntax_error_xml_section ($) { Line 305  sub print_syntax_error_xml_section ($) {
305    return ($doc, undef);    return ($doc, undef);
306  } # print_syntax_error_xml_section  } # print_syntax_error_xml_section
307    
308    sub print_syntax_error_manifest_section ($$) {
309      my ($input, $result) = @_;
310    
311      require Whatpm::CacheManifest;
312    
313      print STDOUT qq[
314    <div id="parse-errors" class="section">
315    <h2>Parse Errors</h2>
316    
317    <dl>];
318      push @nav, ['#parse-errors' => 'Parse Error'];
319    
320      my $onerror = sub {
321        my (%opt) = @_;
322        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level});
323        print STDOUT qq[<dt class="$cls">], get_error_label (\%opt), qq[</dt>];
324        $type =~ tr/ /-/;
325        $type =~ s/\|/%7C/g;
326        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
327        print STDOUT qq[<dd class="$cls">$msg</dd>\n];
328    
329        add_error ('syntax', \%opt => $result);
330      };
331    
332      my $time1 = time;
333      my $manifest = Whatpm::CacheManifest->parse_byte_string
334          ($input->{s}, $input->{uri}, $input->{base_uri}, $onerror);
335      $time{parse_manifest} = time - $time1;
336    
337      print STDOUT qq[</dl></div>];
338    
339      return $manifest;
340    } # print_syntax_error_manifest_section
341    
342  sub print_source_string_section ($$) {  sub print_source_string_section ($$) {
343    require Encode;    require Encode;
344    my $enc = Encode::find_encoding ($_[1]); ## TODO: charset name -> Perl name    my $enc = Encode::find_encoding ($_[1]); ## TODO: charset name -> Perl name
# Line 360  sub print_document_tree ($) { Line 441  sub print_document_tree ($) {
441    print STDOUT $r;    print STDOUT $r;
442  } # print_document_tree  } # print_document_tree
443    
444  sub print_structure_dump_section ($$) {  sub print_structure_dump_dom_section ($$) {
445    my ($doc, $el) = @_;    my ($doc, $el) = @_;
446    
447    print STDOUT qq[    print STDOUT qq[
# Line 372  sub print_structure_dump_section ($$) { Line 453  sub print_structure_dump_section ($$) {
453    print_document_tree ($el || $doc);    print_document_tree ($el || $doc);
454    
455    print STDOUT qq[</div>];    print STDOUT qq[</div>];
456  } # print_structure_dump_section  } # print_structure_dump_dom_section
457    
458  sub print_structure_error_section ($$) {  sub print_structure_dump_manifest_section ($) {
459    my ($doc, $el) = @_;    my $manifest = shift;
460    
461      print STDOUT qq[
462    <div id="dump-manifest" class="section">
463    <h2>Cache Manifest</h2>
464    ];
465      push @nav, ['#dump-manifest' => 'Caceh Manifest'];
466    
467      print STDOUT qq[<dl><dt>Explicit entries</dt>];
468      for my $uri (@{$manifest->[0]}) {
469        my $euri = htescape ($uri);
470        print STDOUT qq[<dd><code class=uri>&lt;<a href="$euri">$euri</a>></code></dd>];
471      }
472    
473      print STDOUT qq[<dt>Fallback entries</dt><dd>
474          <table><thead><tr><th scope=row>Oppotunistic Caching Namespace</th>
475          <th scope=row>Fallback Entry</tr><tbody>];
476      for my $uri (sort {$a cmp $b} keys %{$manifest->[1]}) {
477        my $euri = htescape ($uri);
478        my $euri2 = htescape ($manifest->[1]->{$uri});
479        print STDOUT qq[<tr><td><code class=uri>&lt;<a href="$euri">$euri</a>></code></td>
480            <td><code class=uri>&lt;<a href="$euri2">$euri2</a>></code></td>];
481      }
482    
483      print STDOUT qq[</table><dt>Online whitelist</dt>];
484      for my $uri (@{$manifest->[2]}) {
485        my $euri = htescape ($uri);
486        print STDOUT qq[<dd><code class=uri>&lt;<a href="$euri">$euri</a>></code></dd>];
487      }
488    
489      print STDOUT qq[</dl></div>];
490    } # print_structure_dump_manifest_section
491    
492    sub print_structure_error_dom_section ($$$) {
493      my ($doc, $el, $result) = @_;
494    
495    print STDOUT qq[<div id="document-errors" class="section">    print STDOUT qq[<div id="document-errors" class="section">
496  <h2>Document Errors</h2>  <h2>Document Errors</h2>
# Line 390  sub print_structure_error_section ($$) { Line 505  sub print_structure_error_section ($$) {
505      $type =~ tr/ /-/;      $type =~ tr/ /-/;
506      $type =~ s/\|/%7C/g;      $type =~ s/\|/%7C/g;
507      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
508      print STDOUT qq[<dt class="$cls">] . get_node_link ($opt{node}) .      print STDOUT qq[<dt class="$cls">] . get_error_label (\%opt) .
509          qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";          qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";
510        add_error ('structure', \%opt => $result);
511    };    };
512    
513    my $elements;    my $elements;
# Line 406  sub print_structure_error_section ($$) { Line 522  sub print_structure_error_section ($$) {
522    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
523    
524    return $elements;    return $elements;
525  } # print_structure_error_section  } # print_structure_error_dom_section
526    
527    sub print_structure_error_manifest_section ($$$) {
528      my ($manifest, $result) = @_;
529    
530      print STDOUT qq[<div id="document-errors" class="section">
531    <h2>Document Errors</h2>
532    
533    <dl>];
534      push @nav, ['#document-errors' => 'Document Error'];
535    
536      require Whatpm::CacheManifest;
537      Whatpm::CacheManifest->check_manifest ($manifest, sub {
538        my %opt = @_;
539        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level}, $opt{node});
540        $type =~ tr/ /-/;
541        $type =~ s/\|/%7C/g;
542        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
543        print STDOUT qq[<dt class="$cls">] . get_error_label (\%opt) .
544            qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";
545        add_error ('structure', \%opt => $result);
546      });
547    
548      print STDOUT qq[</div>];
549    } # print_structure_error_manifest_section
550    
551  sub print_table_section ($) {  sub print_table_section ($) {
552    my $tables = shift;    my $tables = shift;
# Line 524  sub print_class_section ($) { Line 664  sub print_class_section ($) {
664    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
665  } # print_class_section  } # print_class_section
666    
667    sub print_result_section ($) {
668      my $result = shift;
669    
670      print STDOUT qq[
671    <div id="result-summary" class="section">
672    <h2>Result</h2>];
673    
674      if ($result->{unsupported} and $result->{conforming_max}) {  
675        print STDOUT qq[<p class=uncertain id=result-para>The conformance
676            checker cannot decide whether the document is conforming or
677            not, since the document contains one or more unsupported
678            features.  The document might or might not be conforming.</p>];
679      } elsif ($result->{conforming_min}) {
680        print STDOUT qq[<p class=PASS id=result-para>No conformance-error is
681            found in this document.</p>];
682      } elsif ($result->{conforming_max}) {
683        print STDOUT qq[<p class=SEE-RESULT id=result-para>This document
684            is <strong>likely <em>non</em>-conforming</strong>, but in rare case
685            it might be conforming.</p>];
686      } else {
687        print STDOUT qq[<p class=FAIL id=result-para>This document is
688            <strong><em>non</em>-conforming</strong>.</p>];
689      }
690    
691      print STDOUT qq[<table>
692    <colgroup><col><colgroup><col><col><col><colgroup><col>
693    <thead>
694    <tr><th scope=col></th><th scope=col><em class=rfc2119>MUST</em>-level
695    Errors</th><th scope=col><em class=rfc2119>SHOULD</em>-level
696    Errors</th><th scope=col>Warnings</th><th scope=col>Score</th></tr>
697    </thead><tbody>];
698    
699      my $must_error = 0;
700      my $should_error = 0;
701      my $warning = 0;
702      my $score_min = 0;
703      my $score_max = 0;
704      my $score_base = 20;
705      my $score_unit = $score_base / 100;
706      for (
707        [Transfer => 'transfer', ''],
708        [Character => 'char', ''],
709        [Syntax => 'syntax', '#parse-errors'],
710        [Structure => 'structure', '#document-errors'],
711      ) {
712        $must_error += ($result->{$_->[1]}->{must} += 0);
713        $should_error += ($result->{$_->[1]}->{should} += 0);
714        $warning += ($result->{$_->[1]}->{warning} += 0);
715        $score_min += (($result->{$_->[1]}->{score_min} *= $score_unit) += $score_base);
716        $score_max += (($result->{$_->[1]}->{score_max} *= $score_unit) += $score_base);
717    
718        my $uncertain = $result->{$_->[1]}->{unsupported} ? '?' : '';
719        my $label = $_->[0];
720        if ($result->{$_->[1]}->{must} or
721            $result->{$_->[1]}->{should} or
722            $result->{$_->[1]}->{warning} or
723            $result->{$_->[1]}->{unsupported}) {
724          $label = qq[<a href="$_->[2]">$label</a>];
725        }
726    
727        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>];
728        if ($uncertain) {
729          print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : $result->{$_->[1]}->{should} ? 'SEE-RESULT' : '']}">&#x2212;&#x221E;..$result->{$_->[1]}->{score_max}</td>];
730        } elsif ($result->{$_->[1]}->{score_min} != $result->{$_->[1]}->{score_max}) {
731          print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : 'SEE-RESULT']}">$result->{$_->[1]}->{score_min}..$result->{$_->[1]}->{score_max}</td></tr>];
732        } else {
733          print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : '']}">$result->{$_->[1]}->{score_min}</td></tr>];
734        }
735      }
736    
737      $score_max += $score_base;
738    
739      print STDOUT qq[
740    <tr class=uncertain><th scope=row>Semantics</th><td>0?</td><td>0?</td><td>0?</td><td>&#x2212;&#x221E;..$score_base</td></tr>
741    </tbody>
742    <tfoot><tr class=uncertain><th scope=row>Total</th>
743    <td class="@{[$must_error ? 'FAIL' : '']}">$must_error?</td>
744    <td class="@{[$should_error ? 'SEE-RESULT' : '']}">$should_error?</td>
745    <td>$warning?</td>
746    <td class="@{[$must_error ? 'FAIL' : $should_error ? 'SEE-RESULT' : '']}"><strong>&#x2212;&#x221E;..$score_max</strong></td></tr></tfoot>
747    </table>
748    
749    <p><strong>Important</strong>: This conformance checking service
750    is <em>under development</em>.  The result above might be <em>wrong</em>.</p>
751    </div>];
752      push @nav, ['#result-summary' => 'Result'];
753    } # print_result_section
754    
755  sub print_result_unknown_type_section ($) {  sub print_result_unknown_type_section ($) {
756    my $input = shift;    my $input = shift;
757    
# Line 543  sub print_result_input_error_section ($) Line 771  sub print_result_input_error_section ($)
771    push @nav, ['#result-summary' => 'Result'];    push @nav, ['#result-summary' => 'Result'];
772  } # print_Result_input_error_section  } # print_Result_input_error_section
773    
774    sub get_error_label ($) {
775      my $err = shift;
776    
777      my $r = '';
778    
779      if (defined $err->{line}) {
780        if ($err->{column} > 0) {
781          $r = qq[<a href="#line-$err->{line}">Line $err->{line}</a> column $err->{column}];
782        } else {
783          $err->{line} = $err->{line} - 1 || 1;
784          $r = qq[<a href="#line-$err->{line}">Line $err->{line}</a>];
785        }
786      }
787    
788      if (defined $err->{node}) {
789        $r .= ' ' if length $r;
790        $r = get_node_path ($err->{node});
791      }
792    
793      if (defined $err->{index}) {
794        $r .= ' ' if length $r;
795        $r .= 'Index ' . (0+$err->{index});
796      }
797    
798      if (defined $err->{value}) {
799        $r .= ' ' if length $r;
800        $r .= '<q><code>' . htescape ($err->{value}) . '</code></q>';
801      }
802    
803      return $r;
804    } # get_error_label
805    
806  sub get_node_path ($) {  sub get_node_path ($) {
807    my $node = shift;    my $node = shift;
808    my @r;    my @r;
# Line 691  EOH Line 951  EOH
951        if (defined $ct and $ct =~ m#^([0-9A-Za-z._+-]+/[0-9A-Za-z._+-]+)#) {        if (defined $ct and $ct =~ m#^([0-9A-Za-z._+-]+/[0-9A-Za-z._+-]+)#) {
952          $r->{media_type} = lc $1;          $r->{media_type} = lc $1;
953        }        }
954        if (defined $ct and $ct =~ /;\s*charset\s*=\s*"?(\S+)"?/i) {        if (defined $ct and $ct =~ /;\s*charset\s*=\s*"?([^\s;"]+)"?/i) {
955          $r->{charset} = lc $1;          $r->{charset} = lc $1;
956          $r->{charset} =~ tr/\\//d;          $r->{charset} =~ tr/\\//d;
957        }        }
Legend:
Removed from v.1.18  
changed lines
  Added in v.1.22
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24