/[pub]/test/html-webhacc/cc.cgi
Suika

Diff of /test/html-webhacc/cc.cgi

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.19 by wakaba, Mon Sep 10 11:51:09 2007 UTC revision 1.29 by wakaba, Fri Nov 23 12:08:32 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    my $result = {};    my $result = {conforming_min => 1, conforming_max => 1};
92    print_http_header_section ($input, $result);    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, $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 345  sub print_document_tree ($) { Line 403  sub print_document_tree ($) {
403          $r .= '<ul class="attributes">';          $r .= '<ul class="attributes">';
404          for my $attr (sort {$a->[0] cmp $b->[0]} map { [$_->name, $_->value, $_->namespace_uri, 'node-'.refaddr $_] }          for my $attr (sort {$a->[0] cmp $b->[0]} map { [$_->name, $_->value, $_->namespace_uri, 'node-'.refaddr $_] }
405                        @{$child->attributes}) {                        @{$child->attributes}) {
406            $r .= qq[<li id="$attr->[3]" class="tree-attribute"><code title="@{[defined $_->[2] ? $_->[2] : '']}">] . htescape ($attr->[0]) . '</code> = '; ## ISSUE: case?            $r .= qq[<li id="$attr->[3]" class="tree-attribute"><code title="@{[defined $attr->[2] ? htescape ($attr->[2]) : '']}">] . htescape ($attr->[0]) . '</code> = '; ## ISSUE: case?
407            $r .= '<q>' . htescape ($attr->[1]) . '</q></li>'; ## TODO: children            $r .= '<q>' . htescape ($attr->[1]) . '</q></li>'; ## TODO: children
408          }          }
409          $r .= '</ul>';          $r .= '</ul>';
# Line 366  sub print_document_tree ($) { Line 424  sub print_document_tree ($) {
424      } elsif ($nt == $child->DOCUMENT_NODE) {      } elsif ($nt == $child->DOCUMENT_NODE) {
425        $r .= qq'<li id="$node_id" class="tree-document">Document';        $r .= qq'<li id="$node_id" class="tree-document">Document';
426        $r .= qq[<ul class="attributes">];        $r .= qq[<ul class="attributes">];
427          my $cp = $child->manakai_charset;
428          if (defined $cp) {
429            $r .= qq[<li><code>charset</code> parameter = <code>];
430            $r .= htescape ($cp) . qq[</code></li>];
431          }
432          $r .= qq[<li><code>inputEncoding</code> = ];
433          my $ie = $child->input_encoding;
434          if (defined $ie) {
435            $r .= qq[<code>@{[htescape ($ie)]}</code>];
436            if ($child->manakai_has_bom) {
437              $r .= qq[ (with <code class=charname><abbr>BOM</abbr></code>)];
438            }
439          } else {
440            $r .= qq[(<code>null</code>)];
441          }
442        $r .= qq[<li>@{[scalar get_text ('manakaiIsHTML:'.($child->manakai_is_html?1:0))]}</li>];        $r .= qq[<li>@{[scalar get_text ('manakaiIsHTML:'.($child->manakai_is_html?1:0))]}</li>];
443        $r .= qq[<li>@{[scalar get_text ('manakaiCompatMode:'.$child->manakai_compat_mode)]}</li>];        $r .= qq[<li>@{[scalar get_text ('manakaiCompatMode:'.$child->manakai_compat_mode)]}</li>];
444        unless ($child->manakai_is_html) {        unless ($child->manakai_is_html) {
# Line 399  sub print_document_tree ($) { Line 472  sub print_document_tree ($) {
472    print STDOUT $r;    print STDOUT $r;
473  } # print_document_tree  } # print_document_tree
474    
475  sub print_structure_dump_section ($$) {  sub print_structure_dump_dom_section ($$) {
476    my ($doc, $el) = @_;    my ($doc, $el) = @_;
477    
478    print STDOUT qq[    print STDOUT qq[
# Line 411  sub print_structure_dump_section ($$) { Line 484  sub print_structure_dump_section ($$) {
484    print_document_tree ($el || $doc);    print_document_tree ($el || $doc);
485    
486    print STDOUT qq[</div>];    print STDOUT qq[</div>];
487  } # print_structure_dump_section  } # print_structure_dump_dom_section
488    
489    sub print_structure_dump_manifest_section ($) {
490      my $manifest = shift;
491    
492      print STDOUT qq[
493    <div id="dump-manifest" class="section">
494    <h2>Cache Manifest</h2>
495    ];
496      push @nav, ['#dump-manifest' => 'Caceh Manifest'];
497    
498      print STDOUT qq[<dl><dt>Explicit entries</dt>];
499      for my $uri (@{$manifest->[0]}) {
500        my $euri = htescape ($uri);
501        print STDOUT qq[<dd><code class=uri>&lt;<a href="$euri">$euri</a>></code></dd>];
502      }
503    
504      print STDOUT qq[<dt>Fallback entries</dt><dd>
505          <table><thead><tr><th scope=row>Oppotunistic Caching Namespace</th>
506          <th scope=row>Fallback Entry</tr><tbody>];
507      for my $uri (sort {$a cmp $b} keys %{$manifest->[1]}) {
508        my $euri = htescape ($uri);
509        my $euri2 = htescape ($manifest->[1]->{$uri});
510        print STDOUT qq[<tr><td><code class=uri>&lt;<a href="$euri">$euri</a>></code></td>
511            <td><code class=uri>&lt;<a href="$euri2">$euri2</a>></code></td>];
512      }
513    
514      print STDOUT qq[</table><dt>Online whitelist</dt>];
515      for my $uri (@{$manifest->[2]}) {
516        my $euri = htescape ($uri);
517        print STDOUT qq[<dd><code class=uri>&lt;<a href="$euri">$euri</a>></code></dd>];
518      }
519    
520      print STDOUT qq[</dl></div>];
521    } # print_structure_dump_manifest_section
522    
523  sub print_structure_error_section ($$$) {  sub print_structure_error_dom_section ($$$) {
524    my ($doc, $el, $result) = @_;    my ($doc, $el, $result) = @_;
525    
526    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 536  sub print_structure_error_section ($$$)
536      $type =~ tr/ /-/;      $type =~ tr/ /-/;
537      $type =~ s/\|/%7C/g;      $type =~ s/\|/%7C/g;
538      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
539      print STDOUT qq[<dt class="$cls">] . get_node_link ($opt{node}) .      print STDOUT qq[<dt class="$cls">] . get_error_label (\%opt) .
540          qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";          qq[</dt>\n<dd class="$cls">], get_error_level_label (\%opt);
541        print STDOUT $msg, "</dd>\n";
542      add_error ('structure', \%opt => $result);      add_error ('structure', \%opt => $result);
543    };    };
544    
# Line 446  sub print_structure_error_section ($$$) Line 554  sub print_structure_error_section ($$$)
554    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
555    
556    return $elements;    return $elements;
557  } # print_structure_error_section  } # print_structure_error_dom_section
558    
559    sub print_structure_error_manifest_section ($$$) {
560      my ($manifest, $result) = @_;
561    
562      print STDOUT qq[<div id="document-errors" class="section">
563    <h2>Document Errors</h2>
564    
565    <dl>];
566      push @nav, ['#document-errors' => 'Document Error'];
567    
568      require Whatpm::CacheManifest;
569      Whatpm::CacheManifest->check_manifest ($manifest, sub {
570        my %opt = @_;
571        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level}, $opt{node});
572        $type =~ tr/ /-/;
573        $type =~ s/\|/%7C/g;
574        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
575        print STDOUT qq[<dt class="$cls">] . get_error_label (\%opt) .
576            qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";
577        add_error ('structure', \%opt => $result);
578      });
579    
580      print STDOUT qq[</div>];
581    } # print_structure_error_manifest_section
582    
583  sub print_table_section ($) {  sub print_table_section ($) {
584    my $tables = shift;    my $tables = shift;
# Line 571  sub print_result_section ($) { Line 703  sub print_result_section ($) {
703  <div id="result-summary" class="section">  <div id="result-summary" class="section">
704  <h2>Result</h2>];  <h2>Result</h2>];
705    
706    if ($result->{unsupported}) {      if ($result->{unsupported} and $result->{conforming_max}) {  
707      print STDOUT qq[<p class=uncertain id=result-para>The conformance      print STDOUT qq[<p class=uncertain id=result-para>The conformance
708          checker cannot decide whether the document is conforming or          checker cannot decide whether the document is conforming or
709          not, since the document contains one or more unsupported          not, since the document contains one or more unsupported
710          features.</p>];          features.  The document might or might not be conforming.</p>];
711    } elsif ($result->{conforming_min}) {    } elsif ($result->{conforming_min}) {
712      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
713          found in this document.</p>];          found in this document.</p>];
# Line 591  sub print_result_section ($) { Line 723  sub print_result_section ($) {
723    print STDOUT qq[<table>    print STDOUT qq[<table>
724  <colgroup><col><colgroup><col><col><col><colgroup><col>  <colgroup><col><colgroup><col><col><col><colgroup><col>
725  <thead>  <thead>
726  <tr><th scope=col></th><th scope=col><em class=rfc2119>MUST</em>-level  <tr><th scope=col></th>
727  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
728  Errors</th><th scope=col>Warnings</th><th scope=col>Score</th></tr>  Errors</a></th>
729  </thead><tbody>];  <th scope=col><a href="../error-description#level-s"><em class=rfc2119>SHOULD</em>‐level
730    Errors</a></th>
731    <th scope=col><a href="../error-description#level-w">Warnings</a></th>
732    <th scope=col>Score</th></tr></thead><tbody>];
733    
734    my $must_error = 0;    my $must_error = 0;
735    my $should_error = 0;    my $should_error = 0;
# Line 602  Errors</th><th scope=col>Warnings</th><t Line 737  Errors</th><th scope=col>Warnings</th><t
737    my $score_min = 0;    my $score_min = 0;
738    my $score_max = 0;    my $score_max = 0;
739    my $score_base = 20;    my $score_base = 20;
740      my $score_unit = $score_base / 100;
741    for (    for (
742      [Transfer => 'transfer', ''],      [Transfer => 'transfer', ''],
743      [Character => 'char', ''],      [Character => 'char', ''],
# Line 611  Errors</th><th scope=col>Warnings</th><t Line 747  Errors</th><th scope=col>Warnings</th><t
747      $must_error += ($result->{$_->[1]}->{must} += 0);      $must_error += ($result->{$_->[1]}->{must} += 0);
748      $should_error += ($result->{$_->[1]}->{should} += 0);      $should_error += ($result->{$_->[1]}->{should} += 0);
749      $warning += ($result->{$_->[1]}->{warning} += 0);      $warning += ($result->{$_->[1]}->{warning} += 0);
750      $score_min += ($result->{$_->[1]}->{score_min} += $score_base);      $score_min += (($result->{$_->[1]}->{score_min} *= $score_unit) += $score_base);
751      $score_max += ($result->{$_->[1]}->{score_max} += $score_base);      $score_max += (($result->{$_->[1]}->{score_max} *= $score_unit) += $score_base);
752    
753      my $uncertain = $result->{$_->[1]}->{unsupported} ? '?' : '';      my $uncertain = $result->{$_->[1]}->{unsupported} ? '?' : '';
754      my $label = $_->[0];      my $label = $_->[0];
# Line 625  Errors</th><th scope=col>Warnings</th><t Line 761  Errors</th><th scope=col>Warnings</th><t
761    
762      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>];
763      if ($uncertain) {      if ($uncertain) {
764        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>];
765      } elsif ($result->{$_->[1]}->{score_min} != $result->{$_->[1]}->{score_max}) {      } elsif ($result->{$_->[1]}->{score_min} != $result->{$_->[1]}->{score_max}) {
766        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>];
767      } else {      } else {
768        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>];
769      }      }
770    }    }
771    
# Line 638  Errors</th><th scope=col>Warnings</th><t Line 774  Errors</th><th scope=col>Warnings</th><t
774    print STDOUT qq[    print STDOUT qq[
775  <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>
776  </tbody>  </tbody>
777  <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>
778    <td class="@{[$must_error ? 'FAIL' : '']}">$must_error?</td>
779    <td class="@{[$should_error ? 'SEE-RESULT' : '']}">$should_error?</td>
780    <td>$warning?</td>
781    <td class="@{[$must_error ? 'FAIL' : $should_error ? 'SEE-RESULT' : '']}"><strong>&#x2212;&#x221E;..$score_max</strong></td></tr></tfoot>
782  </table>  </table>
783    
784  <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 787  is <em>under development</em>.  The resu
787    push @nav, ['#result-summary' => 'Result'];    push @nav, ['#result-summary' => 'Result'];
788  } # print_result_section  } # print_result_section
789    
790  sub print_result_unknown_type_section ($) {  sub print_result_unknown_type_section ($$) {
791    my $input = shift;    my ($input, $result) = @_;
792    
793      my $euri = htescape ($input->{uri});
794    print STDOUT qq[    print STDOUT qq[
795  <div id="result-summary" class="section">  <div id="parse-errors" class="section">
796  <p><em>Media type <code class="MIME" lang="en">@{[htescape $input->{media_type}]}</code> is not supported!</em></p>  <h2>Errors</h2>
797    
798    <dl>
799    <dt class=unsupported><code>&lt;<a href="$euri">$euri</a>&gt;</code></dt>
800        <dd class=unsupported><strong><a href="../error-description#level-u">Not
801            supported</a></strong>:
802        Media type
803        <code class="MIME" lang="en">@{[htescape $input->{media_type}]}</code>
804        is not supported.</dd>
805    </dl>
806  </div>  </div>
807  ];  ];
808    push @nav, ['#result-summary' => 'Result'];    push @nav, ['#parse-errors' => 'Errors'];
809      add_error (char => {level => 'unsupported'} => $result);
810      add_error (syntax => {level => 'unsupported'} => $result);
811      add_error (structure => {level => 'unsupported'} => $result);
812  } # print_result_unknown_type_section  } # print_result_unknown_type_section
813    
814  sub print_result_input_error_section ($) {  sub print_result_input_error_section ($) {
# Line 666  sub print_result_input_error_section ($) Line 819  sub print_result_input_error_section ($)
819    push @nav, ['#result-summary' => 'Result'];    push @nav, ['#result-summary' => 'Result'];
820  } # print_Result_input_error_section  } # print_Result_input_error_section
821    
822    sub get_error_label ($) {
823      my $err = shift;
824    
825      my $r = '';
826    
827      if (defined $err->{line}) {
828        if ($err->{column} > 0) {
829          $r = qq[<a href="#line-$err->{line}">Line $err->{line}</a> column $err->{column}];
830        } else {
831          $err->{line} = $err->{line} - 1 || 1;
832          $r = qq[<a href="#line-$err->{line}">Line $err->{line}</a>];
833        }
834      }
835    
836      if (defined $err->{node}) {
837        $r .= ' ' if length $r;
838        $r = get_node_link ($err->{node});
839      }
840    
841      if (defined $err->{index}) {
842        $r .= ' ' if length $r;
843        $r .= 'Index ' . (0+$err->{index});
844      }
845    
846      if (defined $err->{value}) {
847        $r .= ' ' if length $r;
848        $r .= '<q><code>' . htescape ($err->{value}) . '</code></q>';
849      }
850    
851      return $r;
852    } # get_error_label
853    
854    sub get_error_level_label ($) {
855      my $err = shift;
856    
857      my $r = '';
858    
859      if (not defined $err->{level} or $err->{level} eq 'm') {
860        $r = qq[<strong><a href="../error-description#level-m"><em class=rfc2119>MUST</em>‐level
861            error</a></strong>: ];
862      } elsif ($err->{level} eq 's') {
863        $r = qq[<strong><a href="../error-description#level-s"><em class=rfc2119>SHOULD</em>‐level
864            error</a></strong>: ];
865      } elsif ($err->{level} eq 'w') {
866        $r = qq[<strong><a href="../error-description#level-w">Warning</a></strong>:
867            ];
868      } elsif ($err->{level} eq 'unsupported') {
869        $r = qq[<strong><a href="../error-description#level-u">Not
870            supported</a></strong>: ];
871      } else {
872        my $elevel = htescape ($err->{level});
873        $r = qq[<strong><a href="../error-description#level-$elevel">$elevel</a></strong>:
874            ];
875      }
876    
877      return $r;
878    } # get_error_level_label
879    
880  sub get_node_path ($) {  sub get_node_path ($) {
881    my $node = shift;    my $node = shift;
882    my @r;    my @r;
# Line 703  sub get_node_link ($) { Line 914  sub get_node_link ($) {
914    
915  sub load_text_catalog ($) {  sub load_text_catalog ($) {
916    my $lang = shift; # MUST be a canonical lang name    my $lang = shift; # MUST be a canonical lang name
917    open my $file, '<', "cc-msg.$lang.txt" or die "$0: cc-msg.$lang.txt: $!";    open my $file, '<:utf8', "cc-msg.$lang.txt"
918          or die "$0: cc-msg.$lang.txt: $!";
919    while (<$file>) {    while (<$file>) {
920      if (s/^([^;]+);([^;]*);//) {      if (s/^([^;]+);([^;]*);//) {
921        my ($type, $cls, $msg) = ($1, $2, $_);        my ($type, $cls, $msg) = ($1, $2, $_);
# Line 716  sub load_text_catalog ($) { Line 928  sub load_text_catalog ($) {
928  sub get_text ($) {  sub get_text ($) {
929    my ($type, $level, $node) = @_;    my ($type, $level, $node) = @_;
930    $type = $level . ':' . $type if defined $level;    $type = $level . ':' . $type if defined $level;
931      $level = 'm' unless defined $level;
932    my @arg;    my @arg;
933    {    {
934      if (defined $Msg->{$type}) {      if (defined $Msg->{$type}) {
# Line 740  sub get_text ($) { Line 953  sub get_text ($) {
953            ? htescape ($node->owner_element->manakai_local_name)            ? htescape ($node->owner_element->manakai_local_name)
954            : ''            : ''
955        }ge;        }ge;
956        return ($type, $Msg->{$type}->[0], $msg);        return ($type, 'level-' . $level . ' ' . $Msg->{$type}->[0], $msg);
957      } elsif ($type =~ s/:([^:]*)$//) {      } elsif ($type =~ s/:([^:]*)$//) {
958        unshift @arg, $1;        unshift @arg, $1;
959        redo;        redo;
960      }      }
961    }    }
962    return ($type, '', htescape ($_[0]));    return ($type, 'level-'.$level, htescape ($_[0]));
963  } # get_text  } # get_text
964    
965  }  }
# Line 802  EOH Line 1015  EOH
1015      $ua->protocols_allowed ([qw/http/]);      $ua->protocols_allowed ([qw/http/]);
1016      $ua->max_size (1000_000);      $ua->max_size (1000_000);
1017      my $req = HTTP::Request->new (GET => $request_uri);      my $req = HTTP::Request->new (GET => $request_uri);
1018        $req->header ('Accept-Encoding' => 'identity, *; q=0');
1019      my $res = $ua->request ($req);      my $res = $ua->request ($req);
1020      ## TODO: 401 sets |is_success| true.      ## TODO: 401 sets |is_success| true.
1021      if ($res->is_success or $http->get_parameter ('error-page')) {      if ($res->is_success or $http->get_parameter ('error-page')) {
# Line 811  EOH Line 1025  EOH
1025    
1026        ## TODO: More strict parsing...        ## TODO: More strict parsing...
1027        my $ct = $res->header ('Content-Type');        my $ct = $res->header ('Content-Type');
1028        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) {  
1029          $r->{charset} = lc $1;          $r->{charset} = lc $1;
1030          $r->{charset} =~ tr/\\//d;          $r->{charset} =~ tr/\\//d;
1031            $r->{official_charset} = $r->{charset};
1032        }        }
1033    
1034        my $input_charset = $http->get_parameter ('charset');        my $input_charset = $http->get_parameter ('charset');
# Line 824  EOH Line 1036  EOH
1036          $r->{charset_overridden}          $r->{charset_overridden}
1037              = (not defined $r->{charset} or $r->{charset} ne $input_charset);              = (not defined $r->{charset} or $r->{charset} ne $input_charset);
1038          $r->{charset} = $input_charset;          $r->{charset} = $input_charset;
1039        }        }
1040    
1041          ## TODO: Support for HTTP Content-Encoding
1042    
1043        $r->{s} = ''.$res->content;        $r->{s} = ''.$res->content;
1044    
1045          require Whatpm::ContentType;
1046          ($r->{official_type}, $r->{media_type})
1047              = Whatpm::ContentType->get_sniffed_type
1048                  (get_file_head => sub {
1049                     return substr $r->{s}, 0, shift;
1050                   },
1051                   http_content_type_byte => $ct,
1052                   has_http_content_encoding =>
1053                       defined $res->header ('Content-Encoding'),
1054                   supported_image_types => {});
1055      } else {      } else {
1056        $r->{uri} = $res->request->uri;        $r->{uri} = $res->request->uri;
1057        $r->{request_uri} = $request_uri;        $r->{request_uri} = $request_uri;
# Line 847  EOH Line 1072  EOH
1072      $r->{charset} = ''.$http->get_parameter ('_charset_');      $r->{charset} = ''.$http->get_parameter ('_charset_');
1073      $r->{charset} =~ s/\s+//g;      $r->{charset} =~ s/\s+//g;
1074      $r->{charset} = 'utf-8' if $r->{charset} eq '';      $r->{charset} = 'utf-8' if $r->{charset} eq '';
1075        $r->{official_charset} = $r->{charset};
1076      $r->{header_field} = [];      $r->{header_field} = [];
1077    
1078        require Whatpm::ContentType;
1079        ($r->{official_type}, $r->{media_type})
1080            = Whatpm::ContentType->get_sniffed_type
1081                (get_file_head => sub {
1082                   return substr $r->{s}, 0, shift;
1083                 },
1084                 http_content_type_byte => undef,
1085                 has_http_content_encoding => 0,
1086                 supported_image_types => {});
1087    }    }
1088    
1089    my $input_format = $http->get_parameter ('i');    my $input_format = $http->get_parameter ('i');
# Line 864  EOH Line 1100  EOH
1100    if ($r->{media_type} eq 'text/xml') {    if ($r->{media_type} eq 'text/xml') {
1101      unless (defined $r->{charset}) {      unless (defined $r->{charset}) {
1102        $r->{charset} = 'us-ascii';        $r->{charset} = 'us-ascii';
1103          $r->{official_charset} = $r->{charset};
1104      } elsif ($r->{charset_overridden} and $r->{charset} eq 'us-ascii') {      } elsif ($r->{charset_overridden} and $r->{charset} eq 'us-ascii') {
1105        $r->{charset_overridden} = 0;        $r->{charset_overridden} = 0;
1106      }      }
Legend:
Removed from v.1.19  
changed lines
  Added in v.1.29
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24