/[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.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    print_http_header_section ($input);    my $result = {conforming_min => 1, conforming_max => 1};
88      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);      ($doc, $el) = print_syntax_error_html_section ($input, $result);
96      print_source_string_section (\($input->{s}), $input->{charset});      print_source_string_section (\($input->{s}), $input->{charset});
97    } elsif ({    } elsif ({
98              'text/xml' => 1,              'text/xml' => 1,
# Line 99  if (defined $input->{s}) { Line 102  if (defined $input->{s}) {
102              'application/xhtml+xml' => 1,              'application/xhtml+xml' => 1,
103              'application/xml' => 1,              'application/xml' => 1,
104             }->{$input->{media_type}}) {             }->{$input->{media_type}}) {
105      ($doc, $el) = print_syntax_error_xml_section ($input);      ($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);      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    ## TODO: Show result    print_result_section ($result);
129  } else {  } else {
130    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
131    print_result_input_error_section ($input);    print_result_input_error_section ($input);
# Line 133  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 141  if (defined $input->{s}) { Line 151  if (defined $input->{s}) {
151    
152  exit;  exit;
153    
154  sub print_http_header_section ($) {  sub add_error ($$$) {
155    my $input = shift;    my ($layer, $err, $result) = @_;
156      if (defined $err->{level}) {
157        if ($err->{level} eq 's') {
158          $result->{$layer}->{should}++;
159          $result->{$layer}->{score_min} -= 2;
160          $result->{conforming_min} = 0;
161        } elsif ($err->{level} eq 'w' or $err->{level} eq 'g') {
162          $result->{$layer}->{warning}++;
163        } elsif ($err->{level} eq 'unsupported') {
164          $result->{$layer}->{unsupported}++;
165          $result->{unsupported} = 1;
166        } else {
167          $result->{$layer}->{must}++;
168          $result->{$layer}->{score_max} -= 2;
169          $result->{$layer}->{score_min} -= 2;
170          $result->{conforming_min} = 0;
171          $result->{conforming_max} = 0;
172        }
173      } else {
174        $result->{$layer}->{must}++;
175        $result->{$layer}->{score_max} -= 2;
176        $result->{$layer}->{score_min} -= 2;
177        $result->{conforming_min} = 0;
178        $result->{conforming_max} = 0;
179      }
180    } # add_error
181    
182    sub print_http_header_section ($$) {
183      my ($input, $result) = @_;
184    return unless defined $input->{header_status_code} or    return unless defined $input->{header_status_code} or
185        defined $input->{header_status_text} or        defined $input->{header_status_text} or
186        @{$input->{header_field}};        @{$input->{header_field}};
# Line 175  not be the real header.</p> Line 213  not be the real header.</p>
213    print STDOUT qq[</tbody></table></div>];    print STDOUT qq[</tbody></table></div>];
214  } # print_http_header_section  } # print_http_header_section
215    
216  sub print_syntax_error_html_section ($) {  sub print_syntax_error_html_section ($$) {
217    my $input = shift;    my ($input, $result) = @_;
218        
219    require Encode;    require Encode;
220    require Whatpm::HTML;    require Whatpm::HTML;
# Line 206  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);
251    };    };
252    
253    my $doc = $dom->create_document;    my $doc = $dom->create_document;
# Line 226  sub print_syntax_error_html_section ($) Line 267  sub print_syntax_error_html_section ($)
267    return ($doc, $el);    return ($doc, $el);
268  } # print_syntax_error_html_section  } # print_syntax_error_html_section
269    
270  sub print_syntax_error_xml_section ($) {  sub print_syntax_error_xml_section ($$) {
271    my $input = shift;    my ($input, $result) = @_;
272        
273    require Message::DOM::XMLParserTemp;    require Message::DOM::XMLParserTemp;
274        
# Line 244  sub print_syntax_error_xml_section ($) { Line 285  sub print_syntax_error_xml_section ($) {
285      print STDOUT qq[<dt><a href="#line-$line">Line $line</a> column ];      print STDOUT qq[<dt><a href="#line-$line">Line $line</a> column ];
286      print STDOUT $err->location->column_number, "</dt><dd>";      print STDOUT $err->location->column_number, "</dt><dd>";
287      print STDOUT htescape $err->text, "</dd>\n";      print STDOUT htescape $err->text, "</dd>\n";
288    
289        add_error ('syntax', {type => $err->text,
290                    level => [
291                              $err->SEVERITY_FATAL_ERROR => 'm',
292                              $err->SEVERITY_ERROR => 'm',
293                              $err->SEVERITY_WARNING => 's',
294                             ]->[$err->severity]} => $result);
295    
296      return 1;      return 1;
297    };    };
298    
# Line 258  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 360  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 372  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_error_section ($$) {  sub print_structure_dump_manifest_section ($) {
462    my ($doc, $el) = @_;    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_dom_section ($$$) {
496      my ($doc, $el, $result) = @_;
497    
498    print STDOUT qq[<div id="document-errors" class="section">    print STDOUT qq[<div id="document-errors" class="section">
499  <h2>Document Errors</h2>  <h2>Document Errors</h2>
# Line 390  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);
515    };    };
516    
517    my $elements;    my $elements;
# Line 406  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 524  sub print_class_section ($) { Line 668  sub print_class_section ($) {
668    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
669  } # print_class_section  } # print_class_section
670    
671    sub print_result_section ($) {
672      my $result = shift;
673    
674      print STDOUT qq[
675    <div id="result-summary" class="section">
676    <h2>Result</h2>];
677    
678      if ($result->{unsupported} and $result->{conforming_max}) {  
679        print STDOUT qq[<p class=uncertain id=result-para>The conformance
680            checker cannot decide whether the document is conforming or
681            not, since the document contains one or more unsupported
682            features.  The document might or might not be conforming.</p>];
683      } elsif ($result->{conforming_min}) {
684        print STDOUT qq[<p class=PASS id=result-para>No conformance-error is
685            found in this document.</p>];
686      } elsif ($result->{conforming_max}) {
687        print STDOUT qq[<p class=SEE-RESULT id=result-para>This document
688            is <strong>likely <em>non</em>-conforming</strong>, but in rare case
689            it might be conforming.</p>];
690      } else {
691        print STDOUT qq[<p class=FAIL id=result-para>This document is
692            <strong><em>non</em>-conforming</strong>.</p>];
693      }
694    
695      print STDOUT qq[<table>
696    <colgroup><col><colgroup><col><col><col><colgroup><col>
697    <thead>
698    <tr><th scope=col></th>
699    <th scope=col><a href="../error-description#level-m"><em class=rfc2119>MUST</em>‐level
700    Errors</a></th>
701    <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;
707      my $should_error = 0;
708      my $warning = 0;
709      my $score_min = 0;
710      my $score_max = 0;
711      my $score_base = 20;
712      my $score_unit = $score_base / 100;
713      for (
714        [Transfer => 'transfer', ''],
715        [Character => 'char', ''],
716        [Syntax => 'syntax', '#parse-errors'],
717        [Structure => 'structure', '#document-errors'],
718      ) {
719        $must_error += ($result->{$_->[1]}->{must} += 0);
720        $should_error += ($result->{$_->[1]}->{should} += 0);
721        $warning += ($result->{$_->[1]}->{warning} += 0);
722        $score_min += (($result->{$_->[1]}->{score_min} *= $score_unit) += $score_base);
723        $score_max += (($result->{$_->[1]}->{score_max} *= $score_unit) += $score_base);
724    
725        my $uncertain = $result->{$_->[1]}->{unsupported} ? '?' : '';
726        my $label = $_->[0];
727        if ($result->{$_->[1]}->{must} or
728            $result->{$_->[1]}->{should} or
729            $result->{$_->[1]}->{warning} or
730            $result->{$_->[1]}->{unsupported}) {
731          $label = qq[<a href="$_->[2]">$label</a>];
732        }
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>];
735        if ($uncertain) {
736          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}) {
738          print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : 'SEE-RESULT']}">$result->{$_->[1]}->{score_min}..$result->{$_->[1]}->{score_max}</td></tr>];
739        } else {
740          print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : '']}">$result->{$_->[1]}->{score_min}</td></tr>];
741        }
742      }
743    
744      $score_max += $score_base;
745    
746      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>
748    </tbody>
749    <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>
755    
756    <p><strong>Important</strong>: This conformance checking service
757    is <em>under development</em>.  The result above might be <em>wrong</em>.</p>
758    </div>];
759      push @nav, ['#result-summary' => 'Result'];
760    } # print_result_section
761    
762  sub print_result_unknown_type_section ($) {  sub print_result_unknown_type_section ($) {
763    my $input = shift;    my $input = shift;
764    
# Line 543  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 691  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.18  
changed lines
  Added in v.1.23
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24