/[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.25 by wakaba, Sun Nov 18 05:30:03 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 61  sub htescape ($) { Line 62  sub htescape ($) {
62  <dt>Request URI</dt>  <dt>Request URI</dt>
63      <dd><code class="URI" lang="">&lt;<a href="@{[htescape $input->{request_uri}]}">@{[htescape $input->{request_uri}]}</a>&gt;</code></dd>      <dd><code class="URI" lang="">&lt;<a href="@{[htescape $input->{request_uri}]}">@{[htescape $input->{request_uri}]}</a>&gt;</code></dd>
64  <dt>Document URI</dt>  <dt>Document URI</dt>
65      <dd><code class="URI" lang="">&lt;<a href="@{[htescape $input->{uri}]}">@{[htescape $input->{uri}]}</a>&gt;</code></dd>      <dd><code class="URI" lang="">&lt;<a href="@{[htescape $input->{uri}]}" id=anchor-document-uri>@{[htescape $input->{uri}]}</a>&gt;</code>
66        <script>
67          document.title = '<'
68              + document.getElementById ('anchor-document-uri').href + '> \\u2014 '
69              + document.title;
70        </script></dd>
71  ]; # no </dl> yet  ]; # no </dl> yet
72    push @nav, ['#document-info' => 'Information'];    push @nav, ['#document-info' => 'Information'];
73    
# Line 73  if (defined $input->{s}) { Line 79  if (defined $input->{s}) {
79      <dd><code class="URI" lang="">&lt;<a href="@{[htescape $input->{base_uri}]}">@{[htescape $input->{base_uri}]}</a>&gt;</code></dd>      <dd><code class="URI" lang="">&lt;<a href="@{[htescape $input->{base_uri}]}">@{[htescape $input->{base_uri}]}</a>&gt;</code></dd>
80  <dt>Internet Media Type</dt>  <dt>Internet Media Type</dt>
81      <dd><code class="MIME" lang="en">@{[htescape $input->{media_type}]}</code>      <dd><code class="MIME" lang="en">@{[htescape $input->{media_type}]}</code>
82      @{[$input->{media_type_overridden} ? '<em>(overridden)</em>' : '']}</dd>      @{[$input->{media_type_overridden} ? '<em>(overridden)</em>' : defined $input->{official_type} ? $input->{media_type} eq $input->{official_type} ? '' : '<em>(sniffed; official type is: <code class=MIME lang=en>'.htescape ($input->{official_type}).'</code>)' : '<em>(sniffed)</em>']}</dd>
83  <dt>Character Encoding</dt>  <dt>Character Encoding</dt>
84      <dd>@{[defined $input->{charset} ? '<code class="charset" lang="en">'.htescape ($input->{charset}).'</code>' : '(none)']}      <dd>@{[defined $input->{charset} ? '<code class="charset" lang="en">'.htescape ($input->{charset}).'</code>' : '(none)']}
85      @{[$input->{charset_overridden} ? '<em>(overridden)</em>' : '']}</dd>      @{[$input->{charset_overridden} ? '<em>(overridden)</em>' : '']}</dd>
# Line 83  if (defined $input->{s}) { Line 89  if (defined $input->{s}) {
89  </div>  </div>
90  ];  ];
91    
92    print_http_header_section ($input);    my $result = {conforming_min => 1, conforming_max => 1};
93      print_http_header_section ($input, $result);
94    
95    my $doc;    my $doc;
96    my $el;    my $el;
97      my $manifest;
98    
99    if ($input->{media_type} eq 'text/html') {    if ($input->{media_type} eq 'text/html') {
100      ($doc, $el) = print_syntax_error_html_section ($input);      ($doc, $el) = print_syntax_error_html_section ($input, $result);
101      print_source_string_section (\($input->{s}), $input->{charset});      print_source_string_section
102            (\($input->{s}), $input->{charset} || $doc->input_encoding);
103    } elsif ({    } elsif ({
104              'text/xml' => 1,              'text/xml' => 1,
105              'application/atom+xml' => 1,              'application/atom+xml' => 1,
# Line 99  if (defined $input->{s}) { Line 108  if (defined $input->{s}) {
108              'application/xhtml+xml' => 1,              'application/xhtml+xml' => 1,
109              'application/xml' => 1,              'application/xml' => 1,
110             }->{$input->{media_type}}) {             }->{$input->{media_type}}) {
111      ($doc, $el) = print_syntax_error_xml_section ($input);      ($doc, $el) = print_syntax_error_xml_section ($input, $result);
112      print_source_string_section (\($input->{s}), $doc->input_encoding);      print_source_string_section (\($input->{s}), $doc->input_encoding);
113      } elsif ($input->{media_type} eq 'text/cache-manifest') {
114    ## TODO: MUST be text/cache-manifest
115        $manifest = print_syntax_error_manifest_section ($input, $result);
116        print_source_string_section (\($input->{s}), 'utf-8');
117    } else {    } else {
118      ## TODO: Change HTTP status code??      ## TODO: Change HTTP status code??
119      print_result_unknown_type_section ($input);      print_result_unknown_type_section ($input, $result);
120    }    }
121    
122    if (defined $doc or defined $el) {    if (defined $doc or defined $el) {
123      print_structure_dump_section ($doc, $el);      print_structure_dump_dom_section ($doc, $el);
124      my $elements = print_structure_error_section ($doc, $el);      my $elements = print_structure_error_dom_section ($doc, $el, $result);
125      print_table_section ($elements->{table}) if @{$elements->{table}};      print_table_section ($elements->{table}) if @{$elements->{table}};
126      print_id_section ($elements->{id}) if keys %{$elements->{id}};      print_id_section ($elements->{id}) if keys %{$elements->{id}};
127      print_term_section ($elements->{term}) if keys %{$elements->{term}};      print_term_section ($elements->{term}) if keys %{$elements->{term}};
128      print_class_section ($elements->{class}) if keys %{$elements->{class}};      print_class_section ($elements->{class}) if keys %{$elements->{class}};
129      } elsif (defined $manifest) {
130        print_structure_dump_manifest_section ($manifest);
131        print_structure_error_manifest_section ($manifest, $result);
132    }    }
133    
134    ## TODO: Show result    print_result_section ($result);
135  } else {  } else {
136    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
137    print_result_input_error_section ($input);    print_result_input_error_section ($input);
# Line 133  if (defined $input->{s}) { Line 149  if (defined $input->{s}) {
149  </html>  </html>
150  ];  ];
151    
152    for (qw/decode parse parse_xml check/) {    for (qw/decode parse parse_html parse_xml parse_manifest
153              check check_manifest/) {
154      next unless defined $time{$_};      next unless defined $time{$_};
155      open my $file, '>>', ".cc-$_.txt" or die ".cc-$_.txt: $!";      open my $file, '>>', ".cc-$_.txt" or die ".cc-$_.txt: $!";
156      print $file $char_length, "\t", $time{$_}, "\n";      print $file $char_length, "\t", $time{$_}, "\n";
# Line 141  if (defined $input->{s}) { Line 158  if (defined $input->{s}) {
158    
159  exit;  exit;
160    
161  sub print_http_header_section ($) {  sub add_error ($$$) {
162    my $input = shift;    my ($layer, $err, $result) = @_;
163      if (defined $err->{level}) {
164        if ($err->{level} eq 's') {
165          $result->{$layer}->{should}++;
166          $result->{$layer}->{score_min} -= 2;
167          $result->{conforming_min} = 0;
168        } elsif ($err->{level} eq 'w' or $err->{level} eq 'g') {
169          $result->{$layer}->{warning}++;
170        } elsif ($err->{level} eq 'unsupported') {
171          $result->{$layer}->{unsupported}++;
172          $result->{unsupported} = 1;
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      } else {
181        $result->{$layer}->{must}++;
182        $result->{$layer}->{score_max} -= 2;
183        $result->{$layer}->{score_min} -= 2;
184        $result->{conforming_min} = 0;
185        $result->{conforming_max} = 0;
186      }
187    } # add_error
188    
189    sub print_http_header_section ($$) {
190      my ($input, $result) = @_;
191    return unless defined $input->{header_status_code} or    return unless defined $input->{header_status_code} or
192        defined $input->{header_status_text} or        defined $input->{header_status_text} or
193        @{$input->{header_field}};        @{$input->{header_field}};
# Line 175  not be the real header.</p> Line 220  not be the real header.</p>
220    print STDOUT qq[</tbody></table></div>];    print STDOUT qq[</tbody></table></div>];
221  } # print_http_header_section  } # print_http_header_section
222    
223  sub print_syntax_error_html_section ($) {  sub print_syntax_error_html_section ($$) {
224    my $input = shift;    my ($input, $result) = @_;
225        
226    require Encode;    require Encode;
227    require Whatpm::HTML;    require Whatpm::HTML;
   
   $input->{charset} ||= 'ISO-8859-1'; ## TODO: for now.  
228        
   my $time1 = time;  
   my $t = Encode::decode ($input->{charset}, $input->{s});  
   $time{decode} = time - $time1;  
   
229    print STDOUT qq[    print STDOUT qq[
230  <div id="parse-errors" class="section">  <div id="parse-errors" class="section">
231  <h2>Parse Errors</h2>  <h2>Parse Errors</h2>
# Line 206  sub print_syntax_error_html_section ($) Line 245  sub print_syntax_error_html_section ($)
245      $type =~ tr/ /-/;      $type =~ tr/ /-/;
246      $type =~ s/\|/%7C/g;      $type =~ s/\|/%7C/g;
247      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
248      print STDOUT qq[<dd class="$cls">$msg</dd>\n];      print STDOUT qq[<dd class="$cls">], get_error_level_label (\%opt);
249        print STDOUT qq[$msg</dd>\n];
250    
251        add_error ('syntax', \%opt => $result);
252    };    };
253    
254    my $doc = $dom->create_document;    my $doc = $dom->create_document;
255    my $el;    my $el;
   $time1 = time;  
256    if (defined $inner_html_element and length $inner_html_element) {    if (defined $inner_html_element and length $inner_html_element) {
257        $input->{charset} ||= 'ISO-8859-1'; ## TODO: for now.
258        my $time1 = time;
259        my $t = Encode::decode ($input->{charset}, $input->{s});
260        $time{decode} = time - $time1;
261        
262      $el = $doc->create_element_ns      $el = $doc->create_element_ns
263          ('http://www.w3.org/1999/xhtml', [undef, $inner_html_element]);          ('http://www.w3.org/1999/xhtml', [undef, $inner_html_element]);
264        $time1 = time;
265      Whatpm::HTML->set_inner_html ($el, $t, $onerror);      Whatpm::HTML->set_inner_html ($el, $t, $onerror);
266        $time{parse} = time - $time1;
267    } else {    } else {
268      Whatpm::HTML->parse_string ($t => $doc, $onerror);      my $time1 = time;
269        Whatpm::HTML->parse_byte_string
270            ($input->{charset}, $input->{s} => $doc, $onerror);
271        $time{parse_html} = time - $time1;
272    }    }
273    $time{parse} = time - $time1;    
   
274    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
275    
276    return ($doc, $el);    return ($doc, $el);
277  } # print_syntax_error_html_section  } # print_syntax_error_html_section
278    
279  sub print_syntax_error_xml_section ($) {  sub print_syntax_error_xml_section ($$) {
280    my $input = shift;    my ($input, $result) = @_;
281        
282    require Message::DOM::XMLParserTemp;    require Message::DOM::XMLParserTemp;
283        
# Line 244  sub print_syntax_error_xml_section ($) { Line 294  sub print_syntax_error_xml_section ($) {
294      print STDOUT qq[<dt><a href="#line-$line">Line $line</a> column ];      print STDOUT qq[<dt><a href="#line-$line">Line $line</a> column ];
295      print STDOUT $err->location->column_number, "</dt><dd>";      print STDOUT $err->location->column_number, "</dt><dd>";
296      print STDOUT htescape $err->text, "</dd>\n";      print STDOUT htescape $err->text, "</dd>\n";
297    
298        add_error ('syntax', {type => $err->text,
299                    level => [
300                              $err->SEVERITY_FATAL_ERROR => 'm',
301                              $err->SEVERITY_ERROR => 'm',
302                              $err->SEVERITY_WARNING => 's',
303                             ]->[$err->severity]} => $result);
304    
305      return 1;      return 1;
306    };    };
307    
# Line 258  sub print_syntax_error_xml_section ($) { Line 316  sub print_syntax_error_xml_section ($) {
316    return ($doc, undef);    return ($doc, undef);
317  } # print_syntax_error_xml_section  } # print_syntax_error_xml_section
318    
319    sub print_syntax_error_manifest_section ($$) {
320      my ($input, $result) = @_;
321    
322      require Whatpm::CacheManifest;
323    
324      print STDOUT qq[
325    <div id="parse-errors" class="section">
326    <h2>Parse Errors</h2>
327    
328    <dl>];
329      push @nav, ['#parse-errors' => 'Parse Error'];
330    
331      my $onerror = sub {
332        my (%opt) = @_;
333        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level});
334        print STDOUT qq[<dt class="$cls">], get_error_label (\%opt), qq[</dt>];
335        $type =~ tr/ /-/;
336        $type =~ s/\|/%7C/g;
337        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
338        print STDOUT qq[<dd class="$cls">], get_error_level_label (\%opt);
339        print STDOUT qq[$msg</dd>\n];
340    
341        add_error ('syntax', \%opt => $result);
342      };
343    
344      my $time1 = time;
345      my $manifest = Whatpm::CacheManifest->parse_byte_string
346          ($input->{s}, $input->{uri}, $input->{base_uri}, $onerror);
347      $time{parse_manifest} = time - $time1;
348    
349      print STDOUT qq[</dl></div>];
350    
351      return $manifest;
352    } # print_syntax_error_manifest_section
353    
354  sub print_source_string_section ($$) {  sub print_source_string_section ($$) {
355    require Encode;    require Encode;
356    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 453  sub print_document_tree ($) {
453    print STDOUT $r;    print STDOUT $r;
454  } # print_document_tree  } # print_document_tree
455    
456  sub print_structure_dump_section ($$) {  sub print_structure_dump_dom_section ($$) {
457    my ($doc, $el) = @_;    my ($doc, $el) = @_;
458    
459    print STDOUT qq[    print STDOUT qq[
# Line 372  sub print_structure_dump_section ($$) { Line 465  sub print_structure_dump_section ($$) {
465    print_document_tree ($el || $doc);    print_document_tree ($el || $doc);
466    
467    print STDOUT qq[</div>];    print STDOUT qq[</div>];
468  } # print_structure_dump_section  } # print_structure_dump_dom_section
469    
470  sub print_structure_error_section ($$) {  sub print_structure_dump_manifest_section ($) {
471    my ($doc, $el) = @_;    my $manifest = shift;
472    
473      print STDOUT qq[
474    <div id="dump-manifest" class="section">
475    <h2>Cache Manifest</h2>
476    ];
477      push @nav, ['#dump-manifest' => 'Caceh Manifest'];
478    
479      print STDOUT qq[<dl><dt>Explicit entries</dt>];
480      for my $uri (@{$manifest->[0]}) {
481        my $euri = htescape ($uri);
482        print STDOUT qq[<dd><code class=uri>&lt;<a href="$euri">$euri</a>></code></dd>];
483      }
484    
485      print STDOUT qq[<dt>Fallback entries</dt><dd>
486          <table><thead><tr><th scope=row>Oppotunistic Caching Namespace</th>
487          <th scope=row>Fallback Entry</tr><tbody>];
488      for my $uri (sort {$a cmp $b} keys %{$manifest->[1]}) {
489        my $euri = htescape ($uri);
490        my $euri2 = htescape ($manifest->[1]->{$uri});
491        print STDOUT qq[<tr><td><code class=uri>&lt;<a href="$euri">$euri</a>></code></td>
492            <td><code class=uri>&lt;<a href="$euri2">$euri2</a>></code></td>];
493      }
494    
495      print STDOUT qq[</table><dt>Online whitelist</dt>];
496      for my $uri (@{$manifest->[2]}) {
497        my $euri = htescape ($uri);
498        print STDOUT qq[<dd><code class=uri>&lt;<a href="$euri">$euri</a>></code></dd>];
499      }
500    
501      print STDOUT qq[</dl></div>];
502    } # print_structure_dump_manifest_section
503    
504    sub print_structure_error_dom_section ($$$) {
505      my ($doc, $el, $result) = @_;
506    
507    print STDOUT qq[<div id="document-errors" class="section">    print STDOUT qq[<div id="document-errors" class="section">
508  <h2>Document Errors</h2>  <h2>Document Errors</h2>
# Line 390  sub print_structure_error_section ($$) { Line 517  sub print_structure_error_section ($$) {
517      $type =~ tr/ /-/;      $type =~ tr/ /-/;
518      $type =~ s/\|/%7C/g;      $type =~ s/\|/%7C/g;
519      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
520      print STDOUT qq[<dt class="$cls">] . get_node_link ($opt{node}) .      print STDOUT qq[<dt class="$cls">] . get_error_label (\%opt) .
521          qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";          qq[</dt>\n<dd class="$cls">], get_error_level_label (\%opt);
522        print STDOUT $msg, "</dd>\n";
523        add_error ('structure', \%opt => $result);
524    };    };
525    
526    my $elements;    my $elements;
# Line 406  sub print_structure_error_section ($$) { Line 535  sub print_structure_error_section ($$) {
535    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
536    
537    return $elements;    return $elements;
538  } # print_structure_error_section  } # print_structure_error_dom_section
539    
540    sub print_structure_error_manifest_section ($$$) {
541      my ($manifest, $result) = @_;
542    
543      print STDOUT qq[<div id="document-errors" class="section">
544    <h2>Document Errors</h2>
545    
546    <dl>];
547      push @nav, ['#document-errors' => 'Document Error'];
548    
549      require Whatpm::CacheManifest;
550      Whatpm::CacheManifest->check_manifest ($manifest, sub {
551        my %opt = @_;
552        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level}, $opt{node});
553        $type =~ tr/ /-/;
554        $type =~ s/\|/%7C/g;
555        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
556        print STDOUT qq[<dt class="$cls">] . get_error_label (\%opt) .
557            qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";
558        add_error ('structure', \%opt => $result);
559      });
560    
561      print STDOUT qq[</div>];
562    } # print_structure_error_manifest_section
563    
564  sub print_table_section ($) {  sub print_table_section ($) {
565    my $tables = shift;    my $tables = shift;
# Line 524  sub print_class_section ($) { Line 677  sub print_class_section ($) {
677    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
678  } # print_class_section  } # print_class_section
679    
680  sub print_result_unknown_type_section ($) {  sub print_result_section ($) {
681    my $input = shift;    my $result = shift;
682    
683    print STDOUT qq[    print STDOUT qq[
684  <div id="result-summary" class="section">  <div id="result-summary" class="section">
685  <p><em>Media type <code class="MIME" lang="en">@{[htescape $input->{media_type}]}</code> is not supported!</em></p>  <h2>Result</h2>];
686    
687      if ($result->{unsupported} and $result->{conforming_max}) {  
688        print STDOUT qq[<p class=uncertain id=result-para>The conformance
689            checker cannot decide whether the document is conforming or
690            not, since the document contains one or more unsupported
691            features.  The document might or might not be conforming.</p>];
692      } elsif ($result->{conforming_min}) {
693        print STDOUT qq[<p class=PASS id=result-para>No conformance-error is
694            found in this document.</p>];
695      } elsif ($result->{conforming_max}) {
696        print STDOUT qq[<p class=SEE-RESULT id=result-para>This document
697            is <strong>likely <em>non</em>-conforming</strong>, but in rare case
698            it might be conforming.</p>];
699      } else {
700        print STDOUT qq[<p class=FAIL id=result-para>This document is
701            <strong><em>non</em>-conforming</strong>.</p>];
702      }
703    
704      print STDOUT qq[<table>
705    <colgroup><col><colgroup><col><col><col><colgroup><col>
706    <thead>
707    <tr><th scope=col></th>
708    <th scope=col><a href="../error-description#level-m"><em class=rfc2119>MUST</em>‐level
709    Errors</a></th>
710    <th scope=col><a href="../error-description#level-s"><em class=rfc2119>SHOULD</em>‐level
711    Errors</a></th>
712    <th scope=col><a href="../error-description#level-w">Warnings</a></th>
713    <th scope=col>Score</th></tr></thead><tbody>];
714    
715      my $must_error = 0;
716      my $should_error = 0;
717      my $warning = 0;
718      my $score_min = 0;
719      my $score_max = 0;
720      my $score_base = 20;
721      my $score_unit = $score_base / 100;
722      for (
723        [Transfer => 'transfer', ''],
724        [Character => 'char', ''],
725        [Syntax => 'syntax', '#parse-errors'],
726        [Structure => 'structure', '#document-errors'],
727      ) {
728        $must_error += ($result->{$_->[1]}->{must} += 0);
729        $should_error += ($result->{$_->[1]}->{should} += 0);
730        $warning += ($result->{$_->[1]}->{warning} += 0);
731        $score_min += (($result->{$_->[1]}->{score_min} *= $score_unit) += $score_base);
732        $score_max += (($result->{$_->[1]}->{score_max} *= $score_unit) += $score_base);
733    
734        my $uncertain = $result->{$_->[1]}->{unsupported} ? '?' : '';
735        my $label = $_->[0];
736        if ($result->{$_->[1]}->{must} or
737            $result->{$_->[1]}->{should} or
738            $result->{$_->[1]}->{warning} or
739            $result->{$_->[1]}->{unsupported}) {
740          $label = qq[<a href="$_->[2]">$label</a>];
741        }
742    
743        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>];
744        if ($uncertain) {
745          print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : $result->{$_->[1]}->{should} ? 'SEE-RESULT' : '']}">&#x2212;&#x221E;..$result->{$_->[1]}->{score_max}</td>];
746        } elsif ($result->{$_->[1]}->{score_min} != $result->{$_->[1]}->{score_max}) {
747          print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : 'SEE-RESULT']}">$result->{$_->[1]}->{score_min}..$result->{$_->[1]}->{score_max}</td></tr>];
748        } else {
749          print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : '']}">$result->{$_->[1]}->{score_min}</td></tr>];
750        }
751      }
752    
753      $score_max += $score_base;
754    
755      print STDOUT qq[
756    <tr class=uncertain><th scope=row>Semantics</th><td>0?</td><td>0?</td><td>0?</td><td>&#x2212;&#x221E;..$score_base</td></tr>
757    </tbody>
758    <tfoot><tr class=uncertain><th scope=row>Total</th>
759    <td class="@{[$must_error ? 'FAIL' : '']}">$must_error?</td>
760    <td class="@{[$should_error ? 'SEE-RESULT' : '']}">$should_error?</td>
761    <td>$warning?</td>
762    <td class="@{[$must_error ? 'FAIL' : $should_error ? 'SEE-RESULT' : '']}"><strong>&#x2212;&#x221E;..$score_max</strong></td></tr></tfoot>
763    </table>
764    
765    <p><strong>Important</strong>: This conformance checking service
766    is <em>under development</em>.  The result above might be <em>wrong</em>.</p>
767    </div>];
768      push @nav, ['#result-summary' => 'Result'];
769    } # print_result_section
770    
771    sub print_result_unknown_type_section ($$) {
772      my ($input, $result) = @_;
773    
774      my $euri = htescape ($input->{uri});
775      print STDOUT qq[
776    <div id="parse-errors" class="section">
777    <h2>Errors</h2>
778    
779    <dl>
780    <dt class=unsupported><code>&lt;<a href="$euri">$euri</a>&gt;</code></dt>
781        <dd class=unsupported><strong><a href="../error-description#level-u">Not
782            supported</a></strong>:
783        Media type
784        <code class="MIME" lang="en">@{[htescape $input->{media_type}]}</code>
785        is not supported.</dd>
786    </dl>
787  </div>  </div>
788  ];  ];
789    push @nav, ['#result-summary' => 'Result'];    push @nav, ['#parse-errors' => 'Errors'];
790      add_error (char => {level => 'unsupported'} => $result);
791      add_error (syntax => {level => 'unsupported'} => $result);
792      add_error (structure => {level => 'unsupported'} => $result);
793  } # print_result_unknown_type_section  } # print_result_unknown_type_section
794    
795  sub print_result_input_error_section ($) {  sub print_result_input_error_section ($) {
# Line 543  sub print_result_input_error_section ($) Line 800  sub print_result_input_error_section ($)
800    push @nav, ['#result-summary' => 'Result'];    push @nav, ['#result-summary' => 'Result'];
801  } # print_Result_input_error_section  } # print_Result_input_error_section
802    
803    sub get_error_label ($) {
804      my $err = shift;
805    
806      my $r = '';
807    
808      if (defined $err->{line}) {
809        if ($err->{column} > 0) {
810          $r = qq[<a href="#line-$err->{line}">Line $err->{line}</a> column $err->{column}];
811        } else {
812          $err->{line} = $err->{line} - 1 || 1;
813          $r = qq[<a href="#line-$err->{line}">Line $err->{line}</a>];
814        }
815      }
816    
817      if (defined $err->{node}) {
818        $r .= ' ' if length $r;
819        $r = get_node_link ($err->{node});
820      }
821    
822      if (defined $err->{index}) {
823        $r .= ' ' if length $r;
824        $r .= 'Index ' . (0+$err->{index});
825      }
826    
827      if (defined $err->{value}) {
828        $r .= ' ' if length $r;
829        $r .= '<q><code>' . htescape ($err->{value}) . '</code></q>';
830      }
831    
832      return $r;
833    } # get_error_label
834    
835    sub get_error_level_label ($) {
836      my $err = shift;
837    
838      my $r = '';
839    
840      if (not defined $err->{level} or $err->{level} eq 'm') {
841        $r = qq[<strong><a href="../error-description#level-m"><em class=rfc2119>MUST</em>‐level
842            error</a></strong>: ];
843      } elsif ($err->{level} eq 's') {
844        $r = qq[<strong><a href="../error-description#level-s"><em class=rfc2119>SHOULD</em>‐level
845            error</a></strong>: ];
846      } elsif ($err->{level} eq 'w') {
847        $r = qq[<strong><a href="../error-description#level-w">Warning</a></strong>:
848            ];
849      } elsif ($err->{level} eq 'unsupported') {
850        $r = qq[<strong><a href="../error-description#level-u">Not
851            supported</a></strong>: ];
852      } else {
853        my $elevel = htescape ($err->{level});
854        $r = qq[<strong><a href="../error-description#level-$elevel">$elevel</a></strong>:
855            ];
856      }
857    
858      return $r;
859    } # get_error_level_label
860    
861  sub get_node_path ($) {  sub get_node_path ($) {
862    my $node = shift;    my $node = shift;
863    my @r;    my @r;
# Line 688  EOH Line 1003  EOH
1003    
1004        ## TODO: More strict parsing...        ## TODO: More strict parsing...
1005        my $ct = $res->header ('Content-Type');        my $ct = $res->header ('Content-Type');
1006        if (defined $ct and $ct =~ m#^([0-9A-Za-z._+-]+/[0-9A-Za-z._+-]+)#) {        if (defined $ct and $ct =~ /;\s*charset\s*=\s*"?([^\s;"]+)"?/i) {
         $r->{media_type} = lc $1;  
       }  
       if (defined $ct and $ct =~ /;\s*charset\s*=\s*"?(\S+)"?/i) {  
1007          $r->{charset} = lc $1;          $r->{charset} = lc $1;
1008          $r->{charset} =~ tr/\\//d;          $r->{charset} =~ tr/\\//d;
1009        }        }
# Line 701  EOH Line 1013  EOH
1013          $r->{charset_overridden}          $r->{charset_overridden}
1014              = (not defined $r->{charset} or $r->{charset} ne $input_charset);              = (not defined $r->{charset} or $r->{charset} ne $input_charset);
1015          $r->{charset} = $input_charset;          $r->{charset} = $input_charset;
1016        }        }
1017    
1018          ## TODO: Support for HTTP Content-Encoding
1019    
1020        $r->{s} = ''.$res->content;        $r->{s} = ''.$res->content;
1021    
1022          require Whatpm::ContentType;
1023          ($r->{official_type}, $r->{media_type})
1024              = Whatpm::ContentType->get_sniffed_type
1025                  (get_file_head => sub {
1026                     return substr $r->{s}, 0, shift;
1027                   },
1028                   http_content_type_byte => $ct,
1029                   has_http_content_encoding =>
1030                       defined $res->header ('Content-Encoding'),
1031                   supported_image_types => {});
1032      } else {      } else {
1033        $r->{uri} = $res->request->uri;        $r->{uri} = $res->request->uri;
1034        $r->{request_uri} = $request_uri;        $r->{request_uri} = $request_uri;
# Line 725  EOH Line 1050  EOH
1050      $r->{charset} =~ s/\s+//g;      $r->{charset} =~ s/\s+//g;
1051      $r->{charset} = 'utf-8' if $r->{charset} eq '';      $r->{charset} = 'utf-8' if $r->{charset} eq '';
1052      $r->{header_field} = [];      $r->{header_field} = [];
1053    
1054        require Whatpm::ContentType;
1055        ($r->{official_type}, $r->{media_type})
1056            = Whatpm::ContentType->get_sniffed_type
1057                (get_file_head => sub {
1058                   return substr $r->{s}, 0, shift;
1059                 },
1060                 http_content_type_byte => undef,
1061                 has_http_content_encoding => 0,
1062                 supported_image_types => {});
1063    }    }
1064    
1065    my $input_format = $http->get_parameter ('i');    my $input_format = $http->get_parameter ('i');
Legend:
Removed from v.1.18  
changed lines
  Added in v.1.25
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24