/[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.28 by wakaba, Fri Nov 23 06:36:19 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 306  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 327  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 360  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 372  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_error_section ($$) {  sub print_structure_dump_manifest_section ($) {
490    my ($doc, $el) = @_;    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_dom_section ($$$) {
524      my ($doc, $el, $result) = @_;
525    
526    print STDOUT qq[<div id="document-errors" class="section">    print STDOUT qq[<div id="document-errors" class="section">
527  <h2>Document Errors</h2>  <h2>Document Errors</h2>
# Line 390  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);
543    };    };
544    
545    my $elements;    my $elements;
# Line 406  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 524  sub print_class_section ($) { Line 696  sub print_class_section ($) {
696    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
697  } # print_class_section  } # print_class_section
698    
699  sub print_result_unknown_type_section ($) {  sub print_result_section ($) {
700    my $input = shift;    my $result = shift;
701    
702    print STDOUT qq[    print STDOUT qq[
703  <div id="result-summary" class="section">  <div id="result-summary" class="section">
704  <p><em>Media type <code class="MIME" lang="en">@{[htescape $input->{media_type}]}</code> is not supported!</em></p>  <h2>Result</h2>];
705    
706      if ($result->{unsupported} and $result->{conforming_max}) {  
707        print STDOUT qq[<p class=uncertain id=result-para>The conformance
708            checker cannot decide whether the document is conforming or
709            not, since the document contains one or more unsupported
710            features.  The document might or might not be conforming.</p>];
711      } elsif ($result->{conforming_min}) {
712        print STDOUT qq[<p class=PASS id=result-para>No conformance-error is
713            found in this document.</p>];
714      } elsif ($result->{conforming_max}) {
715        print STDOUT qq[<p class=SEE-RESULT id=result-para>This document
716            is <strong>likely <em>non</em>-conforming</strong>, but in rare case
717            it might be conforming.</p>];
718      } else {
719        print STDOUT qq[<p class=FAIL id=result-para>This document is
720            <strong><em>non</em>-conforming</strong>.</p>];
721      }
722    
723      print STDOUT qq[<table>
724    <colgroup><col><colgroup><col><col><col><colgroup><col>
725    <thead>
726    <tr><th scope=col></th>
727    <th scope=col><a href="../error-description#level-m"><em class=rfc2119>MUST</em>‐level
728    Errors</a></th>
729    <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;
735      my $should_error = 0;
736      my $warning = 0;
737      my $score_min = 0;
738      my $score_max = 0;
739      my $score_base = 20;
740      my $score_unit = $score_base / 100;
741      for (
742        [Transfer => 'transfer', ''],
743        [Character => 'char', ''],
744        [Syntax => 'syntax', '#parse-errors'],
745        [Structure => 'structure', '#document-errors'],
746      ) {
747        $must_error += ($result->{$_->[1]}->{must} += 0);
748        $should_error += ($result->{$_->[1]}->{should} += 0);
749        $warning += ($result->{$_->[1]}->{warning} += 0);
750        $score_min += (($result->{$_->[1]}->{score_min} *= $score_unit) += $score_base);
751        $score_max += (($result->{$_->[1]}->{score_max} *= $score_unit) += $score_base);
752    
753        my $uncertain = $result->{$_->[1]}->{unsupported} ? '?' : '';
754        my $label = $_->[0];
755        if ($result->{$_->[1]}->{must} or
756            $result->{$_->[1]}->{should} or
757            $result->{$_->[1]}->{warning} or
758            $result->{$_->[1]}->{unsupported}) {
759          $label = qq[<a href="$_->[2]">$label</a>];
760        }
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>];
763        if ($uncertain) {
764          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}) {
766          print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : 'SEE-RESULT']}">$result->{$_->[1]}->{score_min}..$result->{$_->[1]}->{score_max}</td></tr>];
767        } else {
768          print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : '']}">$result->{$_->[1]}->{score_min}</td></tr>];
769        }
770      }
771    
772      $score_max += $score_base;
773    
774      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>
776    </tbody>
777    <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>
783    
784    <p><strong>Important</strong>: This conformance checking service
785    is <em>under development</em>.  The result above might be <em>wrong</em>.</p>
786    </div>];
787      push @nav, ['#result-summary' => 'Result'];
788    } # print_result_section
789    
790    sub print_result_unknown_type_section ($$) {
791      my ($input, $result) = @_;
792    
793      my $euri = htescape ($input->{uri});
794      print STDOUT qq[
795    <div id="parse-errors" class="section">
796    <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 543  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 580  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 679  EOH Line 1014  EOH
1014      $ua->protocols_allowed ([qw/http/]);      $ua->protocols_allowed ([qw/http/]);
1015      $ua->max_size (1000_000);      $ua->max_size (1000_000);
1016      my $req = HTTP::Request->new (GET => $request_uri);      my $req = HTTP::Request->new (GET => $request_uri);
1017        $req->header ('Accept-Encoding' => 'identity, *; q=0');
1018      my $res = $ua->request ($req);      my $res = $ua->request ($req);
1019      ## TODO: 401 sets |is_success| true.      ## TODO: 401 sets |is_success| true.
1020      if ($res->is_success or $http->get_parameter ('error-page')) {      if ($res->is_success or $http->get_parameter ('error-page')) {
# Line 688  EOH Line 1024  EOH
1024    
1025        ## TODO: More strict parsing...        ## TODO: More strict parsing...
1026        my $ct = $res->header ('Content-Type');        my $ct = $res->header ('Content-Type');
1027        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) {  
1028          $r->{charset} = lc $1;          $r->{charset} = lc $1;
1029          $r->{charset} =~ tr/\\//d;          $r->{charset} =~ tr/\\//d;
1030            $r->{official_charset} = $r->{charset};
1031        }        }
1032    
1033        my $input_charset = $http->get_parameter ('charset');        my $input_charset = $http->get_parameter ('charset');
# Line 701  EOH Line 1035  EOH
1035          $r->{charset_overridden}          $r->{charset_overridden}
1036              = (not defined $r->{charset} or $r->{charset} ne $input_charset);              = (not defined $r->{charset} or $r->{charset} ne $input_charset);
1037          $r->{charset} = $input_charset;          $r->{charset} = $input_charset;
1038        }        }
1039    
1040          ## TODO: Support for HTTP Content-Encoding
1041    
1042        $r->{s} = ''.$res->content;        $r->{s} = ''.$res->content;
1043    
1044          require Whatpm::ContentType;
1045          ($r->{official_type}, $r->{media_type})
1046              = Whatpm::ContentType->get_sniffed_type
1047                  (get_file_head => sub {
1048                     return substr $r->{s}, 0, shift;
1049                   },
1050                   http_content_type_byte => $ct,
1051                   has_http_content_encoding =>
1052                       defined $res->header ('Content-Encoding'),
1053                   supported_image_types => {});
1054      } else {      } else {
1055        $r->{uri} = $res->request->uri;        $r->{uri} = $res->request->uri;
1056        $r->{request_uri} = $request_uri;        $r->{request_uri} = $request_uri;
# Line 724  EOH Line 1071  EOH
1071      $r->{charset} = ''.$http->get_parameter ('_charset_');      $r->{charset} = ''.$http->get_parameter ('_charset_');
1072      $r->{charset} =~ s/\s+//g;      $r->{charset} =~ s/\s+//g;
1073      $r->{charset} = 'utf-8' if $r->{charset} eq '';      $r->{charset} = 'utf-8' if $r->{charset} eq '';
1074        $r->{official_charset} = $r->{charset};
1075      $r->{header_field} = [];      $r->{header_field} = [];
1076    
1077        require Whatpm::ContentType;
1078        ($r->{official_type}, $r->{media_type})
1079            = Whatpm::ContentType->get_sniffed_type
1080                (get_file_head => sub {
1081                   return substr $r->{s}, 0, shift;
1082                 },
1083                 http_content_type_byte => undef,
1084                 has_http_content_encoding => 0,
1085                 supported_image_types => {});
1086    }    }
1087    
1088    my $input_format = $http->get_parameter ('i');    my $input_format = $http->get_parameter ('i');
# Line 741  EOH Line 1099  EOH
1099    if ($r->{media_type} eq 'text/xml') {    if ($r->{media_type} eq 'text/xml') {
1100      unless (defined $r->{charset}) {      unless (defined $r->{charset}) {
1101        $r->{charset} = 'us-ascii';        $r->{charset} = 'us-ascii';
1102          $r->{official_charset} = $r->{charset};
1103      } elsif ($r->{charset_overridden} and $r->{charset} eq 'us-ascii') {      } elsif ($r->{charset_overridden} and $r->{charset} eq 'us-ascii') {
1104        $r->{charset_overridden} = 0;        $r->{charset_overridden} = 0;
1105      }      }
Legend:
Removed from v.1.18  
changed lines
  Added in v.1.28
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24