/[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.18 by wakaba, Sun Sep 2 08:40:49 2007 UTC revision 1.53 by wakaba, Sun Jul 20 14:58:24 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];
7  use CGI::Carp qw[fatalsToBrowser];  use CGI::Carp qw[fatalsToBrowser];
8  use Scalar::Util qw[refaddr];  use Scalar::Util qw[refaddr];
 use Time::HiRes qw/time/;  
9    
10  sub htescape ($) {    require WebHACC::Input;
11    my $s = $_[0];    require WebHACC::Result;
12    $s =~ s/&/&/g;    require WebHACC::Output;
   $s =~ s/</&lt;/g;  
   $s =~ s/>/&gt;/g;  
   $s =~ s/"/&quot;/g;  
   $s =~ s{([\x00-\x09\x0B-\x1F\x7F-\xA0\x{FEFF}\x{FFFC}-\x{FFFF}])}{  
     sprintf '<var>U+%04X</var>', ord $1;  
   }ge;  
   return $s;  
 } # htescape  
13    
14    my $out;
15    
16      require Message::DOM::DOMImplementation;
17      my $dom = Message::DOM::DOMImplementation->new;
18    {
19    use Message::CGI::HTTP;    use Message::CGI::HTTP;
20    my $http = Message::CGI::HTTP->new;    my $http = Message::CGI::HTTP->new;
21    
# Line 26  sub htescape ($) { Line 23  sub htescape ($) {
23      print STDOUT "Status: 404 Not Found\nContent-Type: text/plain; charset=us-ascii\n\n400";      print STDOUT "Status: 404 Not Found\nContent-Type: text/plain; charset=us-ascii\n\n400";
24      exit;      exit;
25    }    }
26      
   binmode STDOUT, ':utf8';  
   $| = 1;  
   
   require Message::DOM::DOMImplementation;  
   my $dom = Message::DOM::DOMImplementation->new;  
   
27    load_text_catalog ('en'); ## TODO: conneg    load_text_catalog ('en'); ## TODO: conneg
28    
29    my @nav;    $out = WebHACC::Output->new;
30    print STDOUT qq[Content-Type: text/html; charset=utf-8    $out->handle (*STDOUT);
31      $out->set_utf8;
32      $out->set_flush;
33      $out->html (qq[Content-Type: text/html; charset=utf-8
34    
35  <!DOCTYPE html>  <!DOCTYPE html>
36  <html lang="en">  <html lang="en">
# Line 47  sub htescape ($) { Line 41  sub htescape ($) {
41  <body>  <body>
42  <h1><a href="../cc-interface">Web Document Conformance Checker</a>  <h1><a href="../cc-interface">Web Document Conformance Checker</a>
43  (<em>beta</em>)</h1>  (<em>beta</em>)</h1>
44  ];  ]);
45    
   $| = 0;  
46    my $input = get_input_document ($http, $dom);    my $input = get_input_document ($http, $dom);
47    my $inner_html_element = $http->get_parameter ('e');    $out->input ($input);
48    my $char_length = 0;    $out->unset_flush;
   my %time;  
   
   print qq[  
 <div id="document-info" class="section">  
 <dl>  
 <dt>Request URI</dt>  
     <dd><code class="URI" lang="">&lt;<a href="@{[htescape $input->{request_uri}]}">@{[htescape $input->{request_uri}]}</a>&gt;</code></dd>  
 <dt>Document URI</dt>  
     <dd><code class="URI" lang="">&lt;<a href="@{[htescape $input->{uri}]}">@{[htescape $input->{uri}]}</a>&gt;</code></dd>  
 ]; # no </dl> yet  
   push @nav, ['#document-info' => 'Information'];  
49    
50  if (defined $input->{s}) {    my $char_length = 0;
   $char_length = length $input->{s};  
51    
52    print STDOUT qq[    $out->start_section (id => 'document-info', title => 'Information');
53  <dt>Base URI</dt>    $out->html (qq[<dl>
54      <dd><code class="URI" lang="">&lt;<a href="@{[htescape $input->{base_uri}]}">@{[htescape $input->{base_uri}]}</a>&gt;</code></dd>  <dt>Request URL</dt>
55  <dt>Internet Media Type</dt>      <dd>]);
56      <dd><code class="MIME" lang="en">@{[htescape $input->{media_type}]}</code>    $out->url ($input->{request_uri});
57      @{[$input->{media_type_overridden} ? '<em>(overridden)</em>' : '']}</dd>    $out->html (q[<dt>Document URL<!-- HTML5 document's address? -->
58  <dt>Character Encoding</dt>      <dd>]);
59      <dd>@{[defined $input->{charset} ? '<code class="charset" lang="en">'.htescape ($input->{charset}).'</code>' : '(none)']}    $out->url ($input->{uri}, id => 'anchor-document-url');
60      @{[$input->{charset_overridden} ? '<em>(overridden)</em>' : '']}</dd>    $out->html (q[
61        <script>
62          document.title = '<'
63              + document.getElementById ('anchor-document-url').href + '> \\u2014 '
64              + document.title;
65        </script>]);
66      ## NOTE: no </dl> yet
67    
68      if (defined $input->{s}) {
69        $char_length = length $input->{s};
70    
71        $out->html (qq[<dt>Base URI<dd>]);
72        $out->url ($input->{base_uri});
73        $out->html (qq[<dt>Internet Media Type</dt>
74        <dd><code class="MIME" lang="en">]);
75        $out->text ($input->{media_type});
76        $out->html (qq[</code> ]);
77        if ($input->{media_type_overridden}) {
78          $out->html ('<em>(overridden)</em>');
79        } elsif (defined $input->{official_type}) {
80          if ($input->{media_type} eq $input->{official_type}) {
81            #
82          } else {
83            $out->html ('<em>(sniffed; official type is: <code class=MIME lang=en>');
84            $out->text ($input->{official_type});
85            $out->html ('</code>)');
86          }
87        } else {
88          $out->html ('<em>(sniffed)</em>');
89        }
90        $out->html (q[<dt>Character Encoding<dd>]);
91        if (defined $input->{charset}) {
92          $out->html ('<code class="charset" lang="en">');
93          $out->text ($input->{charset});
94          $out->html ('</code>');
95        } else {
96          $out->text ('(none)');
97        }
98        $out->html (' <em>overridden</em>') if $input->{charset_overridden};
99        $out->html (qq[
100  <dt>Length</dt>  <dt>Length</dt>
101      <dd>$char_length byte@{[$char_length == 1 ? '' : 's']}</dd>      <dd>$char_length byte@{[$char_length == 1 ? '' : 's']}</dd>
102  </dl>  </dl>
 </div>  
 ];  
103    
104    print_http_header_section ($input);  <script src="../cc-script.js"></script>
105    ]);
106    my $doc;      $out->end_section;
107    my $el;  
108        my $result = WebHACC::Result->new;
109    if ($input->{media_type} eq 'text/html') {      $result->{conforming_min} = 1;
110      ($doc, $el) = print_syntax_error_html_section ($input);      $result->{conforming_max} = 1;
111      print_source_string_section (\($input->{s}), $input->{charset});      check_and_print ($input => $result => $out);
112    } elsif ({      print_result_section ($result);
             '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);  
     print_source_string_section (\($input->{s}), $doc->input_encoding);  
113    } else {    } else {
114      ## TODO: Change HTTP status code??      $out->html ('</dl>');
115      print_result_unknown_type_section ($input);      $out->end_section;
116        print_result_input_error_section ($input);
117    }    }
118    
119    if (defined $doc or defined $el) {    $out->nav_list;
     print_structure_dump_section ($doc, $el);  
     my $elements = print_structure_error_section ($doc, $el);  
     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}};  
   }  
120    
121    ## TODO: Show result    exit;
 } else {  
   print STDOUT qq[</dl></div>];  
   print_result_input_error_section ($input);  
122  }  }
123    
124    print STDOUT qq[  sub add_error ($$$) {
125  <ul class="navigation" id="nav-items">    my ($layer, $err, $result) = @_;
126  ];    if (defined $err->{level}) {
127    for (@nav) {      if ($err->{level} eq 's') {
128      print STDOUT qq[<li><a href="$_->[0]">$_->[1]</a></li>];        $result->{$layer}->{should}++;
129    }        $result->{$layer}->{score_min} -= 2;
130    print STDOUT qq[        $result->{conforming_min} = 0;
131  </ul>      } elsif ($err->{level} eq 'w' or $err->{level} eq 'g') {
132  </body>        $result->{$layer}->{warning}++;
133  </html>      } elsif ($err->{level} eq 'u' or $err->{level} eq 'unsupported') {
134  ];        $result->{$layer}->{unsupported}++;
135          $result->{unsupported} = 1;
136        } elsif ($err->{level} eq 'i') {
137          #
138        } else {
139          $result->{$layer}->{must}++;
140          $result->{$layer}->{score_max} -= 2;
141          $result->{$layer}->{score_min} -= 2;
142          $result->{conforming_min} = 0;
143          $result->{conforming_max} = 0;
144        }
145      } else {
146        $result->{$layer}->{must}++;
147        $result->{$layer}->{score_max} -= 2;
148        $result->{$layer}->{score_min} -= 2;
149        $result->{conforming_min} = 0;
150        $result->{conforming_max} = 0;
151      }
152    } # add_error
153    
154    sub check_and_print ($$$) {
155      my ($input, $result, $out) = @_;
156      my $original_input = $out->input;
157      $out->input ($input);
158    
159      print_http_header_section ($input, $result);
160    
161      my @subdoc;
162    
163      my $checker_class = {
164        'text/cache-manifest' => 'WebHACC::Language::CacheManifest',
165        'text/css' => 'WebHACC::Language::CSS',
166        'text/html' => 'WebHACC::Language::HTML',
167        'text/x-webidl' => 'WebHACC::Language::WebIDL',
168    
169        'text/xml' => 'WebHACC::Language::XML',
170        'application/atom+xml' => 'WebHACC::Language::XML',
171        'application/rss+xml' => 'WebHACC::Language::XML',
172        'image/svg+xml' => 'WebHACC::Language::XML',
173        'application/xhtml+xml' => 'WebHACC::Language::XML',
174        'application/xml' => 'WebHACC::Language::XML',
175        ## TODO: Should we make all XML MIME Types fall
176        ## into this category?
177    
178        ## NOTE: This type has different model from normal XML types.
179        'application/rdf+xml' => 'WebHACC::Language::XML',
180      }->{$input->{media_type}} || 'WebHACC::Language::Default';
181    
182      eval qq{ require $checker_class } or die "$0: Loading $checker_class: $@";
183      my $checker = $checker_class->new;
184      $checker->input ($input);
185      $checker->output ($out);
186      $checker->result ($result);
187    
188      ## TODO: A cache manifest MUST be text/cache-manifest
189      ## TODO: WebIDL media type "text/x-webidl"
190    
191      $checker->generate_syntax_error_section;
192      $checker->generate_source_string_section;
193    
194      $checker->onsubdoc (sub {
195        push @subdoc, shift;
196      });
197    
198      $checker->generate_structure_dump_section;
199      $checker->generate_structure_error_section;
200      $checker->generate_additional_sections;
201    
202    for (qw/decode parse parse_xml check/) {  =pod
203      next unless defined $time{$_};  
204      open my $file, '>>', ".cc-$_.txt" or die ".cc-$_.txt: $!";    if (defined $doc or defined $el) {
205      print $file $char_length, "\t", $time{$_}, "\n";  
206        print_table_section ($input, $elements->{table}) if @{$elements->{table}};
207        print_listing_section ({
208          id => 'identifiers', label => 'IDs', heading => 'Identifiers',
209        }, $input, $elements->{id}) if keys %{$elements->{id}};
210        print_listing_section ({
211          id => 'terms', label => 'Terms', heading => 'Terms',
212        }, $input, $elements->{term}) if keys %{$elements->{term}};
213        print_listing_section ({
214          id => 'classes', label => 'Classes', heading => 'Classes',
215        }, $input, $elements->{class}) if keys %{$elements->{class}};
216      
217        print_rdf_section ($input, $elements->{rdf}) if @{$elements->{rdf}};
218      }
219    
220    =cut
221    
222      my $id_prefix = 0;
223      for my $_subinput (@subdoc) {
224        my $subinput = WebHACC::Input->new;
225        $subinput->{$_} = $_subinput->{$_} for keys %$_subinput;
226        $subinput->id_prefix ('subdoc-' . ++$id_prefix);
227        $subinput->nested (1);
228        $subinput->{base_uri} = $subinput->{container_node}->base_uri
229            unless defined $subinput->{base_uri};
230        my $ebaseuri = htescape ($subinput->{base_uri});
231        $out->start_section (id => $subinput->id_prefix,
232                             title => qq[Subdocument #$id_prefix]);
233        print STDOUT qq[
234          <dl>
235          <dt>Internet Media Type</dt>
236            <dd><code class="MIME" lang="en">@{[htescape $subinput->{media_type}]}</code>
237          <dt>Container Node</dt>
238            <dd>@{[get_node_link ($input, $subinput->{container_node})]}</dd>
239          <dt>Base <abbr title="Uniform Resource Identifiers">URI</abbr></dt>
240            <dd><code class=URI>&lt;<a href="$ebaseuri">$ebaseuri</a>></code></dd>
241          </dl>];              
242    
243        $subinput->{id_prefix} .= '-';
244        check_and_print ($subinput => $result => $out);
245    
246        $out->end_section;
247    }    }
248    
249  exit;    $out->input ($original_input);
250    } # check_and_print
251    
252  sub print_http_header_section ($) {  sub print_http_header_section ($$) {
253    my $input = shift;    my ($input, $result) = @_;
254    return unless defined $input->{header_status_code} or    return unless defined $input->{header_status_code} or
255        defined $input->{header_status_text} or        defined $input->{header_status_text} or
256        @{$input->{header_field}};        @{$input->{header_field} or []};
257        
258    push @nav, ['#source-header' => 'HTTP Header'];    $out->start_section (id => 'source-header', title => 'HTTP Header');
259    print STDOUT qq[<div id="source-header" class="section">    print STDOUT qq[<p><strong>Note</strong>: Due to the limitation of the
 <h2>HTTP Header</h2>  
   
 <p><strong>Note</strong>: Due to the limitation of the  
260  network library in use, the content of this section might  network library in use, the content of this section might
261  not be the real header.</p>  not be the real header.</p>
262    
# Line 160  not be the real header.</p> Line 265  not be the real header.</p>
265    
266    if (defined $input->{header_status_code}) {    if (defined $input->{header_status_code}) {
267      print STDOUT qq[<tr><th scope="row">Status code</th>];      print STDOUT qq[<tr><th scope="row">Status code</th>];
268      print STDOUT qq[<td><code>@{[htescape ($input->{header_status_code})]}</code></td></tr>];      print STDOUT qq[<td>];
269        $out->code ($input->{header_status_code});
270    }    }
271    if (defined $input->{header_status_text}) {    if (defined $input->{header_status_text}) {
272      print STDOUT qq[<tr><th scope="row">Status text</th>];      print STDOUT qq[<tr><th scope="row">Status text</th>];
273      print STDOUT qq[<td><code>@{[htescape ($input->{header_status_text})]}</code></td></tr>];      print STDOUT qq[<td>];
274        $out->code ($input->{header_status_text});
275    }    }
276        
277    for (@{$input->{header_field}}) {    for (@{$input->{header_field}}) {
278      print STDOUT qq[<tr><th scope="row"><code>@{[htescape ($_->[0])]}</code></th>];      print STDOUT qq[<tr><th scope="row">];
279      print STDOUT qq[<td><code>@{[htescape ($_->[1])]}</code></td></tr>];      $out->code ($_->[0]);
280    }      print STDOUT qq[<td>];
281        $out->code ($_->[1]);
   print STDOUT qq[</tbody></table></div>];  
 } # print_http_header_section  
   
 sub print_syntax_error_html_section ($) {  
   my $input = shift;  
     
   require Encode;  
   require Whatpm::HTML;  
   
   $input->{charset} ||= 'ISO-8859-1'; ## TODO: for now.  
     
   my $time1 = time;  
   my $t = Encode::decode ($input->{charset}, $input->{s});  
   $time{decode} = time - $time1;  
   
   print STDOUT qq[  
 <div id="parse-errors" class="section">  
 <h2>Parse Errors</h2>  
   
 <dl>];  
   push @nav, ['#parse-errors' => 'Parse Error'];  
   
   my $onerror = sub {  
     my (%opt) = @_;  
     my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level});  
     if ($opt{column} > 0) {  
       print STDOUT qq[<dt class="$cls"><a href="#line-$opt{line}">Line $opt{line}</a> column $opt{column}</dt>\n];  
     } else {  
       $opt{line} = $opt{line} - 1 || 1;  
       print STDOUT qq[<dt class="$cls"><a href="#line-$opt{line}">Line $opt{line}</a></dt>\n];  
     }  
     $type =~ tr/ /-/;  
     $type =~ s/\|/%7C/g;  
     $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];  
     print STDOUT qq[<dd class="$cls">$msg</dd>\n];  
   };  
   
   my $doc = $dom->create_document;  
   my $el;  
   $time1 = time;  
   if (defined $inner_html_element and length $inner_html_element) {  
     $el = $doc->create_element_ns  
         ('http://www.w3.org/1999/xhtml', [undef, $inner_html_element]);  
     Whatpm::HTML->set_inner_html ($el, $t, $onerror);  
   } else {  
     Whatpm::HTML->parse_string ($t => $doc, $onerror);  
   }  
   $time{parse} = time - $time1;  
   
   print STDOUT qq[</dl></div>];  
   
   return ($doc, $el);  
 } # print_syntax_error_html_section  
   
 sub print_syntax_error_xml_section ($) {  
   my $input = shift;  
     
   require Message::DOM::XMLParserTemp;  
     
   print STDOUT qq[  
 <div id="parse-errors" class="section">  
 <h2>Parse Errors</h2>  
   
 <dl>];  
   push @nav, ['#parse-errors' => 'Parse Error'];  
   
   my $onerror = sub {  
     my $err = shift;  
     my $line = $err->location->line_number;  
     print STDOUT qq[<dt><a href="#line-$line">Line $line</a> column ];  
     print STDOUT $err->location->column_number, "</dt><dd>";  
     print STDOUT htescape $err->text, "</dd>\n";  
     return 1;  
   };  
   
   my $time1 = time;  
   open my $fh, '<', \($input->{s});  
   my $doc = Message::DOM::XMLParserTemp->parse_byte_stream  
       ($fh => $dom, $onerror, charset => $input->{charset});  
   $time{parse_xml} = time - $time1;  
   
   print STDOUT qq[</dl></div>];  
   
   return ($doc, undef);  
 } # print_syntax_error_xml_section  
   
 sub print_source_string_section ($$) {  
   require Encode;  
   my $enc = Encode::find_encoding ($_[1]); ## TODO: charset name -> Perl name  
   return unless $enc;  
   
   my $s = \($enc->decode (${$_[0]}));  
   my $i = 1;                              
   push @nav, ['#source-string' => 'Source'];  
   print STDOUT qq[<div id="source-string" class="section">  
 <h2>Document Source</h2>  
 <ol lang="">\n];  
   if (length $$s) {  
     while ($$s =~ /\G([^\x0A]*?)\x0D?\x0A/gc) {  
       print STDOUT qq[<li id="line-$i">], htescape $1, "</li>\n";  
       $i++;  
     }  
     if ($$s =~ /\G([^\x0A]+)/gc) {  
       print STDOUT qq[<li id="line-$i">], htescape $1, "</li>\n";  
     }  
   } else {  
     print STDOUT q[<li id="line-1"></li>];  
   }  
   print STDOUT "</ol></div>";  
 } # print_input_string_section  
   
 sub print_document_tree ($) {  
   my $node = shift;  
   my $r = '<ol class="xoxo">';  
   
   my @node = ($node);  
   while (@node) {  
     my $child = shift @node;  
     unless (ref $child) {  
       $r .= $child;  
       next;  
     }  
   
     my $node_id = 'node-'.refaddr $child;  
     my $nt = $child->node_type;  
     if ($nt == $child->ELEMENT_NODE) {  
       my $child_nsuri = $child->namespace_uri;  
       $r .= qq[<li id="$node_id" class="tree-element"><code title="@{[defined $child_nsuri ? $child_nsuri : '']}">] . htescape ($child->tag_name) .  
           '</code>'; ## ISSUE: case  
   
       if ($child->has_attributes) {  
         $r .= '<ul class="attributes">';  
         for my $attr (sort {$a->[0] cmp $b->[0]} map { [$_->name, $_->value, $_->namespace_uri, 'node-'.refaddr $_] }  
                       @{$child->attributes}) {  
           $r .= qq[<li id="$attr->[3]" class="tree-attribute"><code title="@{[defined $_->[2] ? $_->[2] : '']}">] . htescape ($attr->[0]) . '</code> = '; ## ISSUE: case?  
           $r .= '<q>' . htescape ($attr->[1]) . '</q></li>'; ## TODO: children  
         }  
         $r .= '</ul>';  
       }  
   
       if ($child->has_child_nodes) {  
         $r .= '<ol class="children">';  
         unshift @node, @{$child->child_nodes}, '</ol></li>';  
       } else {  
         $r .= '</li>';  
       }  
     } elsif ($nt == $child->TEXT_NODE) {  
       $r .= qq'<li id="$node_id" class="tree-text"><q lang="">' . htescape ($child->data) . '</q></li>';  
     } elsif ($nt == $child->CDATA_SECTION_NODE) {  
       $r .= qq'<li id="$node_id" class="tree-cdata"><code>&lt;[CDATA[</code><q lang="">' . htescape ($child->data) . '</q><code>]]&gt;</code></li>';  
     } elsif ($nt == $child->COMMENT_NODE) {  
       $r .= qq'<li id="$node_id" class="tree-comment"><code>&lt;!--</code><q lang="">' . htescape ($child->data) . '</q><code>--&gt;</code></li>';  
     } elsif ($nt == $child->DOCUMENT_NODE) {  
       $r .= qq'<li id="$node_id" class="tree-document">Document';  
       $r .= qq[<ul class="attributes">];  
       $r .= qq[<li>@{[scalar get_text ('manakaiIsHTML:'.($child->manakai_is_html?1:0))]}</li>];  
       $r .= qq[<li>@{[scalar get_text ('manakaiCompatMode:'.$child->manakai_compat_mode)]}</li>];  
       unless ($child->manakai_is_html) {  
         $r .= qq[<li>XML version = <code>@{[htescape ($child->xml_version)]}</code></li>];  
         if (defined $child->xml_encoding) {  
           $r .= qq[<li>XML encoding = <code>@{[htescape ($child->xml_encoding)]}</code></li>];  
         } else {  
           $r .= qq[<li>XML encoding = (null)</li>];  
         }  
         $r .= qq[<li>XML standalone = @{[$child->xml_standalone ? 'true' : 'false']}</li>];  
       }  
       $r .= qq[</ul>];  
       if ($child->has_child_nodes) {  
         $r .= '<ol class="children">';  
         unshift @node, @{$child->child_nodes}, '</ol></li>';  
       }  
     } elsif ($nt == $child->DOCUMENT_TYPE_NODE) {  
       $r .= qq'<li id="$node_id" class="tree-doctype"><code>&lt;!DOCTYPE&gt;</code><ul class="attributes">';  
       $r .= qq[<li class="tree-doctype-name">Name = <q>@{[htescape ($child->name)]}</q></li>];  
       $r .= qq[<li class="tree-doctype-publicid">Public identifier = <q>@{[htescape ($child->public_id)]}</q></li>];  
       $r .= qq[<li class="tree-doctype-systemid">System identifier = <q>@{[htescape ($child->system_id)]}</q></li>];  
       $r .= '</ul></li>';  
     } elsif ($nt == $child->PROCESSING_INSTRUCTION_NODE) {  
       $r .= qq'<li id="$node_id" class="tree-id"><code>&lt;?@{[htescape ($child->target)]}</code> <q>@{[htescape ($child->data)]}</q><code>?&gt;</code></li>';  
     } else {  
       $r .= qq'<li id="$node_id" class="tree-unknown">@{[$child->node_type]} @{[htescape ($child->node_name)]}</li>'; # error  
     }  
   }  
   
   $r .= '</ol>';  
   print STDOUT $r;  
 } # print_document_tree  
   
 sub print_structure_dump_section ($$) {  
   my ($doc, $el) = @_;  
   
   print STDOUT qq[  
 <div id="document-tree" class="section">  
 <h2>Document Tree</h2>  
 ];  
   push @nav, ['#document-tree' => 'Tree'];  
   
   print_document_tree ($el || $doc);  
   
   print STDOUT qq[</div>];  
 } # print_structure_dump_section  
   
 sub print_structure_error_section ($$) {  
   my ($doc, $el) = @_;  
   
   print STDOUT qq[<div id="document-errors" class="section">  
 <h2>Document Errors</h2>  
   
 <dl>];  
   push @nav, ['#document-errors' => 'Document Error'];  
   
   require Whatpm::ContentChecker;  
   my $onerror = sub {  
     my %opt = @_;  
     my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level}, $opt{node});  
     $type =~ tr/ /-/;  
     $type =~ s/\|/%7C/g;  
     $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];  
     print STDOUT qq[<dt class="$cls">] . get_node_link ($opt{node}) .  
         qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";  
   };  
   
   my $elements;  
   my $time1 = time;  
   if ($el) {  
     $elements = Whatpm::ContentChecker->check_element ($el, $onerror);  
   } else {  
     $elements = Whatpm::ContentChecker->check_document ($doc, $onerror);  
282    }    }
   $time{check} = time - $time1;  
283    
284    print STDOUT qq[</dl></div>];    print STDOUT qq[</tbody></table>];
285    
286    return $elements;    $out->end_section;
287  } # print_structure_error_section  } # print_http_header_section
288    
289  sub print_table_section ($) {  sub print_table_section ($$) {
290    my $tables = shift;    my ($input, $tables) = @_;
291        
292    push @nav, ['#tables' => 'Tables'];  #  push @nav, [qq[#$input->{id_prefix}tables] => 'Tables']
293    #      unless $input->{nested};
294    print STDOUT qq[    print STDOUT qq[
295  <div id="tables" class="section">  <div id="$input->{id_prefix}tables" class="section">
296  <h2>Tables</h2>  <h2>Tables</h2>
297    
298  <!--[if IE]><script type="text/javascript" src="../excanvas.js"></script><![endif]-->  <!--[if IE]><script type="text/javascript" src="../excanvas.js"></script><![endif]-->
# Line 426  sub print_table_section ($) { Line 305  sub print_table_section ($) {
305    require JSON;    require JSON;
306        
307    my $i = 0;    my $i = 0;
308    for my $table_el (@$tables) {    for my $table (@$tables) {
309      $i++;      $i++;
310      print STDOUT qq[<div class="section" id="table-$i"><h3>] .      print STDOUT qq[<div class="section" id="$input->{id_prefix}table-$i"><h3>] .
311          get_node_link ($table_el) . q[</h3>];          get_node_link ($input, $table->{element}) . q[</h3>];
312    
313      ## TODO: Make |ContentChecker| return |form_table| result      delete $table->{element};
314      ## so that this script don't have to run the algorithm twice.  
315      my $table = Whatpm::HTMLTable->form_table ($table_el);      for (@{$table->{column_group}}, @{$table->{column}}, $table->{caption},
316                 @{$table->{row}}) {
     for (@{$table->{column_group}}, @{$table->{column}}, $table->{caption}) {  
317        next unless $_;        next unless $_;
318        delete $_->{element};        delete $_->{element};
319      }      }
# Line 461  sub print_table_section ($) { Line 339  sub print_table_section ($) {
339                    
340      print STDOUT '</div><script type="text/javascript">tableToCanvas (';      print STDOUT '</div><script type="text/javascript">tableToCanvas (';
341      print STDOUT JSON::objToJson ($table);      print STDOUT JSON::objToJson ($table);
342      print STDOUT qq[, document.getElementById ('table-$i'));</script>];      print STDOUT qq[, document.getElementById ('$input->{id_prefix}table-$i')];
343        print STDOUT qq[, '$input->{id_prefix}');</script>];
344    }    }
345        
346    print STDOUT qq[</div>];    print STDOUT qq[</div>];
347  } # print_table_section  } # print_table_section
348    
349  sub print_id_section ($) {  sub print_listing_section ($$$) {
350    my $ids = shift;    my ($opt, $input, $ids) = @_;
351        
352    push @nav, ['#identifiers' => 'IDs'];  #  push @nav, ['#' . $input->{id_prefix} . $opt->{id} => $opt->{label}]
353    #      unless $input->{nested};
354    print STDOUT qq[    print STDOUT qq[
355  <div id="identifiers" class="section">  <div id="$input->{id_prefix}$opt->{id}" class="section">
356  <h2>Identifiers</h2>  <h2>$opt->{heading}</h2>
357    
358  <dl>  <dl>
359  ];  ];
360    for my $id (sort {$a cmp $b} keys %$ids) {    for my $id (sort {$a cmp $b} keys %$ids) {
361      print STDOUT qq[<dt><code>@{[htescape $id]}</code></dt>];      print STDOUT qq[<dt><code>@{[htescape $id]}</code></dt>];
362      for (@{$ids->{$id}}) {      for (@{$ids->{$id}}) {
363        print STDOUT qq[<dd>].get_node_link ($_).qq[</dd>];        print STDOUT qq[<dd>].get_node_link ($input, $_).qq[</dd>];
364      }      }
365    }    }
366    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
367  } # print_id_section  } # print_listing_section
368    
369  sub print_term_section ($) {  
370    my $terms = shift;  sub print_rdf_section ($$$) {
371      my ($input, $rdfs) = @_;
372        
373    push @nav, ['#terms' => 'Terms'];  #  push @nav, ['#' . $input->{id_prefix} . 'rdf' => 'RDF']
374    #      unless $input->{nested};
375    print STDOUT qq[    print STDOUT qq[
376  <div id="terms" class="section">  <div id="$input->{id_prefix}rdf" class="section">
377  <h2>Terms</h2>  <h2>RDF Triples</h2>
378    
379  <dl>  <dl>];
380  ];    my $i = 0;
381    for my $term (sort {$a cmp $b} keys %$terms) {    for my $rdf (@$rdfs) {
382      print STDOUT qq[<dt>@{[htescape $term]}</dt>];      print STDOUT qq[<dt id="$input->{id_prefix}rdf-@{[$i++]}">];
383      for (@{$terms->{$term}}) {      print STDOUT get_node_link ($input, $rdf->[0]);
384        print STDOUT qq[<dd>].get_node_link ($_).qq[</dd>];      print STDOUT qq[<dd><dl>];
385        for my $triple (@{$rdf->[1]}) {
386          print STDOUT '<dt>' . get_node_link ($input, $triple->[0]) . '<dd>';
387          print STDOUT get_rdf_resource_html ($triple->[1]);
388          print STDOUT ' ';
389          print STDOUT get_rdf_resource_html ($triple->[2]);
390          print STDOUT ' ';
391          print STDOUT get_rdf_resource_html ($triple->[3]);
392      }      }
393        print STDOUT qq[</dl>];
394    }    }
395    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
396  } # print_term_section  } # print_rdf_section
397    
398  sub print_class_section ($) {  sub get_rdf_resource_html ($) {
399    my $classes = shift;    my $resource = shift;
400        if (defined $resource->{uri}) {
401    push @nav, ['#classes' => 'Classes'];      my $euri = htescape ($resource->{uri});
402    print STDOUT qq[      return '<code class=uri>&lt;<a href="' . $euri . '">' . $euri .
403  <div id="classes" class="section">          '</a>></code>';
404  <h2>Classes</h2>    } elsif (defined $resource->{bnodeid}) {
405        return htescape ('_:' . $resource->{bnodeid});
406  <dl>    } elsif ($resource->{nodes}) {
407  ];      return '(rdf:XMLLiteral)';
408    for my $class (sort {$a cmp $b} keys %$classes) {    } elsif (defined $resource->{value}) {
409      print STDOUT qq[<dt><code>@{[htescape $class]}</code></dt>];      my $elang = htescape (defined $resource->{language}
410      for (@{$classes->{$class}}) {                                ? $resource->{language} : '');
411        print STDOUT qq[<dd>].get_node_link ($_).qq[</dd>];      my $r = qq[<q lang="$elang">] . htescape ($resource->{value}) . '</q>';
412        if (defined $resource->{datatype}) {
413          my $euri = htescape ($resource->{datatype});
414          $r .= '^^<code class=uri>&lt;<a href="' . $euri . '">' . $euri .
415              '</a>></code>';
416        } elsif (length $resource->{language}) {
417          $r .= '@' . htescape ($resource->{language});
418      }      }
419        return $r;
420      } else {
421        return '??';
422    }    }
423    print STDOUT qq[</dl></div>];  } # get_rdf_resource_html
 } # print_class_section  
424    
425  sub print_result_unknown_type_section ($) {  sub print_result_section ($) {
426    my $input = shift;    my $result = shift;
427    
428    print STDOUT qq[    $out->start_section (id => 'result-summary',
429  <div id="result-summary" class="section">                         title => 'Result');
430  <p><em>Media type <code class="MIME" lang="en">@{[htescape $input->{media_type}]}</code> is not supported!</em></p>  
431  </div>    if ($result->{unsupported} and $result->{conforming_max}) {  
432  ];      print STDOUT qq[<p class=uncertain id=result-para>The conformance
433    push @nav, ['#result-summary' => 'Result'];          checker cannot decide whether the document is conforming or
434  } # print_result_unknown_type_section          not, since the document contains one or more unsupported
435            features.  The document might or might not be conforming.</p>];
436      } elsif ($result->{conforming_min}) {
437        print STDOUT qq[<p class=PASS id=result-para>No conformance-error is
438            found in this document.</p>];
439      } elsif ($result->{conforming_max}) {
440        print STDOUT qq[<p class=SEE-RESULT id=result-para>This document
441            is <strong>likely <em>non</em>-conforming</strong>, but in rare case
442            it might be conforming.</p>];
443      } else {
444        print STDOUT qq[<p class=FAIL id=result-para>This document is
445            <strong><em>non</em>-conforming</strong>.</p>];
446      }
447    
448  sub print_result_input_error_section ($) {    print STDOUT qq[<table>
449    my $input = shift;  <colgroup><col><colgroup><col><col><col><colgroup><col>
450    print STDOUT qq[<div class="section" id="result-summary">  <thead>
451  <p><em><strong>Input Error</strong>: @{[htescape ($input->{error_status_text})]}</em></p>  <tr><th scope=col></th>
452  </div>];  <th scope=col><a href="../error-description#level-m"><em class=rfc2119>MUST</em>‐level
453    push @nav, ['#result-summary' => 'Result'];  Errors</a></th>
454  } # print_Result_input_error_section  <th scope=col><a href="../error-description#level-s"><em class=rfc2119>SHOULD</em>‐level
455    Errors</a></th>
456  sub get_node_path ($) {  <th scope=col><a href="../error-description#level-w">Warnings</a></th>
457    my $node = shift;  <th scope=col>Score</th></tr></thead><tbody>];
458    my @r;  
459    while (defined $node) {    my $must_error = 0;
460      my $rs;    my $should_error = 0;
461      if ($node->node_type == 1) {    my $warning = 0;
462        $rs = $node->manakai_local_name;    my $score_min = 0;
463        $node = $node->parent_node;    my $score_max = 0;
464      } elsif ($node->node_type == 2) {    my $score_base = 20;
465        $rs = '@' . $node->manakai_local_name;    my $score_unit = $score_base / 100;
466        $node = $node->owner_element;    for (
467      } elsif ($node->node_type == 3) {      [Transfer => 'transfer', ''],
468        $rs = '"' . $node->data . '"';      [Character => 'char', ''],
469        $node = $node->parent_node;      [Syntax => 'syntax', '#parse-errors'],
470      } elsif ($node->node_type == 9) {      [Structure => 'structure', '#document-errors'],
471        @r = ('') unless @r;    ) {
472        $rs = '';      $must_error += ($result->{$_->[1]}->{must} += 0);
473        $node = $node->parent_node;      $should_error += ($result->{$_->[1]}->{should} += 0);
474        $warning += ($result->{$_->[1]}->{warning} += 0);
475        $score_min += (($result->{$_->[1]}->{score_min} *= $score_unit) += $score_base);
476        $score_max += (($result->{$_->[1]}->{score_max} *= $score_unit) += $score_base);
477    
478        my $uncertain = $result->{$_->[1]}->{unsupported} ? '?' : '';
479        my $label = $_->[0];
480        if ($result->{$_->[1]}->{must} or
481            $result->{$_->[1]}->{should} or
482            $result->{$_->[1]}->{warning} or
483            $result->{$_->[1]}->{unsupported}) {
484          $label = qq[<a href="$_->[2]">$label</a>];
485        }
486    
487        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>];
488        if ($uncertain) {
489          print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : $result->{$_->[1]}->{should} ? 'SEE-RESULT' : '']}">&#x2212;&#x221E;..$result->{$_->[1]}->{score_max}];
490        } elsif ($result->{$_->[1]}->{score_min} != $result->{$_->[1]}->{score_max}) {
491          print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : 'SEE-RESULT']}">$result->{$_->[1]}->{score_min}..$result->{$_->[1]}->{score_max}];
492      } else {      } else {
493        $rs = '#' . $node->node_type;        print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : '']}">$result->{$_->[1]}->{score_min}];
       $node = $node->parent_node;  
494      }      }
495      unshift @r, $rs;      print qq[ / 20];
496    }    }
   return join '/', @r;  
 } # get_node_path  
497    
498  sub get_node_link ($) {    $score_max += $score_base;
499    return qq[<a href="#node-@{[refaddr $_[0]]}">] .  
500        htescape (get_node_path ($_[0])) . qq[</a>];    print STDOUT qq[
501  } # get_node_link  <tr class=uncertain><th scope=row>Semantics</th><td>0?</td><td>0?</td><td>0?</td><td>&#x2212;&#x221E;..$score_base / 20
502    </tbody>
503    <tfoot><tr class=uncertain><th scope=row>Total</th>
504    <td class="@{[$must_error ? 'FAIL' : '']}">$must_error?</td>
505    <td class="@{[$should_error ? 'SEE-RESULT' : '']}">$should_error?</td>
506    <td>$warning?</td>
507    <td class="@{[$must_error ? 'FAIL' : $should_error ? 'SEE-RESULT' : '']}"><strong>&#x2212;&#x221E;..$score_max</strong> / 100
508    </table>
509    
510    <p><strong>Important</strong>: This conformance checking service
511    is <em>under development</em>.  The result above might be <em>wrong</em>.</p>];
512      $out->end_section;
513    } # print_result_section
514    
515    sub print_result_input_error_section ($) {
516      my $input = shift;
517      $out->start_section (id => 'result-summary', title => 'Result');
518      print STDOUT qq[
519    <p><em><strong>Input Error</strong>: @{[htescape ($input->{error_status_text})]}</em></p>];
520      $out->end_section;
521    } # print_result_input_error_section
522    
523  {  {
524    my $Msg = {};    my $Msg = {};
525    
526  sub load_text_catalog ($) {  sub load_text_catalog ($) {
527    #  my $self = shift;
528    my $lang = shift; # MUST be a canonical lang name    my $lang = shift; # MUST be a canonical lang name
529    open my $file, '<', "cc-msg.$lang.txt" or die "$0: cc-msg.$lang.txt: $!";    open my $file, '<:utf8', "cc-msg.$lang.txt"
530          or die "$0: cc-msg.$lang.txt: $!";
531    while (<$file>) {    while (<$file>) {
532      if (s/^([^;]+);([^;]*);//) {      if (s/^([^;]+);([^;]*);//) {
533        my ($type, $cls, $msg) = ($1, $2, $_);        my ($type, $cls, $msg) = ($1, $2, $_);
# Line 590  sub load_text_catalog ($) { Line 537  sub load_text_catalog ($) {
537    }    }
538  } # load_text_catalog  } # load_text_catalog
539    
540  sub get_text ($) {  sub get_text ($;$$) {
541    #  my $self = shift;
542    my ($type, $level, $node) = @_;    my ($type, $level, $node) = @_;
543    $type = $level . ':' . $type if defined $level;    $type = $level . ':' . $type if defined $level;
544      $level = 'm' unless defined $level;
545    my @arg;    my @arg;
546    {    {
547      if (defined $Msg->{$type}) {      if (defined $Msg->{$type}) {
548        my $msg = $Msg->{$type}->[1];        my $msg = $Msg->{$type}->[1];
549        $msg =~ s{<var>\$([0-9]+)</var>}{        $msg =~ s{<var>\$([0-9]+)</var>}{
550          defined $arg[$1] ? htescape ($arg[$1]) : '(undef)';          defined $arg[$1] ? ($arg[$1]) : '(undef)';
551        }ge;        }ge;                 ##BUG: ^ must be escaped
552        $msg =~ s{<var>{\@([A-Za-z0-9:_.-]+)}</var>}{        $msg =~ s{<var>{\@([A-Za-z0-9:_.-]+)}</var>}{
553          UNIVERSAL::can ($node, 'get_attribute_ns')          UNIVERSAL::can ($node, 'get_attribute_ns')
554              ? htescape ($node->get_attribute_ns (undef, $1)) : ''              ?  ($node->get_attribute_ns (undef, $1)) : ''
555        }ge;        }ge; ## BUG: ^ must be escaped
556        $msg =~ s{<var>{\@}</var>}{        $msg =~ s{<var>{\@}</var>}{        ## BUG: v must be escaped
557          UNIVERSAL::can ($node, 'value') ? htescape ($node->value) : ''          UNIVERSAL::can ($node, 'value') ? ($node->value) : ''
558        }ge;        }ge;
559        $msg =~ s{<var>{local-name}</var>}{        $msg =~ s{<var>{local-name}</var>}{
560          UNIVERSAL::can ($node, 'manakai_local_name')          UNIVERSAL::can ($node, 'manakai_local_name')
561            ? htescape ($node->manakai_local_name) : ''            ? ($node->manakai_local_name) : ''
562        }ge;        }ge;  ## BUG: ^ must be escaped
563        $msg =~ s{<var>{element-local-name}</var>}{        $msg =~ s{<var>{element-local-name}</var>}{
564          (UNIVERSAL::can ($node, 'owner_element') and          (UNIVERSAL::can ($node, 'owner_element') and
565           $node->owner_element)           $node->owner_element)
566            ? htescape ($node->owner_element->manakai_local_name)            ?  ($node->owner_element->manakai_local_name)
567            : ''            : '' ## BUG: ^ must be escaped
568        }ge;        }ge;
569        return ($type, $Msg->{$type}->[0], $msg);        return ($type, 'level-' . $level . ' ' . $Msg->{$type}->[0], $msg);
570      } elsif ($type =~ s/:([^:]*)$//) {      } elsif ($type =~ s/:([^:]*)$//) {
571        unshift @arg, $1;        unshift @arg, $1;
572        redo;        redo;
573      }      }
574    }    }
575    return ($type, '', htescape ($_[0]));    return ($type, 'level-'.$level, ($_[0]));
576                                     ## BUG: ^ must be escaped
577  } # get_text  } # get_text
578    
579  }  }
# Line 632  sub get_input_document ($$) { Line 582  sub get_input_document ($$) {
582    my ($http, $dom) = @_;    my ($http, $dom) = @_;
583    
584    my $request_uri = $http->get_parameter ('uri');    my $request_uri = $http->get_parameter ('uri');
585    my $r = {};    my $r = WebHACC::Input->new;
586    if (defined $request_uri and length $request_uri) {    if (defined $request_uri and length $request_uri) {
587      my $uri = $dom->create_uri_reference ($request_uri);      my $uri = $dom->create_uri_reference ($request_uri);
588      unless ({      unless ({
# Line 679  EOH Line 629  EOH
629      $ua->protocols_allowed ([qw/http/]);      $ua->protocols_allowed ([qw/http/]);
630      $ua->max_size (1000_000);      $ua->max_size (1000_000);
631      my $req = HTTP::Request->new (GET => $request_uri);      my $req = HTTP::Request->new (GET => $request_uri);
632        $req->header ('Accept-Encoding' => 'identity, *; q=0');
633      my $res = $ua->request ($req);      my $res = $ua->request ($req);
634      ## TODO: 401 sets |is_success| true.      ## TODO: 401 sets |is_success| true.
635      if ($res->is_success or $http->get_parameter ('error-page')) {      if ($res->is_success or $http->get_parameter ('error-page')) {
# Line 688  EOH Line 639  EOH
639    
640        ## TODO: More strict parsing...        ## TODO: More strict parsing...
641        my $ct = $res->header ('Content-Type');        my $ct = $res->header ('Content-Type');
642        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) {  
643          $r->{charset} = lc $1;          $r->{charset} = lc $1;
644          $r->{charset} =~ tr/\\//d;          $r->{charset} =~ tr/\\//d;
645            $r->{official_charset} = $r->{charset};
646        }        }
647    
648        my $input_charset = $http->get_parameter ('charset');        my $input_charset = $http->get_parameter ('charset');
# Line 701  EOH Line 650  EOH
650          $r->{charset_overridden}          $r->{charset_overridden}
651              = (not defined $r->{charset} or $r->{charset} ne $input_charset);              = (not defined $r->{charset} or $r->{charset} ne $input_charset);
652          $r->{charset} = $input_charset;          $r->{charset} = $input_charset;
653        }        }
654    
655          ## TODO: Support for HTTP Content-Encoding
656    
657        $r->{s} = ''.$res->content;        $r->{s} = ''.$res->content;
658    
659          require Whatpm::ContentType;
660          ($r->{official_type}, $r->{media_type})
661              = Whatpm::ContentType->get_sniffed_type
662                  (get_file_head => sub {
663                     return substr $r->{s}, 0, shift;
664                   },
665                   http_content_type_byte => $ct,
666                   has_http_content_encoding =>
667                       defined $res->header ('Content-Encoding'),
668                   supported_image_types => {});
669      } else {      } else {
670        $r->{uri} = $res->request->uri;        $r->{uri} = $res->request->uri;
671        $r->{request_uri} = $request_uri;        $r->{request_uri} = $request_uri;
# Line 724  EOH Line 686  EOH
686      $r->{charset} = ''.$http->get_parameter ('_charset_');      $r->{charset} = ''.$http->get_parameter ('_charset_');
687      $r->{charset} =~ s/\s+//g;      $r->{charset} =~ s/\s+//g;
688      $r->{charset} = 'utf-8' if $r->{charset} eq '';      $r->{charset} = 'utf-8' if $r->{charset} eq '';
689        $r->{official_charset} = $r->{charset};
690      $r->{header_field} = [];      $r->{header_field} = [];
691    
692        require Whatpm::ContentType;
693        ($r->{official_type}, $r->{media_type})
694            = Whatpm::ContentType->get_sniffed_type
695                (get_file_head => sub {
696                   return substr $r->{s}, 0, shift;
697                 },
698                 http_content_type_byte => undef,
699                 has_http_content_encoding => 0,
700                 supported_image_types => {});
701    }    }
702    
703    my $input_format = $http->get_parameter ('i');    my $input_format = $http->get_parameter ('i');
# Line 741  EOH Line 714  EOH
714    if ($r->{media_type} eq 'text/xml') {    if ($r->{media_type} eq 'text/xml') {
715      unless (defined $r->{charset}) {      unless (defined $r->{charset}) {
716        $r->{charset} = 'us-ascii';        $r->{charset} = 'us-ascii';
717          $r->{official_charset} = $r->{charset};
718      } elsif ($r->{charset_overridden} and $r->{charset} eq 'us-ascii') {      } elsif ($r->{charset_overridden} and $r->{charset} eq 'us-ascii') {
719        $r->{charset_overridden} = 0;        $r->{charset_overridden} = 0;
720      }      }
# Line 752  EOH Line 726  EOH
726      return $r;      return $r;
727    }    }
728    
729      $r->{inner_html_element} = $http->get_parameter ('e');
730    
731    return $r;    return $r;
732  } # get_input_document  } # get_input_document
733    
# Line 784  Wakaba <w@suika.fam.cx>. Line 760  Wakaba <w@suika.fam.cx>.
760    
761  =head1 LICENSE  =head1 LICENSE
762    
763  Copyright 2007 Wakaba <w@suika.fam.cx>  Copyright 2007-2008 Wakaba <w@suika.fam.cx>
764    
765  This library is free software; you can redistribute it  This library is free software; you can redistribute it
766  and/or modify it under the same terms as Perl itself.  and/or modify it under the same terms as Perl itself.
Legend:
Removed from v.1.18  
changed lines
  Added in v.1.53
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24