/[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.20 by wakaba, Mon Sep 10 12:09:34 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 88  if (defined $input->{s}) { Line 93  if (defined $input->{s}) {
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, $result);      ($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 102  if (defined $input->{s}) { Line 109  if (defined $input->{s}) {
109             }->{$input->{media_type}}) {             }->{$input->{media_type}}) {
110      ($doc, $el) = print_syntax_error_xml_section ($input, $result);      ($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, $result);      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    print_result_section ($result);    print_result_section ($result);
# Line 134  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 209  sub print_syntax_error_html_section ($$) Line 224  sub print_syntax_error_html_section ($$)
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 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    };    };
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);
# Line 291  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 399  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 411  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_dump_manifest_section ($) {
475      my $manifest = shift;
476    
477  sub print_structure_error_section ($$$) {    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) = @_;    my ($doc, $el, $result) = @_;
510    
511    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 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);      add_error ('structure', \%opt => $result);
528    };    };
529    
# Line 446  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 571  sub print_result_section ($) { Line 688  sub print_result_section ($) {
688  <div id="result-summary" class="section">  <div id="result-summary" class="section">
689  <h2>Result</h2>];  <h2>Result</h2>];
690    
691    if ($result->{unsupported}) {      if ($result->{unsupported} and $result->{conforming_max}) {  
692      print STDOUT qq[<p class=uncertain id=result-para>The conformance      print STDOUT qq[<p class=uncertain id=result-para>The conformance
693          checker cannot decide whether the document is conforming or          checker cannot decide whether the document is conforming or
694          not, since the document contains one or more unsupported          not, since the document contains one or more unsupported
695          features.</p>];          features.  The document might or might not be conforming.</p>];
696    } elsif ($result->{conforming_min}) {    } elsif ($result->{conforming_min}) {
697      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
698          found in this document.</p>];          found in this document.</p>];
# Line 591  sub print_result_section ($) { Line 708  sub print_result_section ($) {
708    print STDOUT qq[<table>    print STDOUT qq[<table>
709  <colgroup><col><colgroup><col><col><col><colgroup><col>  <colgroup><col><colgroup><col><col><col><colgroup><col>
710  <thead>  <thead>
711  <tr><th scope=col></th><th scope=col><em class=rfc2119>MUST</em>-level  <tr><th scope=col></th>
712  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
713  Errors</th><th scope=col>Warnings</th><th scope=col>Score</th></tr>  Errors</a></th>
714  </thead><tbody>];  <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;    my $must_error = 0;
720    my $should_error = 0;    my $should_error = 0;
# Line 602  Errors</th><th scope=col>Warnings</th><t Line 722  Errors</th><th scope=col>Warnings</th><t
722    my $score_min = 0;    my $score_min = 0;
723    my $score_max = 0;    my $score_max = 0;
724    my $score_base = 20;    my $score_base = 20;
725      my $score_unit = $score_base / 100;
726    for (    for (
727      [Transfer => 'transfer', ''],      [Transfer => 'transfer', ''],
728      [Character => 'char', ''],      [Character => 'char', ''],
# Line 611  Errors</th><th scope=col>Warnings</th><t Line 732  Errors</th><th scope=col>Warnings</th><t
732      $must_error += ($result->{$_->[1]}->{must} += 0);      $must_error += ($result->{$_->[1]}->{must} += 0);
733      $should_error += ($result->{$_->[1]}->{should} += 0);      $should_error += ($result->{$_->[1]}->{should} += 0);
734      $warning += ($result->{$_->[1]}->{warning} += 0);      $warning += ($result->{$_->[1]}->{warning} += 0);
735      $score_min += ($result->{$_->[1]}->{score_min} += $score_base);      $score_min += (($result->{$_->[1]}->{score_min} *= $score_unit) += $score_base);
736      $score_max += ($result->{$_->[1]}->{score_max} += $score_base);      $score_max += (($result->{$_->[1]}->{score_max} *= $score_unit) += $score_base);
737    
738      my $uncertain = $result->{$_->[1]}->{unsupported} ? '?' : '';      my $uncertain = $result->{$_->[1]}->{unsupported} ? '?' : '';
739      my $label = $_->[0];      my $label = $_->[0];
# Line 625  Errors</th><th scope=col>Warnings</th><t Line 746  Errors</th><th scope=col>Warnings</th><t
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>];      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) {      if ($uncertain) {
749        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>];
750      } elsif ($result->{$_->[1]}->{score_min} != $result->{$_->[1]}->{score_max}) {      } elsif ($result->{$_->[1]}->{score_min} != $result->{$_->[1]}->{score_max}) {
751        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>];
752      } else {      } else {
753        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>];
754      }      }
755    }    }
756    
# Line 638  Errors</th><th scope=col>Warnings</th><t Line 759  Errors</th><th scope=col>Warnings</th><t
759    print STDOUT qq[    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>  <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>  </tbody>
762  <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>
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>  </table>
768    
769  <p><strong>Important</strong>: This conformance checking service  <p><strong>Important</strong>: This conformance checking service
# Line 647  is <em>under development</em>.  The resu Line 772  is <em>under development</em>.  The resu
772    push @nav, ['#result-summary' => 'Result'];    push @nav, ['#result-summary' => 'Result'];
773  } # print_result_section  } # print_result_section
774    
775  sub print_result_unknown_type_section ($) {  sub print_result_unknown_type_section ($$) {
776    my $input = shift;    my ($input, $result) = @_;
777    
778      my $euri = htescape ($input->{uri});
779    print STDOUT qq[    print STDOUT qq[
780  <div id="result-summary" class="section">  <div id="parse-errors" class="section">
781  <p><em>Media type <code class="MIME" lang="en">@{[htescape $input->{media_type}]}</code> is not supported!</em></p>  <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 666  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 703  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 811  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 824  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 847  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 864  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.20  
changed lines
  Added in v.1.26
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24