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