/[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.19 by wakaba, Mon Sep 10 11:51:09 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    my $result = {};    my $result = {conforming_min => 1, conforming_max => 1};
87    print_http_header_section ($input, $result);    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, $result);      ($doc, $el) = print_syntax_error_html_section ($input, $result);
# Line 102  if (defined $input->{s}) { Line 103  if (defined $input->{s}) {
103             }->{$input->{media_type}}) {             }->{$input->{media_type}}) {
104      ($doc, $el) = print_syntax_error_xml_section ($input, $result);      ($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, $result);      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    print_result_section ($result);    print_result_section ($result);
# Line 134  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 297  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 399  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 411  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_dump_manifest_section ($) {
459      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  sub print_structure_error_section ($$$) {    print STDOUT qq[</dl></div>];
490    } # print_structure_dump_manifest_section
491    
492    sub print_structure_error_dom_section ($$$) {
493    my ($doc, $el, $result) = @_;    my ($doc, $el, $result) = @_;
494    
495    print STDOUT qq[<div id="document-errors" class="section">    print STDOUT qq[<div id="document-errors" class="section">
# Line 429  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);      add_error ('structure', \%opt => $result);
511    };    };
# Line 446  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 571  sub print_result_section ($) { Line 671  sub print_result_section ($) {
671  <div id="result-summary" class="section">  <div id="result-summary" class="section">
672  <h2>Result</h2>];  <h2>Result</h2>];
673    
674    if ($result->{unsupported}) {      if ($result->{unsupported} and $result->{conforming_max}) {  
675      print STDOUT qq[<p class=uncertain id=result-para>The conformance      print STDOUT qq[<p class=uncertain id=result-para>The conformance
676          checker cannot decide whether the document is conforming or          checker cannot decide whether the document is conforming or
677          not, since the document contains one or more unsupported          not, since the document contains one or more unsupported
678          features.</p>];          features.  The document might or might not be conforming.</p>];
679    } elsif ($result->{conforming_min}) {    } elsif ($result->{conforming_min}) {
680      print STDOUT qq[<p class=PASS id=result-para>No conformance-error is      print STDOUT qq[<p class=PASS id=result-para>No conformance-error is
681          found in this document.</p>];          found in this document.</p>];
# Line 602  Errors</th><th scope=col>Warnings</th><t Line 702  Errors</th><th scope=col>Warnings</th><t
702    my $score_min = 0;    my $score_min = 0;
703    my $score_max = 0;    my $score_max = 0;
704    my $score_base = 20;    my $score_base = 20;
705      my $score_unit = $score_base / 100;
706    for (    for (
707      [Transfer => 'transfer', ''],      [Transfer => 'transfer', ''],
708      [Character => 'char', ''],      [Character => 'char', ''],
# Line 611  Errors</th><th scope=col>Warnings</th><t Line 712  Errors</th><th scope=col>Warnings</th><t
712      $must_error += ($result->{$_->[1]}->{must} += 0);      $must_error += ($result->{$_->[1]}->{must} += 0);
713      $should_error += ($result->{$_->[1]}->{should} += 0);      $should_error += ($result->{$_->[1]}->{should} += 0);
714      $warning += ($result->{$_->[1]}->{warning} += 0);      $warning += ($result->{$_->[1]}->{warning} += 0);
715      $score_min += ($result->{$_->[1]}->{score_min} += $score_base);      $score_min += (($result->{$_->[1]}->{score_min} *= $score_unit) += $score_base);
716      $score_max += ($result->{$_->[1]}->{score_max} += $score_base);      $score_max += (($result->{$_->[1]}->{score_max} *= $score_unit) += $score_base);
717    
718      my $uncertain = $result->{$_->[1]}->{unsupported} ? '?' : '';      my $uncertain = $result->{$_->[1]}->{unsupported} ? '?' : '';
719      my $label = $_->[0];      my $label = $_->[0];
# Line 625  Errors</th><th scope=col>Warnings</th><t Line 726  Errors</th><th scope=col>Warnings</th><t
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>];      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) {      if ($uncertain) {
729        print qq[<td class="@{[$score_max < $score_base ? $score_min < $score_max ? 'FAIL' : 'SEE-RESULT' : '']}">&#x2212;&#x221E;..$result->{$_->[1]}->{score_max}</td>];        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}) {      } elsif ($result->{$_->[1]}->{score_min} != $result->{$_->[1]}->{score_max}) {
731        print qq[<td class="@{[$score_max < $score_base ? 'FAIL' : 'SEE-RESULT']}">$result->{$_->[1]}->{score_min}..$result->{$_->[1]}->{score_max} + $score_base</td></tr>];        print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : 'SEE-RESULT']}">$result->{$_->[1]}->{score_min}..$result->{$_->[1]}->{score_max}</td></tr>];
732      } else {      } else {
733        print qq[<td class="@{[$score_max < $score_base ? 'FAIL' : '']}">$result->{$_->[1]}->{score_min}</td></tr>];        print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : '']}">$result->{$_->[1]}->{score_min}</td></tr>];
734      }      }
735    }    }
736    
# Line 638  Errors</th><th scope=col>Warnings</th><t Line 739  Errors</th><th scope=col>Warnings</th><t
739    print STDOUT qq[    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>  <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>  </tbody>
742  <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>  <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>  </table>
748    
749  <p><strong>Important</strong>: This conformance checking service  <p><strong>Important</strong>: This conformance checking service
# Line 666  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 814  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.19  
changed lines
  Added in v.1.22
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24