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

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

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

revision 1.19 by wakaba, Mon Sep 10 11:51:09 2007 UTC revision 1.34 by wakaba, Sun Feb 10 03:11:06 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    my $result = {};    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      my @subdoc;
159    
160      if ($input->{media_type} eq 'text/html') {
161        ($doc, $el) = print_syntax_error_html_section ($input, $result);
162        print_source_string_section
163            (\($input->{s}), $input->{charset} || $doc->input_encoding);
164      } elsif ({
165                'text/xml' => 1,
166                'application/atom+xml' => 1,
167                'application/rss+xml' => 1,
168                'application/svg+xml' => 1,
169                'application/xhtml+xml' => 1,
170                'application/xml' => 1,
171               }->{$input->{media_type}}) {
172        ($doc, $el) = print_syntax_error_xml_section ($input, $result);
173        print_source_string_section (\($input->{s}), $doc->input_encoding);
174      } elsif ($input->{media_type} eq 'text/cache-manifest') {
175    ## TODO: MUST be text/cache-manifest
176        $manifest = print_syntax_error_manifest_section ($input, $result);
177        print_source_string_section (\($input->{s}), 'utf-8');
178      } else {
179        ## TODO: Change HTTP status code??
180        print_result_unknown_type_section ($input, $result);
181      }
182    
183      if (defined $doc or defined $el) {
184        $doc->document_uri ($input->{uri});
185        $doc->manakai_entity_base_uri ($input->{base_uri});
186        print_structure_dump_dom_section ($input, $doc, $el);
187        my $elements = print_structure_error_dom_section
188            ($input, $doc, $el, $result, sub {
189              push @subdoc, shift;
190            });
191        print_table_section ($input, $elements->{table}) if @{$elements->{table}};
192        print_listing_section ({
193          id => 'identifiers', label => 'IDs', heading => 'Identifiers',
194        }, $input, $elements->{id}) if keys %{$elements->{id}};
195        print_listing_section ({
196          id => 'terms', label => 'Terms', heading => 'Terms',
197        }, $input, $elements->{term}) if keys %{$elements->{term}};
198        print_listing_section ({
199          id => 'classes', label => 'Classes', heading => 'Classes',
200        }, $input, $elements->{class}) if keys %{$elements->{class}};
201      } elsif (defined $manifest) {
202        print_structure_dump_manifest_section ($input, $manifest);
203        print_structure_error_manifest_section ($input, $manifest, $result);
204      }
205    
206      my $id_prefix = 0;
207      for my $subinput (@subdoc) {
208        $subinput->{id_prefix} = 'subdoc-' . ++$id_prefix;
209        $subinput->{nested} = 1;
210        $subinput->{base_uri} = $subinput->{container_node}->base_uri
211            unless defined $subinput->{base_uri};
212        my $ebaseuri = htescape ($subinput->{base_uri});
213        push @nav, ['#' . $subinput->{id_prefix} => 'Sub #' . $id_prefix];
214        print STDOUT qq[<div id="$subinput->{id_prefix}" class=section>
215          <h2>Subdocument #$id_prefix</h2>
216    
217          <dl>
218          <dt>Internet Media Type</dt>
219            <dd><code class="MIME" lang="en">@{[htescape $subinput->{media_type}]}</code>
220          <dt>Container Node</dt>
221            <dd>@{[get_node_link ($input, $subinput->{container_node})]}</dd>
222          <dt>Base <abbr title="Uniform Resource Identifiers">URI</abbr></dt>
223            <dd><code class=URI>&lt;<a href="$ebaseuri">$ebaseuri</a>></code></dd>
224          </dl>];              
225    
226        check_and_print ($subinput => $result);
227    
228        print STDOUT qq[</div>];
229      }
230    } # check_and_print
231    
232  sub print_http_header_section ($$) {  sub print_http_header_section ($$) {
233    my ($input, $result) = @_;    my ($input, $result) = @_;
234    return unless defined $input->{header_status_code} or    return unless defined $input->{header_status_code} or
235        defined $input->{header_status_text} or        defined $input->{header_status_text} or
236        @{$input->{header_field}};        @{$input->{header_field} or []};
237        
238    push @nav, ['#source-header' => 'HTTP Header'];    push @nav, ['#source-header' => 'HTTP Header'] unless $input->{nested};
239    print STDOUT qq[<div id="source-header" class="section">    print STDOUT qq[<div id="$input->{id_prefix}source-header" class="section">
240  <h2>HTTP Header</h2>  <h2>HTTP Header</h2>
241    
242  <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 268  sub print_syntax_error_html_section ($$)
268        
269    require Encode;    require Encode;
270    require Whatpm::HTML;    require Whatpm::HTML;
   
   $input->{charset} ||= 'ISO-8859-1'; ## TODO: for now.  
271        
   my $time1 = time;  
   my $t = Encode::decode ($input->{charset}, $input->{s});  
   $time{decode} = time - $time1;  
   
272    print STDOUT qq[    print STDOUT qq[
273  <div id="parse-errors" class="section">  <div id="$input->{id_prefix}parse-errors" class="section">
274  <h2>Parse Errors</h2>  <h2>Parse Errors</h2>
275    
276  <dl>];  <dl>];
277    push @nav, ['#parse-errors' => 'Parse Error'];    push @nav, ['#parse-errors' => 'Parse Error'] unless $input->{nested};
278    
279    my $onerror = sub {    my $onerror = sub {
280      my (%opt) = @_;      my (%opt) = @_;
# Line 235  sub print_syntax_error_html_section ($$) Line 288  sub print_syntax_error_html_section ($$)
288      $type =~ tr/ /-/;      $type =~ tr/ /-/;
289      $type =~ s/\|/%7C/g;      $type =~ s/\|/%7C/g;
290      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
291      print STDOUT qq[<dd class="$cls">$msg</dd>\n];      print STDOUT qq[<dd class="$cls">], get_error_level_label (\%opt);
292        print STDOUT qq[$msg</dd>\n];
293    
294      add_error ('syntax', \%opt => $result);      add_error ('syntax', \%opt => $result);
295    };    };
296    
297    my $doc = $dom->create_document;    my $doc = $dom->create_document;
298    my $el;    my $el;
299    $time1 = time;    my $inner_html_element = $http->get_parameter ('e');
300    if (defined $inner_html_element and length $inner_html_element) {    if (defined $inner_html_element and length $inner_html_element) {
301        $input->{charset} ||= 'windows-1252'; ## TODO: for now.
302        my $time1 = time;
303        my $t = Encode::decode ($input->{charset}, $input->{s});
304        $time{decode} = time - $time1;
305        
306      $el = $doc->create_element_ns      $el = $doc->create_element_ns
307          ('http://www.w3.org/1999/xhtml', [undef, $inner_html_element]);          ('http://www.w3.org/1999/xhtml', [undef, $inner_html_element]);
308        $time1 = time;
309      Whatpm::HTML->set_inner_html ($el, $t, $onerror);      Whatpm::HTML->set_inner_html ($el, $t, $onerror);
310        $time{parse} = time - $time1;
311    } else {    } else {
312      Whatpm::HTML->parse_string ($t => $doc, $onerror);      my $time1 = time;
313        Whatpm::HTML->parse_byte_string
314            ($input->{charset}, $input->{s} => $doc, $onerror);
315        $time{parse_html} = time - $time1;
316    }    }
317    $time{parse} = time - $time1;    $doc->manakai_charset ($input->{official_charset})
318          if defined $input->{official_charset};
319      
320    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
321    
322    return ($doc, $el);    return ($doc, $el);
# Line 263  sub print_syntax_error_xml_section ($$) Line 328  sub print_syntax_error_xml_section ($$)
328    require Message::DOM::XMLParserTemp;    require Message::DOM::XMLParserTemp;
329        
330    print STDOUT qq[    print STDOUT qq[
331  <div id="parse-errors" class="section">  <div id="$input->{id_prefix}parse-errors" class="section">
332  <h2>Parse Errors</h2>  <h2>Parse Errors</h2>
333    
334  <dl>];  <dl>];
335    push @nav, ['#parse-errors' => 'Parse Error'];    push @nav, ['#parse-errors' => 'Parse Error'] unless $input->{prefix};
336    
337    my $onerror = sub {    my $onerror = sub {
338      my $err = shift;      my $err = shift;
# Line 291  sub print_syntax_error_xml_section ($$) Line 356  sub print_syntax_error_xml_section ($$)
356    my $doc = Message::DOM::XMLParserTemp->parse_byte_stream    my $doc = Message::DOM::XMLParserTemp->parse_byte_stream
357        ($fh => $dom, $onerror, charset => $input->{charset});        ($fh => $dom, $onerror, charset => $input->{charset});
358    $time{parse_xml} = time - $time1;    $time{parse_xml} = time - $time1;
359      $doc->manakai_charset ($input->{official_charset})
360          if defined $input->{official_charset};
361    
362    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
363    
364    return ($doc, undef);    return ($doc, undef);
365  } # print_syntax_error_xml_section  } # print_syntax_error_xml_section
366    
367    sub print_syntax_error_manifest_section ($$) {
368      my ($input, $result) = @_;
369    
370      require Whatpm::CacheManifest;
371    
372      print STDOUT qq[
373    <div id="$input->{id_prefix}parse-errors" class="section">
374    <h2>Parse Errors</h2>
375    
376    <dl>];
377      push @nav, ['#parse-errors' => 'Parse Error'] unless $input->{nested};
378    
379      my $onerror = sub {
380        my (%opt) = @_;
381        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level});
382        print STDOUT qq[<dt class="$cls">], get_error_label ($input, \%opt),
383            qq[</dt>];
384        $type =~ tr/ /-/;
385        $type =~ s/\|/%7C/g;
386        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
387        print STDOUT qq[<dd class="$cls">], get_error_level_label (\%opt);
388        print STDOUT qq[$msg</dd>\n];
389    
390        add_error ('syntax', \%opt => $result);
391      };
392    
393      my $time1 = time;
394      my $manifest = Whatpm::CacheManifest->parse_byte_string
395          ($input->{s}, $input->{uri}, $input->{base_uri}, $onerror);
396      $time{parse_manifest} = time - $time1;
397    
398      print STDOUT qq[</dl></div>];
399    
400      return $manifest;
401    } # print_syntax_error_manifest_section
402    
403  sub print_source_string_section ($$) {  sub print_source_string_section ($$) {
404    require Encode;    require Encode;
405    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 407  sub print_source_string_section ($$) {
407    
408    my $s = \($enc->decode (${$_[0]}));    my $s = \($enc->decode (${$_[0]}));
409    my $i = 1;                                my $i = 1;                            
410    push @nav, ['#source-string' => 'Source'];    push @nav, ['#source-string' => 'Source'] unless $input->{nested};
411    print STDOUT qq[<div id="source-string" class="section">    print STDOUT qq[<div id="$input->{id_prefix}source-string" class="section">
412  <h2>Document Source</h2>  <h2>Document Source</h2>
413  <ol lang="">\n];  <ol lang="">\n];
414    if (length $$s) {    if (length $$s) {
415      while ($$s =~ /\G([^\x0A]*?)\x0D?\x0A/gc) {      while ($$s =~ /\G([^\x0A]*?)\x0D?\x0A/gc) {
416        print STDOUT qq[<li id="line-$i">], htescape $1, "</li>\n";        print STDOUT qq[<li id="$input->{id_prefix}line-$i">], htescape $1,
417              "</li>\n";
418        $i++;        $i++;
419      }      }
420      if ($$s =~ /\G([^\x0A]+)/gc) {      if ($$s =~ /\G([^\x0A]+)/gc) {
421        print STDOUT qq[<li id="line-$i">], htescape $1, "</li>\n";        print STDOUT qq[<li id="$input->{id_prefix}line-$i">], htescape $1,
422              "</li>\n";
423      }      }
424    } else {    } else {
425      print STDOUT q[<li id="line-1"></li>];      print STDOUT q[<li id="$input->{id_prefix}line-1"></li>];
426    }    }
427    print STDOUT "</ol></div>";    print STDOUT "</ol></div>";
428  } # print_input_string_section  } # print_input_string_section
# Line 334  sub print_document_tree ($) { Line 439  sub print_document_tree ($) {
439        next;        next;
440      }      }
441    
442      my $node_id = 'node-'.refaddr $child;      my $node_id = $input->{id_prefix} . 'node-'.refaddr $child;
443      my $nt = $child->node_type;      my $nt = $child->node_type;
444      if ($nt == $child->ELEMENT_NODE) {      if ($nt == $child->ELEMENT_NODE) {
445        my $child_nsuri = $child->namespace_uri;        my $child_nsuri = $child->namespace_uri;
# Line 345  sub print_document_tree ($) { Line 450  sub print_document_tree ($) {
450          $r .= '<ul class="attributes">';          $r .= '<ul class="attributes">';
451          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 $_] }
452                        @{$child->attributes}) {                        @{$child->attributes}) {
453            $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?
454            $r .= '<q>' . htescape ($attr->[1]) . '</q></li>'; ## TODO: children            $r .= '<q>' . htescape ($attr->[1]) . '</q></li>'; ## TODO: children
455          }          }
456          $r .= '</ul>';          $r .= '</ul>';
# Line 366  sub print_document_tree ($) { Line 471  sub print_document_tree ($) {
471      } elsif ($nt == $child->DOCUMENT_NODE) {      } elsif ($nt == $child->DOCUMENT_NODE) {
472        $r .= qq'<li id="$node_id" class="tree-document">Document';        $r .= qq'<li id="$node_id" class="tree-document">Document';
473        $r .= qq[<ul class="attributes">];        $r .= qq[<ul class="attributes">];
474          my $cp = $child->manakai_charset;
475          if (defined $cp) {
476            $r .= qq[<li><code>charset</code> parameter = <code>];
477            $r .= htescape ($cp) . qq[</code></li>];
478          }
479          $r .= qq[<li><code>inputEncoding</code> = ];
480          my $ie = $child->input_encoding;
481          if (defined $ie) {
482            $r .= qq[<code>@{[htescape ($ie)]}</code>];
483            if ($child->manakai_has_bom) {
484              $r .= qq[ (with <code class=charname><abbr>BOM</abbr></code>)];
485            }
486          } else {
487            $r .= qq[(<code>null</code>)];
488          }
489        $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>];
490        $r .= qq[<li>@{[scalar get_text ('manakaiCompatMode:'.$child->manakai_compat_mode)]}</li>];        $r .= qq[<li>@{[scalar get_text ('manakaiCompatMode:'.$child->manakai_compat_mode)]}</li>];
491        unless ($child->manakai_is_html) {        unless ($child->manakai_is_html) {
# Line 399  sub print_document_tree ($) { Line 519  sub print_document_tree ($) {
519    print STDOUT $r;    print STDOUT $r;
520  } # print_document_tree  } # print_document_tree
521    
522  sub print_structure_dump_section ($$) {  sub print_structure_dump_dom_section ($$$) {
523    my ($doc, $el) = @_;    my ($input, $doc, $el) = @_;
524    
525    print STDOUT qq[    print STDOUT qq[
526  <div id="document-tree" class="section">  <div id="$input->{id_prefix}document-tree" class="section">
527  <h2>Document Tree</h2>  <h2>Document Tree</h2>
528  ];  ];
529    push @nav, ['#document-tree' => 'Tree'];    push @nav, ['#document-tree' => 'Tree'] unless $input->{nested};
530    
531    print_document_tree ($el || $doc);    print_document_tree ($el || $doc);
532    
533    print STDOUT qq[</div>];    print STDOUT qq[</div>];
534  } # print_structure_dump_section  } # print_structure_dump_dom_section
535    
536  sub print_structure_error_section ($$$) {  sub print_structure_dump_manifest_section ($$) {
537    my ($doc, $el, $result) = @_;    my ($input, $manifest) = @_;
538    
539    print STDOUT qq[<div id="document-errors" class="section">    print STDOUT qq[
540    <div id="$input->{id_prefix}dump-manifest" class="section">
541    <h2>Cache Manifest</h2>
542    ];
543      push @nav, ['#dump-manifest' => 'Caceh Manifest'] unless $input->{nested};
544    
545      print STDOUT qq[<dl><dt>Explicit entries</dt>];
546      for my $uri (@{$manifest->[0]}) {
547        my $euri = htescape ($uri);
548        print STDOUT qq[<dd><code class=uri>&lt;<a href="$euri">$euri</a>></code></dd>];
549      }
550    
551      print STDOUT qq[<dt>Fallback entries</dt><dd>
552          <table><thead><tr><th scope=row>Oppotunistic Caching Namespace</th>
553          <th scope=row>Fallback Entry</tr><tbody>];
554      for my $uri (sort {$a cmp $b} keys %{$manifest->[1]}) {
555        my $euri = htescape ($uri);
556        my $euri2 = htescape ($manifest->[1]->{$uri});
557        print STDOUT qq[<tr><td><code class=uri>&lt;<a href="$euri">$euri</a>></code></td>
558            <td><code class=uri>&lt;<a href="$euri2">$euri2</a>></code></td>];
559      }
560    
561      print STDOUT qq[</table><dt>Online whitelist</dt>];
562      for my $uri (@{$manifest->[2]}) {
563        my $euri = htescape ($uri);
564        print STDOUT qq[<dd><code class=uri>&lt;<a href="$euri">$euri</a>></code></dd>];
565      }
566    
567      print STDOUT qq[</dl></div>];
568    } # print_structure_dump_manifest_section
569    
570    sub print_structure_error_dom_section ($$$$$) {
571      my ($input, $doc, $el, $result, $onsubdoc) = @_;
572    
573      print STDOUT qq[<div id="$input->{id_prefix}document-errors" class="section">
574  <h2>Document Errors</h2>  <h2>Document Errors</h2>
575    
576  <dl>];  <dl>];
577    push @nav, ['#document-errors' => 'Document Error'];    push @nav, ['#document-errors' => 'Document Error'] unless $input->{nested};
578    
579    require Whatpm::ContentChecker;    require Whatpm::ContentChecker;
580    my $onerror = sub {    my $onerror = sub {
# Line 429  sub print_structure_error_section ($$$) Line 583  sub print_structure_error_section ($$$)
583      $type =~ tr/ /-/;      $type =~ tr/ /-/;
584      $type =~ s/\|/%7C/g;      $type =~ s/\|/%7C/g;
585      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
586      print STDOUT qq[<dt class="$cls">] . get_node_link ($opt{node}) .      print STDOUT qq[<dt class="$cls">] . get_error_label ($input, \%opt) .
587          qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";          qq[</dt>\n<dd class="$cls">], get_error_level_label (\%opt);
588        print STDOUT $msg, "</dd>\n";
589      add_error ('structure', \%opt => $result);      add_error ('structure', \%opt => $result);
590    };    };
591    
592    my $elements;    my $elements;
593    my $time1 = time;    my $time1 = time;
594    if ($el) {    if ($el) {
595      $elements = Whatpm::ContentChecker->check_element ($el, $onerror);      $elements = Whatpm::ContentChecker->check_element
596            ($el, $onerror, $onsubdoc);
597    } else {    } else {
598      $elements = Whatpm::ContentChecker->check_document ($doc, $onerror);      $elements = Whatpm::ContentChecker->check_document
599            ($doc, $onerror, $onsubdoc);
600    }    }
601    $time{check} = time - $time1;    $time{check} = time - $time1;
602    
603    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
604    
605    return $elements;    return $elements;
606  } # print_structure_error_section  } # print_structure_error_dom_section
607    
608    sub print_structure_error_manifest_section ($$$) {
609      my ($input, $manifest, $result) = @_;
610    
611      print STDOUT qq[<div id="$input->{id_prefix}document-errors" class="section">
612    <h2>Document Errors</h2>
613    
614    <dl>];
615      push @nav, ['#document-errors' => 'Document Error'] unless $input->{nested};
616    
617  sub print_table_section ($) {    require Whatpm::CacheManifest;
618    my $tables = shift;    Whatpm::CacheManifest->check_manifest ($manifest, sub {
619        my %opt = @_;
620        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level}, $opt{node});
621        $type =~ tr/ /-/;
622        $type =~ s/\|/%7C/g;
623        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
624        print STDOUT qq[<dt class="$cls">] . get_error_label ($input, \%opt) .
625            qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";
626        add_error ('structure', \%opt => $result);
627      });
628    
629      print STDOUT qq[</div>];
630    } # print_structure_error_manifest_section
631    
632    sub print_table_section ($$) {
633      my ($input, $tables) = @_;
634        
635    push @nav, ['#tables' => 'Tables'];    push @nav, ['#tables' => 'Tables'] unless $input->{nested};
636    print STDOUT qq[    print STDOUT qq[
637  <div id="tables" class="section">  <div id="$input->{id_prefix}tables" class="section">
638  <h2>Tables</h2>  <h2>Tables</h2>
639    
640  <!--[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 649  sub print_table_section ($) {
649    my $i = 0;    my $i = 0;
650    for my $table_el (@$tables) {    for my $table_el (@$tables) {
651      $i++;      $i++;
652      print STDOUT qq[<div class="section" id="table-$i"><h3>] .      print STDOUT qq[<div class="section" id="$input->{id_prefix}table-$i"><h3>] .
653          get_node_link ($table_el) . q[</h3>];          get_node_link ($input, $table_el) . q[</h3>];
654    
655      ## TODO: Make |ContentChecker| return |form_table| result      ## TODO: Make |ContentChecker| return |form_table| result
656      ## 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 682  sub print_table_section ($) {
682                    
683      print STDOUT '</div><script type="text/javascript">tableToCanvas (';      print STDOUT '</div><script type="text/javascript">tableToCanvas (';
684      print STDOUT JSON::objToJson ($table);      print STDOUT JSON::objToJson ($table);
685      print STDOUT qq[, document.getElementById ('table-$i'));</script>];      print STDOUT qq[, document.getElementById ('$input->{id_prefix}table-$i')];
686        print STDOUT qq[, '$input->{id_prefix}');</script>];
687    }    }
688        
689    print STDOUT qq[</div>];    print STDOUT qq[</div>];
690  } # print_table_section  } # print_table_section
691    
692  sub print_id_section ($) {  sub print_listing_section ($$$) {
693    my $ids = shift;    my ($opt, $input, $ids) = @_;
694        
695    push @nav, ['#identifiers' => 'IDs'];    push @nav, ['#' . $opt->{id} => $opt->{label}] unless $input->{nested};
696    print STDOUT qq[    print STDOUT qq[
697  <div id="identifiers" class="section">  <div id="$input->{id_prefix}$opt->{id}" class="section">
698  <h2>Identifiers</h2>  <h2>$opt->{heading}</h2>
699    
700  <dl>  <dl>
701  ];  ];
702    for my $id (sort {$a cmp $b} keys %$ids) {    for my $id (sort {$a cmp $b} keys %$ids) {
703      print STDOUT qq[<dt><code>@{[htescape $id]}</code></dt>];      print STDOUT qq[<dt><code>@{[htescape $id]}</code></dt>];
704      for (@{$ids->{$id}}) {      for (@{$ids->{$id}}) {
705        print STDOUT qq[<dd>].get_node_link ($_).qq[</dd>];        print STDOUT qq[<dd>].get_node_link ($input, $_).qq[</dd>];
706      }      }
707    }    }
708    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
709  } # 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  
710    
711  sub print_result_section ($) {  sub print_result_section ($) {
712    my $result = shift;    my $result = shift;
# Line 571  sub print_result_section ($) { Line 715  sub print_result_section ($) {
715  <div id="result-summary" class="section">  <div id="result-summary" class="section">
716  <h2>Result</h2>];  <h2>Result</h2>];
717    
718    if ($result->{unsupported}) {      if ($result->{unsupported} and $result->{conforming_max}) {  
719      print STDOUT qq[<p class=uncertain id=result-para>The conformance      print STDOUT qq[<p class=uncertain id=result-para>The conformance
720          checker cannot decide whether the document is conforming or          checker cannot decide whether the document is conforming or
721          not, since the document contains one or more unsupported          not, since the document contains one or more unsupported
722          features.</p>];          features.  The document might or might not be conforming.</p>];
723    } elsif ($result->{conforming_min}) {    } elsif ($result->{conforming_min}) {
724      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
725          found in this document.</p>];          found in this document.</p>];
# Line 591  sub print_result_section ($) { Line 735  sub print_result_section ($) {
735    print STDOUT qq[<table>    print STDOUT qq[<table>
736  <colgroup><col><colgroup><col><col><col><colgroup><col>  <colgroup><col><colgroup><col><col><col><colgroup><col>
737  <thead>  <thead>
738  <tr><th scope=col></th><th scope=col><em class=rfc2119>MUST</em>-level  <tr><th scope=col></th>
739  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
740  Errors</th><th scope=col>Warnings</th><th scope=col>Score</th></tr>  Errors</a></th>
741  </thead><tbody>];  <th scope=col><a href="../error-description#level-s"><em class=rfc2119>SHOULD</em>‐level
742    Errors</a></th>
743    <th scope=col><a href="../error-description#level-w">Warnings</a></th>
744    <th scope=col>Score</th></tr></thead><tbody>];
745    
746    my $must_error = 0;    my $must_error = 0;
747    my $should_error = 0;    my $should_error = 0;
# Line 602  Errors</th><th scope=col>Warnings</th><t Line 749  Errors</th><th scope=col>Warnings</th><t
749    my $score_min = 0;    my $score_min = 0;
750    my $score_max = 0;    my $score_max = 0;
751    my $score_base = 20;    my $score_base = 20;
752      my $score_unit = $score_base / 100;
753    for (    for (
754      [Transfer => 'transfer', ''],      [Transfer => 'transfer', ''],
755      [Character => 'char', ''],      [Character => 'char', ''],
# Line 611  Errors</th><th scope=col>Warnings</th><t Line 759  Errors</th><th scope=col>Warnings</th><t
759      $must_error += ($result->{$_->[1]}->{must} += 0);      $must_error += ($result->{$_->[1]}->{must} += 0);
760      $should_error += ($result->{$_->[1]}->{should} += 0);      $should_error += ($result->{$_->[1]}->{should} += 0);
761      $warning += ($result->{$_->[1]}->{warning} += 0);      $warning += ($result->{$_->[1]}->{warning} += 0);
762      $score_min += ($result->{$_->[1]}->{score_min} += $score_base);      $score_min += (($result->{$_->[1]}->{score_min} *= $score_unit) += $score_base);
763      $score_max += ($result->{$_->[1]}->{score_max} += $score_base);      $score_max += (($result->{$_->[1]}->{score_max} *= $score_unit) += $score_base);
764    
765      my $uncertain = $result->{$_->[1]}->{unsupported} ? '?' : '';      my $uncertain = $result->{$_->[1]}->{unsupported} ? '?' : '';
766      my $label = $_->[0];      my $label = $_->[0];
# Line 625  Errors</th><th scope=col>Warnings</th><t Line 773  Errors</th><th scope=col>Warnings</th><t
773    
774      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>];
775      if ($uncertain) {      if ($uncertain) {
776        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>];
777      } elsif ($result->{$_->[1]}->{score_min} != $result->{$_->[1]}->{score_max}) {      } elsif ($result->{$_->[1]}->{score_min} != $result->{$_->[1]}->{score_max}) {
778        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>];
779      } else {      } else {
780        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>];
781      }      }
782    }    }
783    
# Line 638  Errors</th><th scope=col>Warnings</th><t Line 786  Errors</th><th scope=col>Warnings</th><t
786    print STDOUT qq[    print STDOUT qq[
787  <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>
788  </tbody>  </tbody>
789  <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>
790    <td class="@{[$must_error ? 'FAIL' : '']}">$must_error?</td>
791    <td class="@{[$should_error ? 'SEE-RESULT' : '']}">$should_error?</td>
792    <td>$warning?</td>
793    <td class="@{[$must_error ? 'FAIL' : $should_error ? 'SEE-RESULT' : '']}"><strong>&#x2212;&#x221E;..$score_max</strong></td></tr></tfoot>
794  </table>  </table>
795    
796  <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 799  is <em>under development</em>.  The resu
799    push @nav, ['#result-summary' => 'Result'];    push @nav, ['#result-summary' => 'Result'];
800  } # print_result_section  } # print_result_section
801    
802  sub print_result_unknown_type_section ($) {  sub print_result_unknown_type_section ($$) {
803    my $input = shift;    my ($input, $result) = @_;
804    
805      my $euri = htescape ($input->{uri});
806    print STDOUT qq[    print STDOUT qq[
807  <div id="result-summary" class="section">  <div id="parse-errors" class="section">
808  <p><em>Media type <code class="MIME" lang="en">@{[htescape $input->{media_type}]}</code> is not supported!</em></p>  <h2>Errors</h2>
809    
810    <dl>
811    <dt class=unsupported><code>&lt;<a href="$euri">$euri</a>&gt;</code></dt>
812        <dd class=unsupported><strong><a href="../error-description#level-u">Not
813            supported</a></strong>:
814        Media type
815        <code class="MIME" lang="en">@{[htescape $input->{media_type}]}</code>
816        is not supported.</dd>
817    </dl>
818  </div>  </div>
819  ];  ];
820    push @nav, ['#result-summary' => 'Result'];    push @nav, ['#parse-errors' => 'Errors'];
821      add_error (char => {level => 'u'} => $result);
822      add_error (syntax => {level => 'u'} => $result);
823      add_error (structure => {level => 'u'} => $result);
824  } # print_result_unknown_type_section  } # print_result_unknown_type_section
825    
826  sub print_result_input_error_section ($) {  sub print_result_input_error_section ($) {
# Line 664  sub print_result_input_error_section ($) Line 829  sub print_result_input_error_section ($)
829  <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>
830  </div>];  </div>];
831    push @nav, ['#result-summary' => 'Result'];    push @nav, ['#result-summary' => 'Result'];
832  } # print_Result_input_error_section  } # print_result_input_error_section
833    
834    sub get_error_label ($$) {
835      my ($input, $err) = @_;
836    
837      my $r = '';
838    
839      if (defined $err->{line}) {
840        if ($err->{column} > 0) {
841          $r = qq[<a href="#line-$err->{line}">Line $err->{line}</a> column $err->{column}];
842        } else {
843          $err->{line} = $err->{line} - 1 || 1;
844          $r = qq[<a href="#line-$err->{line}">Line $err->{line}</a>];
845        }
846      }
847    
848      if (defined $err->{node}) {
849        $r .= ' ' if length $r;
850        $r = get_node_link ($input, $err->{node});
851      }
852    
853      if (defined $err->{index}) {
854        $r .= ' ' if length $r;
855        $r .= 'Index ' . (0+$err->{index});
856      }
857    
858      if (defined $err->{value}) {
859        $r .= ' ' if length $r;
860        $r .= '<q><code>' . htescape ($err->{value}) . '</code></q>';
861      }
862    
863      return $r;
864    } # get_error_label
865    
866    sub get_error_level_label ($) {
867      my $err = shift;
868    
869      my $r = '';
870    
871      if (not defined $err->{level} or $err->{level} eq 'm') {
872        $r = qq[<strong><a href="../error-description#level-m"><em class=rfc2119>MUST</em>‐level
873            error</a></strong>: ];
874      } elsif ($err->{level} eq 's') {
875        $r = qq[<strong><a href="../error-description#level-s"><em class=rfc2119>SHOULD</em>‐level
876            error</a></strong>: ];
877      } elsif ($err->{level} eq 'w') {
878        $r = qq[<strong><a href="../error-description#level-w">Warning</a></strong>:
879            ];
880      } elsif ($err->{level} eq 'u' or $err->{level} eq 'unsupported') {
881        $r = qq[<strong><a href="../error-description#level-u">Not
882            supported</a></strong>: ];
883      } else {
884        my $elevel = htescape ($err->{level});
885        $r = qq[<strong><a href="../error-description#level-$elevel">$elevel</a></strong>:
886            ];
887      }
888    
889      return $r;
890    } # get_error_level_label
891    
892  sub get_node_path ($) {  sub get_node_path ($) {
893    my $node = shift;    my $node = shift;
# Line 693  sub get_node_path ($) { Line 916  sub get_node_path ($) {
916    return join '/', @r;    return join '/', @r;
917  } # get_node_path  } # get_node_path
918    
919  sub get_node_link ($) {  sub get_node_link ($$) {
920    return qq[<a href="#node-@{[refaddr $_[0]]}">] .    return qq[<a href="#$_[0]->{id_prefix}node-@{[refaddr $_[1]]}">] .
921        htescape (get_node_path ($_[0])) . qq[</a>];        htescape (get_node_path ($_[1])) . qq[</a>];
922  } # get_node_link  } # get_node_link
923    
924  {  {
# Line 703  sub get_node_link ($) { Line 926  sub get_node_link ($) {
926    
927  sub load_text_catalog ($) {  sub load_text_catalog ($) {
928    my $lang = shift; # MUST be a canonical lang name    my $lang = shift; # MUST be a canonical lang name
929    open my $file, '<', "cc-msg.$lang.txt" or die "$0: cc-msg.$lang.txt: $!";    open my $file, '<:utf8', "cc-msg.$lang.txt"
930          or die "$0: cc-msg.$lang.txt: $!";
931    while (<$file>) {    while (<$file>) {
932      if (s/^([^;]+);([^;]*);//) {      if (s/^([^;]+);([^;]*);//) {
933        my ($type, $cls, $msg) = ($1, $2, $_);        my ($type, $cls, $msg) = ($1, $2, $_);
# Line 716  sub load_text_catalog ($) { Line 940  sub load_text_catalog ($) {
940  sub get_text ($) {  sub get_text ($) {
941    my ($type, $level, $node) = @_;    my ($type, $level, $node) = @_;
942    $type = $level . ':' . $type if defined $level;    $type = $level . ':' . $type if defined $level;
943      $level = 'm' unless defined $level;
944    my @arg;    my @arg;
945    {    {
946      if (defined $Msg->{$type}) {      if (defined $Msg->{$type}) {
# Line 740  sub get_text ($) { Line 965  sub get_text ($) {
965            ? htescape ($node->owner_element->manakai_local_name)            ? htescape ($node->owner_element->manakai_local_name)
966            : ''            : ''
967        }ge;        }ge;
968        return ($type, $Msg->{$type}->[0], $msg);        return ($type, 'level-' . $level . ' ' . $Msg->{$type}->[0], $msg);
969      } elsif ($type =~ s/:([^:]*)$//) {      } elsif ($type =~ s/:([^:]*)$//) {
970        unshift @arg, $1;        unshift @arg, $1;
971        redo;        redo;
972      }      }
973    }    }
974    return ($type, '', htescape ($_[0]));    return ($type, 'level-'.$level, htescape ($_[0]));
975  } # get_text  } # get_text
976    
977  }  }
# Line 802  EOH Line 1027  EOH
1027      $ua->protocols_allowed ([qw/http/]);      $ua->protocols_allowed ([qw/http/]);
1028      $ua->max_size (1000_000);      $ua->max_size (1000_000);
1029      my $req = HTTP::Request->new (GET => $request_uri);      my $req = HTTP::Request->new (GET => $request_uri);
1030        $req->header ('Accept-Encoding' => 'identity, *; q=0');
1031      my $res = $ua->request ($req);      my $res = $ua->request ($req);
1032      ## TODO: 401 sets |is_success| true.      ## TODO: 401 sets |is_success| true.
1033      if ($res->is_success or $http->get_parameter ('error-page')) {      if ($res->is_success or $http->get_parameter ('error-page')) {
# Line 811  EOH Line 1037  EOH
1037    
1038        ## TODO: More strict parsing...        ## TODO: More strict parsing...
1039        my $ct = $res->header ('Content-Type');        my $ct = $res->header ('Content-Type');
1040        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) {  
1041          $r->{charset} = lc $1;          $r->{charset} = lc $1;
1042          $r->{charset} =~ tr/\\//d;          $r->{charset} =~ tr/\\//d;
1043            $r->{official_charset} = $r->{charset};
1044        }        }
1045    
1046        my $input_charset = $http->get_parameter ('charset');        my $input_charset = $http->get_parameter ('charset');
# Line 824  EOH Line 1048  EOH
1048          $r->{charset_overridden}          $r->{charset_overridden}
1049              = (not defined $r->{charset} or $r->{charset} ne $input_charset);              = (not defined $r->{charset} or $r->{charset} ne $input_charset);
1050          $r->{charset} = $input_charset;          $r->{charset} = $input_charset;
1051        }        }
1052    
1053          ## TODO: Support for HTTP Content-Encoding
1054    
1055        $r->{s} = ''.$res->content;        $r->{s} = ''.$res->content;
1056    
1057          require Whatpm::ContentType;
1058          ($r->{official_type}, $r->{media_type})
1059              = Whatpm::ContentType->get_sniffed_type
1060                  (get_file_head => sub {
1061                     return substr $r->{s}, 0, shift;
1062                   },
1063                   http_content_type_byte => $ct,
1064                   has_http_content_encoding =>
1065                       defined $res->header ('Content-Encoding'),
1066                   supported_image_types => {});
1067      } else {      } else {
1068        $r->{uri} = $res->request->uri;        $r->{uri} = $res->request->uri;
1069        $r->{request_uri} = $request_uri;        $r->{request_uri} = $request_uri;
# Line 847  EOH Line 1084  EOH
1084      $r->{charset} = ''.$http->get_parameter ('_charset_');      $r->{charset} = ''.$http->get_parameter ('_charset_');
1085      $r->{charset} =~ s/\s+//g;      $r->{charset} =~ s/\s+//g;
1086      $r->{charset} = 'utf-8' if $r->{charset} eq '';      $r->{charset} = 'utf-8' if $r->{charset} eq '';
1087        $r->{official_charset} = $r->{charset};
1088      $r->{header_field} = [];      $r->{header_field} = [];
1089    
1090        require Whatpm::ContentType;
1091        ($r->{official_type}, $r->{media_type})
1092            = Whatpm::ContentType->get_sniffed_type
1093                (get_file_head => sub {
1094                   return substr $r->{s}, 0, shift;
1095                 },
1096                 http_content_type_byte => undef,
1097                 has_http_content_encoding => 0,
1098                 supported_image_types => {});
1099    }    }
1100    
1101    my $input_format = $http->get_parameter ('i');    my $input_format = $http->get_parameter ('i');
# Line 864  EOH Line 1112  EOH
1112    if ($r->{media_type} eq 'text/xml') {    if ($r->{media_type} eq 'text/xml') {
1113      unless (defined $r->{charset}) {      unless (defined $r->{charset}) {
1114        $r->{charset} = 'us-ascii';        $r->{charset} = 'us-ascii';
1115          $r->{official_charset} = $r->{charset};
1116      } elsif ($r->{charset_overridden} and $r->{charset} eq 'us-ascii') {      } elsif ($r->{charset_overridden} and $r->{charset} eq 'us-ascii') {
1117        $r->{charset_overridden} = 0;        $r->{charset_overridden} = 0;
1118      }      }
Legend:
Removed from v.1.19  
changed lines
  Added in v.1.34
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24