/[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.22 by wakaba, Sun Nov 4 09:15:02 2007 UTC revision 1.33 by wakaba, Sun Feb 10 02:42:01 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 84  if (defined $input->{s}) { Line 89  if (defined $input->{s}) {
89  ];  ];
90    
91    my $result = {conforming_min => 1, conforming_max => 1};    my $result = {conforming_min => 1, conforming_max => 1};
92    print_http_header_section ($input, $result);    check_and_print ($input => $result);
   
   my $doc;  
   my $el;  
   my $manifest;  
   
   if ($input->{media_type} eq 'text/html') {  
     ($doc, $el) = print_syntax_error_html_section ($input, $result);  
     print_source_string_section (\($input->{s}), $input->{charset});  
   } elsif ({  
             'text/xml' => 1,  
             'application/atom+xml' => 1,  
             'application/rss+xml' => 1,  
             'application/svg+xml' => 1,  
             'application/xhtml+xml' => 1,  
             'application/xml' => 1,  
            }->{$input->{media_type}}) {  
     ($doc, $el) = print_syntax_error_xml_section ($input, $result);  
     print_source_string_section (\($input->{s}), $doc->input_encoding);  
   } elsif ($input->{media_type} eq 'text/cache-manifest') {  
 ## TODO: MUST be text/cache-manifest  
     $manifest = print_syntax_error_manifest_section ($input, $result);  
     print_source_string_section (\($input->{s}), 'utf-8');  
   } else {  
     ## TODO: Change HTTP status code??  
     print_result_unknown_type_section ($input);  
   }  
   
   if (defined $doc or defined $el) {  
     print_structure_dump_dom_section ($doc, $el);  
     my $elements = print_structure_error_dom_section ($doc, $el, $result);  
     print_table_section ($elements->{table}) if @{$elements->{table}};  
     print_id_section ($elements->{id}) if keys %{$elements->{id}};  
     print_term_section ($elements->{term}) if keys %{$elements->{term}};  
     print_class_section ($elements->{class}) if keys %{$elements->{class}};  
   } elsif (defined $manifest) {  
     print_structure_dump_manifest_section ($manifest);  
     print_structure_error_manifest_section ($manifest, $result);  
   }  
   
93    print_result_section ($result);    print_result_section ($result);
94  } else {  } else {
95    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
# Line 142  if (defined $input->{s}) { Line 108  if (defined $input->{s}) {
108  </html>  </html>
109  ];  ];
110    
111    for (qw/decode parse parse_xml parse_manifest check check_manifest/) {    for (qw/decode parse parse_html parse_xml parse_manifest
112              check check_manifest/) {
113      next unless defined $time{$_};      next unless defined $time{$_};
114      open my $file, '>>', ".cc-$_.txt" or die ".cc-$_.txt: $!";      open my $file, '>>', ".cc-$_.txt" or die ".cc-$_.txt: $!";
115      print $file $char_length, "\t", $time{$_}, "\n";      print $file $char_length, "\t", $time{$_}, "\n";
# Line 159  sub add_error ($$$) { Line 126  sub add_error ($$$) {
126        $result->{conforming_min} = 0;        $result->{conforming_min} = 0;
127      } elsif ($err->{level} eq 'w' or $err->{level} eq 'g') {      } elsif ($err->{level} eq 'w' or $err->{level} eq 'g') {
128        $result->{$layer}->{warning}++;        $result->{$layer}->{warning}++;
129      } elsif ($err->{level} eq 'unsupported') {      } elsif ($err->{level} eq 'u' or $err->{level} eq 'unsupported') {
130        $result->{$layer}->{unsupported}++;        $result->{$layer}->{unsupported}++;
131        $result->{unsupported} = 1;        $result->{unsupported} = 1;
132      } else {      } else {
# Line 178  sub add_error ($$$) { Line 145  sub add_error ($$$) {
145    }    }
146  } # add_error  } # add_error
147    
148    sub check_and_print ($$) {
149      my ($input, $result) = @_;
150      $input->{id_prefix} = '';
151      #$input->{nested} = 1/0;
152    
153      print_http_header_section ($input, $result);
154    
155      my $doc;
156      my $el;
157      my $manifest;
158    
159      if ($input->{media_type} eq 'text/html') {
160        ($doc, $el) = print_syntax_error_html_section ($input, $result);
161        print_source_string_section
162            (\($input->{s}), $input->{charset} || $doc->input_encoding);
163      } elsif ({
164                'text/xml' => 1,
165                'application/atom+xml' => 1,
166                'application/rss+xml' => 1,
167                'application/svg+xml' => 1,
168                'application/xhtml+xml' => 1,
169                'application/xml' => 1,
170               }->{$input->{media_type}}) {
171        ($doc, $el) = print_syntax_error_xml_section ($input, $result);
172        print_source_string_section (\($input->{s}), $doc->input_encoding);
173      } elsif ($input->{media_type} eq 'text/cache-manifest') {
174    ## TODO: MUST be text/cache-manifest
175        $manifest = print_syntax_error_manifest_section ($input, $result);
176        print_source_string_section (\($input->{s}), 'utf-8');
177      } else {
178        ## TODO: Change HTTP status code??
179        print_result_unknown_type_section ($input, $result);
180      }
181    
182      if (defined $doc or defined $el) {
183        print_structure_dump_dom_section ($input, $doc, $el);
184        my $elements = print_structure_error_dom_section
185            ($input, $doc, $el, $result);
186        print_table_section ($input, $elements->{table}) if @{$elements->{table}};
187        print_listing_section ({
188          id => 'identifiers', label => 'IDs', heading => 'Identifiers',
189        }, $input, $elements->{id}) if keys %{$elements->{id}};
190        print_listing_section ({
191          id => 'terms', label => 'Terms', heading => 'Terms',
192        }, $input, $elements->{term}) if keys %{$elements->{term}};
193        print_listing_section ({
194          id => 'classes', label => 'Classes', heading => 'Classes',
195        }, $input, $elements->{class}) if keys %{$elements->{class}};
196      } elsif (defined $manifest) {
197        print_structure_dump_manifest_section ($input, $manifest);
198        print_structure_error_manifest_section ($input, $manifest, $result);
199      }
200    } # check_and_print
201    
202  sub print_http_header_section ($$) {  sub print_http_header_section ($$) {
203    my ($input, $result) = @_;    my ($input, $result) = @_;
204    return unless defined $input->{header_status_code} or    return unless defined $input->{header_status_code} or
205        defined $input->{header_status_text} or        defined $input->{header_status_text} or
206        @{$input->{header_field}};        @{$input->{header_field}};
207        
208    push @nav, ['#source-header' => 'HTTP Header'];    push @nav, ['#source-header' => 'HTTP Header'] unless $input->{nested};
209    print STDOUT qq[<div id="source-header" class="section">    print STDOUT qq[<div id="$input->{id_prefix}source-header" class="section">
210  <h2>HTTP Header</h2>  <h2>HTTP Header</h2>
211    
212  <p><strong>Note</strong>: Due to the limitation of the  <p><strong>Note</strong>: Due to the limitation of the
# Line 217  sub print_syntax_error_html_section ($$) Line 238  sub print_syntax_error_html_section ($$)
238        
239    require Encode;    require Encode;
240    require Whatpm::HTML;    require Whatpm::HTML;
   
   $input->{charset} ||= 'ISO-8859-1'; ## TODO: for now.  
241        
   my $time1 = time;  
   my $t = Encode::decode ($input->{charset}, $input->{s});  
   $time{decode} = time - $time1;  
   
242    print STDOUT qq[    print STDOUT qq[
243  <div id="parse-errors" class="section">  <div id="$input->{id_prefix}parse-errors" class="section">
244  <h2>Parse Errors</h2>  <h2>Parse Errors</h2>
245    
246  <dl>];  <dl>];
247    push @nav, ['#parse-errors' => 'Parse Error'];    push @nav, ['#parse-errors' => 'Parse Error'] unless $input->{nested};
248    
249    my $onerror = sub {    my $onerror = sub {
250      my (%opt) = @_;      my (%opt) = @_;
# Line 243  sub print_syntax_error_html_section ($$) Line 258  sub print_syntax_error_html_section ($$)
258      $type =~ tr/ /-/;      $type =~ tr/ /-/;
259      $type =~ s/\|/%7C/g;      $type =~ s/\|/%7C/g;
260      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
261      print STDOUT qq[<dd class="$cls">$msg</dd>\n];      print STDOUT qq[<dd class="$cls">], get_error_level_label (\%opt);
262        print STDOUT qq[$msg</dd>\n];
263    
264      add_error ('syntax', \%opt => $result);      add_error ('syntax', \%opt => $result);
265    };    };
266    
267    my $doc = $dom->create_document;    my $doc = $dom->create_document;
268    my $el;    my $el;
269    $time1 = time;    my $inner_html_element = $http->get_parameter ('e');
270    if (defined $inner_html_element and length $inner_html_element) {    if (defined $inner_html_element and length $inner_html_element) {
271        $input->{charset} ||= 'windows-1252'; ## TODO: for now.
272        my $time1 = time;
273        my $t = Encode::decode ($input->{charset}, $input->{s});
274        $time{decode} = time - $time1;
275        
276      $el = $doc->create_element_ns      $el = $doc->create_element_ns
277          ('http://www.w3.org/1999/xhtml', [undef, $inner_html_element]);          ('http://www.w3.org/1999/xhtml', [undef, $inner_html_element]);
278        $time1 = time;
279      Whatpm::HTML->set_inner_html ($el, $t, $onerror);      Whatpm::HTML->set_inner_html ($el, $t, $onerror);
280        $time{parse} = time - $time1;
281    } else {    } else {
282      Whatpm::HTML->parse_string ($t => $doc, $onerror);      my $time1 = time;
283        Whatpm::HTML->parse_byte_string
284            ($input->{charset}, $input->{s} => $doc, $onerror);
285        $time{parse_html} = time - $time1;
286    }    }
287    $time{parse} = time - $time1;    $doc->manakai_charset ($input->{official_charset})
288          if defined $input->{official_charset};
289      
290    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
291    
292    return ($doc, $el);    return ($doc, $el);
# Line 271  sub print_syntax_error_xml_section ($$) Line 298  sub print_syntax_error_xml_section ($$)
298    require Message::DOM::XMLParserTemp;    require Message::DOM::XMLParserTemp;
299        
300    print STDOUT qq[    print STDOUT qq[
301  <div id="parse-errors" class="section">  <div id="$input->{id_prefix}parse-errors" class="section">
302  <h2>Parse Errors</h2>  <h2>Parse Errors</h2>
303    
304  <dl>];  <dl>];
305    push @nav, ['#parse-errors' => 'Parse Error'];    push @nav, ['#parse-errors' => 'Parse Error'] unless $input->{prefix};
306    
307    my $onerror = sub {    my $onerror = sub {
308      my $err = shift;      my $err = shift;
# Line 299  sub print_syntax_error_xml_section ($$) Line 326  sub print_syntax_error_xml_section ($$)
326    my $doc = Message::DOM::XMLParserTemp->parse_byte_stream    my $doc = Message::DOM::XMLParserTemp->parse_byte_stream
327        ($fh => $dom, $onerror, charset => $input->{charset});        ($fh => $dom, $onerror, charset => $input->{charset});
328    $time{parse_xml} = time - $time1;    $time{parse_xml} = time - $time1;
329      $doc->manakai_charset ($input->{official_charset})
330          if defined $input->{official_charset};
331    
332    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
333    
# Line 311  sub print_syntax_error_manifest_section Line 340  sub print_syntax_error_manifest_section
340    require Whatpm::CacheManifest;    require Whatpm::CacheManifest;
341    
342    print STDOUT qq[    print STDOUT qq[
343  <div id="parse-errors" class="section">  <div id="$input->{id_prefix}parse-errors" class="section">
344  <h2>Parse Errors</h2>  <h2>Parse Errors</h2>
345    
346  <dl>];  <dl>];
347    push @nav, ['#parse-errors' => 'Parse Error'];    push @nav, ['#parse-errors' => 'Parse Error'] unless $input->{nested};
348    
349    my $onerror = sub {    my $onerror = sub {
350      my (%opt) = @_;      my (%opt) = @_;
351      my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level});      my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level});
352      print STDOUT qq[<dt class="$cls">], get_error_label (\%opt), qq[</dt>];      print STDOUT qq[<dt class="$cls">], get_error_label ($input, \%opt),
353            qq[</dt>];
354      $type =~ tr/ /-/;      $type =~ tr/ /-/;
355      $type =~ s/\|/%7C/g;      $type =~ s/\|/%7C/g;
356      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
357      print STDOUT qq[<dd class="$cls">$msg</dd>\n];      print STDOUT qq[<dd class="$cls">], get_error_level_label (\%opt);
358        print STDOUT qq[$msg</dd>\n];
359    
360      add_error ('syntax', \%opt => $result);      add_error ('syntax', \%opt => $result);
361    };    };
# Line 346  sub print_source_string_section ($$) { Line 377  sub print_source_string_section ($$) {
377    
378    my $s = \($enc->decode (${$_[0]}));    my $s = \($enc->decode (${$_[0]}));
379    my $i = 1;                                my $i = 1;                            
380    push @nav, ['#source-string' => 'Source'];    push @nav, ['#source-string' => 'Source'] unless $input->{nested};
381    print STDOUT qq[<div id="source-string" class="section">    print STDOUT qq[<div id="$input->{id_prefix}source-string" class="section">
382  <h2>Document Source</h2>  <h2>Document Source</h2>
383  <ol lang="">\n];  <ol lang="">\n];
384    if (length $$s) {    if (length $$s) {
385      while ($$s =~ /\G([^\x0A]*?)\x0D?\x0A/gc) {      while ($$s =~ /\G([^\x0A]*?)\x0D?\x0A/gc) {
386        print STDOUT qq[<li id="line-$i">], htescape $1, "</li>\n";        print STDOUT qq[<li id="$input->{id_prefix}line-$i">], htescape $1,
387              "</li>\n";
388        $i++;        $i++;
389      }      }
390      if ($$s =~ /\G([^\x0A]+)/gc) {      if ($$s =~ /\G([^\x0A]+)/gc) {
391        print STDOUT qq[<li id="line-$i">], htescape $1, "</li>\n";        print STDOUT qq[<li id="$input->{id_prefix}line-$i">], htescape $1,
392              "</li>\n";
393      }      }
394    } else {    } else {
395      print STDOUT q[<li id="line-1"></li>];      print STDOUT q[<li id="$input->{id_prefix}line-1"></li>];
396    }    }
397    print STDOUT "</ol></div>";    print STDOUT "</ol></div>";
398  } # print_input_string_section  } # print_input_string_section
# Line 376  sub print_document_tree ($) { Line 409  sub print_document_tree ($) {
409        next;        next;
410      }      }
411    
412      my $node_id = 'node-'.refaddr $child;      my $node_id = $input->{id_prefix} . 'node-'.refaddr $child;
413      my $nt = $child->node_type;      my $nt = $child->node_type;
414      if ($nt == $child->ELEMENT_NODE) {      if ($nt == $child->ELEMENT_NODE) {
415        my $child_nsuri = $child->namespace_uri;        my $child_nsuri = $child->namespace_uri;
# Line 387  sub print_document_tree ($) { Line 420  sub print_document_tree ($) {
420          $r .= '<ul class="attributes">';          $r .= '<ul class="attributes">';
421          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 $_] }
422                        @{$child->attributes}) {                        @{$child->attributes}) {
423            $r .= qq[<li id="$attr->[3]" class="tree-attribute"><code title="@{[defined $_->[2] ? $_->[2] : '']}">] . htescape ($attr->[0]) . '</code> = '; ## ISSUE: case?            $r .= qq[<li id="$input->{id_prefix}$attr->[3]" class="tree-attribute"><code title="@{[defined $attr->[2] ? htescape ($attr->[2]) : '']}">] . htescape ($attr->[0]) . '</code> = '; ## ISSUE: case?
424            $r .= '<q>' . htescape ($attr->[1]) . '</q></li>'; ## TODO: children            $r .= '<q>' . htescape ($attr->[1]) . '</q></li>'; ## TODO: children
425          }          }
426          $r .= '</ul>';          $r .= '</ul>';
# Line 408  sub print_document_tree ($) { Line 441  sub print_document_tree ($) {
441      } elsif ($nt == $child->DOCUMENT_NODE) {      } elsif ($nt == $child->DOCUMENT_NODE) {
442        $r .= qq'<li id="$node_id" class="tree-document">Document';        $r .= qq'<li id="$node_id" class="tree-document">Document';
443        $r .= qq[<ul class="attributes">];        $r .= qq[<ul class="attributes">];
444          my $cp = $child->manakai_charset;
445          if (defined $cp) {
446            $r .= qq[<li><code>charset</code> parameter = <code>];
447            $r .= htescape ($cp) . qq[</code></li>];
448          }
449          $r .= qq[<li><code>inputEncoding</code> = ];
450          my $ie = $child->input_encoding;
451          if (defined $ie) {
452            $r .= qq[<code>@{[htescape ($ie)]}</code>];
453            if ($child->manakai_has_bom) {
454              $r .= qq[ (with <code class=charname><abbr>BOM</abbr></code>)];
455            }
456          } else {
457            $r .= qq[(<code>null</code>)];
458          }
459        $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>];
460        $r .= qq[<li>@{[scalar get_text ('manakaiCompatMode:'.$child->manakai_compat_mode)]}</li>];        $r .= qq[<li>@{[scalar get_text ('manakaiCompatMode:'.$child->manakai_compat_mode)]}</li>];
461        unless ($child->manakai_is_html) {        unless ($child->manakai_is_html) {
# Line 441  sub print_document_tree ($) { Line 489  sub print_document_tree ($) {
489    print STDOUT $r;    print STDOUT $r;
490  } # print_document_tree  } # print_document_tree
491    
492  sub print_structure_dump_dom_section ($$) {  sub print_structure_dump_dom_section ($$$) {
493    my ($doc, $el) = @_;    my ($input, $doc, $el) = @_;
494    
495    print STDOUT qq[    print STDOUT qq[
496  <div id="document-tree" class="section">  <div id="$input->{id_prefix}document-tree" class="section">
497  <h2>Document Tree</h2>  <h2>Document Tree</h2>
498  ];  ];
499    push @nav, ['#document-tree' => 'Tree'];    push @nav, ['#document-tree' => 'Tree'] unless $input->{nested};
500    
501    print_document_tree ($el || $doc);    print_document_tree ($el || $doc);
502    
503    print STDOUT qq[</div>];    print STDOUT qq[</div>];
504  } # print_structure_dump_dom_section  } # print_structure_dump_dom_section
505    
506  sub print_structure_dump_manifest_section ($) {  sub print_structure_dump_manifest_section ($$) {
507    my $manifest = shift;    my ($input, $manifest) = @_;
508    
509    print STDOUT qq[    print STDOUT qq[
510  <div id="dump-manifest" class="section">  <div id="$input->{id_prefix}dump-manifest" class="section">
511  <h2>Cache Manifest</h2>  <h2>Cache Manifest</h2>
512  ];  ];
513    push @nav, ['#dump-manifest' => 'Caceh Manifest'];    push @nav, ['#dump-manifest' => 'Caceh Manifest'] unless $input->{nested};
514    
515    print STDOUT qq[<dl><dt>Explicit entries</dt>];    print STDOUT qq[<dl><dt>Explicit entries</dt>];
516    for my $uri (@{$manifest->[0]}) {    for my $uri (@{$manifest->[0]}) {
# Line 489  sub print_structure_dump_manifest_sectio Line 537  sub print_structure_dump_manifest_sectio
537    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
538  } # print_structure_dump_manifest_section  } # print_structure_dump_manifest_section
539    
540  sub print_structure_error_dom_section ($$$) {  sub print_structure_error_dom_section ($$$$) {
541    my ($doc, $el, $result) = @_;    my ($input, $doc, $el, $result) = @_;
542    
543    print STDOUT qq[<div id="document-errors" class="section">    print STDOUT qq[<div id="$input->{id_prefix}document-errors" class="section">
544  <h2>Document Errors</h2>  <h2>Document Errors</h2>
545    
546  <dl>];  <dl>];
547    push @nav, ['#document-errors' => 'Document Error'];    push @nav, ['#document-errors' => 'Document Error'] unless $input->{nested};
548    
549    require Whatpm::ContentChecker;    require Whatpm::ContentChecker;
550    my $onerror = sub {    my $onerror = sub {
# Line 505  sub print_structure_error_dom_section ($ Line 553  sub print_structure_error_dom_section ($
553      $type =~ tr/ /-/;      $type =~ tr/ /-/;
554      $type =~ s/\|/%7C/g;      $type =~ s/\|/%7C/g;
555      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
556      print STDOUT qq[<dt class="$cls">] . get_error_label (\%opt) .      print STDOUT qq[<dt class="$cls">] . get_error_label ($input, \%opt) .
557          qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";          qq[</dt>\n<dd class="$cls">], get_error_level_label (\%opt);
558        print STDOUT $msg, "</dd>\n";
559      add_error ('structure', \%opt => $result);      add_error ('structure', \%opt => $result);
560    };    };
561    
# Line 525  sub print_structure_error_dom_section ($ Line 574  sub print_structure_error_dom_section ($
574  } # print_structure_error_dom_section  } # print_structure_error_dom_section
575    
576  sub print_structure_error_manifest_section ($$$) {  sub print_structure_error_manifest_section ($$$) {
577    my ($manifest, $result) = @_;    my ($input, $manifest, $result) = @_;
578    
579    print STDOUT qq[<div id="document-errors" class="section">    print STDOUT qq[<div id="$input->{id_prefix}document-errors" class="section">
580  <h2>Document Errors</h2>  <h2>Document Errors</h2>
581    
582  <dl>];  <dl>];
583    push @nav, ['#document-errors' => 'Document Error'];    push @nav, ['#document-errors' => 'Document Error'] unless $input->{nested};
584    
585    require Whatpm::CacheManifest;    require Whatpm::CacheManifest;
586    Whatpm::CacheManifest->check_manifest ($manifest, sub {    Whatpm::CacheManifest->check_manifest ($manifest, sub {
# Line 540  sub print_structure_error_manifest_secti Line 589  sub print_structure_error_manifest_secti
589      $type =~ tr/ /-/;      $type =~ tr/ /-/;
590      $type =~ s/\|/%7C/g;      $type =~ s/\|/%7C/g;
591      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
592      print STDOUT qq[<dt class="$cls">] . get_error_label (\%opt) .      print STDOUT qq[<dt class="$cls">] . get_error_label ($input, \%opt) .
593          qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";          qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";
594      add_error ('structure', \%opt => $result);      add_error ('structure', \%opt => $result);
595    });    });
# Line 548  sub print_structure_error_manifest_secti Line 597  sub print_structure_error_manifest_secti
597    print STDOUT qq[</div>];    print STDOUT qq[</div>];
598  } # print_structure_error_manifest_section  } # print_structure_error_manifest_section
599    
600  sub print_table_section ($) {  sub print_table_section ($$) {
601    my $tables = shift;    my ($input, $tables) = @_;
602        
603    push @nav, ['#tables' => 'Tables'];    push @nav, ['#tables' => 'Tables'] unless $input->{nested};
604    print STDOUT qq[    print STDOUT qq[
605  <div id="tables" class="section">  <div id="$input->{id_prefix}tables" class="section">
606  <h2>Tables</h2>  <h2>Tables</h2>
607    
608  <!--[if IE]><script type="text/javascript" src="../excanvas.js"></script><![endif]-->  <!--[if IE]><script type="text/javascript" src="../excanvas.js"></script><![endif]-->
# Line 568  sub print_table_section ($) { Line 617  sub print_table_section ($) {
617    my $i = 0;    my $i = 0;
618    for my $table_el (@$tables) {    for my $table_el (@$tables) {
619      $i++;      $i++;
620      print STDOUT qq[<div class="section" id="table-$i"><h3>] .      print STDOUT qq[<div class="section" id="$input->{id_prefix}table-$i"><h3>] .
621          get_node_link ($table_el) . q[</h3>];          get_node_link ($input, $table_el) . q[</h3>];
622    
623      ## TODO: Make |ContentChecker| return |form_table| result      ## TODO: Make |ContentChecker| return |form_table| result
624      ## so that this script don't have to run the algorithm twice.      ## so that this script don't have to run the algorithm twice.
# Line 601  sub print_table_section ($) { Line 650  sub print_table_section ($) {
650                    
651      print STDOUT '</div><script type="text/javascript">tableToCanvas (';      print STDOUT '</div><script type="text/javascript">tableToCanvas (';
652      print STDOUT JSON::objToJson ($table);      print STDOUT JSON::objToJson ($table);
653      print STDOUT qq[, document.getElementById ('table-$i'));</script>];      print STDOUT qq[, document.getElementById ('$input->{id_prefix}table-$i')];
654        print STDOUT qq[, '$input->{id_prefix}');</script>];
655    }    }
656        
657    print STDOUT qq[</div>];    print STDOUT qq[</div>];
658  } # print_table_section  } # print_table_section
659    
660  sub print_id_section ($) {  sub print_listing_section ($$$) {
661    my $ids = shift;    my ($opt, $input, $ids) = @_;
662        
663    push @nav, ['#identifiers' => 'IDs'];    push @nav, ['#' . $opt->{id} => $opt->{label}] unless $input->{nested};
664    print STDOUT qq[    print STDOUT qq[
665  <div id="identifiers" class="section">  <div id="$input->{id_prefix}$opt->{id}" class="section">
666  <h2>Identifiers</h2>  <h2>$opt->{heading}</h2>
667    
668  <dl>  <dl>
669  ];  ];
670    for my $id (sort {$a cmp $b} keys %$ids) {    for my $id (sort {$a cmp $b} keys %$ids) {
671      print STDOUT qq[<dt><code>@{[htescape $id]}</code></dt>];      print STDOUT qq[<dt><code>@{[htescape $id]}</code></dt>];
672      for (@{$ids->{$id}}) {      for (@{$ids->{$id}}) {
673        print STDOUT qq[<dd>].get_node_link ($_).qq[</dd>];        print STDOUT qq[<dd>].get_node_link ($input, $_).qq[</dd>];
674      }      }
675    }    }
676    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
677  } # print_id_section  } # print_listing_section
   
 sub print_term_section ($) {  
   my $terms = shift;  
     
   push @nav, ['#terms' => 'Terms'];  
   print STDOUT qq[  
 <div id="terms" class="section">  
 <h2>Terms</h2>  
   
 <dl>  
 ];  
   for my $term (sort {$a cmp $b} keys %$terms) {  
     print STDOUT qq[<dt>@{[htescape $term]}</dt>];  
     for (@{$terms->{$term}}) {  
       print STDOUT qq[<dd>].get_node_link ($_).qq[</dd>];  
     }  
   }  
   print STDOUT qq[</dl></div>];  
 } # print_term_section  
   
 sub print_class_section ($) {  
   my $classes = shift;  
     
   push @nav, ['#classes' => 'Classes'];  
   print STDOUT qq[  
 <div id="classes" class="section">  
 <h2>Classes</h2>  
   
 <dl>  
 ];  
   for my $class (sort {$a cmp $b} keys %$classes) {  
     print STDOUT qq[<dt><code>@{[htescape $class]}</code></dt>];  
     for (@{$classes->{$class}}) {  
       print STDOUT qq[<dd>].get_node_link ($_).qq[</dd>];  
     }  
   }  
   print STDOUT qq[</dl></div>];  
 } # print_class_section  
678    
679  sub print_result_section ($) {  sub print_result_section ($) {
680    my $result = shift;    my $result = shift;
# Line 691  sub print_result_section ($) { Line 703  sub print_result_section ($) {
703    print STDOUT qq[<table>    print STDOUT qq[<table>
704  <colgroup><col><colgroup><col><col><col><colgroup><col>  <colgroup><col><colgroup><col><col><col><colgroup><col>
705  <thead>  <thead>
706  <tr><th scope=col></th><th scope=col><em class=rfc2119>MUST</em>-level  <tr><th scope=col></th>
707  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
708  Errors</th><th scope=col>Warnings</th><th scope=col>Score</th></tr>  Errors</a></th>
709  </thead><tbody>];  <th scope=col><a href="../error-description#level-s"><em class=rfc2119>SHOULD</em>‐level
710    Errors</a></th>
711    <th scope=col><a href="../error-description#level-w">Warnings</a></th>
712    <th scope=col>Score</th></tr></thead><tbody>];
713    
714    my $must_error = 0;    my $must_error = 0;
715    my $should_error = 0;    my $should_error = 0;
# Line 752  is <em>under development</em>.  The resu Line 767  is <em>under development</em>.  The resu
767    push @nav, ['#result-summary' => 'Result'];    push @nav, ['#result-summary' => 'Result'];
768  } # print_result_section  } # print_result_section
769    
770  sub print_result_unknown_type_section ($) {  sub print_result_unknown_type_section ($$) {
771    my $input = shift;    my ($input, $result) = @_;
772    
773      my $euri = htescape ($input->{uri});
774    print STDOUT qq[    print STDOUT qq[
775  <div id="result-summary" class="section">  <div id="parse-errors" class="section">
776  <p><em>Media type <code class="MIME" lang="en">@{[htescape $input->{media_type}]}</code> is not supported!</em></p>  <h2>Errors</h2>
777    
778    <dl>
779    <dt class=unsupported><code>&lt;<a href="$euri">$euri</a>&gt;</code></dt>
780        <dd class=unsupported><strong><a href="../error-description#level-u">Not
781            supported</a></strong>:
782        Media type
783        <code class="MIME" lang="en">@{[htescape $input->{media_type}]}</code>
784        is not supported.</dd>
785    </dl>
786  </div>  </div>
787  ];  ];
788    push @nav, ['#result-summary' => 'Result'];    push @nav, ['#parse-errors' => 'Errors'];
789      add_error (char => {level => 'u'} => $result);
790      add_error (syntax => {level => 'u'} => $result);
791      add_error (structure => {level => 'u'} => $result);
792  } # print_result_unknown_type_section  } # print_result_unknown_type_section
793    
794  sub print_result_input_error_section ($) {  sub print_result_input_error_section ($) {
# Line 769  sub print_result_input_error_section ($) Line 797  sub print_result_input_error_section ($)
797  <p><em><strong>Input Error</strong>: @{[htescape ($input->{error_status_text})]}</em></p>  <p><em><strong>Input Error</strong>: @{[htescape ($input->{error_status_text})]}</em></p>
798  </div>];  </div>];
799    push @nav, ['#result-summary' => 'Result'];    push @nav, ['#result-summary' => 'Result'];
800  } # print_Result_input_error_section  } # print_result_input_error_section
801    
802  sub get_error_label ($) {  sub get_error_label ($$) {
803    my $err = shift;    my ($input, $err) = @_;
804    
805    my $r = '';    my $r = '';
806    
# Line 787  sub get_error_label ($) { Line 815  sub get_error_label ($) {
815    
816    if (defined $err->{node}) {    if (defined $err->{node}) {
817      $r .= ' ' if length $r;      $r .= ' ' if length $r;
818      $r = get_node_path ($err->{node});      $r = get_node_link ($input, $err->{node});
819    }    }
820    
821    if (defined $err->{index}) {    if (defined $err->{index}) {
# Line 803  sub get_error_label ($) { Line 831  sub get_error_label ($) {
831    return $r;    return $r;
832  } # get_error_label  } # get_error_label
833    
834    sub get_error_level_label ($) {
835      my $err = shift;
836    
837      my $r = '';
838    
839      if (not defined $err->{level} or $err->{level} eq 'm') {
840        $r = qq[<strong><a href="../error-description#level-m"><em class=rfc2119>MUST</em>‐level
841            error</a></strong>: ];
842      } elsif ($err->{level} eq 's') {
843        $r = qq[<strong><a href="../error-description#level-s"><em class=rfc2119>SHOULD</em>‐level
844            error</a></strong>: ];
845      } elsif ($err->{level} eq 'w') {
846        $r = qq[<strong><a href="../error-description#level-w">Warning</a></strong>:
847            ];
848      } elsif ($err->{level} eq 'u' or $err->{level} eq 'unsupported') {
849        $r = qq[<strong><a href="../error-description#level-u">Not
850            supported</a></strong>: ];
851      } else {
852        my $elevel = htescape ($err->{level});
853        $r = qq[<strong><a href="../error-description#level-$elevel">$elevel</a></strong>:
854            ];
855      }
856    
857      return $r;
858    } # get_error_level_label
859    
860  sub get_node_path ($) {  sub get_node_path ($) {
861    my $node = shift;    my $node = shift;
862    my @r;    my @r;
# Line 830  sub get_node_path ($) { Line 884  sub get_node_path ($) {
884    return join '/', @r;    return join '/', @r;
885  } # get_node_path  } # get_node_path
886    
887  sub get_node_link ($) {  sub get_node_link ($$) {
888    return qq[<a href="#node-@{[refaddr $_[0]]}">] .    return qq[<a href="#$_[0]->{id_prefix}node-@{[refaddr $_[1]]}">] .
889        htescape (get_node_path ($_[0])) . qq[</a>];        htescape (get_node_path ($_[1])) . qq[</a>];
890  } # get_node_link  } # get_node_link
891    
892  {  {
# Line 840  sub get_node_link ($) { Line 894  sub get_node_link ($) {
894    
895  sub load_text_catalog ($) {  sub load_text_catalog ($) {
896    my $lang = shift; # MUST be a canonical lang name    my $lang = shift; # MUST be a canonical lang name
897    open my $file, '<', "cc-msg.$lang.txt" or die "$0: cc-msg.$lang.txt: $!";    open my $file, '<:utf8', "cc-msg.$lang.txt"
898          or die "$0: cc-msg.$lang.txt: $!";
899    while (<$file>) {    while (<$file>) {
900      if (s/^([^;]+);([^;]*);//) {      if (s/^([^;]+);([^;]*);//) {
901        my ($type, $cls, $msg) = ($1, $2, $_);        my ($type, $cls, $msg) = ($1, $2, $_);
# Line 853  sub load_text_catalog ($) { Line 908  sub load_text_catalog ($) {
908  sub get_text ($) {  sub get_text ($) {
909    my ($type, $level, $node) = @_;    my ($type, $level, $node) = @_;
910    $type = $level . ':' . $type if defined $level;    $type = $level . ':' . $type if defined $level;
911      $level = 'm' unless defined $level;
912    my @arg;    my @arg;
913    {    {
914      if (defined $Msg->{$type}) {      if (defined $Msg->{$type}) {
# Line 877  sub get_text ($) { Line 933  sub get_text ($) {
933            ? htescape ($node->owner_element->manakai_local_name)            ? htescape ($node->owner_element->manakai_local_name)
934            : ''            : ''
935        }ge;        }ge;
936        return ($type, $Msg->{$type}->[0], $msg);        return ($type, 'level-' . $level . ' ' . $Msg->{$type}->[0], $msg);
937      } elsif ($type =~ s/:([^:]*)$//) {      } elsif ($type =~ s/:([^:]*)$//) {
938        unshift @arg, $1;        unshift @arg, $1;
939        redo;        redo;
940      }      }
941    }    }
942    return ($type, '', htescape ($_[0]));    return ($type, 'level-'.$level, htescape ($_[0]));
943  } # get_text  } # get_text
944    
945  }  }
# Line 939  EOH Line 995  EOH
995      $ua->protocols_allowed ([qw/http/]);      $ua->protocols_allowed ([qw/http/]);
996      $ua->max_size (1000_000);      $ua->max_size (1000_000);
997      my $req = HTTP::Request->new (GET => $request_uri);      my $req = HTTP::Request->new (GET => $request_uri);
998        $req->header ('Accept-Encoding' => 'identity, *; q=0');
999      my $res = $ua->request ($req);      my $res = $ua->request ($req);
1000      ## TODO: 401 sets |is_success| true.      ## TODO: 401 sets |is_success| true.
1001      if ($res->is_success or $http->get_parameter ('error-page')) {      if ($res->is_success or $http->get_parameter ('error-page')) {
# Line 948  EOH Line 1005  EOH
1005    
1006        ## TODO: More strict parsing...        ## TODO: More strict parsing...
1007        my $ct = $res->header ('Content-Type');        my $ct = $res->header ('Content-Type');
       if (defined $ct and $ct =~ m#^([0-9A-Za-z._+-]+/[0-9A-Za-z._+-]+)#) {  
         $r->{media_type} = lc $1;  
       }  
1008        if (defined $ct and $ct =~ /;\s*charset\s*=\s*"?([^\s;"]+)"?/i) {        if (defined $ct and $ct =~ /;\s*charset\s*=\s*"?([^\s;"]+)"?/i) {
1009          $r->{charset} = lc $1;          $r->{charset} = lc $1;
1010          $r->{charset} =~ tr/\\//d;          $r->{charset} =~ tr/\\//d;
1011            $r->{official_charset} = $r->{charset};
1012        }        }
1013    
1014        my $input_charset = $http->get_parameter ('charset');        my $input_charset = $http->get_parameter ('charset');
# Line 961  EOH Line 1016  EOH
1016          $r->{charset_overridden}          $r->{charset_overridden}
1017              = (not defined $r->{charset} or $r->{charset} ne $input_charset);              = (not defined $r->{charset} or $r->{charset} ne $input_charset);
1018          $r->{charset} = $input_charset;          $r->{charset} = $input_charset;
1019        }        }
1020    
1021          ## TODO: Support for HTTP Content-Encoding
1022    
1023        $r->{s} = ''.$res->content;        $r->{s} = ''.$res->content;
1024    
1025          require Whatpm::ContentType;
1026          ($r->{official_type}, $r->{media_type})
1027              = Whatpm::ContentType->get_sniffed_type
1028                  (get_file_head => sub {
1029                     return substr $r->{s}, 0, shift;
1030                   },
1031                   http_content_type_byte => $ct,
1032                   has_http_content_encoding =>
1033                       defined $res->header ('Content-Encoding'),
1034                   supported_image_types => {});
1035      } else {      } else {
1036        $r->{uri} = $res->request->uri;        $r->{uri} = $res->request->uri;
1037        $r->{request_uri} = $request_uri;        $r->{request_uri} = $request_uri;
# Line 984  EOH Line 1052  EOH
1052      $r->{charset} = ''.$http->get_parameter ('_charset_');      $r->{charset} = ''.$http->get_parameter ('_charset_');
1053      $r->{charset} =~ s/\s+//g;      $r->{charset} =~ s/\s+//g;
1054      $r->{charset} = 'utf-8' if $r->{charset} eq '';      $r->{charset} = 'utf-8' if $r->{charset} eq '';
1055        $r->{official_charset} = $r->{charset};
1056      $r->{header_field} = [];      $r->{header_field} = [];
1057    
1058        require Whatpm::ContentType;
1059        ($r->{official_type}, $r->{media_type})
1060            = Whatpm::ContentType->get_sniffed_type
1061                (get_file_head => sub {
1062                   return substr $r->{s}, 0, shift;
1063                 },
1064                 http_content_type_byte => undef,
1065                 has_http_content_encoding => 0,
1066                 supported_image_types => {});
1067    }    }
1068    
1069    my $input_format = $http->get_parameter ('i');    my $input_format = $http->get_parameter ('i');
# Line 1001  EOH Line 1080  EOH
1080    if ($r->{media_type} eq 'text/xml') {    if ($r->{media_type} eq 'text/xml') {
1081      unless (defined $r->{charset}) {      unless (defined $r->{charset}) {
1082        $r->{charset} = 'us-ascii';        $r->{charset} = 'us-ascii';
1083          $r->{official_charset} = $r->{charset};
1084      } elsif ($r->{charset_overridden} and $r->{charset} eq 'us-ascii') {      } elsif ($r->{charset_overridden} and $r->{charset} eq 'us-ascii') {
1085        $r->{charset_overridden} = 0;        $r->{charset_overridden} = 0;
1086      }      }
Legend:
Removed from v.1.22  
changed lines
  Added in v.1.33
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24