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

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

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

revision 1.20 by wakaba, Mon Sep 10 12:09:34 2007 UTC revision 1.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;  
   
   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);  
   } else {  
     ## TODO: Change HTTP status code??  
     print_result_unknown_type_section ($input);  
   }  
   
   if (defined $doc or defined $el) {  
     print_structure_dump_section ($doc, $el);  
     my $elements = print_structure_error_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}};  
   }  
   
93    print_result_section ($result);    print_result_section ($result);
94  } else {  } else {
95    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
# Line 134  if (defined $input->{s}) { Line 108  if (defined $input->{s}) {
108  </html>  </html>
109  ];  ];
110    
111    for (qw/decode parse parse_xml check/) {    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 151  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 170  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 209  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 235  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 263  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 291  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    
334    return ($doc, undef);    return ($doc, undef);
335  } # print_syntax_error_xml_section  } # print_syntax_error_xml_section
336    
337    sub print_syntax_error_manifest_section ($$) {
338      my ($input, $result) = @_;
339    
340      require Whatpm::CacheManifest;
341    
342      print STDOUT qq[
343    <div id="$input->{id_prefix}parse-errors" class="section">
344    <h2>Parse Errors</h2>
345    
346    <dl>];
347      push @nav, ['#parse-errors' => 'Parse Error'] unless $input->{nested};
348    
349      my $onerror = sub {
350        my (%opt) = @_;
351        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level});
352        print STDOUT qq[<dt class="$cls">], get_error_label ($input, \%opt),
353            qq[</dt>];
354        $type =~ tr/ /-/;
355        $type =~ s/\|/%7C/g;
356        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
357        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);
361      };
362    
363      my $time1 = time;
364      my $manifest = Whatpm::CacheManifest->parse_byte_string
365          ($input->{s}, $input->{uri}, $input->{base_uri}, $onerror);
366      $time{parse_manifest} = time - $time1;
367    
368      print STDOUT qq[</dl></div>];
369    
370      return $manifest;
371    } # print_syntax_error_manifest_section
372    
373  sub print_source_string_section ($$) {  sub print_source_string_section ($$) {
374    require Encode;    require Encode;
375    my $enc = Encode::find_encoding ($_[1]); ## TODO: charset name -> Perl name    my $enc = Encode::find_encoding ($_[1]); ## TODO: charset name -> Perl name
# Line 304  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 334  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 345  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 366  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 399  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_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_section  } # print_structure_dump_dom_section
505    
506    sub print_structure_dump_manifest_section ($$) {
507      my ($input, $manifest) = @_;
508    
509      print STDOUT qq[
510    <div id="$input->{id_prefix}dump-manifest" class="section">
511    <h2>Cache Manifest</h2>
512    ];
513      push @nav, ['#dump-manifest' => 'Caceh Manifest'] unless $input->{nested};
514    
515  sub print_structure_error_section ($$$) {    print STDOUT qq[<dl><dt>Explicit entries</dt>];
516    my ($doc, $el, $result) = @_;    for my $uri (@{$manifest->[0]}) {
517        my $euri = htescape ($uri);
518        print STDOUT qq[<dd><code class=uri>&lt;<a href="$euri">$euri</a>></code></dd>];
519      }
520    
521      print STDOUT qq[<dt>Fallback entries</dt><dd>
522          <table><thead><tr><th scope=row>Oppotunistic Caching Namespace</th>
523          <th scope=row>Fallback Entry</tr><tbody>];
524      for my $uri (sort {$a cmp $b} keys %{$manifest->[1]}) {
525        my $euri = htescape ($uri);
526        my $euri2 = htescape ($manifest->[1]->{$uri});
527        print STDOUT qq[<tr><td><code class=uri>&lt;<a href="$euri">$euri</a>></code></td>
528            <td><code class=uri>&lt;<a href="$euri2">$euri2</a>></code></td>];
529      }
530    
531      print STDOUT qq[</table><dt>Online whitelist</dt>];
532      for my $uri (@{$manifest->[2]}) {
533        my $euri = htescape ($uri);
534        print STDOUT qq[<dd><code class=uri>&lt;<a href="$euri">$euri</a>></code></dd>];
535      }
536    
537      print STDOUT qq[</dl></div>];
538    } # print_structure_dump_manifest_section
539    
540    print STDOUT qq[<div id="document-errors" class="section">  sub print_structure_error_dom_section ($$$$) {
541      my ($input, $doc, $el, $result) = @_;
542    
543      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 429  sub print_structure_error_section ($$$) Line 553  sub print_structure_error_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_node_link ($opt{node}) .      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 446  sub print_structure_error_section ($$$) Line 571  sub print_structure_error_section ($$$)
571    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
572    
573    return $elements;    return $elements;
574  } # print_structure_error_section  } # print_structure_error_dom_section
575    
576    sub print_structure_error_manifest_section ($$$) {
577      my ($input, $manifest, $result) = @_;
578    
579      print STDOUT qq[<div id="$input->{id_prefix}document-errors" class="section">
580    <h2>Document Errors</h2>
581    
582    <dl>];
583      push @nav, ['#document-errors' => 'Document Error'] unless $input->{nested};
584    
585  sub print_table_section ($) {    require Whatpm::CacheManifest;
586    my $tables = shift;    Whatpm::CacheManifest->check_manifest ($manifest, sub {
587        my %opt = @_;
588        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level}, $opt{node});
589        $type =~ tr/ /-/;
590        $type =~ s/\|/%7C/g;
591        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
592        print STDOUT qq[<dt class="$cls">] . get_error_label ($input, \%opt) .
593            qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";
594        add_error ('structure', \%opt => $result);
595      });
596    
597      print STDOUT qq[</div>];
598    } # print_structure_error_manifest_section
599    
600    sub print_table_section ($$) {
601      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 468  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 501  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>];
     }  
   }  
   print STDOUT qq[</dl></div>];  
 } # print_id_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>];  
674      }      }
675    }    }
676    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
677  } # print_class_section  } # print_listing_section
678    
679  sub print_result_section ($) {  sub print_result_section ($) {
680    my $result = shift;    my $result = shift;
# Line 571  sub print_result_section ($) { Line 683  sub print_result_section ($) {
683  <div id="result-summary" class="section">  <div id="result-summary" class="section">
684  <h2>Result</h2>];  <h2>Result</h2>];
685    
686    if ($result->{unsupported}) {      if ($result->{unsupported} and $result->{conforming_max}) {  
687      print STDOUT qq[<p class=uncertain id=result-para>The conformance      print STDOUT qq[<p class=uncertain id=result-para>The conformance
688          checker cannot decide whether the document is conforming or          checker cannot decide whether the document is conforming or
689          not, since the document contains one or more unsupported          not, since the document contains one or more unsupported
690          features.</p>];          features.  The document might or might not be conforming.</p>];
691    } elsif ($result->{conforming_min}) {    } elsif ($result->{conforming_min}) {
692      print STDOUT qq[<p class=PASS id=result-para>No conformance-error is      print STDOUT qq[<p class=PASS id=result-para>No conformance-error is
693          found in this document.</p>];          found in this document.</p>];
# Line 591  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 602  Errors</th><th scope=col>Warnings</th><t Line 717  Errors</th><th scope=col>Warnings</th><t
717    my $score_min = 0;    my $score_min = 0;
718    my $score_max = 0;    my $score_max = 0;
719    my $score_base = 20;    my $score_base = 20;
720      my $score_unit = $score_base / 100;
721    for (    for (
722      [Transfer => 'transfer', ''],      [Transfer => 'transfer', ''],
723      [Character => 'char', ''],      [Character => 'char', ''],
# Line 611  Errors</th><th scope=col>Warnings</th><t Line 727  Errors</th><th scope=col>Warnings</th><t
727      $must_error += ($result->{$_->[1]}->{must} += 0);      $must_error += ($result->{$_->[1]}->{must} += 0);
728      $should_error += ($result->{$_->[1]}->{should} += 0);      $should_error += ($result->{$_->[1]}->{should} += 0);
729      $warning += ($result->{$_->[1]}->{warning} += 0);      $warning += ($result->{$_->[1]}->{warning} += 0);
730      $score_min += ($result->{$_->[1]}->{score_min} += $score_base);      $score_min += (($result->{$_->[1]}->{score_min} *= $score_unit) += $score_base);
731      $score_max += ($result->{$_->[1]}->{score_max} += $score_base);      $score_max += (($result->{$_->[1]}->{score_max} *= $score_unit) += $score_base);
732    
733      my $uncertain = $result->{$_->[1]}->{unsupported} ? '?' : '';      my $uncertain = $result->{$_->[1]}->{unsupported} ? '?' : '';
734      my $label = $_->[0];      my $label = $_->[0];
# Line 625  Errors</th><th scope=col>Warnings</th><t Line 741  Errors</th><th scope=col>Warnings</th><t
741    
742      print STDOUT qq[<tr class="@{[$uncertain ? 'uncertain' : '']}"><th scope=row>$label</th><td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : '']}">$result->{$_->[1]}->{must}$uncertain</td><td class="@{[$result->{$_->[1]}->{should} ? 'SEE-RESULT' : '']}">$result->{$_->[1]}->{should}$uncertain</td><td>$result->{$_->[1]}->{warning}$uncertain</td>];      print STDOUT qq[<tr class="@{[$uncertain ? 'uncertain' : '']}"><th scope=row>$label</th><td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : '']}">$result->{$_->[1]}->{must}$uncertain</td><td class="@{[$result->{$_->[1]}->{should} ? 'SEE-RESULT' : '']}">$result->{$_->[1]}->{should}$uncertain</td><td>$result->{$_->[1]}->{warning}$uncertain</td>];
743      if ($uncertain) {      if ($uncertain) {
744        print qq[<td class="@{[$score_max < $score_base ? $score_min < $score_max ? 'FAIL' : 'SEE-RESULT' : '']}">&#x2212;&#x221E;..$result->{$_->[1]}->{score_max}</td>];        print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : $result->{$_->[1]}->{should} ? 'SEE-RESULT' : '']}">&#x2212;&#x221E;..$result->{$_->[1]}->{score_max}</td>];
745      } elsif ($result->{$_->[1]}->{score_min} != $result->{$_->[1]}->{score_max}) {      } elsif ($result->{$_->[1]}->{score_min} != $result->{$_->[1]}->{score_max}) {
746        print qq[<td class="@{[$score_max < $score_base ? 'FAIL' : 'SEE-RESULT']}">$result->{$_->[1]}->{score_min}..$result->{$_->[1]}->{score_max} + $score_base</td></tr>];        print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : 'SEE-RESULT']}">$result->{$_->[1]}->{score_min}..$result->{$_->[1]}->{score_max}</td></tr>];
747      } else {      } else {
748        print qq[<td class="@{[$score_max < $score_base ? 'FAIL' : '']}">$result->{$_->[1]}->{score_min}</td></tr>];        print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : '']}">$result->{$_->[1]}->{score_min}</td></tr>];
749      }      }
750    }    }
751    
# Line 638  Errors</th><th scope=col>Warnings</th><t Line 754  Errors</th><th scope=col>Warnings</th><t
754    print STDOUT qq[    print STDOUT qq[
755  <tr class=uncertain><th scope=row>Semantics</th><td>0?</td><td>0?</td><td>0?</td><td>&#x2212;&#x221E;..$score_base</td></tr>  <tr class=uncertain><th scope=row>Semantics</th><td>0?</td><td>0?</td><td>0?</td><td>&#x2212;&#x221E;..$score_base</td></tr>
756  </tbody>  </tbody>
757  <tfoot><tr class=uncertain><th scope=row>Total</th><td>$must_error?</td><td>$should_error?</td><td>$warning?</td><td><strong>&#x2212;&#x221E;..$score_max</strong></td></tr></tfoot>  <tfoot><tr class=uncertain><th scope=row>Total</th>
758    <td class="@{[$must_error ? 'FAIL' : '']}">$must_error?</td>
759    <td class="@{[$should_error ? 'SEE-RESULT' : '']}">$should_error?</td>
760    <td>$warning?</td>
761    <td class="@{[$must_error ? 'FAIL' : $should_error ? 'SEE-RESULT' : '']}"><strong>&#x2212;&#x221E;..$score_max</strong></td></tr></tfoot>
762  </table>  </table>
763    
764  <p><strong>Important</strong>: This conformance checking service  <p><strong>Important</strong>: This conformance checking service
# Line 647  is <em>under development</em>.  The resu Line 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 664  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 ($$) {
803      my ($input, $err) = @_;
804    
805      my $r = '';
806    
807      if (defined $err->{line}) {
808        if ($err->{column} > 0) {
809          $r = qq[<a href="#line-$err->{line}">Line $err->{line}</a> column $err->{column}];
810        } else {
811          $err->{line} = $err->{line} - 1 || 1;
812          $r = qq[<a href="#line-$err->{line}">Line $err->{line}</a>];
813        }
814      }
815    
816      if (defined $err->{node}) {
817        $r .= ' ' if length $r;
818        $r = get_node_link ($input, $err->{node});
819      }
820    
821      if (defined $err->{index}) {
822        $r .= ' ' if length $r;
823        $r .= 'Index ' . (0+$err->{index});
824      }
825    
826      if (defined $err->{value}) {
827        $r .= ' ' if length $r;
828        $r .= '<q><code>' . htescape ($err->{value}) . '</code></q>';
829      }
830    
831      return $r;
832    } # 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;
# Line 693  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 703  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 716  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 740  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 802  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 811  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');
1008        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) {  
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 824  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 847  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 864  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.20  
changed lines
  Added in v.1.33
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24