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

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

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

revision 1.3 by wakaba, Wed Jun 27 13:30:15 2007 UTC revision 1.24 by wakaba, Sun Nov 11 06:57:16 2007 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/manakai/lib             /home/wakaba/work/manakai2/lib];
            /home/wakaba/public_html/-temp/wiki/lib];  
7  use CGI::Carp qw[fatalsToBrowser];  use CGI::Carp qw[fatalsToBrowser];
8  use Scalar::Util qw[refaddr];  use Scalar::Util qw[refaddr];
9    use Time::HiRes qw/time/;
 use SuikaWiki::Input::HTTP; ## TODO: Use some better CGI module  
10    
11  sub htescape ($) {  sub htescape ($) {
12    my $s = $_[0];    my $s = $_[0];
# Line 15  sub htescape ($) { Line 14  sub htescape ($) {
14    $s =~ s/</&lt;/g;    $s =~ s/</&lt;/g;
15    $s =~ s/>/&gt;/g;    $s =~ s/>/&gt;/g;
16    $s =~ s/"/&quot;/g;    $s =~ s/"/&quot;/g;
17    $s =~ s!([\x00-\x09\x0B-\x1F\x7F-\x80])!sprintf '<var>U+%04X</var>', ord $1!ge;    $s =~ s{([\x00-\x09\x0B-\x1F\x7F-\xA0\x{FEFF}\x{FFFC}-\x{FFFF}])}{
18        sprintf '<var>U+%04X</var>', ord $1;
19      }ge;
20    return $s;    return $s;
21  } # htescape  } # htescape
22    
23  my $http = SuikaWiki::Input::HTTP->new;    use Message::CGI::HTTP;
24      my $http = Message::CGI::HTTP->new;
 ## TODO: _charset_  
   
   my $input_format = $http->parameter ('i') || 'text/html';  
   my $inner_html_element = $http->parameter ('e');  
   my $input_uri = 'thismessage:/';  
25    
26    my $s = $http->parameter ('s');    if ($http->get_meta_variable ('PATH_INFO') ne '/') {
27    if (length $s > 1000_000) {      print STDOUT "Status: 404 Not Found\nContent-Type: text/plain; charset=us-ascii\n\n400";
     print STDOUT "Status: 400 Document Too Long\nContent-Type: text/plain; charset=us-ascii\n\nToo long";  
28      exit;      exit;
29    }    }
30    
31      binmode STDOUT, ':utf8';
32      $| = 1;
33    
34      require Message::DOM::DOMImplementation;
35      my $dom = Message::DOM::DOMImplementation->new;
36    
37      load_text_catalog ('en'); ## TODO: conneg
38    
39    my @nav;    my @nav;
40    print STDOUT qq[Content-Type: text/html; charset=utf-8    print STDOUT qq[Content-Type: text/html; charset=utf-8
41    
# Line 43  my $http = SuikaWiki::Input::HTTP->new; Line 46  my $http = SuikaWiki::Input::HTTP->new;
46  <link rel="stylesheet" href="../cc-style.css" type="text/css">  <link rel="stylesheet" href="../cc-style.css" type="text/css">
47  </head>  </head>
48  <body>  <body>
49  <h1>Web Document Conformance Checker (<em>beta</em>)</h1>  <h1><a href="../cc-interface">Web Document Conformance Checker</a>
50    (<em>beta</em>)</h1>
51    ];
52    
53      $| = 0;
54      my $input = get_input_document ($http, $dom);
55      my $inner_html_element = $http->get_parameter ('e');
56      my $char_length = 0;
57      my %time;
58    
59  <div id="document-info" section="section">    print qq[
60    <div id="document-info" class="section">
61  <dl>  <dl>
62    <dt>Request URI</dt>
63        <dd><code class="URI" lang="">&lt;<a href="@{[htescape $input->{request_uri}]}">@{[htescape $input->{request_uri}]}</a>&gt;</code></dd>
64  <dt>Document URI</dt>  <dt>Document URI</dt>
65      <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}]}">@{[htescape $input->{uri}]}</a>&gt;</code></dd>
 <dt>Internet Media Type</dt>  
     <dd><code class="MIME" lang="en">@{[htescape $input_format]}</code></dd>  
66  ]; # no </dl> yet  ]; # no </dl> yet
67    push @nav, ['#document-info' => 'Information'];    push @nav, ['#document-info' => 'Information'];
68    
69    require Message::DOM::DOMImplementation;  if (defined $input->{s}) {
70    my $dom = Message::DOM::DOMImplementation->____new;    $char_length = length $input->{s};
   my $doc;  
   my $el;  
71    
72    if ($input_format eq 'text/html') {    print STDOUT qq[
73      require Encode;  <dt>Base URI</dt>
74      require Whatpm::HTML;      <dd><code class="URI" lang="">&lt;<a href="@{[htescape $input->{base_uri}]}">@{[htescape $input->{base_uri}]}</a>&gt;</code></dd>
75        <dt>Internet Media Type</dt>
76      $s = Encode::decode ('utf-8', $s);      <dd><code class="MIME" lang="en">@{[htescape $input->{media_type}]}</code>
77        @{[$input->{media_type_overridden} ? '<em>(overridden)</em>' : '']}</dd>
     print STDOUT qq[  
78  <dt>Character Encoding</dt>  <dt>Character Encoding</dt>
79      <dd>(none)</dd>      <dd>@{[defined $input->{charset} ? '<code class="charset" lang="en">'.htescape ($input->{charset}).'</code>' : '(none)']}
80        @{[$input->{charset_overridden} ? '<em>(overridden)</em>' : '']}</dd>
81    <dt>Length</dt>
82        <dd>$char_length byte@{[$char_length == 1 ? '' : 's']}</dd>
83  </dl>  </dl>
84  </div>  </div>
85    ];
86    
87  <div id="source-string" class="section">    my $result = {conforming_min => 1, conforming_max => 1};
88  <h2>Document Source</h2>    print_http_header_section ($input, $result);
89    
90      my $doc;
91      my $el;
92      my $manifest;
93    
94      if ($input->{media_type} eq 'text/html') {
95        ($doc, $el) = print_syntax_error_html_section ($input, $result);
96        print_source_string_section (\($input->{s}), $input->{charset});
97      } elsif ({
98                'text/xml' => 1,
99                'application/atom+xml' => 1,
100                'application/rss+xml' => 1,
101                'application/svg+xml' => 1,
102                'application/xhtml+xml' => 1,
103                'application/xml' => 1,
104               }->{$input->{media_type}}) {
105        ($doc, $el) = print_syntax_error_xml_section ($input, $result);
106        print_source_string_section (\($input->{s}), $doc->input_encoding);
107      } elsif ($input->{media_type} eq 'text/cache-manifest') {
108    ## TODO: MUST be text/cache-manifest
109        $manifest = print_syntax_error_manifest_section ($input, $result);
110        print_source_string_section (\($input->{s}), 'utf-8');
111      } else {
112        ## TODO: Change HTTP status code??
113        print_result_unknown_type_section ($input, $result);
114      }
115    
116      if (defined $doc or defined $el) {
117        print_structure_dump_dom_section ($doc, $el);
118        my $elements = print_structure_error_dom_section ($doc, $el, $result);
119        print_table_section ($elements->{table}) if @{$elements->{table}};
120        print_id_section ($elements->{id}) if keys %{$elements->{id}};
121        print_term_section ($elements->{term}) if keys %{$elements->{term}};
122        print_class_section ($elements->{class}) if keys %{$elements->{class}};
123      } elsif (defined $manifest) {
124        print_structure_dump_manifest_section ($manifest);
125        print_structure_error_manifest_section ($manifest, $result);
126      }
127    
128      print_result_section ($result);
129    } else {
130      print STDOUT qq[</dl></div>];
131      print_result_input_error_section ($input);
132    }
133    
134      print STDOUT qq[
135    <ul class="navigation" id="nav-items">
136  ];  ];
137      push @nav, ['#source-string' => 'Source'];    for (@nav) {
138      print_source_string (\$s);      print STDOUT qq[<li><a href="$_->[0]">$_->[1]</a></li>];
139      print STDOUT qq[    }
140  </div>    print STDOUT qq[
141    </ul>
142    </body>
143    </html>
144    ];
145    
146      for (qw/decode parse parse_html parse_xml parse_manifest
147              check check_manifest/) {
148        next unless defined $time{$_};
149        open my $file, '>>', ".cc-$_.txt" or die ".cc-$_.txt: $!";
150        print $file $char_length, "\t", $time{$_}, "\n";
151      }
152    
153    exit;
154    
155    sub add_error ($$$) {
156      my ($layer, $err, $result) = @_;
157      if (defined $err->{level}) {
158        if ($err->{level} eq 's') {
159          $result->{$layer}->{should}++;
160          $result->{$layer}->{score_min} -= 2;
161          $result->{conforming_min} = 0;
162        } elsif ($err->{level} eq 'w' or $err->{level} eq 'g') {
163          $result->{$layer}->{warning}++;
164        } elsif ($err->{level} eq 'unsupported') {
165          $result->{$layer}->{unsupported}++;
166          $result->{unsupported} = 1;
167        } else {
168          $result->{$layer}->{must}++;
169          $result->{$layer}->{score_max} -= 2;
170          $result->{$layer}->{score_min} -= 2;
171          $result->{conforming_min} = 0;
172          $result->{conforming_max} = 0;
173        }
174      } else {
175        $result->{$layer}->{must}++;
176        $result->{$layer}->{score_max} -= 2;
177        $result->{$layer}->{score_min} -= 2;
178        $result->{conforming_min} = 0;
179        $result->{conforming_max} = 0;
180      }
181    } # add_error
182    
183    sub print_http_header_section ($$) {
184      my ($input, $result) = @_;
185      return unless defined $input->{header_status_code} or
186          defined $input->{header_status_text} or
187          @{$input->{header_field}};
188      
189      push @nav, ['#source-header' => 'HTTP Header'];
190      print STDOUT qq[<div id="source-header" class="section">
191    <h2>HTTP Header</h2>
192    
193    <p><strong>Note</strong>: Due to the limitation of the
194    network library in use, the content of this section might
195    not be the real header.</p>
196    
197    <table><tbody>
198    ];
199    
200      if (defined $input->{header_status_code}) {
201        print STDOUT qq[<tr><th scope="row">Status code</th>];
202        print STDOUT qq[<td><code>@{[htescape ($input->{header_status_code})]}</code></td></tr>];
203      }
204      if (defined $input->{header_status_text}) {
205        print STDOUT qq[<tr><th scope="row">Status text</th>];
206        print STDOUT qq[<td><code>@{[htescape ($input->{header_status_text})]}</code></td></tr>];
207      }
208      
209      for (@{$input->{header_field}}) {
210        print STDOUT qq[<tr><th scope="row"><code>@{[htescape ($_->[0])]}</code></th>];
211        print STDOUT qq[<td><code>@{[htescape ($_->[1])]}</code></td></tr>];
212      }
213    
214      print STDOUT qq[</tbody></table></div>];
215    } # print_http_header_section
216    
217    sub print_syntax_error_html_section ($$) {
218      my ($input, $result) = @_;
219      
220      require Encode;
221      require Whatpm::HTML;
222      
223      print STDOUT qq[
224  <div id="parse-errors" class="section">  <div id="parse-errors" class="section">
225  <h2>Parse Errors</h2>  <h2>Parse Errors</h2>
226    
227  <ul>  <dl>];
 ];  
228    push @nav, ['#parse-errors' => 'Parse Error'];    push @nav, ['#parse-errors' => 'Parse Error'];
229    
230    my $onerror = sub {    my $onerror = sub {
231      my (%opt) = @_;      my (%opt) = @_;
232        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level});
233      if ($opt{column} > 0) {      if ($opt{column} > 0) {
234        print STDOUT qq[<li><a href="#line-$opt{line}">Line $opt{line}</a> column $opt{column}: ];        print STDOUT qq[<dt class="$cls"><a href="#line-$opt{line}">Line $opt{line}</a> column $opt{column}</dt>\n];
235      } else {      } else {
236        $opt{line}--;        $opt{line} = $opt{line} - 1 || 1;
237        print STDOUT qq[<li><a href="#line-$opt{line}">Line $opt{line}</a>: ];        print STDOUT qq[<dt class="$cls"><a href="#line-$opt{line}">Line $opt{line}</a></dt>\n];
238      }      }
239      print STDOUT qq[@{[htescape $opt{type}]}</li>\n];      $type =~ tr/ /-/;
240        $type =~ s/\|/%7C/g;
241        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
242        print STDOUT qq[<dd class="$cls">], get_error_level_label (\%opt);
243        print STDOUT qq[$msg</dd>\n];
244    
245        add_error ('syntax', \%opt => $result);
246    };    };
247    
248    $doc = $dom->create_document;    my $doc = $dom->create_document;
249      my $el;
250    if (defined $inner_html_element and length $inner_html_element) {    if (defined $inner_html_element and length $inner_html_element) {
251        $input->{charset} ||= 'ISO-8859-1'; ## TODO: for now.
252        my $time1 = time;
253        my $t = Encode::decode ($input->{charset}, $input->{s});
254        $time{decode} = time - $time1;
255        
256      $el = $doc->create_element_ns      $el = $doc->create_element_ns
257          ('http://www.w3.org/1999/xhtml', [undef, $inner_html_element]);          ('http://www.w3.org/1999/xhtml', [undef, $inner_html_element]);
258      Whatpm::HTML->set_inner_html ($el, $s, $onerror);      $time1 = time;
259        Whatpm::HTML->set_inner_html ($el, $t, $onerror);
260        $time{parse} = time - $time1;
261    } else {    } else {
262      Whatpm::HTML->parse_string ($s => $doc, $onerror);      my $time1 = time;
263        Whatpm::HTML->parse_byte_string
264            ($input->{charset}, $input->{s} => $doc, $onerror);
265        $time{parse_html} = time - $time1;
266    }    }
267      
268      print STDOUT qq[</dl></div>];
269    
270    print STDOUT qq[    return ($doc, $el);
271  </ul>  } # print_syntax_error_html_section
 </div>  
 ];  
   } elsif ($input_format eq 'application/xhtml+xml') {  
     require Message::DOM::XMLParserTemp;  
     require Encode;  
       
     my $t = Encode::decode ('utf-8', $s);  
   
     print STDOUT qq[  
 <dt>Character Encoding</dt>  
     <dd>(none)</dd>  
 </dl>  
 </div>  
   
 <div id="source-string" class="section">  
 <h2>Document Source</h2>  
 ];  
     push @nav, ['#source-string' => 'Source'];  
     print_source_string (\$t);  
     print STDOUT qq[  
 </div>  
272    
273    sub print_syntax_error_xml_section ($$) {
274      my ($input, $result) = @_;
275      
276      require Message::DOM::XMLParserTemp;
277      
278      print STDOUT qq[
279  <div id="parse-errors" class="section">  <div id="parse-errors" class="section">
280  <h2>Parse Errors</h2>  <h2>Parse Errors</h2>
281    
282  <ul>  <dl>];
 ];  
283    push @nav, ['#parse-errors' => 'Parse Error'];    push @nav, ['#parse-errors' => 'Parse Error'];
284    
285    my $onerror = sub {    my $onerror = sub {
286      my $err = shift;      my $err = shift;
287      my $line = $err->location->line_number;      my $line = $err->location->line_number;
288      print STDOUT qq[<li><a href="#line-$line">Line $line</a> column ];      print STDOUT qq[<dt><a href="#line-$line">Line $line</a> column ];
289      print STDOUT $err->location->column_number, ": ";      print STDOUT $err->location->column_number, "</dt><dd>";
290      print STDOUT htescape $err->text, "</li>\n";      print STDOUT htescape $err->text, "</dd>\n";
291    
292        add_error ('syntax', {type => $err->text,
293                    level => [
294                              $err->SEVERITY_FATAL_ERROR => 'm',
295                              $err->SEVERITY_ERROR => 'm',
296                              $err->SEVERITY_WARNING => 's',
297                             ]->[$err->severity]} => $result);
298    
299      return 1;      return 1;
300    };    };
301    
302    open my $fh, '<', \$s;    my $time1 = time;
303    $doc = Message::DOM::XMLParserTemp->parse_byte_stream    open my $fh, '<', \($input->{s});
304        ($fh => $dom, $onerror, charset => 'utf-8');    my $doc = Message::DOM::XMLParserTemp->parse_byte_stream
305          ($fh => $dom, $onerror, charset => $input->{charset});
306      print STDOUT qq[    $time{parse_xml} = time - $time1;
 </ul>  
 </div>  
 ];  
   } else {  
     print STDOUT qq[  
 </dl>  
307    
308  <div id="result-summary" class="section">    print STDOUT qq[</dl></div>];
 <p><em>Media type <code class="MIME" lang="en">@{[htescape $input_format]}</code> is not supported!</em></p>  
 </div>  
 ];  
     push @nav, ['#result-summary' => 'Result'];  
   }  
309    
310      return ($doc, undef);
311    } # print_syntax_error_xml_section
312    
313    if (defined $doc or defined $el) {  sub print_syntax_error_manifest_section ($$) {
314      print STDOUT qq[    my ($input, $result) = @_;
 <div id="document-tree" class="section">  
 <h2>Document Tree</h2>  
 ];  
     push @nav, ['#document-tree' => 'Tree'];  
315    
316      print_document_tree ($el || $doc);    require Whatpm::CacheManifest;
317    
318      print STDOUT qq[    print STDOUT qq[
319  </div>  <div id="parse-errors" class="section">
320    <h2>Parse Errors</h2>
321    
322  <div id="document-errors" class="section">  <dl>];
323  <h2>Document Errors</h2>    push @nav, ['#parse-errors' => 'Parse Error'];
324    
325  <ul>    my $onerror = sub {
326  ];      my (%opt) = @_;
327      push @nav, ['#document-errors' => 'Document Error'];      my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level});
328        print STDOUT qq[<dt class="$cls">], get_error_label (\%opt), qq[</dt>];
329        $type =~ tr/ /-/;
330        $type =~ s/\|/%7C/g;
331        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
332        print STDOUT qq[<dd class="$cls">], get_error_level_label (\%opt);
333        print STDOUT qq[$msg</dd>\n];
334    
335      require Whatpm::ContentChecker;      add_error ('syntax', \%opt => $result);
336      my $onerror = sub {    };
       my %opt = @_;  
       print STDOUT qq[<li><a href="#node-@{[refaddr $opt{node}]}">],  
           htescape get_node_path ($opt{node}),  
           "</a>: ", htescape $opt{type}, "</li>\n";  
     };  
337    
338      if ($el) {    my $time1 = time;
339        Whatpm::ContentChecker->check_element ($el, $onerror);    my $manifest = Whatpm::CacheManifest->parse_byte_string
340      } else {        ($input->{s}, $input->{uri}, $input->{base_uri}, $onerror);
341        Whatpm::ContentChecker->check_document ($doc, $onerror);    $time{parse_manifest} = time - $time1;
342    
343      print STDOUT qq[</dl></div>];
344    
345      return $manifest;
346    } # print_syntax_error_manifest_section
347    
348    sub print_source_string_section ($$) {
349      require Encode;
350      my $enc = Encode::find_encoding ($_[1]); ## TODO: charset name -> Perl name
351      return unless $enc;
352    
353      my $s = \($enc->decode (${$_[0]}));
354      my $i = 1;                            
355      push @nav, ['#source-string' => 'Source'];
356      print STDOUT qq[<div id="source-string" class="section">
357    <h2>Document Source</h2>
358    <ol lang="">\n];
359      if (length $$s) {
360        while ($$s =~ /\G([^\x0A]*?)\x0D?\x0A/gc) {
361          print STDOUT qq[<li id="line-$i">], htescape $1, "</li>\n";
362          $i++;
363      }      }
364        if ($$s =~ /\G([^\x0A]+)/gc) {
365      print STDOUT qq[        print STDOUT qq[<li id="line-$i">], htescape $1, "</li>\n";
366  </ul>      }
367  </div>    } else {
368  ];      print STDOUT q[<li id="line-1"></li>];
   }  
   
   ## TODO: Show result  
   
   print STDOUT qq[  
 <ul class="navigation" id="nav-items">  
 ];  
   for (@nav) {  
     print STDOUT qq[<li><a href="$_->[0]">$_->[1]</a></li>];  
   }  
   print STDOUT qq[  
 </ul>  
 </body>  
 </html>  
 ];  
   
 exit;  
   
 sub print_source_string ($) {  
   my $s = $_[0];  
   my $i = 1;  
   print STDOUT qq[<ol lang="">\n];  
   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";  
369    }    }
370    print STDOUT "</ol>";    print STDOUT "</ol></div>";
371  } # print_input_string  } # print_input_string_section
372    
373  sub print_document_tree ($) {  sub print_document_tree ($) {
374    my $node = shift;    my $node = shift;
# Line 250  sub print_document_tree ($) { Line 385  sub print_document_tree ($) {
385      my $node_id = 'node-'.refaddr $child;      my $node_id = 'node-'.refaddr $child;
386      my $nt = $child->node_type;      my $nt = $child->node_type;
387      if ($nt == $child->ELEMENT_NODE) {      if ($nt == $child->ELEMENT_NODE) {
388        $r .= qq'<li id="$node_id"><code>' . htescape ($child->tag_name) .        my $child_nsuri = $child->namespace_uri;
389          $r .= qq[<li id="$node_id" class="tree-element"><code title="@{[defined $child_nsuri ? $child_nsuri : '']}">] . htescape ($child->tag_name) .
390            '</code>'; ## ISSUE: case            '</code>'; ## ISSUE: case
391    
392        if ($child->has_attributes) {        if ($child->has_attributes) {
393          $r .= '<ul class="attributes">';          $r .= '<ul class="attributes">';
394          for my $attr (sort {$a->[0] cmp $b->[0]} map { [$_->name, $_->value, 'node-'.refaddr $_] }          for my $attr (sort {$a->[0] cmp $b->[0]} map { [$_->name, $_->value, $_->namespace_uri, 'node-'.refaddr $_] }
395                        @{$child->attributes}) {                        @{$child->attributes}) {
396            $r .= qq'<li id="$attr->[2]"><code>' . htescape ($attr->[0]) . '</code> = '; ## ISSUE: case?            $r .= qq[<li id="$attr->[3]" class="tree-attribute"><code title="@{[defined $_->[2] ? $_->[2] : '']}">] . htescape ($attr->[0]) . '</code> = '; ## ISSUE: case?
397            $r .= '<q>' . htescape ($attr->[1]) . '</q></li>'; ## TODO: children            $r .= '<q>' . htescape ($attr->[1]) . '</q></li>'; ## TODO: children
398          }          }
399          $r .= '</ul>';          $r .= '</ul>';
400        }        }
401    
402        if ($node->has_child_nodes) {        if ($child->has_child_nodes) {
403          $r .= '<ol class="children">';          $r .= '<ol class="children">';
404          unshift @node, @{$child->child_nodes}, '</ol>';          unshift @node, @{$child->child_nodes}, '</ol></li>';
405          } else {
406            $r .= '</li>';
407        }        }
408      } elsif ($nt == $child->TEXT_NODE) {      } elsif ($nt == $child->TEXT_NODE) {
409        $r .= qq'<li id="$node_id"><q>' . htescape ($child->data) . '</q></li>';        $r .= qq'<li id="$node_id" class="tree-text"><q lang="">' . htescape ($child->data) . '</q></li>';
410      } elsif ($nt == $child->CDATA_SECTION_NODE) {      } elsif ($nt == $child->CDATA_SECTION_NODE) {
411        $r .= qq'<li id="$node_id"><code>&lt;[CDATA[</code><q>' . htescape ($child->data) . '</q><code>]]&gt;</code></li>';        $r .= qq'<li id="$node_id" class="tree-cdata"><code>&lt;[CDATA[</code><q lang="">' . htescape ($child->data) . '</q><code>]]&gt;</code></li>';
412      } elsif ($nt == $child->COMMENT_NODE) {      } elsif ($nt == $child->COMMENT_NODE) {
413        $r .= qq'<li id="$node_id"><code>&lt;!--</code><q>' . htescape ($child->data) . '</q><code>--&gt;</code></li>';        $r .= qq'<li id="$node_id" class="tree-comment"><code>&lt;!--</code><q lang="">' . htescape ($child->data) . '</q><code>--&gt;</code></li>';
414      } elsif ($nt == $child->DOCUMENT_NODE) {      } elsif ($nt == $child->DOCUMENT_NODE) {
415        $r .= qq'<li id="$node_id">Document</li>';        $r .= qq'<li id="$node_id" class="tree-document">Document';
416          $r .= qq[<ul class="attributes">];
417          $r .= qq[<li>@{[scalar get_text ('manakaiIsHTML:'.($child->manakai_is_html?1:0))]}</li>];
418          $r .= qq[<li>@{[scalar get_text ('manakaiCompatMode:'.$child->manakai_compat_mode)]}</li>];
419          unless ($child->manakai_is_html) {
420            $r .= qq[<li>XML version = <code>@{[htescape ($child->xml_version)]}</code></li>];
421            if (defined $child->xml_encoding) {
422              $r .= qq[<li>XML encoding = <code>@{[htescape ($child->xml_encoding)]}</code></li>];
423            } else {
424              $r .= qq[<li>XML encoding = (null)</li>];
425            }
426            $r .= qq[<li>XML standalone = @{[$child->xml_standalone ? 'true' : 'false']}</li>];
427          }
428          $r .= qq[</ul>];
429        if ($child->has_child_nodes) {        if ($child->has_child_nodes) {
430          $r .= '<ol>';          $r .= '<ol class="children">';
431          unshift @node, @{$child->child_nodes}, '</ol>';          unshift @node, @{$child->child_nodes}, '</ol></li>';
432        }        }
433      } elsif ($nt == $child->DOCUMENT_TYPE_NODE) {      } elsif ($nt == $child->DOCUMENT_TYPE_NODE) {
434        $r .= qq'<li id="$node_id"><code>&lt;!DOCTYPE&gt;</code><ul>';        $r .= qq'<li id="$node_id" class="tree-doctype"><code>&lt;!DOCTYPE&gt;</code><ul class="attributes">';
435        $r .= '<li>Name = <q>@{[htescape ($child->name)]}</q></li>';        $r .= qq[<li class="tree-doctype-name">Name = <q>@{[htescape ($child->name)]}</q></li>];
436        $r .= '<li>Public identifier = <q>@{[htescape ($child->public_id)]}</q></li>';        $r .= qq[<li class="tree-doctype-publicid">Public identifier = <q>@{[htescape ($child->public_id)]}</q></li>];
437        $r .= '<li>System identifier = <q>@{[htescape ($child->system_id)]}</q></li>';        $r .= qq[<li class="tree-doctype-systemid">System identifier = <q>@{[htescape ($child->system_id)]}</q></li>];
438        $r .= '</ul></li>';        $r .= '</ul></li>';
439      } elsif ($nt == $child->PROCESSING_INSTRUCTION_NODE) {      } elsif ($nt == $child->PROCESSING_INSTRUCTION_NODE) {
440        $r .= qq'<li id="$node_id"><code>&lt;?@{[htescape ($child->target)]}?&gt;</code>';        $r .= qq'<li id="$node_id" class="tree-id"><code>&lt;?@{[htescape ($child->target)]}</code> <q>@{[htescape ($child->data)]}</q><code>?&gt;</code></li>';
       $r .= '<ul><li>@{[htescape ($child->data)]}</li></ul></li>';  
441      } else {      } else {
442        $r .= qq'<li id="$node_id">@{[$child->node_type]} @{[htescape ($child->node_name)]}</li>'; # error        $r .= qq'<li id="$node_id" class="tree-unknown">@{[$child->node_type]} @{[htescape ($child->node_name)]}</li>'; # error
443      }      }
444    }    }
445    
# Line 297  sub print_document_tree ($) { Line 447  sub print_document_tree ($) {
447    print STDOUT $r;    print STDOUT $r;
448  } # print_document_tree  } # print_document_tree
449    
450    sub print_structure_dump_dom_section ($$) {
451      my ($doc, $el) = @_;
452    
453      print STDOUT qq[
454    <div id="document-tree" class="section">
455    <h2>Document Tree</h2>
456    ];
457      push @nav, ['#document-tree' => 'Tree'];
458    
459      print_document_tree ($el || $doc);
460    
461      print STDOUT qq[</div>];
462    } # print_structure_dump_dom_section
463    
464    sub print_structure_dump_manifest_section ($) {
465      my $manifest = shift;
466    
467      print STDOUT qq[
468    <div id="dump-manifest" class="section">
469    <h2>Cache Manifest</h2>
470    ];
471      push @nav, ['#dump-manifest' => 'Caceh Manifest'];
472    
473      print STDOUT qq[<dl><dt>Explicit entries</dt>];
474      for my $uri (@{$manifest->[0]}) {
475        my $euri = htescape ($uri);
476        print STDOUT qq[<dd><code class=uri>&lt;<a href="$euri">$euri</a>></code></dd>];
477      }
478    
479      print STDOUT qq[<dt>Fallback entries</dt><dd>
480          <table><thead><tr><th scope=row>Oppotunistic Caching Namespace</th>
481          <th scope=row>Fallback Entry</tr><tbody>];
482      for my $uri (sort {$a cmp $b} keys %{$manifest->[1]}) {
483        my $euri = htescape ($uri);
484        my $euri2 = htescape ($manifest->[1]->{$uri});
485        print STDOUT qq[<tr><td><code class=uri>&lt;<a href="$euri">$euri</a>></code></td>
486            <td><code class=uri>&lt;<a href="$euri2">$euri2</a>></code></td>];
487      }
488    
489      print STDOUT qq[</table><dt>Online whitelist</dt>];
490      for my $uri (@{$manifest->[2]}) {
491        my $euri = htescape ($uri);
492        print STDOUT qq[<dd><code class=uri>&lt;<a href="$euri">$euri</a>></code></dd>];
493      }
494    
495      print STDOUT qq[</dl></div>];
496    } # print_structure_dump_manifest_section
497    
498    sub print_structure_error_dom_section ($$$) {
499      my ($doc, $el, $result) = @_;
500    
501      print STDOUT qq[<div id="document-errors" class="section">
502    <h2>Document Errors</h2>
503    
504    <dl>];
505      push @nav, ['#document-errors' => 'Document Error'];
506    
507      require Whatpm::ContentChecker;
508      my $onerror = sub {
509        my %opt = @_;
510        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level}, $opt{node});
511        $type =~ tr/ /-/;
512        $type =~ s/\|/%7C/g;
513        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
514        print STDOUT qq[<dt class="$cls">] . get_error_label (\%opt) .
515            qq[</dt>\n<dd class="$cls">], get_error_level_label (\%opt);
516        print STDOUT $msg, "</dd>\n";
517        add_error ('structure', \%opt => $result);
518      };
519    
520      my $elements;
521      my $time1 = time;
522      if ($el) {
523        $elements = Whatpm::ContentChecker->check_element ($el, $onerror);
524      } else {
525        $elements = Whatpm::ContentChecker->check_document ($doc, $onerror);
526      }
527      $time{check} = time - $time1;
528    
529      print STDOUT qq[</dl></div>];
530    
531      return $elements;
532    } # print_structure_error_dom_section
533    
534    sub print_structure_error_manifest_section ($$$) {
535      my ($manifest, $result) = @_;
536    
537      print STDOUT qq[<div id="document-errors" class="section">
538    <h2>Document Errors</h2>
539    
540    <dl>];
541      push @nav, ['#document-errors' => 'Document Error'];
542    
543      require Whatpm::CacheManifest;
544      Whatpm::CacheManifest->check_manifest ($manifest, sub {
545        my %opt = @_;
546        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level}, $opt{node});
547        $type =~ tr/ /-/;
548        $type =~ s/\|/%7C/g;
549        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
550        print STDOUT qq[<dt class="$cls">] . get_error_label (\%opt) .
551            qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";
552        add_error ('structure', \%opt => $result);
553      });
554    
555      print STDOUT qq[</div>];
556    } # print_structure_error_manifest_section
557    
558    sub print_table_section ($) {
559      my $tables = shift;
560      
561      push @nav, ['#tables' => 'Tables'];
562      print STDOUT qq[
563    <div id="tables" class="section">
564    <h2>Tables</h2>
565    
566    <!--[if IE]><script type="text/javascript" src="../excanvas.js"></script><![endif]-->
567    <script src="../table-script.js" type="text/javascript"></script>
568    <noscript>
569    <p><em>Structure of tables are visualized here if scripting is enabled.</em></p>
570    </noscript>
571    ];
572      
573      require JSON;
574      
575      my $i = 0;
576      for my $table_el (@$tables) {
577        $i++;
578        print STDOUT qq[<div class="section" id="table-$i"><h3>] .
579            get_node_link ($table_el) . q[</h3>];
580    
581        ## TODO: Make |ContentChecker| return |form_table| result
582        ## so that this script don't have to run the algorithm twice.
583        my $table = Whatpm::HTMLTable->form_table ($table_el);
584        
585        for (@{$table->{column_group}}, @{$table->{column}}, $table->{caption}) {
586          next unless $_;
587          delete $_->{element};
588        }
589        
590        for (@{$table->{row_group}}) {
591          next unless $_;
592          next unless $_->{element};
593          $_->{type} = $_->{element}->manakai_local_name;
594          delete $_->{element};
595        }
596        
597        for (@{$table->{cell}}) {
598          next unless $_;
599          for (@{$_}) {
600            next unless $_;
601            for (@$_) {
602              $_->{id} = refaddr $_->{element} if defined $_->{element};
603              delete $_->{element};
604              $_->{is_header} = $_->{is_header} ? 1 : 0;
605            }
606          }
607        }
608            
609        print STDOUT '</div><script type="text/javascript">tableToCanvas (';
610        print STDOUT JSON::objToJson ($table);
611        print STDOUT qq[, document.getElementById ('table-$i'));</script>];
612      }
613      
614      print STDOUT qq[</div>];
615    } # print_table_section
616    
617    sub print_id_section ($) {
618      my $ids = shift;
619      
620      push @nav, ['#identifiers' => 'IDs'];
621      print STDOUT qq[
622    <div id="identifiers" class="section">
623    <h2>Identifiers</h2>
624    
625    <dl>
626    ];
627      for my $id (sort {$a cmp $b} keys %$ids) {
628        print STDOUT qq[<dt><code>@{[htescape $id]}</code></dt>];
629        for (@{$ids->{$id}}) {
630          print STDOUT qq[<dd>].get_node_link ($_).qq[</dd>];
631        }
632      }
633      print STDOUT qq[</dl></div>];
634    } # print_id_section
635    
636    sub print_term_section ($) {
637      my $terms = shift;
638      
639      push @nav, ['#terms' => 'Terms'];
640      print STDOUT qq[
641    <div id="terms" class="section">
642    <h2>Terms</h2>
643    
644    <dl>
645    ];
646      for my $term (sort {$a cmp $b} keys %$terms) {
647        print STDOUT qq[<dt>@{[htescape $term]}</dt>];
648        for (@{$terms->{$term}}) {
649          print STDOUT qq[<dd>].get_node_link ($_).qq[</dd>];
650        }
651      }
652      print STDOUT qq[</dl></div>];
653    } # print_term_section
654    
655    sub print_class_section ($) {
656      my $classes = shift;
657      
658      push @nav, ['#classes' => 'Classes'];
659      print STDOUT qq[
660    <div id="classes" class="section">
661    <h2>Classes</h2>
662    
663    <dl>
664    ];
665      for my $class (sort {$a cmp $b} keys %$classes) {
666        print STDOUT qq[<dt><code>@{[htescape $class]}</code></dt>];
667        for (@{$classes->{$class}}) {
668          print STDOUT qq[<dd>].get_node_link ($_).qq[</dd>];
669        }
670      }
671      print STDOUT qq[</dl></div>];
672    } # print_class_section
673    
674    sub print_result_section ($) {
675      my $result = shift;
676    
677      print STDOUT qq[
678    <div id="result-summary" class="section">
679    <h2>Result</h2>];
680    
681      if ($result->{unsupported} and $result->{conforming_max}) {  
682        print STDOUT qq[<p class=uncertain id=result-para>The conformance
683            checker cannot decide whether the document is conforming or
684            not, since the document contains one or more unsupported
685            features.  The document might or might not be conforming.</p>];
686      } elsif ($result->{conforming_min}) {
687        print STDOUT qq[<p class=PASS id=result-para>No conformance-error is
688            found in this document.</p>];
689      } elsif ($result->{conforming_max}) {
690        print STDOUT qq[<p class=SEE-RESULT id=result-para>This document
691            is <strong>likely <em>non</em>-conforming</strong>, but in rare case
692            it might be conforming.</p>];
693      } else {
694        print STDOUT qq[<p class=FAIL id=result-para>This document is
695            <strong><em>non</em>-conforming</strong>.</p>];
696      }
697    
698      print STDOUT qq[<table>
699    <colgroup><col><colgroup><col><col><col><colgroup><col>
700    <thead>
701    <tr><th scope=col></th>
702    <th scope=col><a href="../error-description#level-m"><em class=rfc2119>MUST</em>‐level
703    Errors</a></th>
704    <th scope=col><a href="../error-description#level-s"><em class=rfc2119>SHOULD</em>‐level
705    Errors</a></th>
706    <th scope=col><a href="../error-description#level-w">Warnings</a></th>
707    <th scope=col>Score</th></tr></thead><tbody>];
708    
709      my $must_error = 0;
710      my $should_error = 0;
711      my $warning = 0;
712      my $score_min = 0;
713      my $score_max = 0;
714      my $score_base = 20;
715      my $score_unit = $score_base / 100;
716      for (
717        [Transfer => 'transfer', ''],
718        [Character => 'char', ''],
719        [Syntax => 'syntax', '#parse-errors'],
720        [Structure => 'structure', '#document-errors'],
721      ) {
722        $must_error += ($result->{$_->[1]}->{must} += 0);
723        $should_error += ($result->{$_->[1]}->{should} += 0);
724        $warning += ($result->{$_->[1]}->{warning} += 0);
725        $score_min += (($result->{$_->[1]}->{score_min} *= $score_unit) += $score_base);
726        $score_max += (($result->{$_->[1]}->{score_max} *= $score_unit) += $score_base);
727    
728        my $uncertain = $result->{$_->[1]}->{unsupported} ? '?' : '';
729        my $label = $_->[0];
730        if ($result->{$_->[1]}->{must} or
731            $result->{$_->[1]}->{should} or
732            $result->{$_->[1]}->{warning} or
733            $result->{$_->[1]}->{unsupported}) {
734          $label = qq[<a href="$_->[2]">$label</a>];
735        }
736    
737        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>];
738        if ($uncertain) {
739          print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : $result->{$_->[1]}->{should} ? 'SEE-RESULT' : '']}">&#x2212;&#x221E;..$result->{$_->[1]}->{score_max}</td>];
740        } elsif ($result->{$_->[1]}->{score_min} != $result->{$_->[1]}->{score_max}) {
741          print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : 'SEE-RESULT']}">$result->{$_->[1]}->{score_min}..$result->{$_->[1]}->{score_max}</td></tr>];
742        } else {
743          print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : '']}">$result->{$_->[1]}->{score_min}</td></tr>];
744        }
745      }
746    
747      $score_max += $score_base;
748    
749      print STDOUT qq[
750    <tr class=uncertain><th scope=row>Semantics</th><td>0?</td><td>0?</td><td>0?</td><td>&#x2212;&#x221E;..$score_base</td></tr>
751    </tbody>
752    <tfoot><tr class=uncertain><th scope=row>Total</th>
753    <td class="@{[$must_error ? 'FAIL' : '']}">$must_error?</td>
754    <td class="@{[$should_error ? 'SEE-RESULT' : '']}">$should_error?</td>
755    <td>$warning?</td>
756    <td class="@{[$must_error ? 'FAIL' : $should_error ? 'SEE-RESULT' : '']}"><strong>&#x2212;&#x221E;..$score_max</strong></td></tr></tfoot>
757    </table>
758    
759    <p><strong>Important</strong>: This conformance checking service
760    is <em>under development</em>.  The result above might be <em>wrong</em>.</p>
761    </div>];
762      push @nav, ['#result-summary' => 'Result'];
763    } # print_result_section
764    
765    sub print_result_unknown_type_section ($$) {
766      my ($input, $result) = @_;
767    
768      my $euri = htescape ($input->{uri});
769      print STDOUT qq[
770    <div id="parse-errors" class="section">
771    <h2>Errors</h2>
772    
773    <dl>
774    <dt class=unsupported><code>&lt;<a href="$euri">$euri</a>&gt;</code></dt>
775        <dd class=unsupported><strong><a href="../error-description#level-u">Not
776            supported</a></strong>:
777        Media type
778        <code class="MIME" lang="en">@{[htescape $input->{media_type}]}</code>
779        is not supported.</dd>
780    </dl>
781    </div>
782    ];
783      push @nav, ['#parse-errors' => 'Errors'];
784      add_error (char => {level => 'unsupported'} => $result);
785      add_error (syntax => {level => 'unsupported'} => $result);
786      add_error (structure => {level => 'unsupported'} => $result);
787    } # print_result_unknown_type_section
788    
789    sub print_result_input_error_section ($) {
790      my $input = shift;
791      print STDOUT qq[<div class="section" id="result-summary">
792    <p><em><strong>Input Error</strong>: @{[htescape ($input->{error_status_text})]}</em></p>
793    </div>];
794      push @nav, ['#result-summary' => 'Result'];
795    } # print_Result_input_error_section
796    
797    sub get_error_label ($) {
798      my $err = shift;
799    
800      my $r = '';
801    
802      if (defined $err->{line}) {
803        if ($err->{column} > 0) {
804          $r = qq[<a href="#line-$err->{line}">Line $err->{line}</a> column $err->{column}];
805        } else {
806          $err->{line} = $err->{line} - 1 || 1;
807          $r = qq[<a href="#line-$err->{line}">Line $err->{line}</a>];
808        }
809      }
810    
811      if (defined $err->{node}) {
812        $r .= ' ' if length $r;
813        $r = get_node_link ($err->{node});
814      }
815    
816      if (defined $err->{index}) {
817        $r .= ' ' if length $r;
818        $r .= 'Index ' . (0+$err->{index});
819      }
820    
821      if (defined $err->{value}) {
822        $r .= ' ' if length $r;
823        $r .= '<q><code>' . htescape ($err->{value}) . '</code></q>';
824      }
825    
826      return $r;
827    } # get_error_label
828    
829    sub get_error_level_label ($) {
830      my $err = shift;
831    
832      my $r = '';
833    
834      if (not defined $err->{level} or $err->{level} eq 'm') {
835        $r = qq[<strong><a href="../error-description#level-m"><em class=rfc2119>MUST</em>‐level
836            error</a></strong>: ];
837      } elsif ($err->{level} eq 's') {
838        $r = qq[<strong><a href="../error-description#level-s"><em class=rfc2119>SHOULD</em>‐level
839            error</a></strong>: ];
840      } elsif ($err->{level} eq 'w') {
841        $r = qq[<strong><a href="../error-description#level-w">Warning</a></strong>:
842            ];
843      } elsif ($err->{level} eq 'unsupported') {
844        $r = qq[<strong><a href="../error-description#level-u">Not
845            supported</a></strong>: ];
846      } else {
847        my $elevel = htescape ($err->{level});
848        $r = qq[<strong><a href="../error-description#level-$elevel">$elevel</a></strong>:
849            ];
850      }
851    
852      return $r;
853    } # get_error_level_label
854    
855  sub get_node_path ($) {  sub get_node_path ($) {
856    my $node = shift;    my $node = shift;
857    my @r;    my @r;
# Line 312  sub get_node_path ($) { Line 867  sub get_node_path ($) {
867        $rs = '"' . $node->data . '"';        $rs = '"' . $node->data . '"';
868        $node = $node->parent_node;        $node = $node->parent_node;
869      } elsif ($node->node_type == 9) {      } elsif ($node->node_type == 9) {
870          @r = ('') unless @r;
871        $rs = '';        $rs = '';
872        $node = $node->parent_node;        $node = $node->parent_node;
873      } else {      } else {
# Line 323  sub get_node_path ($) { Line 879  sub get_node_path ($) {
879    return join '/', @r;    return join '/', @r;
880  } # get_node_path  } # get_node_path
881    
882    sub get_node_link ($) {
883      return qq[<a href="#node-@{[refaddr $_[0]]}">] .
884          htescape (get_node_path ($_[0])) . qq[</a>];
885    } # get_node_link
886    
887    {
888      my $Msg = {};
889    
890    sub load_text_catalog ($) {
891      my $lang = shift; # MUST be a canonical lang name
892      open my $file, '<', "cc-msg.$lang.txt" or die "$0: cc-msg.$lang.txt: $!";
893      while (<$file>) {
894        if (s/^([^;]+);([^;]*);//) {
895          my ($type, $cls, $msg) = ($1, $2, $_);
896          $msg =~ tr/\x0D\x0A//d;
897          $Msg->{$type} = [$cls, $msg];
898        }
899      }
900    } # load_text_catalog
901    
902    sub get_text ($) {
903      my ($type, $level, $node) = @_;
904      $type = $level . ':' . $type if defined $level;
905      my @arg;
906      {
907        if (defined $Msg->{$type}) {
908          my $msg = $Msg->{$type}->[1];
909          $msg =~ s{<var>\$([0-9]+)</var>}{
910            defined $arg[$1] ? htescape ($arg[$1]) : '(undef)';
911          }ge;
912          $msg =~ s{<var>{\@([A-Za-z0-9:_.-]+)}</var>}{
913            UNIVERSAL::can ($node, 'get_attribute_ns')
914                ? htescape ($node->get_attribute_ns (undef, $1)) : ''
915          }ge;
916          $msg =~ s{<var>{\@}</var>}{
917            UNIVERSAL::can ($node, 'value') ? htescape ($node->value) : ''
918          }ge;
919          $msg =~ s{<var>{local-name}</var>}{
920            UNIVERSAL::can ($node, 'manakai_local_name')
921              ? htescape ($node->manakai_local_name) : ''
922          }ge;
923          $msg =~ s{<var>{element-local-name}</var>}{
924            (UNIVERSAL::can ($node, 'owner_element') and
925             $node->owner_element)
926              ? htescape ($node->owner_element->manakai_local_name)
927              : ''
928          }ge;
929          return ($type, $Msg->{$type}->[0], $msg);
930        } elsif ($type =~ s/:([^:]*)$//) {
931          unshift @arg, $1;
932          redo;
933        }
934      }
935      return ($type, '', htescape ($_[0]));
936    } # get_text
937    
938    }
939    
940    sub get_input_document ($$) {
941      my ($http, $dom) = @_;
942    
943      my $request_uri = $http->get_parameter ('uri');
944      my $r = {};
945      if (defined $request_uri and length $request_uri) {
946        my $uri = $dom->create_uri_reference ($request_uri);
947        unless ({
948                 http => 1,
949                }->{lc $uri->uri_scheme}) {
950          return {uri => $request_uri, request_uri => $request_uri,
951                  error_status_text => 'URI scheme not allowed'};
952        }
953    
954        require Message::Util::HostPermit;
955        my $host_permit = new Message::Util::HostPermit;
956        $host_permit->add_rule (<<EOH);
957    Allow host=suika port=80
958    Deny host=suika
959    Allow host=suika.fam.cx port=80
960    Deny host=suika.fam.cx
961    Deny host=localhost
962    Deny host=*.localdomain
963    Deny ipv4=0.0.0.0/8
964    Deny ipv4=10.0.0.0/8
965    Deny ipv4=127.0.0.0/8
966    Deny ipv4=169.254.0.0/16
967    Deny ipv4=172.0.0.0/11
968    Deny ipv4=192.0.2.0/24
969    Deny ipv4=192.88.99.0/24
970    Deny ipv4=192.168.0.0/16
971    Deny ipv4=198.18.0.0/15
972    Deny ipv4=224.0.0.0/4
973    Deny ipv4=255.255.255.255/32
974    Deny ipv6=0::0/0
975    Allow host=*
976    EOH
977        unless ($host_permit->check ($uri->uri_host, $uri->uri_port || 80)) {
978          return {uri => $request_uri, request_uri => $request_uri,
979                  error_status_text => 'Connection to the host is forbidden'};
980        }
981    
982        require LWP::UserAgent;
983        my $ua = WDCC::LWPUA->new;
984        $ua->{wdcc_dom} = $dom;
985        $ua->{wdcc_host_permit} = $host_permit;
986        $ua->agent ('Mozilla'); ## TODO: for now.
987        $ua->parse_head (0);
988        $ua->protocols_allowed ([qw/http/]);
989        $ua->max_size (1000_000);
990        my $req = HTTP::Request->new (GET => $request_uri);
991        my $res = $ua->request ($req);
992        ## TODO: 401 sets |is_success| true.
993        if ($res->is_success or $http->get_parameter ('error-page')) {
994          $r->{base_uri} = $res->base; ## NOTE: It does check |Content-Base|, |Content-Location|, and <base>. ## TODO: Use our own code!
995          $r->{uri} = $res->request->uri;
996          $r->{request_uri} = $request_uri;
997    
998          ## TODO: More strict parsing...
999          my $ct = $res->header ('Content-Type');
1000          if (defined $ct and $ct =~ m#^([0-9A-Za-z._+-]+/[0-9A-Za-z._+-]+)#) {
1001            $r->{media_type} = lc $1;
1002          }
1003          if (defined $ct and $ct =~ /;\s*charset\s*=\s*"?([^\s;"]+)"?/i) {
1004            $r->{charset} = lc $1;
1005            $r->{charset} =~ tr/\\//d;
1006          }
1007    
1008          my $input_charset = $http->get_parameter ('charset');
1009          if (defined $input_charset and length $input_charset) {
1010            $r->{charset_overridden}
1011                = (not defined $r->{charset} or $r->{charset} ne $input_charset);
1012            $r->{charset} = $input_charset;
1013          }
1014    
1015          $r->{s} = ''.$res->content;
1016        } else {
1017          $r->{uri} = $res->request->uri;
1018          $r->{request_uri} = $request_uri;
1019          $r->{error_status_text} = $res->status_line;
1020        }
1021    
1022        $r->{header_field} = [];
1023        $res->scan (sub {
1024          push @{$r->{header_field}}, [$_[0], $_[1]];
1025        });
1026        $r->{header_status_code} = $res->code;
1027        $r->{header_status_text} = $res->message;
1028      } else {
1029        $r->{s} = ''.$http->get_parameter ('s');
1030        $r->{uri} = q<thismessage:/>;
1031        $r->{request_uri} = q<thismessage:/>;
1032        $r->{base_uri} = q<thismessage:/>;
1033        $r->{charset} = ''.$http->get_parameter ('_charset_');
1034        $r->{charset} =~ s/\s+//g;
1035        $r->{charset} = 'utf-8' if $r->{charset} eq '';
1036        $r->{header_field} = [];
1037      }
1038    
1039      my $input_format = $http->get_parameter ('i');
1040      if (defined $input_format and length $input_format) {
1041        $r->{media_type_overridden}
1042            = (not defined $r->{media_type} or $input_format ne $r->{media_type});
1043        $r->{media_type} = $input_format;
1044      }
1045      if (defined $r->{s} and not defined $r->{media_type}) {
1046        $r->{media_type} = 'text/html';
1047        $r->{media_type_overridden} = 1;
1048      }
1049    
1050      if ($r->{media_type} eq 'text/xml') {
1051        unless (defined $r->{charset}) {
1052          $r->{charset} = 'us-ascii';
1053        } elsif ($r->{charset_overridden} and $r->{charset} eq 'us-ascii') {
1054          $r->{charset_overridden} = 0;
1055        }
1056      }
1057    
1058      if (length $r->{s} > 1000_000) {
1059        $r->{error_status_text} = 'Entity-body too large';
1060        delete $r->{s};
1061        return $r;
1062      }
1063    
1064      return $r;
1065    } # get_input_document
1066    
1067    package WDCC::LWPUA;
1068    BEGIN { push our @ISA, 'LWP::UserAgent'; }
1069    
1070    sub redirect_ok {
1071      my $ua = shift;
1072      unless ($ua->SUPER::redirect_ok (@_)) {
1073        return 0;
1074      }
1075    
1076      my $uris = $_[1]->header ('Location');
1077      return 0 unless $uris;
1078      my $uri = $ua->{wdcc_dom}->create_uri_reference ($uris);
1079      unless ({
1080               http => 1,
1081              }->{lc $uri->uri_scheme}) {
1082        return 0;
1083      }
1084      unless ($ua->{wdcc_host_permit}->check ($uri->uri_host, $uri->uri_port || 80)) {
1085        return 0;
1086      }
1087      return 1;
1088    } # redirect_ok
1089    
1090  =head1 AUTHOR  =head1 AUTHOR
1091    
1092  Wakaba <w@suika.fam.cx>.  Wakaba <w@suika.fam.cx>.
Legend:
Removed from v.1.3  
changed lines
  Added in v.1.24
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24