/[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.31 by wakaba, Sun Feb 10 02:05:30 2008 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      check_and_print ($input => $result);
93      print_result_section ($result);
94    } else {
95      print STDOUT qq[</dl></div>];
96      print_result_input_error_section ($input);
97    }
98    
99      print STDOUT qq[
100    <ul class="navigation" id="nav-items">
101    ];
102      for (@nav) {
103        print STDOUT qq[<li><a href="$_->[0]">$_->[1]</a></li>];
104      }
105      print STDOUT qq[
106    </ul>
107    </body>
108    </html>
109    ];
110    
111      for (qw/decode parse parse_html parse_xml parse_manifest
112              check check_manifest/) {
113        next unless defined $time{$_};
114        open my $file, '>>', ".cc-$_.txt" or die ".cc-$_.txt: $!";
115        print $file $char_length, "\t", $time{$_}, "\n";
116      }
117    
118    exit;
119    
120    sub add_error ($$$) {
121      my ($layer, $err, $result) = @_;
122      if (defined $err->{level}) {
123        if ($err->{level} eq 's') {
124          $result->{$layer}->{should}++;
125          $result->{$layer}->{score_min} -= 2;
126          $result->{conforming_min} = 0;
127        } elsif ($err->{level} eq 'w' or $err->{level} eq 'g') {
128          $result->{$layer}->{warning}++;
129        } elsif ($err->{level} eq 'u' or $err->{level} eq 'unsupported') {
130          $result->{$layer}->{unsupported}++;
131          $result->{unsupported} = 1;
132        } else {
133          $result->{$layer}->{must}++;
134          $result->{$layer}->{score_max} -= 2;
135          $result->{$layer}->{score_min} -= 2;
136          $result->{conforming_min} = 0;
137          $result->{conforming_max} = 0;
138        }
139      } else {
140        $result->{$layer}->{must}++;
141        $result->{$layer}->{score_max} -= 2;
142        $result->{$layer}->{score_min} -= 2;
143        $result->{conforming_min} = 0;
144        $result->{conforming_max} = 0;
145      }
146    } # add_error
147    
148    sub check_and_print ($$) {
149      my ($input, $result) = @_;
150    
151      print_http_header_section ($input, $result);
152    
153    my $doc;    my $doc;
154    my $el;    my $el;
155      my $manifest;
156    
157    if ($input->{media_type} eq 'text/html') {    if ($input->{media_type} eq 'text/html') {
158      ($doc, $el) = print_syntax_error_html_section ($input);      ($doc, $el) = print_syntax_error_html_section ($input, $result);
159      print_source_string_section (\($input->{s}), $input->{charset});      print_source_string_section
160            (\($input->{s}), $input->{charset} || $doc->input_encoding);
161    } elsif ({    } elsif ({
162              'text/xml' => 1,              'text/xml' => 1,
163              'application/atom+xml' => 1,              'application/atom+xml' => 1,
# Line 99  if (defined $input->{s}) { Line 166  if (defined $input->{s}) {
166              'application/xhtml+xml' => 1,              'application/xhtml+xml' => 1,
167              'application/xml' => 1,              'application/xml' => 1,
168             }->{$input->{media_type}}) {             }->{$input->{media_type}}) {
169      ($doc, $el) = print_syntax_error_xml_section ($input);      ($doc, $el) = print_syntax_error_xml_section ($input, $result);
170      print_source_string_section (\($input->{s}), $doc->input_encoding);      print_source_string_section (\($input->{s}), $doc->input_encoding);
171      } elsif ($input->{media_type} eq 'text/cache-manifest') {
172    ## TODO: MUST be text/cache-manifest
173        $manifest = print_syntax_error_manifest_section ($input, $result);
174        print_source_string_section (\($input->{s}), 'utf-8');
175    } else {    } else {
176      ## TODO: Change HTTP status code??      ## TODO: Change HTTP status code??
177      print_result_unknown_type_section ($input);      print_result_unknown_type_section ($input, $result);
178    }    }
179    
180    if (defined $doc or defined $el) {    if (defined $doc or defined $el) {
181      print_structure_dump_section ($doc, $el);      print_structure_dump_dom_section ($doc, $el);
182      my $elements = print_structure_error_section ($doc, $el);      my $elements = print_structure_error_dom_section ($doc, $el, $result);
183      print_table_section ($elements->{table}) if @{$elements->{table}};      print_table_section ($elements->{table}) if @{$elements->{table}};
184      print_id_section ($elements->{id}) if keys %{$elements->{id}};      print_id_section ($elements->{id}) if keys %{$elements->{id}};
185      print_term_section ($elements->{term}) if keys %{$elements->{term}};      print_term_section ($elements->{term}) if keys %{$elements->{term}};
186      print_class_section ($elements->{class}) if keys %{$elements->{class}};      print_class_section ($elements->{class}) if keys %{$elements->{class}};
187      } elsif (defined $manifest) {
188        print_structure_dump_manifest_section ($manifest);
189        print_structure_error_manifest_section ($manifest, $result);
190    }    }
191    } # check_and_print
192    
193    ## TODO: Show result  sub print_http_header_section ($$) {
194  } else {    my ($input, $result) = @_;
   print STDOUT qq[</dl></div>];  
   print_result_input_error_section ($input);  
 }  
   
   print STDOUT qq[  
 <ul class="navigation" id="nav-items">  
 ];  
   for (@nav) {  
     print STDOUT qq[<li><a href="$_->[0]">$_->[1]</a></li>];  
   }  
   print STDOUT qq[  
 </ul>  
 </body>  
 </html>  
 ];  
   
   for (qw/decode parse parse_xml check/) {  
     next unless defined $time{$_};  
     open my $file, '>>', ".cc-$_.txt" or die ".cc-$_.txt: $!";  
     print $file $char_length, "\t", $time{$_}, "\n";  
   }  
   
 exit;  
   
 sub print_http_header_section ($) {  
   my $input = shift;  
195    return unless defined $input->{header_status_code} or    return unless defined $input->{header_status_code} or
196        defined $input->{header_status_text} or        defined $input->{header_status_text} or
197        @{$input->{header_field}};        @{$input->{header_field}};
# Line 175  not be the real header.</p> Line 224  not be the real header.</p>
224    print STDOUT qq[</tbody></table></div>];    print STDOUT qq[</tbody></table></div>];
225  } # print_http_header_section  } # print_http_header_section
226    
227  sub print_syntax_error_html_section ($) {  sub print_syntax_error_html_section ($$) {
228    my $input = shift;    my ($input, $result) = @_;
229        
230    require Encode;    require Encode;
231    require Whatpm::HTML;    require Whatpm::HTML;
   
   $input->{charset} ||= 'ISO-8859-1'; ## TODO: for now.  
232        
   my $time1 = time;  
   my $t = Encode::decode ($input->{charset}, $input->{s});  
   $time{decode} = time - $time1;  
   
233    print STDOUT qq[    print STDOUT qq[
234  <div id="parse-errors" class="section">  <div id="parse-errors" class="section">
235  <h2>Parse Errors</h2>  <h2>Parse Errors</h2>
# Line 206  sub print_syntax_error_html_section ($) Line 249  sub print_syntax_error_html_section ($)
249      $type =~ tr/ /-/;      $type =~ tr/ /-/;
250      $type =~ s/\|/%7C/g;      $type =~ s/\|/%7C/g;
251      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
252      print STDOUT qq[<dd class="$cls">$msg</dd>\n];      print STDOUT qq[<dd class="$cls">], get_error_level_label (\%opt);
253        print STDOUT qq[$msg</dd>\n];
254    
255        add_error ('syntax', \%opt => $result);
256    };    };
257    
258    my $doc = $dom->create_document;    my $doc = $dom->create_document;
259    my $el;    my $el;
260    $time1 = time;    my $inner_html_element = $http->get_parameter ('e');
261    if (defined $inner_html_element and length $inner_html_element) {    if (defined $inner_html_element and length $inner_html_element) {
262        $input->{charset} ||= 'windows-1252'; ## TODO: for now.
263        my $time1 = time;
264        my $t = Encode::decode ($input->{charset}, $input->{s});
265        $time{decode} = time - $time1;
266        
267      $el = $doc->create_element_ns      $el = $doc->create_element_ns
268          ('http://www.w3.org/1999/xhtml', [undef, $inner_html_element]);          ('http://www.w3.org/1999/xhtml', [undef, $inner_html_element]);
269        $time1 = time;
270      Whatpm::HTML->set_inner_html ($el, $t, $onerror);      Whatpm::HTML->set_inner_html ($el, $t, $onerror);
271        $time{parse} = time - $time1;
272    } else {    } else {
273      Whatpm::HTML->parse_string ($t => $doc, $onerror);      my $time1 = time;
274        Whatpm::HTML->parse_byte_string
275            ($input->{charset}, $input->{s} => $doc, $onerror);
276        $time{parse_html} = time - $time1;
277    }    }
278    $time{parse} = time - $time1;    $doc->manakai_charset ($input->{official_charset})
279          if defined $input->{official_charset};
280      
281    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
282    
283    return ($doc, $el);    return ($doc, $el);
284  } # print_syntax_error_html_section  } # print_syntax_error_html_section
285    
286  sub print_syntax_error_xml_section ($) {  sub print_syntax_error_xml_section ($$) {
287    my $input = shift;    my ($input, $result) = @_;
288        
289    require Message::DOM::XMLParserTemp;    require Message::DOM::XMLParserTemp;
290        
# Line 244  sub print_syntax_error_xml_section ($) { Line 301  sub print_syntax_error_xml_section ($) {
301      print STDOUT qq[<dt><a href="#line-$line">Line $line</a> column ];      print STDOUT qq[<dt><a href="#line-$line">Line $line</a> column ];
302      print STDOUT $err->location->column_number, "</dt><dd>";      print STDOUT $err->location->column_number, "</dt><dd>";
303      print STDOUT htescape $err->text, "</dd>\n";      print STDOUT htescape $err->text, "</dd>\n";
304    
305        add_error ('syntax', {type => $err->text,
306                    level => [
307                              $err->SEVERITY_FATAL_ERROR => 'm',
308                              $err->SEVERITY_ERROR => 'm',
309                              $err->SEVERITY_WARNING => 's',
310                             ]->[$err->severity]} => $result);
311    
312      return 1;      return 1;
313    };    };
314    
# Line 252  sub print_syntax_error_xml_section ($) { Line 317  sub print_syntax_error_xml_section ($) {
317    my $doc = Message::DOM::XMLParserTemp->parse_byte_stream    my $doc = Message::DOM::XMLParserTemp->parse_byte_stream
318        ($fh => $dom, $onerror, charset => $input->{charset});        ($fh => $dom, $onerror, charset => $input->{charset});
319    $time{parse_xml} = time - $time1;    $time{parse_xml} = time - $time1;
320      $doc->manakai_charset ($input->{official_charset})
321          if defined $input->{official_charset};
322    
323    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
324    
325    return ($doc, undef);    return ($doc, undef);
326  } # print_syntax_error_xml_section  } # print_syntax_error_xml_section
327    
328    sub print_syntax_error_manifest_section ($$) {
329      my ($input, $result) = @_;
330    
331      require Whatpm::CacheManifest;
332    
333      print STDOUT qq[
334    <div id="parse-errors" class="section">
335    <h2>Parse Errors</h2>
336    
337    <dl>];
338      push @nav, ['#parse-errors' => 'Parse Error'];
339    
340      my $onerror = sub {
341        my (%opt) = @_;
342        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level});
343        print STDOUT qq[<dt class="$cls">], get_error_label (\%opt), qq[</dt>];
344        $type =~ tr/ /-/;
345        $type =~ s/\|/%7C/g;
346        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
347        print STDOUT qq[<dd class="$cls">], get_error_level_label (\%opt);
348        print STDOUT qq[$msg</dd>\n];
349    
350        add_error ('syntax', \%opt => $result);
351      };
352    
353      my $time1 = time;
354      my $manifest = Whatpm::CacheManifest->parse_byte_string
355          ($input->{s}, $input->{uri}, $input->{base_uri}, $onerror);
356      $time{parse_manifest} = time - $time1;
357    
358      print STDOUT qq[</dl></div>];
359    
360      return $manifest;
361    } # print_syntax_error_manifest_section
362    
363  sub print_source_string_section ($$) {  sub print_source_string_section ($$) {
364    require Encode;    require Encode;
365    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 408  sub print_document_tree ($) {
408          $r .= '<ul class="attributes">';          $r .= '<ul class="attributes">';
409          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 $_] }
410                        @{$child->attributes}) {                        @{$child->attributes}) {
411            $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?
412            $r .= '<q>' . htescape ($attr->[1]) . '</q></li>'; ## TODO: children            $r .= '<q>' . htescape ($attr->[1]) . '</q></li>'; ## TODO: children
413          }          }
414          $r .= '</ul>';          $r .= '</ul>';
# Line 327  sub print_document_tree ($) { Line 429  sub print_document_tree ($) {
429      } elsif ($nt == $child->DOCUMENT_NODE) {      } elsif ($nt == $child->DOCUMENT_NODE) {
430        $r .= qq'<li id="$node_id" class="tree-document">Document';        $r .= qq'<li id="$node_id" class="tree-document">Document';
431        $r .= qq[<ul class="attributes">];        $r .= qq[<ul class="attributes">];
432          my $cp = $child->manakai_charset;
433          if (defined $cp) {
434            $r .= qq[<li><code>charset</code> parameter = <code>];
435            $r .= htescape ($cp) . qq[</code></li>];
436          }
437          $r .= qq[<li><code>inputEncoding</code> = ];
438          my $ie = $child->input_encoding;
439          if (defined $ie) {
440            $r .= qq[<code>@{[htescape ($ie)]}</code>];
441            if ($child->manakai_has_bom) {
442              $r .= qq[ (with <code class=charname><abbr>BOM</abbr></code>)];
443            }
444          } else {
445            $r .= qq[(<code>null</code>)];
446          }
447        $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>];
448        $r .= qq[<li>@{[scalar get_text ('manakaiCompatMode:'.$child->manakai_compat_mode)]}</li>];        $r .= qq[<li>@{[scalar get_text ('manakaiCompatMode:'.$child->manakai_compat_mode)]}</li>];
449        unless ($child->manakai_is_html) {        unless ($child->manakai_is_html) {
# Line 360  sub print_document_tree ($) { Line 477  sub print_document_tree ($) {
477    print STDOUT $r;    print STDOUT $r;
478  } # print_document_tree  } # print_document_tree
479    
480  sub print_structure_dump_section ($$) {  sub print_structure_dump_dom_section ($$) {
481    my ($doc, $el) = @_;    my ($doc, $el) = @_;
482    
483    print STDOUT qq[    print STDOUT qq[
# Line 372  sub print_structure_dump_section ($$) { Line 489  sub print_structure_dump_section ($$) {
489    print_document_tree ($el || $doc);    print_document_tree ($el || $doc);
490    
491    print STDOUT qq[</div>];    print STDOUT qq[</div>];
492  } # print_structure_dump_section  } # print_structure_dump_dom_section
493    
494  sub print_structure_error_section ($$) {  sub print_structure_dump_manifest_section ($) {
495    my ($doc, $el) = @_;    my $manifest = shift;
496    
497      print STDOUT qq[
498    <div id="dump-manifest" class="section">
499    <h2>Cache Manifest</h2>
500    ];
501      push @nav, ['#dump-manifest' => 'Caceh Manifest'];
502    
503      print STDOUT qq[<dl><dt>Explicit entries</dt>];
504      for my $uri (@{$manifest->[0]}) {
505        my $euri = htescape ($uri);
506        print STDOUT qq[<dd><code class=uri>&lt;<a href="$euri">$euri</a>></code></dd>];
507      }
508    
509      print STDOUT qq[<dt>Fallback entries</dt><dd>
510          <table><thead><tr><th scope=row>Oppotunistic Caching Namespace</th>
511          <th scope=row>Fallback Entry</tr><tbody>];
512      for my $uri (sort {$a cmp $b} keys %{$manifest->[1]}) {
513        my $euri = htescape ($uri);
514        my $euri2 = htescape ($manifest->[1]->{$uri});
515        print STDOUT qq[<tr><td><code class=uri>&lt;<a href="$euri">$euri</a>></code></td>
516            <td><code class=uri>&lt;<a href="$euri2">$euri2</a>></code></td>];
517      }
518    
519      print STDOUT qq[</table><dt>Online whitelist</dt>];
520      for my $uri (@{$manifest->[2]}) {
521        my $euri = htescape ($uri);
522        print STDOUT qq[<dd><code class=uri>&lt;<a href="$euri">$euri</a>></code></dd>];
523      }
524    
525      print STDOUT qq[</dl></div>];
526    } # print_structure_dump_manifest_section
527    
528    sub print_structure_error_dom_section ($$$) {
529      my ($doc, $el, $result) = @_;
530    
531    print STDOUT qq[<div id="document-errors" class="section">    print STDOUT qq[<div id="document-errors" class="section">
532  <h2>Document Errors</h2>  <h2>Document Errors</h2>
# Line 390  sub print_structure_error_section ($$) { Line 541  sub print_structure_error_section ($$) {
541      $type =~ tr/ /-/;      $type =~ tr/ /-/;
542      $type =~ s/\|/%7C/g;      $type =~ s/\|/%7C/g;
543      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
544      print STDOUT qq[<dt class="$cls">] . get_node_link ($opt{node}) .      print STDOUT qq[<dt class="$cls">] . get_error_label (\%opt) .
545          qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";          qq[</dt>\n<dd class="$cls">], get_error_level_label (\%opt);
546        print STDOUT $msg, "</dd>\n";
547        add_error ('structure', \%opt => $result);
548    };    };
549    
550    my $elements;    my $elements;
# Line 406  sub print_structure_error_section ($$) { Line 559  sub print_structure_error_section ($$) {
559    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
560    
561    return $elements;    return $elements;
562  } # print_structure_error_section  } # print_structure_error_dom_section
563    
564    sub print_structure_error_manifest_section ($$$) {
565      my ($manifest, $result) = @_;
566    
567      print STDOUT qq[<div id="document-errors" class="section">
568    <h2>Document Errors</h2>
569    
570    <dl>];
571      push @nav, ['#document-errors' => 'Document Error'];
572    
573      require Whatpm::CacheManifest;
574      Whatpm::CacheManifest->check_manifest ($manifest, sub {
575        my %opt = @_;
576        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level}, $opt{node});
577        $type =~ tr/ /-/;
578        $type =~ s/\|/%7C/g;
579        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
580        print STDOUT qq[<dt class="$cls">] . get_error_label (\%opt) .
581            qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";
582        add_error ('structure', \%opt => $result);
583      });
584    
585      print STDOUT qq[</div>];
586    } # print_structure_error_manifest_section
587    
588  sub print_table_section ($) {  sub print_table_section ($) {
589    my $tables = shift;    my $tables = shift;
# Line 524  sub print_class_section ($) { Line 701  sub print_class_section ($) {
701    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
702  } # print_class_section  } # print_class_section
703    
704  sub print_result_unknown_type_section ($) {  sub print_result_section ($) {
705    my $input = shift;    my $result = shift;
706    
707    print STDOUT qq[    print STDOUT qq[
708  <div id="result-summary" class="section">  <div id="result-summary" class="section">
709  <p><em>Media type <code class="MIME" lang="en">@{[htescape $input->{media_type}]}</code> is not supported!</em></p>  <h2>Result</h2>];
710    
711      if ($result->{unsupported} and $result->{conforming_max}) {  
712        print STDOUT qq[<p class=uncertain id=result-para>The conformance
713            checker cannot decide whether the document is conforming or
714            not, since the document contains one or more unsupported
715            features.  The document might or might not be conforming.</p>];
716      } elsif ($result->{conforming_min}) {
717        print STDOUT qq[<p class=PASS id=result-para>No conformance-error is
718            found in this document.</p>];
719      } elsif ($result->{conforming_max}) {
720        print STDOUT qq[<p class=SEE-RESULT id=result-para>This document
721            is <strong>likely <em>non</em>-conforming</strong>, but in rare case
722            it might be conforming.</p>];
723      } else {
724        print STDOUT qq[<p class=FAIL id=result-para>This document is
725            <strong><em>non</em>-conforming</strong>.</p>];
726      }
727    
728      print STDOUT qq[<table>
729    <colgroup><col><colgroup><col><col><col><colgroup><col>
730    <thead>
731    <tr><th scope=col></th>
732    <th scope=col><a href="../error-description#level-m"><em class=rfc2119>MUST</em>‐level
733    Errors</a></th>
734    <th scope=col><a href="../error-description#level-s"><em class=rfc2119>SHOULD</em>‐level
735    Errors</a></th>
736    <th scope=col><a href="../error-description#level-w">Warnings</a></th>
737    <th scope=col>Score</th></tr></thead><tbody>];
738    
739      my $must_error = 0;
740      my $should_error = 0;
741      my $warning = 0;
742      my $score_min = 0;
743      my $score_max = 0;
744      my $score_base = 20;
745      my $score_unit = $score_base / 100;
746      for (
747        [Transfer => 'transfer', ''],
748        [Character => 'char', ''],
749        [Syntax => 'syntax', '#parse-errors'],
750        [Structure => 'structure', '#document-errors'],
751      ) {
752        $must_error += ($result->{$_->[1]}->{must} += 0);
753        $should_error += ($result->{$_->[1]}->{should} += 0);
754        $warning += ($result->{$_->[1]}->{warning} += 0);
755        $score_min += (($result->{$_->[1]}->{score_min} *= $score_unit) += $score_base);
756        $score_max += (($result->{$_->[1]}->{score_max} *= $score_unit) += $score_base);
757    
758        my $uncertain = $result->{$_->[1]}->{unsupported} ? '?' : '';
759        my $label = $_->[0];
760        if ($result->{$_->[1]}->{must} or
761            $result->{$_->[1]}->{should} or
762            $result->{$_->[1]}->{warning} or
763            $result->{$_->[1]}->{unsupported}) {
764          $label = qq[<a href="$_->[2]">$label</a>];
765        }
766    
767        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>];
768        if ($uncertain) {
769          print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : $result->{$_->[1]}->{should} ? 'SEE-RESULT' : '']}">&#x2212;&#x221E;..$result->{$_->[1]}->{score_max}</td>];
770        } elsif ($result->{$_->[1]}->{score_min} != $result->{$_->[1]}->{score_max}) {
771          print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : 'SEE-RESULT']}">$result->{$_->[1]}->{score_min}..$result->{$_->[1]}->{score_max}</td></tr>];
772        } else {
773          print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : '']}">$result->{$_->[1]}->{score_min}</td></tr>];
774        }
775      }
776    
777      $score_max += $score_base;
778    
779      print STDOUT qq[
780    <tr class=uncertain><th scope=row>Semantics</th><td>0?</td><td>0?</td><td>0?</td><td>&#x2212;&#x221E;..$score_base</td></tr>
781    </tbody>
782    <tfoot><tr class=uncertain><th scope=row>Total</th>
783    <td class="@{[$must_error ? 'FAIL' : '']}">$must_error?</td>
784    <td class="@{[$should_error ? 'SEE-RESULT' : '']}">$should_error?</td>
785    <td>$warning?</td>
786    <td class="@{[$must_error ? 'FAIL' : $should_error ? 'SEE-RESULT' : '']}"><strong>&#x2212;&#x221E;..$score_max</strong></td></tr></tfoot>
787    </table>
788    
789    <p><strong>Important</strong>: This conformance checking service
790    is <em>under development</em>.  The result above might be <em>wrong</em>.</p>
791    </div>];
792      push @nav, ['#result-summary' => 'Result'];
793    } # print_result_section
794    
795    sub print_result_unknown_type_section ($$) {
796      my ($input, $result) = @_;
797    
798      my $euri = htescape ($input->{uri});
799      print STDOUT qq[
800    <div id="parse-errors" class="section">
801    <h2>Errors</h2>
802    
803    <dl>
804    <dt class=unsupported><code>&lt;<a href="$euri">$euri</a>&gt;</code></dt>
805        <dd class=unsupported><strong><a href="../error-description#level-u">Not
806            supported</a></strong>:
807        Media type
808        <code class="MIME" lang="en">@{[htescape $input->{media_type}]}</code>
809        is not supported.</dd>
810    </dl>
811  </div>  </div>
812  ];  ];
813    push @nav, ['#result-summary' => 'Result'];    push @nav, ['#parse-errors' => 'Errors'];
814      add_error (char => {level => 'u'} => $result);
815      add_error (syntax => {level => 'u'} => $result);
816      add_error (structure => {level => 'u'} => $result);
817  } # print_result_unknown_type_section  } # print_result_unknown_type_section
818    
819  sub print_result_input_error_section ($) {  sub print_result_input_error_section ($) {
# Line 543  sub print_result_input_error_section ($) Line 824  sub print_result_input_error_section ($)
824    push @nav, ['#result-summary' => 'Result'];    push @nav, ['#result-summary' => 'Result'];
825  } # print_Result_input_error_section  } # print_Result_input_error_section
826    
827    sub get_error_label ($) {
828      my $err = shift;
829    
830      my $r = '';
831    
832      if (defined $err->{line}) {
833        if ($err->{column} > 0) {
834          $r = qq[<a href="#line-$err->{line}">Line $err->{line}</a> column $err->{column}];
835        } else {
836          $err->{line} = $err->{line} - 1 || 1;
837          $r = qq[<a href="#line-$err->{line}">Line $err->{line}</a>];
838        }
839      }
840    
841      if (defined $err->{node}) {
842        $r .= ' ' if length $r;
843        $r = get_node_link ($err->{node});
844      }
845    
846      if (defined $err->{index}) {
847        $r .= ' ' if length $r;
848        $r .= 'Index ' . (0+$err->{index});
849      }
850    
851      if (defined $err->{value}) {
852        $r .= ' ' if length $r;
853        $r .= '<q><code>' . htescape ($err->{value}) . '</code></q>';
854      }
855    
856      return $r;
857    } # get_error_label
858    
859    sub get_error_level_label ($) {
860      my $err = shift;
861    
862      my $r = '';
863    
864      if (not defined $err->{level} or $err->{level} eq 'm') {
865        $r = qq[<strong><a href="../error-description#level-m"><em class=rfc2119>MUST</em>‐level
866            error</a></strong>: ];
867      } elsif ($err->{level} eq 's') {
868        $r = qq[<strong><a href="../error-description#level-s"><em class=rfc2119>SHOULD</em>‐level
869            error</a></strong>: ];
870      } elsif ($err->{level} eq 'w') {
871        $r = qq[<strong><a href="../error-description#level-w">Warning</a></strong>:
872            ];
873      } elsif ($err->{level} eq 'u' or $err->{level} eq 'unsupported') {
874        $r = qq[<strong><a href="../error-description#level-u">Not
875            supported</a></strong>: ];
876      } else {
877        my $elevel = htescape ($err->{level});
878        $r = qq[<strong><a href="../error-description#level-$elevel">$elevel</a></strong>:
879            ];
880      }
881    
882      return $r;
883    } # get_error_level_label
884    
885  sub get_node_path ($) {  sub get_node_path ($) {
886    my $node = shift;    my $node = shift;
887    my @r;    my @r;
# Line 580  sub get_node_link ($) { Line 919  sub get_node_link ($) {
919    
920  sub load_text_catalog ($) {  sub load_text_catalog ($) {
921    my $lang = shift; # MUST be a canonical lang name    my $lang = shift; # MUST be a canonical lang name
922    open my $file, '<', "cc-msg.$lang.txt" or die "$0: cc-msg.$lang.txt: $!";    open my $file, '<:utf8', "cc-msg.$lang.txt"
923          or die "$0: cc-msg.$lang.txt: $!";
924    while (<$file>) {    while (<$file>) {
925      if (s/^([^;]+);([^;]*);//) {      if (s/^([^;]+);([^;]*);//) {
926        my ($type, $cls, $msg) = ($1, $2, $_);        my ($type, $cls, $msg) = ($1, $2, $_);
# Line 593  sub load_text_catalog ($) { Line 933  sub load_text_catalog ($) {
933  sub get_text ($) {  sub get_text ($) {
934    my ($type, $level, $node) = @_;    my ($type, $level, $node) = @_;
935    $type = $level . ':' . $type if defined $level;    $type = $level . ':' . $type if defined $level;
936      $level = 'm' unless defined $level;
937    my @arg;    my @arg;
938    {    {
939      if (defined $Msg->{$type}) {      if (defined $Msg->{$type}) {
# Line 617  sub get_text ($) { Line 958  sub get_text ($) {
958            ? htescape ($node->owner_element->manakai_local_name)            ? htescape ($node->owner_element->manakai_local_name)
959            : ''            : ''
960        }ge;        }ge;
961        return ($type, $Msg->{$type}->[0], $msg);        return ($type, 'level-' . $level . ' ' . $Msg->{$type}->[0], $msg);
962      } elsif ($type =~ s/:([^:]*)$//) {      } elsif ($type =~ s/:([^:]*)$//) {
963        unshift @arg, $1;        unshift @arg, $1;
964        redo;        redo;
965      }      }
966    }    }
967    return ($type, '', htescape ($_[0]));    return ($type, 'level-'.$level, htescape ($_[0]));
968  } # get_text  } # get_text
969    
970  }  }
# Line 679  EOH Line 1020  EOH
1020      $ua->protocols_allowed ([qw/http/]);      $ua->protocols_allowed ([qw/http/]);
1021      $ua->max_size (1000_000);      $ua->max_size (1000_000);
1022      my $req = HTTP::Request->new (GET => $request_uri);      my $req = HTTP::Request->new (GET => $request_uri);
1023        $req->header ('Accept-Encoding' => 'identity, *; q=0');
1024      my $res = $ua->request ($req);      my $res = $ua->request ($req);
1025      ## TODO: 401 sets |is_success| true.      ## TODO: 401 sets |is_success| true.
1026      if ($res->is_success or $http->get_parameter ('error-page')) {      if ($res->is_success or $http->get_parameter ('error-page')) {
# Line 688  EOH Line 1030  EOH
1030    
1031        ## TODO: More strict parsing...        ## TODO: More strict parsing...
1032        my $ct = $res->header ('Content-Type');        my $ct = $res->header ('Content-Type');
1033        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) {  
1034          $r->{charset} = lc $1;          $r->{charset} = lc $1;
1035          $r->{charset} =~ tr/\\//d;          $r->{charset} =~ tr/\\//d;
1036            $r->{official_charset} = $r->{charset};
1037        }        }
1038    
1039        my $input_charset = $http->get_parameter ('charset');        my $input_charset = $http->get_parameter ('charset');
# Line 701  EOH Line 1041  EOH
1041          $r->{charset_overridden}          $r->{charset_overridden}
1042              = (not defined $r->{charset} or $r->{charset} ne $input_charset);              = (not defined $r->{charset} or $r->{charset} ne $input_charset);
1043          $r->{charset} = $input_charset;          $r->{charset} = $input_charset;
1044        }        }
1045    
1046          ## TODO: Support for HTTP Content-Encoding
1047    
1048        $r->{s} = ''.$res->content;        $r->{s} = ''.$res->content;
1049    
1050          require Whatpm::ContentType;
1051          ($r->{official_type}, $r->{media_type})
1052              = Whatpm::ContentType->get_sniffed_type
1053                  (get_file_head => sub {
1054                     return substr $r->{s}, 0, shift;
1055                   },
1056                   http_content_type_byte => $ct,
1057                   has_http_content_encoding =>
1058                       defined $res->header ('Content-Encoding'),
1059                   supported_image_types => {});
1060      } else {      } else {
1061        $r->{uri} = $res->request->uri;        $r->{uri} = $res->request->uri;
1062        $r->{request_uri} = $request_uri;        $r->{request_uri} = $request_uri;
# Line 724  EOH Line 1077  EOH
1077      $r->{charset} = ''.$http->get_parameter ('_charset_');      $r->{charset} = ''.$http->get_parameter ('_charset_');
1078      $r->{charset} =~ s/\s+//g;      $r->{charset} =~ s/\s+//g;
1079      $r->{charset} = 'utf-8' if $r->{charset} eq '';      $r->{charset} = 'utf-8' if $r->{charset} eq '';
1080        $r->{official_charset} = $r->{charset};
1081      $r->{header_field} = [];      $r->{header_field} = [];
1082    
1083        require Whatpm::ContentType;
1084        ($r->{official_type}, $r->{media_type})
1085            = Whatpm::ContentType->get_sniffed_type
1086                (get_file_head => sub {
1087                   return substr $r->{s}, 0, shift;
1088                 },
1089                 http_content_type_byte => undef,
1090                 has_http_content_encoding => 0,
1091                 supported_image_types => {});
1092    }    }
1093    
1094    my $input_format = $http->get_parameter ('i');    my $input_format = $http->get_parameter ('i');
# Line 741  EOH Line 1105  EOH
1105    if ($r->{media_type} eq 'text/xml') {    if ($r->{media_type} eq 'text/xml') {
1106      unless (defined $r->{charset}) {      unless (defined $r->{charset}) {
1107        $r->{charset} = 'us-ascii';        $r->{charset} = 'us-ascii';
1108          $r->{official_charset} = $r->{charset};
1109      } elsif ($r->{charset_overridden} and $r->{charset} eq 'us-ascii') {      } elsif ($r->{charset_overridden} and $r->{charset} eq 'us-ascii') {
1110        $r->{charset_overridden} = 0;        $r->{charset_overridden} = 0;
1111      }      }
Legend:
Removed from v.1.18  
changed lines
  Added in v.1.31
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24