/[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.19 by wakaba, Mon Sep 10 11:51:09 2007 UTC revision 1.23 by wakaba, Mon Nov 5 09:33:52 2007 UTC
# Line 1  Line 1 
1  #!/usr/bin/perl  #!/usr/bin/perl
2  use strict;  use strict;
3    use utf8;
4    
5  use lib qw[/home/httpd/html/www/markup/html/whatpm  use lib qw[/home/httpd/html/www/markup/html/whatpm
6             /home/wakaba/work/manakai2/lib];             /home/wakaba/work/manakai2/lib];
# Line 83  if (defined $input->{s}) { Line 84  if (defined $input->{s}) {
84  </div>  </div>
85  ];  ];
86    
87    my $result = {};    my $result = {conforming_min => 1, conforming_max => 1};
88    print_http_header_section ($input, $result);    print_http_header_section ($input, $result);
89    
90    my $doc;    my $doc;
91    my $el;    my $el;
92      my $manifest;
93    
94    if ($input->{media_type} eq 'text/html') {    if ($input->{media_type} eq 'text/html') {
95      ($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 104  if (defined $input->{s}) {
104             }->{$input->{media_type}}) {             }->{$input->{media_type}}) {
105      ($doc, $el) = print_syntax_error_xml_section ($input, $result);      ($doc, $el) = print_syntax_error_xml_section ($input, $result);
106      print_source_string_section (\($input->{s}), $doc->input_encoding);      print_source_string_section (\($input->{s}), $doc->input_encoding);
107      } elsif ($input->{media_type} eq 'text/cache-manifest') {
108    ## TODO: MUST be text/cache-manifest
109        $manifest = print_syntax_error_manifest_section ($input, $result);
110        print_source_string_section (\($input->{s}), 'utf-8');
111    } else {    } else {
112      ## TODO: Change HTTP status code??      ## TODO: Change HTTP status code??
113      print_result_unknown_type_section ($input);      print_result_unknown_type_section ($input);
114    }    }
115    
116    if (defined $doc or defined $el) {    if (defined $doc or defined $el) {
117      print_structure_dump_section ($doc, $el);      print_structure_dump_dom_section ($doc, $el);
118      my $elements = print_structure_error_section ($doc, $el, $result);      my $elements = print_structure_error_dom_section ($doc, $el, $result);
119      print_table_section ($elements->{table}) if @{$elements->{table}};      print_table_section ($elements->{table}) if @{$elements->{table}};
120      print_id_section ($elements->{id}) if keys %{$elements->{id}};      print_id_section ($elements->{id}) if keys %{$elements->{id}};
121      print_term_section ($elements->{term}) if keys %{$elements->{term}};      print_term_section ($elements->{term}) if keys %{$elements->{term}};
122      print_class_section ($elements->{class}) if keys %{$elements->{class}};      print_class_section ($elements->{class}) if keys %{$elements->{class}};
123      } elsif (defined $manifest) {
124        print_structure_dump_manifest_section ($manifest);
125        print_structure_error_manifest_section ($manifest, $result);
126    }    }
127    
128    print_result_section ($result);    print_result_section ($result);
# Line 134  if (defined $input->{s}) { Line 143  if (defined $input->{s}) {
143  </html>  </html>
144  ];  ];
145    
146    for (qw/decode parse parse_xml check/) {    for (qw/decode parse parse_xml parse_manifest check check_manifest/) {
147      next unless defined $time{$_};      next unless defined $time{$_};
148      open my $file, '>>', ".cc-$_.txt" or die ".cc-$_.txt: $!";      open my $file, '>>', ".cc-$_.txt" or die ".cc-$_.txt: $!";
149      print $file $char_length, "\t", $time{$_}, "\n";      print $file $char_length, "\t", $time{$_}, "\n";
# Line 235  sub print_syntax_error_html_section ($$) Line 244  sub print_syntax_error_html_section ($$)
244      $type =~ tr/ /-/;      $type =~ tr/ /-/;
245      $type =~ s/\|/%7C/g;      $type =~ s/\|/%7C/g;
246      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
247      print STDOUT qq[<dd class="$cls">$msg</dd>\n];      print STDOUT qq[<dd class="$cls">], get_error_level_label (\%opt);
248        print STDOUT qq[$msg</dd>\n];
249    
250      add_error ('syntax', \%opt => $result);      add_error ('syntax', \%opt => $result);
251    };    };
# Line 297  sub print_syntax_error_xml_section ($$) Line 307  sub print_syntax_error_xml_section ($$)
307    return ($doc, undef);    return ($doc, undef);
308  } # print_syntax_error_xml_section  } # print_syntax_error_xml_section
309    
310    sub print_syntax_error_manifest_section ($$) {
311      my ($input, $result) = @_;
312    
313      require Whatpm::CacheManifest;
314    
315      print STDOUT qq[
316    <div id="parse-errors" class="section">
317    <h2>Parse Errors</h2>
318    
319    <dl>];
320      push @nav, ['#parse-errors' => 'Parse Error'];
321    
322      my $onerror = sub {
323        my (%opt) = @_;
324        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level});
325        print STDOUT qq[<dt class="$cls">], get_error_label (\%opt), qq[</dt>];
326        $type =~ tr/ /-/;
327        $type =~ s/\|/%7C/g;
328        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
329        print STDOUT qq[<dd class="$cls">], get_error_level_label (\%opt);
330        print STDOUT qq[$msg</dd>\n];
331    
332        add_error ('syntax', \%opt => $result);
333      };
334    
335      my $time1 = time;
336      my $manifest = Whatpm::CacheManifest->parse_byte_string
337          ($input->{s}, $input->{uri}, $input->{base_uri}, $onerror);
338      $time{parse_manifest} = time - $time1;
339    
340      print STDOUT qq[</dl></div>];
341    
342      return $manifest;
343    } # print_syntax_error_manifest_section
344    
345  sub print_source_string_section ($$) {  sub print_source_string_section ($$) {
346    require Encode;    require Encode;
347    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 444  sub print_document_tree ($) {
444    print STDOUT $r;    print STDOUT $r;
445  } # print_document_tree  } # print_document_tree
446    
447  sub print_structure_dump_section ($$) {  sub print_structure_dump_dom_section ($$) {
448    my ($doc, $el) = @_;    my ($doc, $el) = @_;
449    
450    print STDOUT qq[    print STDOUT qq[
# Line 411  sub print_structure_dump_section ($$) { Line 456  sub print_structure_dump_section ($$) {
456    print_document_tree ($el || $doc);    print_document_tree ($el || $doc);
457    
458    print STDOUT qq[</div>];    print STDOUT qq[</div>];
459  } # print_structure_dump_section  } # print_structure_dump_dom_section
460    
461    sub print_structure_dump_manifest_section ($) {
462      my $manifest = shift;
463    
464      print STDOUT qq[
465    <div id="dump-manifest" class="section">
466    <h2>Cache Manifest</h2>
467    ];
468      push @nav, ['#dump-manifest' => 'Caceh Manifest'];
469    
470      print STDOUT qq[<dl><dt>Explicit entries</dt>];
471      for my $uri (@{$manifest->[0]}) {
472        my $euri = htescape ($uri);
473        print STDOUT qq[<dd><code class=uri>&lt;<a href="$euri">$euri</a>></code></dd>];
474      }
475    
476      print STDOUT qq[<dt>Fallback entries</dt><dd>
477          <table><thead><tr><th scope=row>Oppotunistic Caching Namespace</th>
478          <th scope=row>Fallback Entry</tr><tbody>];
479      for my $uri (sort {$a cmp $b} keys %{$manifest->[1]}) {
480        my $euri = htescape ($uri);
481        my $euri2 = htescape ($manifest->[1]->{$uri});
482        print STDOUT qq[<tr><td><code class=uri>&lt;<a href="$euri">$euri</a>></code></td>
483            <td><code class=uri>&lt;<a href="$euri2">$euri2</a>></code></td>];
484      }
485    
486      print STDOUT qq[</table><dt>Online whitelist</dt>];
487      for my $uri (@{$manifest->[2]}) {
488        my $euri = htescape ($uri);
489        print STDOUT qq[<dd><code class=uri>&lt;<a href="$euri">$euri</a>></code></dd>];
490      }
491    
492      print STDOUT qq[</dl></div>];
493    } # print_structure_dump_manifest_section
494    
495  sub print_structure_error_section ($$$) {  sub print_structure_error_dom_section ($$$) {
496    my ($doc, $el, $result) = @_;    my ($doc, $el, $result) = @_;
497    
498    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 508  sub print_structure_error_section ($$$)
508      $type =~ tr/ /-/;      $type =~ tr/ /-/;
509      $type =~ s/\|/%7C/g;      $type =~ s/\|/%7C/g;
510      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
511      print STDOUT qq[<dt class="$cls">] . get_node_link ($opt{node}) .      print STDOUT qq[<dt class="$cls">] . get_error_label (\%opt) .
512          qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";          qq[</dt>\n<dd class="$cls">], get_error_level_label (\%opt);
513        print STDOUT $msg, "</dd>\n";
514      add_error ('structure', \%opt => $result);      add_error ('structure', \%opt => $result);
515    };    };
516    
# Line 446  sub print_structure_error_section ($$$) Line 526  sub print_structure_error_section ($$$)
526    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
527    
528    return $elements;    return $elements;
529  } # print_structure_error_section  } # print_structure_error_dom_section
530    
531    sub print_structure_error_manifest_section ($$$) {
532      my ($manifest, $result) = @_;
533    
534      print STDOUT qq[<div id="document-errors" class="section">
535    <h2>Document Errors</h2>
536    
537    <dl>];
538      push @nav, ['#document-errors' => 'Document Error'];
539    
540      require Whatpm::CacheManifest;
541      Whatpm::CacheManifest->check_manifest ($manifest, sub {
542        my %opt = @_;
543        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level}, $opt{node});
544        $type =~ tr/ /-/;
545        $type =~ s/\|/%7C/g;
546        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
547        print STDOUT qq[<dt class="$cls">] . get_error_label (\%opt) .
548            qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";
549        add_error ('structure', \%opt => $result);
550      });
551    
552      print STDOUT qq[</div>];
553    } # print_structure_error_manifest_section
554    
555  sub print_table_section ($) {  sub print_table_section ($) {
556    my $tables = shift;    my $tables = shift;
# Line 571  sub print_result_section ($) { Line 675  sub print_result_section ($) {
675  <div id="result-summary" class="section">  <div id="result-summary" class="section">
676  <h2>Result</h2>];  <h2>Result</h2>];
677    
678    if ($result->{unsupported}) {      if ($result->{unsupported} and $result->{conforming_max}) {  
679      print STDOUT qq[<p class=uncertain id=result-para>The conformance      print STDOUT qq[<p class=uncertain id=result-para>The conformance
680          checker cannot decide whether the document is conforming or          checker cannot decide whether the document is conforming or
681          not, since the document contains one or more unsupported          not, since the document contains one or more unsupported
682          features.</p>];          features.  The document might or might not be conforming.</p>];
683    } elsif ($result->{conforming_min}) {    } elsif ($result->{conforming_min}) {
684      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
685          found in this document.</p>];          found in this document.</p>];
# Line 591  sub print_result_section ($) { Line 695  sub print_result_section ($) {
695    print STDOUT qq[<table>    print STDOUT qq[<table>
696  <colgroup><col><colgroup><col><col><col><colgroup><col>  <colgroup><col><colgroup><col><col><col><colgroup><col>
697  <thead>  <thead>
698  <tr><th scope=col></th><th scope=col><em class=rfc2119>MUST</em>-level  <tr><th scope=col></th>
699  Errors</th><th scope=col><em class=rfc2119>SHOULD</em>-level  <th scope=col><a href="../error-description#level-m"><em class=rfc2119>MUST</em>‐level
700  Errors</th><th scope=col>Warnings</th><th scope=col>Score</th></tr>  Errors</a></th>
701  </thead><tbody>];  <th scope=col><a href="../error-description#level-s"><em class=rfc2119>SHOULD</em>‐level
702    Errors</a></th>
703    <th scope=col><a href="../error-description#level-w">Warnings</a></th>
704    <th scope=col>Score</th></tr></thead><tbody>];
705    
706    my $must_error = 0;    my $must_error = 0;
707    my $should_error = 0;    my $should_error = 0;
# Line 602  Errors</th><th scope=col>Warnings</th><t Line 709  Errors</th><th scope=col>Warnings</th><t
709    my $score_min = 0;    my $score_min = 0;
710    my $score_max = 0;    my $score_max = 0;
711    my $score_base = 20;    my $score_base = 20;
712      my $score_unit = $score_base / 100;
713    for (    for (
714      [Transfer => 'transfer', ''],      [Transfer => 'transfer', ''],
715      [Character => 'char', ''],      [Character => 'char', ''],
# Line 611  Errors</th><th scope=col>Warnings</th><t Line 719  Errors</th><th scope=col>Warnings</th><t
719      $must_error += ($result->{$_->[1]}->{must} += 0);      $must_error += ($result->{$_->[1]}->{must} += 0);
720      $should_error += ($result->{$_->[1]}->{should} += 0);      $should_error += ($result->{$_->[1]}->{should} += 0);
721      $warning += ($result->{$_->[1]}->{warning} += 0);      $warning += ($result->{$_->[1]}->{warning} += 0);
722      $score_min += ($result->{$_->[1]}->{score_min} += $score_base);      $score_min += (($result->{$_->[1]}->{score_min} *= $score_unit) += $score_base);
723      $score_max += ($result->{$_->[1]}->{score_max} += $score_base);      $score_max += (($result->{$_->[1]}->{score_max} *= $score_unit) += $score_base);
724    
725      my $uncertain = $result->{$_->[1]}->{unsupported} ? '?' : '';      my $uncertain = $result->{$_->[1]}->{unsupported} ? '?' : '';
726      my $label = $_->[0];      my $label = $_->[0];
# Line 625  Errors</th><th scope=col>Warnings</th><t Line 733  Errors</th><th scope=col>Warnings</th><t
733    
734      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>];
735      if ($uncertain) {      if ($uncertain) {
736        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>];
737      } elsif ($result->{$_->[1]}->{score_min} != $result->{$_->[1]}->{score_max}) {      } elsif ($result->{$_->[1]}->{score_min} != $result->{$_->[1]}->{score_max}) {
738        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>];
739      } else {      } else {
740        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>];
741      }      }
742    }    }
743    
# Line 638  Errors</th><th scope=col>Warnings</th><t Line 746  Errors</th><th scope=col>Warnings</th><t
746    print STDOUT qq[    print STDOUT qq[
747  <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>
748  </tbody>  </tbody>
749  <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>
750    <td class="@{[$must_error ? 'FAIL' : '']}">$must_error?</td>
751    <td class="@{[$should_error ? 'SEE-RESULT' : '']}">$should_error?</td>
752    <td>$warning?</td>
753    <td class="@{[$must_error ? 'FAIL' : $should_error ? 'SEE-RESULT' : '']}"><strong>&#x2212;&#x221E;..$score_max</strong></td></tr></tfoot>
754  </table>  </table>
755    
756  <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 778  sub print_result_input_error_section ($)
778    push @nav, ['#result-summary' => 'Result'];    push @nav, ['#result-summary' => 'Result'];
779  } # print_Result_input_error_section  } # print_Result_input_error_section
780    
781    sub get_error_label ($) {
782      my $err = shift;
783    
784      my $r = '';
785    
786      if (defined $err->{line}) {
787        if ($err->{column} > 0) {
788          $r = qq[<a href="#line-$err->{line}">Line $err->{line}</a> column $err->{column}];
789        } else {
790          $err->{line} = $err->{line} - 1 || 1;
791          $r = qq[<a href="#line-$err->{line}">Line $err->{line}</a>];
792        }
793      }
794    
795      if (defined $err->{node}) {
796        $r .= ' ' if length $r;
797        $r = get_node_link ($err->{node});
798      }
799    
800      if (defined $err->{index}) {
801        $r .= ' ' if length $r;
802        $r .= 'Index ' . (0+$err->{index});
803      }
804    
805      if (defined $err->{value}) {
806        $r .= ' ' if length $r;
807        $r .= '<q><code>' . htescape ($err->{value}) . '</code></q>';
808      }
809    
810      return $r;
811    } # get_error_label
812    
813    sub get_error_level_label ($) {
814      my $err = shift;
815    
816      my $r = '';
817    
818      if (not defined $err->{level} or $err->{level} eq 'm') {
819        $r = qq[<strong><a href="../error-description#level-m"><em class=rfc2119>MUST</em>‐level
820            error</a></strong>: ];
821      } elsif ($err->{level} eq 's') {
822        $r = qq[<strong><a href="../error-description#level-s"><em class=rfc2119>SHOULD</em>‐level
823            error</a></strong>: ];
824      } elsif ($err->{level} eq 'w') {
825        $r = qq[<strong><a href="../error-description#level-w">Warning</a></strong>:
826            ];
827      } elsif ($err->{level} eq 'unsupported') {
828        $r = qq[<strong><a href="../error-description#level-u">Not
829            supported</a></strong>: ];
830      } else {
831        my $elevel = htescape ($err->{level});
832        $r = qq[<strong><a href="../error-description#level-$elevel">$elevel</a></strong>:
833            ];
834      }
835    
836      return $r;
837    } # get_error_level_label
838    
839  sub get_node_path ($) {  sub get_node_path ($) {
840    my $node = shift;    my $node = shift;
841    my @r;    my @r;
# Line 814  EOH Line 984  EOH
984        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._+-]+)#) {
985          $r->{media_type} = lc $1;          $r->{media_type} = lc $1;
986        }        }
987        if (defined $ct and $ct =~ /;\s*charset\s*=\s*"?(\S+)"?/i) {        if (defined $ct and $ct =~ /;\s*charset\s*=\s*"?([^\s;"]+)"?/i) {
988          $r->{charset} = lc $1;          $r->{charset} = lc $1;
989          $r->{charset} =~ tr/\\//d;          $r->{charset} =~ tr/\\//d;
990        }        }
Legend:
Removed from v.1.19  
changed lines
  Added in v.1.23
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24