/[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.5 by wakaba, Sat Jun 30 08:26:08 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/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    
10  use SuikaWiki::Input::HTTP; ## TODO: Use some better CGI module    require WebHACC::Input;
11      require WebHACC::Result;
12      require WebHACC::Output;
13    
14  sub htescape ($) {  my $out;
15    my $s = $_[0];  
16    $s =~ s/&/&/g;    require Message::DOM::DOMImplementation;
17    $s =~ s/</&lt;/g;    my $dom = Message::DOM::DOMImplementation->new;
18    $s =~ s/>/&gt;/g;  {
19    $s =~ s/"/&quot;/g;    use Message::CGI::HTTP;
20    $s =~ s!([\x00-\x09\x0B-\x1F\x7F-\x80])!sprintf '<var>U+%04X</var>', ord $1!ge;    my $http = Message::CGI::HTTP->new;
21    return $s;  
22  } # htescape    if ($http->get_meta_variable ('PATH_INFO') ne '/') {
23        print STDOUT "Status: 404 Not Found\nContent-Type: text/plain; charset=us-ascii\n\n400";
 my $http = SuikaWiki::Input::HTTP->new;  
   
 ## TODO: _charset_  
   
   my $input_format = $http->parameter ('i') || 'text/html';  
   my $inner_html_element = $http->parameter ('e');  
   my $input_uri = 'thismessage:/';  
   
   my $s = $http->parameter ('s');  
   if (length $s > 1000_000) {  
     print STDOUT "Status: 400 Document Too Long\nContent-Type: text/plain; charset=us-ascii\n\nToo long";  
24      exit;      exit;
25    }    }
26      
27      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 43  my $http = SuikaWiki::Input::HTTP->new; Line 39  my $http = SuikaWiki::Input::HTTP->new;
39  <link rel="stylesheet" href="../cc-style.css" type="text/css">  <link rel="stylesheet" href="../cc-style.css" type="text/css">
40  </head>  </head>
41  <body>  <body>
42  <h1>Web Document Conformance Checker (<em>beta</em>)</h1>  <h1><a href="../cc-interface">Web Document Conformance Checker</a>
43    (<em>beta</em>)</h1>
44  <div id="document-info" class="section">  ]);
45  <dl>  
46  <dt>Document URI</dt>    my $input = get_input_document ($http, $dom);
47      <dd><code class="URI" lang="">&lt;<a href="@{[htescape $input_uri]}">@{[htescape $input_uri]}</a>&gt;</code></dd>    $out->input ($input);
48  <dt>Internet Media Type</dt>    $out->unset_flush;
49      <dd><code class="MIME" lang="en">@{[htescape $input_format]}</code></dd>  
50  ]; # no </dl> yet    my $char_length = 0;
51    push @nav, ['#document-info' => 'Information'];  
52      $out->start_section (id => 'document-info', title => 'Information');
53    require Message::DOM::DOMImplementation;    $out->html (qq[<dl>
54    my $dom = Message::DOM::DOMImplementation->____new;  <dt>Request URL</dt>
55    my $doc;      <dd>]);
56    my $el;    $out->url ($input->{request_uri});
57      $out->html (q[<dt>Document URL<!-- HTML5 document's address? -->
58    if ($input_format eq 'text/html') {      <dd>]);
59      require Encode;    $out->url ($input->{uri}, id => 'anchor-document-url');
60      require Whatpm::HTML;    $out->html (q[
61            <script>
62      $s = Encode::decode ('utf-8', $s);        document.title = '<'
63              + document.getElementById ('anchor-document-url').href + '> \\u2014 '
64      print STDOUT qq[            + document.title;
65  <dt>Character Encoding</dt>      </script>]);
66      <dd>(none)</dd>    ## 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>
101        <dd>$char_length byte@{[$char_length == 1 ? '' : 's']}</dd>
102  </dl>  </dl>
 </div>  
103    
104  <div id="source-string" class="section">  <script src="../cc-script.js"></script>
105  <h2>Document Source</h2>  ]);
106  ];      $out->end_section;
107      push @nav, ['#source-string' => 'Source'];  
108      print_source_string (\$s);      my $result = WebHACC::Result->new;
109      print STDOUT qq[      $result->{conforming_min} = 1;
110  </div>      $result->{conforming_max} = 1;
111        check_and_print ($input => $result => $out);
112        print_result_section ($result);
113      } else {
114        $out->html ('</dl>');
115        $out->end_section;
116        print_result_input_error_section ($input);
117      }
118    
119  <div id="parse-errors" class="section">    $out->nav_list;
 <h2>Parse Errors</h2>  
120    
121  <dl>    exit;
122  ];  }
   push @nav, ['#parse-errors' => 'Parse Error'];  
123    
124    my $onerror = sub {  sub add_error ($$$) {
125      my (%opt) = @_;    my ($layer, $err, $result) = @_;
126      if ($opt{column} > 0) {    if (defined $err->{level}) {
127        print STDOUT qq[<dt><a href="#line-$opt{line}">Line $opt{line}</a> column $opt{column}</dt>\n];      if ($err->{level} eq 's') {
128          $result->{$layer}->{should}++;
129          $result->{$layer}->{score_min} -= 2;
130          $result->{conforming_min} = 0;
131        } elsif ($err->{level} eq 'w' or $err->{level} eq 'g') {
132          $result->{$layer}->{warning}++;
133        } 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 {      } else {
139        $opt{line}--;        $result->{$layer}->{must}++;
140        print STDOUT qq[<dt><a href="#line-$opt{line}">Line $opt{line}</a></dt>\n];        $result->{$layer}->{score_max} -= 2;
141          $result->{$layer}->{score_min} -= 2;
142          $result->{conforming_min} = 0;
143          $result->{conforming_max} = 0;
144      }      }
     print STDOUT qq[<dd>@{[htescape $opt{type}]}</dd>\n];  
   };  
   
   $doc = $dom->create_document;  
   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, $s, $onerror);  
145    } else {    } else {
146      Whatpm::HTML->parse_string ($s => $doc, $onerror);      $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    print STDOUT qq[  sub check_and_print ($$$) {
155  </dl>    my ($input, $result, $out) = @_;
156  </div>    my $original_input = $out->input;
157  ];    $out->input ($input);
158    } elsif ($input_format eq 'application/xhtml+xml') {  
159      require Message::DOM::XMLParserTemp;    print_http_header_section ($input, $result);
160      require Encode;  
161          my @subdoc;
162      my $t = Encode::decode ('utf-8', $s);  
163      my $checker_class = {
164      print STDOUT qq[      'text/cache-manifest' => 'WebHACC::Language::CacheManifest',
165  <dt>Character Encoding</dt>      'text/css' => 'WebHACC::Language::CSS',
166      <dd>(none)</dd>      'text/html' => 'WebHACC::Language::HTML',
167  </dl>      'text/x-webidl' => 'WebHACC::Language::WebIDL',
168  </div>  
169        'text/xml' => 'WebHACC::Language::XML',
170  <div id="source-string" class="section">      'application/atom+xml' => 'WebHACC::Language::XML',
171  <h2>Document Source</h2>      'application/rss+xml' => 'WebHACC::Language::XML',
172  ];      'image/svg+xml' => 'WebHACC::Language::XML',
173      push @nav, ['#source-string' => 'Source'];      'application/xhtml+xml' => 'WebHACC::Language::XML',
174      print_source_string (\$t);      'application/xml' => 'WebHACC::Language::XML',
175      print STDOUT qq[      ## TODO: Should we make all XML MIME Types fall
176  </div>      ## into this category?
177    
178  <div id="parse-errors" class="section">      ## NOTE: This type has different model from normal XML types.
179  <h2>Parse Errors</h2>      '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  <dl>  =pod
 ];  
   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;  
   };  
   
   open my $fh, '<', \$s;  
   $doc = Message::DOM::XMLParserTemp->parse_byte_stream  
       ($fh => $dom, $onerror, charset => 'utf-8');  
203    
204      print STDOUT qq[    if (defined $doc or defined $el) {
 </dl>  
 </div>  
 ];  
   } else {  
     print STDOUT qq[  
 </dl>  
 </div>  
205    
206  <div id="result-summary" class="section">      print_table_section ($input, $elements->{table}) if @{$elements->{table}};
207  <p><em>Media type <code class="MIME" lang="en">@{[htescape $input_format]}</code> is not supported!</em></p>      print_listing_section ({
208  </div>        id => 'identifiers', label => 'IDs', heading => 'Identifiers',
209  ];      }, $input, $elements->{id}) if keys %{$elements->{id}};
210      push @nav, ['#result-summary' => 'Result'];      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    if (defined $doc or defined $el) {    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[      print STDOUT qq[
234  <div id="document-tree" class="section">        <dl>
235  <h2>Document Tree</h2>        <dt>Internet Media Type</dt>
236  ];          <dd><code class="MIME" lang="en">@{[htescape $subinput->{media_type}]}</code>
237      push @nav, ['#document-tree' => 'Tree'];        <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      print_document_tree ($el || $doc);      $subinput->{id_prefix} .= '-';
244        check_and_print ($subinput => $result => $out);
245    
246      print STDOUT qq[      $out->end_section;
247  </div>    }
248    
249  <div id="document-errors" class="section">    $out->input ($original_input);
250  <h2>Document Errors</h2>  } # check_and_print
251    
252  <dl>  sub print_http_header_section ($$) {
253  ];    my ($input, $result) = @_;
254      push @nav, ['#document-errors' => 'Document Error'];    return unless defined $input->{header_status_code} or
255          defined $input->{header_status_text} or
256      require Whatpm::ContentChecker;        @{$input->{header_field} or []};
257      my $onerror = sub {    
258        my %opt = @_;    $out->start_section (id => 'source-header', title => 'HTTP Header');
259        print STDOUT qq[<dt><a href="#node-@{[refaddr $opt{node}]}">],    print STDOUT qq[<p><strong>Note</strong>: Due to the limitation of the
260            htescape get_node_path ($opt{node}),  network library in use, the content of this section might
261            "</a></dt>\n<dd>", htescape $opt{type}, "</dd>\n";  not be the real header.</p>
262      };  
263    <table><tbody>
264      my $elements;  ];
265      if ($el) {  
266        $elements = Whatpm::ContentChecker->check_element ($el, $onerror);    if (defined $input->{header_status_code}) {
267      } else {      print STDOUT qq[<tr><th scope="row">Status code</th>];
268        $elements = Whatpm::ContentChecker->check_document ($doc, $onerror);      print STDOUT qq[<td>];
269      }      $out->code ($input->{header_status_code});
270      }
271      if (defined $input->{header_status_text}) {
272        print STDOUT qq[<tr><th scope="row">Status text</th>];
273        print STDOUT qq[<td>];
274        $out->code ($input->{header_status_text});
275      }
276      
277      for (@{$input->{header_field}}) {
278        print STDOUT qq[<tr><th scope="row">];
279        $out->code ($_->[0]);
280        print STDOUT qq[<td>];
281        $out->code ($_->[1]);
282      }
283    
284      print STDOUT qq[    print STDOUT qq[</tbody></table>];
 </dl>  
 </div>  
 ];  
285    
286      if (@{$elements->{table}}) {    $out->end_section;
287        require JSON;  } # print_http_header_section
288    
289        print STDOUT qq[  sub print_table_section ($$) {
290  <div id="tables" class="section">    my ($input, $tables) = @_;
291      
292    #  push @nav, [qq[#$input->{id_prefix}tables] => 'Tables']
293    #      unless $input->{nested};
294      print STDOUT qq[
295    <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 219  my $http = SuikaWiki::Input::HTTP->new; Line 301  my $http = SuikaWiki::Input::HTTP->new;
301  <p><em>Structure of tables are visualized here if scripting is enabled.</em></p>  <p><em>Structure of tables are visualized here if scripting is enabled.</em></p>
302  </noscript>  </noscript>
303  ];  ];
304      
305      require JSON;
306      
307      my $i = 0;
308      for my $table (@$tables) {
309        $i++;
310        print STDOUT qq[<div class="section" id="$input->{id_prefix}table-$i"><h3>] .
311            get_node_link ($input, $table->{element}) . q[</h3>];
312    
313        my $i = 0;      delete $table->{element};
314        for my $table_el (@{$elements->{table}}) {  
315          $i++;      for (@{$table->{column_group}}, @{$table->{column}}, $table->{caption},
316          print STDOUT qq[<div class="section" id="table-$i"><h3>];           @{$table->{row}}) {
317          print STDOUT qq[<a href="#node-@{[refaddr $table_el]}">],        next unless $_;
318            htescape get_node_path ($table_el);        delete $_->{element};
319          print STDOUT qq[</a></h3>\n];      }
320                
321          my $table = Whatpm::HTMLTable->form_table ($table_el);      for (@{$table->{row_group}}) {
322                  next unless $_;
323          for (@{$table->{column_group}}, @{$table->{column}}, $table->{caption}) {        next unless $_->{element};
324            next unless $_;        $_->{type} = $_->{element}->manakai_local_name;
325            delete $_->{element};        delete $_->{element};
326          }      }
327                
328          for (@{$table->{row_group}}) {      for (@{$table->{cell}}) {
329            next unless $_;        next unless $_;
330            next unless $_->{element};        for (@{$_}) {
331            $_->{type} = $_->{element}->manakai_local_name;          next unless $_;
332            for (@$_) {
333              $_->{id} = refaddr $_->{element} if defined $_->{element};
334            delete $_->{element};            delete $_->{element};
335              $_->{is_header} = $_->{is_header} ? 1 : 0;
336          }          }
           
         for (@{$table->{cell}}) {  
           next unless $_;  
           for (@{$_}) {  
             next unless $_;  
             for (@$_) {  
               $_->{id} = refaddr $_->{element} if defined $_->{element};  
               delete $_->{element};  
             }  
           }  
         }  
           
         print STDOUT '</div><script type="text/javascript">tableToCanvas (';  
         print STDOUT JSON::objToJson ($table);  
         print STDOUT qq[, document.getElementById ('table-$i'));</script>];  
337        }        }
       
       print STDOUT qq[</div>];  
338      }      }
339            
340        print STDOUT '</div><script type="text/javascript">tableToCanvas (';
341        print STDOUT JSON::objToJson ($table);
342        print STDOUT qq[, document.getElementById ('$input->{id_prefix}table-$i')];
343        print STDOUT qq[, '$input->{id_prefix}');</script>];
344    }    }
345      
346    ## TODO: Show result    print STDOUT qq[</div>];
347    } # print_table_section
348    
349    sub print_listing_section ($$$) {
350      my ($opt, $input, $ids) = @_;
351      
352    #  push @nav, ['#' . $input->{id_prefix} . $opt->{id} => $opt->{label}]
353    #      unless $input->{nested};
354    print STDOUT qq[    print STDOUT qq[
355  <ul class="navigation" id="nav-items">  <div id="$input->{id_prefix}$opt->{id}" class="section">
356    <h2>$opt->{heading}</h2>
357    
358    <dl>
359  ];  ];
360    for (@nav) {    for my $id (sort {$a cmp $b} keys %$ids) {
361      print STDOUT qq[<li><a href="$_->[0]">$_->[1]</a></li>];      print STDOUT qq[<dt><code>@{[htescape $id]}</code></dt>];
362        for (@{$ids->{$id}}) {
363          print STDOUT qq[<dd>].get_node_link ($input, $_).qq[</dd>];
364        }
365    }    }
366      print STDOUT qq[</dl></div>];
367    } # print_listing_section
368    
369    
370    sub print_rdf_section ($$$) {
371      my ($input, $rdfs) = @_;
372      
373    #  push @nav, ['#' . $input->{id_prefix} . 'rdf' => 'RDF']
374    #      unless $input->{nested};
375    print STDOUT qq[    print STDOUT qq[
376  </ul>  <div id="$input->{id_prefix}rdf" class="section">
377  </body>  <h2>RDF Triples</h2>
 </html>  
 ];  
378    
379  exit;  <dl>];
380      my $i = 0;
381      for my $rdf (@$rdfs) {
382        print STDOUT qq[<dt id="$input->{id_prefix}rdf-@{[$i++]}">];
383        print STDOUT get_node_link ($input, $rdf->[0]);
384        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>];
396    } # print_rdf_section
397    
398  sub print_source_string ($) {  sub get_rdf_resource_html ($) {
399    my $s = $_[0];    my $resource = shift;
400    my $i = 1;    if (defined $resource->{uri}) {
401    print STDOUT qq[<ol lang="">\n];      my $euri = htescape ($resource->{uri});
402    while ($$s =~ /\G([^\x0A]*?)\x0D?\x0A/gc) {      return '<code class=uri>&lt;<a href="' . $euri . '">' . $euri .
403      print STDOUT qq[<li id="line-$i">], htescape $1, "</li>\n";          '</a>></code>';
404      $i++;    } elsif (defined $resource->{bnodeid}) {
405        return htescape ('_:' . $resource->{bnodeid});
406      } elsif ($resource->{nodes}) {
407        return '(rdf:XMLLiteral)';
408      } elsif (defined $resource->{value}) {
409        my $elang = htescape (defined $resource->{language}
410                                  ? $resource->{language} : '');
411        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    if ($$s =~ /\G([^\x0A]+)/gc) {  } # get_rdf_resource_html
424      print STDOUT qq[<li id="line-$i">], htescape $1, "</li>\n";  
425    sub print_result_section ($) {
426      my $result = shift;
427    
428      $out->start_section (id => 'result-summary',
429                           title => 'Result');
430    
431      if ($result->{unsupported} and $result->{conforming_max}) {  
432        print STDOUT qq[<p class=uncertain id=result-para>The conformance
433            checker cannot decide whether the document is conforming or
434            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    }    }
   print STDOUT "</ol>";  
 } # print_input_string  
447    
448  sub print_document_tree ($) {    print STDOUT qq[<table>
449    my $node = shift;  <colgroup><col><colgroup><col><col><col><colgroup><col>
450    my $r = '<ol class="xoxo">';  <thead>
451    <tr><th scope=col></th>
452    my @node = ($node);  <th scope=col><a href="../error-description#level-m"><em class=rfc2119>MUST</em>‐level
453    while (@node) {  Errors</a></th>
454      my $child = shift @node;  <th scope=col><a href="../error-description#level-s"><em class=rfc2119>SHOULD</em>‐level
455      unless (ref $child) {  Errors</a></th>
456        $r .= $child;  <th scope=col><a href="../error-description#level-w">Warnings</a></th>
457        next;  <th scope=col>Score</th></tr></thead><tbody>];
458      }  
459      my $must_error = 0;
460      my $node_id = 'node-'.refaddr $child;    my $should_error = 0;
461      my $nt = $child->node_type;    my $warning = 0;
462      if ($nt == $child->ELEMENT_NODE) {    my $score_min = 0;
463        my $child_nsuri = $child->namespace_uri;    my $score_max = 0;
464        $r .= qq[<li id="$node_id" class="tree-element"><code title="@{[defined $child_nsuri ? $child_nsuri : '']}">] . htescape ($child->tag_name) .    my $score_base = 20;
465            '</code>'; ## ISSUE: case    my $score_unit = $score_base / 100;
466      for (
467        if ($child->has_attributes) {      [Transfer => 'transfer', ''],
468          $r .= '<ul class="attributes">';      [Character => 'char', ''],
469          for my $attr (sort {$a->[0] cmp $b->[0]} map { [$_->name, $_->value, $_->namespace_uri, 'node-'.refaddr $_] }      [Syntax => 'syntax', '#parse-errors'],
470                        @{$child->attributes}) {      [Structure => 'structure', '#document-errors'],
471            $r .= qq[<li id="$attr->[3]" class="tree-attribute"><code title="@{[defined $_->[2] ? $_->[2] : '']}">] . htescape ($attr->[0]) . '</code> = '; ## ISSUE: case?    ) {
472            $r .= '<q>' . htescape ($attr->[1]) . '</q></li>'; ## TODO: children      $must_error += ($result->{$_->[1]}->{must} += 0);
473          }      $should_error += ($result->{$_->[1]}->{should} += 0);
474          $r .= '</ul>';      $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 {
493          print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : '']}">$result->{$_->[1]}->{score_min}];
494        }
495        print qq[ / 20];
496      }
497    
498      $score_max += $score_base;
499    
500        if ($node->has_child_nodes) {    print STDOUT qq[
501          $r .= '<ol class="children">';  <tr class=uncertain><th scope=row>Semantics</th><td>0?</td><td>0?</td><td>0?</td><td>&#x2212;&#x221E;..$score_base / 20
502          unshift @node, @{$child->child_nodes}, '</ol>';  </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 = {};
525    
526    sub load_text_catalog ($) {
527    #  my $self = shift;
528      my $lang = shift; # MUST be a canonical lang name
529      open my $file, '<:utf8', "cc-msg.$lang.txt"
530          or die "$0: cc-msg.$lang.txt: $!";
531      while (<$file>) {
532        if (s/^([^;]+);([^;]*);//) {
533          my ($type, $cls, $msg) = ($1, $2, $_);
534          $msg =~ tr/\x0D\x0A//d;
535          $Msg->{$type} = [$cls, $msg];
536        }
537      }
538    } # load_text_catalog
539    
540    sub get_text ($;$$) {
541    #  my $self = shift;
542      my ($type, $level, $node) = @_;
543      $type = $level . ':' . $type if defined $level;
544      $level = 'm' unless defined $level;
545      my @arg;
546      {
547        if (defined $Msg->{$type}) {
548          my $msg = $Msg->{$type}->[1];
549          $msg =~ s{<var>\$([0-9]+)</var>}{
550            defined $arg[$1] ? ($arg[$1]) : '(undef)';
551          }ge;                 ##BUG: ^ must be escaped
552          $msg =~ s{<var>{\@([A-Za-z0-9:_.-]+)}</var>}{
553            UNIVERSAL::can ($node, 'get_attribute_ns')
554                ?  ($node->get_attribute_ns (undef, $1)) : ''
555          }ge; ## BUG: ^ must be escaped
556          $msg =~ s{<var>{\@}</var>}{        ## BUG: v must be escaped
557            UNIVERSAL::can ($node, 'value') ? ($node->value) : ''
558          }ge;
559          $msg =~ s{<var>{local-name}</var>}{
560            UNIVERSAL::can ($node, 'manakai_local_name')
561              ? ($node->manakai_local_name) : ''
562          }ge;  ## BUG: ^ must be escaped
563          $msg =~ s{<var>{element-local-name}</var>}{
564            (UNIVERSAL::can ($node, 'owner_element') and
565             $node->owner_element)
566              ?  ($node->owner_element->manakai_local_name)
567              : '' ## BUG: ^ must be escaped
568          }ge;
569          return ($type, 'level-' . $level . ' ' . $Msg->{$type}->[0], $msg);
570        } elsif ($type =~ s/:([^:]*)$//) {
571          unshift @arg, $1;
572          redo;
573        }
574      }
575      return ($type, 'level-'.$level, ($_[0]));
576                                     ## BUG: ^ must be escaped
577    } # get_text
578    
579    }
580    
581    sub get_input_document ($$) {
582      my ($http, $dom) = @_;
583    
584      my $request_uri = $http->get_parameter ('uri');
585      my $r = WebHACC::Input->new;
586      if (defined $request_uri and length $request_uri) {
587        my $uri = $dom->create_uri_reference ($request_uri);
588        unless ({
589                 http => 1,
590                }->{lc $uri->uri_scheme}) {
591          return {uri => $request_uri, request_uri => $request_uri,
592                  error_status_text => 'URI scheme not allowed'};
593        }
594    
595        require Message::Util::HostPermit;
596        my $host_permit = new Message::Util::HostPermit;
597        $host_permit->add_rule (<<EOH);
598    Allow host=suika port=80
599    Deny host=suika
600    Allow host=suika.fam.cx port=80
601    Deny host=suika.fam.cx
602    Deny host=localhost
603    Deny host=*.localdomain
604    Deny ipv4=0.0.0.0/8
605    Deny ipv4=10.0.0.0/8
606    Deny ipv4=127.0.0.0/8
607    Deny ipv4=169.254.0.0/16
608    Deny ipv4=172.0.0.0/11
609    Deny ipv4=192.0.2.0/24
610    Deny ipv4=192.88.99.0/24
611    Deny ipv4=192.168.0.0/16
612    Deny ipv4=198.18.0.0/15
613    Deny ipv4=224.0.0.0/4
614    Deny ipv4=255.255.255.255/32
615    Deny ipv6=0::0/0
616    Allow host=*
617    EOH
618        unless ($host_permit->check ($uri->uri_host, $uri->uri_port || 80)) {
619          return {uri => $request_uri, request_uri => $request_uri,
620                  error_status_text => 'Connection to the host is forbidden'};
621        }
622    
623        require LWP::UserAgent;
624        my $ua = WDCC::LWPUA->new;
625        $ua->{wdcc_dom} = $dom;
626        $ua->{wdcc_host_permit} = $host_permit;
627        $ua->agent ('Mozilla'); ## TODO: for now.
628        $ua->parse_head (0);
629        $ua->protocols_allowed ([qw/http/]);
630        $ua->max_size (1000_000);
631        my $req = HTTP::Request->new (GET => $request_uri);
632        $req->header ('Accept-Encoding' => 'identity, *; q=0');
633        my $res = $ua->request ($req);
634        ## TODO: 401 sets |is_success| true.
635        if ($res->is_success or $http->get_parameter ('error-page')) {
636          $r->{base_uri} = $res->base; ## NOTE: It does check |Content-Base|, |Content-Location|, and <base>. ## TODO: Use our own code!
637          $r->{uri} = $res->request->uri;
638          $r->{request_uri} = $request_uri;
639    
640          ## TODO: More strict parsing...
641          my $ct = $res->header ('Content-Type');
642          if (defined $ct and $ct =~ /;\s*charset\s*=\s*"?([^\s;"]+)"?/i) {
643            $r->{charset} = lc $1;
644            $r->{charset} =~ tr/\\//d;
645            $r->{official_charset} = $r->{charset};
646        }        }
647      } elsif ($nt == $child->TEXT_NODE) {  
648        $r .= qq'<li id="$node_id" class="tree-text"><q lang="">' . htescape ($child->data) . '</q></li>';        my $input_charset = $http->get_parameter ('charset');
649      } elsif ($nt == $child->CDATA_SECTION_NODE) {        if (defined $input_charset and length $input_charset) {
650        $r .= qq'<li id="$node_id" class="tree-cdata"><code>&lt;[CDATA[</code><q lang="">' . htescape ($child->data) . '</q><code>]]&gt;</code></li>';          $r->{charset_overridden}
651      } elsif ($nt == $child->COMMENT_NODE) {              = (not defined $r->{charset} or $r->{charset} ne $input_charset);
652        $r .= qq'<li id="$node_id" class="tree-comment"><code>&lt;!--</code><q lang="">' . htescape ($child->data) . '</q><code>--&gt;</code></li>';          $r->{charset} = $input_charset;
     } elsif ($nt == $child->DOCUMENT_NODE) {  
       $r .= qq'<li id="$node_id" class="tree-document">Document</li>';  
       if ($child->has_child_nodes) {  
         $r .= '<ol>';  
         unshift @node, @{$child->child_nodes}, '</ol>';  
653        }        }
654      } elsif ($nt == $child->DOCUMENT_TYPE_NODE) {  
655        $r .= qq'<li id="$node_id" class="tree-doctype"><code>&lt;!DOCTYPE&gt;</code><ul class="attributes">';        ## TODO: Support for HTTP Content-Encoding
656        $r .= qq[<li class="tree-doctype-name">Name = <q>@{[htescape ($child->name)]}</q></li>];  
657        $r .= qq[<li class="tree-doctype-publicid">Public identifier = <q>@{[htescape ($child->public_id)]}</q></li>];        $r->{s} = ''.$res->content;
658        $r .= qq[<li class="tree-doctype-systemid">System identifier = <q>@{[htescape ($child->system_id)]}</q></li>];  
659        $r .= '</ul></li>';        require Whatpm::ContentType;
660      } elsif ($nt == $child->PROCESSING_INSTRUCTION_NODE) {        ($r->{official_type}, $r->{media_type})
661        $r .= qq'<li id="$node_id" class="tree-id"><code>&lt;?@{[htescape ($child->target)]}</code> <q>@{[htescape ($child->data)]}</q><code>?&gt;</code></li>';            = 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 .= qq'<li id="$node_id" class="tree-unknown">@{[$child->node_type]} @{[htescape ($child->node_name)]}</li>'; # error        $r->{uri} = $res->request->uri;
671          $r->{request_uri} = $request_uri;
672          $r->{error_status_text} = $res->status_line;
673      }      }
674    
675        $r->{header_field} = [];
676        $res->scan (sub {
677          push @{$r->{header_field}}, [$_[0], $_[1]];
678        });
679        $r->{header_status_code} = $res->code;
680        $r->{header_status_text} = $res->message;
681      } else {
682        $r->{s} = ''.$http->get_parameter ('s');
683        $r->{uri} = q<thismessage:/>;
684        $r->{request_uri} = q<thismessage:/>;
685        $r->{base_uri} = q<thismessage:/>;
686        $r->{charset} = ''.$http->get_parameter ('_charset_');
687        $r->{charset} =~ s/\s+//g;
688        $r->{charset} = 'utf-8' if $r->{charset} eq '';
689        $r->{official_charset} = $r->{charset};
690        $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    $r .= '</ol>';    my $input_format = $http->get_parameter ('i');
704    print STDOUT $r;    if (defined $input_format and length $input_format) {
705  } # print_document_tree      $r->{media_type_overridden}
706            = (not defined $r->{media_type} or $input_format ne $r->{media_type});
707  sub get_node_path ($) {      $r->{media_type} = $input_format;
708    my $node = shift;    }
709    my @r;    if (defined $r->{s} and not defined $r->{media_type}) {
710    while (defined $node) {      $r->{media_type} = 'text/html';
711      my $rs;      $r->{media_type_overridden} = 1;
712      if ($node->node_type == 1) {    }
713        $rs = $node->manakai_local_name;  
714        $node = $node->parent_node;    if ($r->{media_type} eq 'text/xml') {
715      } elsif ($node->node_type == 2) {      unless (defined $r->{charset}) {
716        $rs = '@' . $node->manakai_local_name;        $r->{charset} = 'us-ascii';
717        $node = $node->owner_element;        $r->{official_charset} = $r->{charset};
718      } elsif ($node->node_type == 3) {      } elsif ($r->{charset_overridden} and $r->{charset} eq 'us-ascii') {
719        $rs = '"' . $node->data . '"';        $r->{charset_overridden} = 0;
       $node = $node->parent_node;  
     } elsif ($node->node_type == 9) {  
       $rs = '';  
       $node = $node->parent_node;  
     } else {  
       $rs = '#' . $node->node_type;  
       $node = $node->parent_node;  
720      }      }
     unshift @r, $rs;  
721    }    }
722    return join '/', @r;  
723  } # get_node_path    if (length $r->{s} > 1000_000) {
724        $r->{error_status_text} = 'Entity-body too large';
725        delete $r->{s};
726        return $r;
727      }
728    
729      $r->{inner_html_element} = $http->get_parameter ('e');
730    
731      return $r;
732    } # get_input_document
733    
734    package WDCC::LWPUA;
735    BEGIN { push our @ISA, 'LWP::UserAgent'; }
736    
737    sub redirect_ok {
738      my $ua = shift;
739      unless ($ua->SUPER::redirect_ok (@_)) {
740        return 0;
741      }
742    
743      my $uris = $_[1]->header ('Location');
744      return 0 unless $uris;
745      my $uri = $ua->{wdcc_dom}->create_uri_reference ($uris);
746      unless ({
747               http => 1,
748              }->{lc $uri->uri_scheme}) {
749        return 0;
750      }
751      unless ($ua->{wdcc_host_permit}->check ($uri->uri_host, $uri->uri_port || 80)) {
752        return 0;
753      }
754      return 1;
755    } # redirect_ok
756    
757  =head1 AUTHOR  =head1 AUTHOR
758    
# Line 386  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.5  
changed lines
  Added in v.1.53
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24