/[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.15 by wakaba, Sat Jul 21 04:58:17 2007 UTC revision 1.22 by wakaba, Sun Nov 4 09:15:02 2007 UTC
# Line 2  Line 2 
2  use strict;  use strict;
3    
4  use lib qw[/home/httpd/html/www/markup/html/whatpm  use lib qw[/home/httpd/html/www/markup/html/whatpm
5             /home/wakaba/work/manakai/lib             /home/wakaba/work/manakai2/lib];
            /home/wakaba/public_html/-temp/wiki/lib];  
6  use CGI::Carp qw[fatalsToBrowser];  use CGI::Carp qw[fatalsToBrowser];
7  use Scalar::Util qw[refaddr];  use Scalar::Util qw[refaddr];
8    use Time::HiRes qw/time/;
 use SuikaWiki::Input::HTTP; ## TODO: Use some better CGI module  
9    
10  sub htescape ($) {  sub htescape ($) {
11    my $s = $_[0];    my $s = $_[0];
# Line 21  sub htescape ($) { Line 19  sub htescape ($) {
19    return $s;    return $s;
20  } # htescape  } # htescape
21    
22  my $http = SuikaWiki::Input::HTTP->new;    use Message::CGI::HTTP;
23      my $http = Message::CGI::HTTP->new;
 ## TODO: _charset_  
24    
25    if ($http->meta_variable ('PATH_INFO') ne '/') {    if ($http->get_meta_variable ('PATH_INFO') ne '/') {
26      print STDOUT "Status: 404 Not Found\nContent-Type: text/plain; charset=us-ascii\n\n400";      print STDOUT "Status: 404 Not Found\nContent-Type: text/plain; charset=us-ascii\n\n400";
27      exit;      exit;
28    }    }
# Line 54  my $http = SuikaWiki::Input::HTTP->new; Line 51  my $http = SuikaWiki::Input::HTTP->new;
51    
52    $| = 0;    $| = 0;
53    my $input = get_input_document ($http, $dom);    my $input = get_input_document ($http, $dom);
54    my $inner_html_element = $http->parameter ('e');    my $inner_html_element = $http->get_parameter ('e');
55      my $char_length = 0;
56      my %time;
57    
58    print qq[    print qq[
59  <div id="document-info" class="section">  <div id="document-info" class="section">
# Line 67  my $http = SuikaWiki::Input::HTTP->new; Line 66  my $http = SuikaWiki::Input::HTTP->new;
66    push @nav, ['#document-info' => 'Information'];    push @nav, ['#document-info' => 'Information'];
67    
68  if (defined $input->{s}) {  if (defined $input->{s}) {
69      $char_length = length $input->{s};
70    
71    print STDOUT qq[    print STDOUT qq[
72  <dt>Base URI</dt>  <dt>Base URI</dt>
# Line 77  if (defined $input->{s}) { Line 77  if (defined $input->{s}) {
77  <dt>Character Encoding</dt>  <dt>Character Encoding</dt>
78      <dd>@{[defined $input->{charset} ? '<code class="charset" lang="en">'.htescape ($input->{charset}).'</code>' : '(none)']}      <dd>@{[defined $input->{charset} ? '<code class="charset" lang="en">'.htescape ($input->{charset}).'</code>' : '(none)']}
79      @{[$input->{charset_overridden} ? '<em>(overridden)</em>' : '']}</dd>      @{[$input->{charset_overridden} ? '<em>(overridden)</em>' : '']}</dd>
80    <dt>Length</dt>
81        <dd>$char_length byte@{[$char_length == 1 ? '' : 's']}</dd>
82  </dl>  </dl>
83  </div>  </div>
84  ];  ];
85    
86    print_http_header_section ($input);    my $result = {conforming_min => 1, conforming_max => 1};
87      print_http_header_section ($input, $result);
88    
89    my $doc;    my $doc;
90    my $el;    my $el;
91      my $manifest;
92    
93    if ($input->{media_type} eq 'text/html') {    if ($input->{media_type} eq 'text/html') {
94      require Encode;      ($doc, $el) = print_syntax_error_html_section ($input, $result);
     require Whatpm::HTML;  
   
     $input->{charset} ||= 'ISO-8859-1'; ## TODO: for now.  
       
     my $t = Encode::decode ($input->{charset}, $input->{s});  
   
     print STDOUT qq[  
 <div id="parse-errors" class="section">  
 <h2>Parse Errors</h2>  
   
 <dl>];  
   push @nav, ['#parse-errors' => 'Parse Error'];  
   
   my $onerror = sub {  
     my (%opt) = @_;  
     my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level});  
     if ($opt{column} > 0) {  
       print STDOUT qq[<dt class="$cls"><a href="#line-$opt{line}">Line $opt{line}</a> column $opt{column}</dt>\n];  
     } else {  
       $opt{line} = $opt{line} - 1 || 1;  
       print STDOUT qq[<dt class="$cls"><a href="#line-$opt{line}">Line $opt{line}</a></dt>\n];  
     }  
     $type =~ tr/ /-/;  
     $type =~ s/\|/%7C/g;  
     $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];  
     print STDOUT qq[<dd class="$cls">$msg</dd>\n];  
   };  
   
   $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, $t, $onerror);  
   } else {  
     Whatpm::HTML->parse_string ($t => $doc, $onerror);  
   }  
   
   print STDOUT qq[</dl>  
 </div>  
 ];  
   
95      print_source_string_section (\($input->{s}), $input->{charset});      print_source_string_section (\($input->{s}), $input->{charset});
96    } elsif ({    } elsif ({
97              'text/xml' => 1,              'text/xml' => 1,
98                'application/atom+xml' => 1,
99                'application/rss+xml' => 1,
100                'application/svg+xml' => 1,
101              'application/xhtml+xml' => 1,              'application/xhtml+xml' => 1,
102              'application/xml' => 1,              'application/xml' => 1,
103             }->{$input->{media_type}}) {             }->{$input->{media_type}}) {
104      require Message::DOM::XMLParserTemp;      ($doc, $el) = print_syntax_error_xml_section ($input, $result);
   
     print STDOUT qq[  
 <div id="parse-errors" class="section">  
 <h2>Parse Errors</h2>  
   
 <dl>];  
   push @nav, ['#parse-errors' => 'Parse Error'];  
   
   my $onerror = sub {  
     my $err = shift;  
     my $line = $err->location->line_number;  
     print STDOUT qq[<dt><a href="#line-$line">Line $line</a> column ];  
     print STDOUT $err->location->column_number, "</dt><dd>";  
     print STDOUT htescape $err->text, "</dd>\n";  
     return 1;  
   };  
   
   open my $fh, '<', \($input->{s});  
   $doc = Message::DOM::XMLParserTemp->parse_byte_stream  
       ($fh => $dom, $onerror, charset => $input->{charset});  
   
     print STDOUT qq[</dl>  
 </div>  
   
 ];  
105      print_source_string_section (\($input->{s}), $doc->input_encoding);      print_source_string_section (\($input->{s}), $doc->input_encoding);
106      } elsif ($input->{media_type} eq 'text/cache-manifest') {
107    ## TODO: MUST be text/cache-manifest
108        $manifest = print_syntax_error_manifest_section ($input, $result);
109        print_source_string_section (\($input->{s}), 'utf-8');
110    } else {    } else {
111      ## TODO: Change HTTP status code??      ## TODO: Change HTTP status code??
112      print STDOUT qq[      print_result_unknown_type_section ($input);
 <div id="result-summary" class="section">  
 <p><em>Media type <code class="MIME" lang="en">@{[htescape $input->{media_type}]}</code> is not supported!</em></p>  
 </div>  
 ];  
     push @nav, ['#result-summary' => 'Result'];  
113    }    }
114    
   
115    if (defined $doc or defined $el) {    if (defined $doc or defined $el) {
116      print STDOUT qq[      print_structure_dump_dom_section ($doc, $el);
117  <div id="document-tree" class="section">      my $elements = print_structure_error_dom_section ($doc, $el, $result);
118  <h2>Document Tree</h2>      print_table_section ($elements->{table}) if @{$elements->{table}};
119  ];      print_id_section ($elements->{id}) if keys %{$elements->{id}};
120      push @nav, ['#document-tree' => 'Tree'];      print_term_section ($elements->{term}) if keys %{$elements->{term}};
121        print_class_section ($elements->{class}) if keys %{$elements->{class}};
122      print_document_tree ($el || $doc);    } elsif (defined $manifest) {
123        print_structure_dump_manifest_section ($manifest);
124      print STDOUT qq[      print_structure_error_manifest_section ($manifest, $result);
 </div>  
   
 <div id="document-errors" class="section">  
 <h2>Document Errors</h2>  
   
 <dl>];  
     push @nav, ['#document-errors' => 'Document Error'];  
   
     require Whatpm::ContentChecker;  
     my $onerror = sub {  
       my %opt = @_;  
       my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level}, $opt{node});  
       $type =~ tr/ /-/;  
       $type =~ s/\|/%7C/g;  
       $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];  
       print STDOUT qq[<dt class="$cls">] . get_node_link ($opt{node}) .  
           qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";  
     };  
   
     my $elements;  
     if ($el) {  
       $elements = Whatpm::ContentChecker->check_element ($el, $onerror);  
     } else {  
       $elements = Whatpm::ContentChecker->check_document ($doc, $onerror);  
     }  
   
     print STDOUT qq[</dl>  
 </div>  
 ];  
   
     if (@{$elements->{table}}) {  
       require JSON;  
   
       push @nav, ['#tables' => 'Tables'];  
       print STDOUT qq[  
 <div id="tables" class="section">  
 <h2>Tables</h2>  
   
 <!--[if IE]><script type="text/javascript" src="../excanvas.js"></script><![endif]-->  
 <script src="../table-script.js" type="text/javascript"></script>  
 <noscript>  
 <p><em>Structure of tables are visualized here if scripting is enabled.</em></p>  
 </noscript>  
 ];  
   
       my $i = 0;  
       for my $table_el (@{$elements->{table}}) {  
         $i++;  
         print STDOUT qq[<div class="section" id="table-$i"><h3>] .  
             get_node_link ($table_el) . q[</h3>];  
   
         ## TODO: Make |ContentChecker| return |form_table| result  
         ## so that this script don't have to run the algorithm twice.  
         my $table = Whatpm::HTMLTable->form_table ($table_el);  
           
         for (@{$table->{column_group}}, @{$table->{column}}, $table->{caption}) {  
           next unless $_;  
           delete $_->{element};  
         }  
           
         for (@{$table->{row_group}}) {  
           next unless $_;  
           next unless $_->{element};  
           $_->{type} = $_->{element}->manakai_local_name;  
           delete $_->{element};  
         }  
           
         for (@{$table->{cell}}) {  
           next unless $_;  
           for (@{$_}) {  
             next unless $_;  
             for (@$_) {  
               $_->{id} = refaddr $_->{element} if defined $_->{element};  
               delete $_->{element};  
               $_->{is_header} = $_->{is_header} ? 1 : 0;  
             }  
           }  
         }  
           
         print STDOUT '</div><script type="text/javascript">tableToCanvas (';  
         print STDOUT JSON::objToJson ($table);  
         print STDOUT qq[, document.getElementById ('table-$i'));</script>];  
       }  
       
       print STDOUT qq[</div>];  
     }  
   
     if (keys %{$elements->{id}}) {  
       push @nav, ['#identifiers' => 'IDs'];  
       print STDOUT qq[  
 <div id="identifiers" class="section">  
 <h2>Identifiers</h2>  
   
 <dl>  
 ];  
       for my $id (sort {$a cmp $b} keys %{$elements->{id}}) {  
         print STDOUT qq[<dt><code>@{[htescape $id]}</code></dt>];  
         for (@{$elements->{id}->{$id}}) {  
           print STDOUT qq[<dd>].get_node_link ($_).qq[</dd>];  
         }  
       }  
       print STDOUT qq[</dl></div>];  
     }  
   
     if (keys %{$elements->{term}}) {  
       push @nav, ['#terms' => 'Terms'];  
       print STDOUT qq[  
 <div id="terms" class="section">  
 <h2>Terms</h2>  
   
 <dl>  
 ];  
       for my $term (sort {$a cmp $b} keys %{$elements->{term}}) {  
         print STDOUT qq[<dt>@{[htescape $term]}</dt>];  
         for (@{$elements->{term}->{$term}}) {  
           print STDOUT qq[<dd>].get_node_link ($_).qq[</dd>];  
         }  
       }  
       print STDOUT qq[</dl></div>];  
     }  
   
     if (keys %{$elements->{class}}) {  
       push @nav, ['#classes' => 'Classes'];  
       print STDOUT qq[  
 <div id="classes" class="section">  
 <h2>Classes</h2>  
   
 <dl>  
 ];  
       for my $class (sort {$a cmp $b} keys %{$elements->{class}}) {  
         print STDOUT qq[<dt><code>@{[htescape $class]}</code></dt>];  
         for (@{$elements->{class}->{$class}}) {  
           print STDOUT qq[<dd>].get_node_link ($_).qq[</dd>];  
         }  
       }  
       print STDOUT qq[</dl></div>];  
     }  
125    }    }
126    
127    ## TODO: Show result    print_result_section ($result);
128  } else {  } else {
129    print STDOUT qq[    print STDOUT qq[</dl></div>];
130  </dl>    print_result_input_error_section ($input);
 </div>  
   
 <div class="section" id="result-summary">  
 <p><em><strong>Input Error</strong>: @{[htescape ($input->{error_status_text})]}</em></p>  
 </div>  
 ];  
   push @nav, ['#result-summary' => 'Result'];  
   
131  }  }
132    
133    print STDOUT qq[    print STDOUT qq[
# Line 348  if (defined $input->{s}) { Line 142  if (defined $input->{s}) {
142  </html>  </html>
143  ];  ];
144    
145      for (qw/decode parse parse_xml parse_manifest check check_manifest/) {
146        next unless defined $time{$_};
147        open my $file, '>>', ".cc-$_.txt" or die ".cc-$_.txt: $!";
148        print $file $char_length, "\t", $time{$_}, "\n";
149      }
150    
151  exit;  exit;
152    
153  sub print_http_header_section ($) {  sub add_error ($$$) {
154    my $input = shift;    my ($layer, $err, $result) = @_;
155      if (defined $err->{level}) {
156        if ($err->{level} eq 's') {
157          $result->{$layer}->{should}++;
158          $result->{$layer}->{score_min} -= 2;
159          $result->{conforming_min} = 0;
160        } elsif ($err->{level} eq 'w' or $err->{level} eq 'g') {
161          $result->{$layer}->{warning}++;
162        } elsif ($err->{level} eq 'unsupported') {
163          $result->{$layer}->{unsupported}++;
164          $result->{unsupported} = 1;
165        } else {
166          $result->{$layer}->{must}++;
167          $result->{$layer}->{score_max} -= 2;
168          $result->{$layer}->{score_min} -= 2;
169          $result->{conforming_min} = 0;
170          $result->{conforming_max} = 0;
171        }
172      } else {
173        $result->{$layer}->{must}++;
174        $result->{$layer}->{score_max} -= 2;
175        $result->{$layer}->{score_min} -= 2;
176        $result->{conforming_min} = 0;
177        $result->{conforming_max} = 0;
178      }
179    } # add_error
180    
181    sub print_http_header_section ($$) {
182      my ($input, $result) = @_;
183    return unless defined $input->{header_status_code} or    return unless defined $input->{header_status_code} or
184        defined $input->{header_status_text} or        defined $input->{header_status_text} or
185        @{$input->{header_field}};        @{$input->{header_field}};
# Line 384  not be the real header.</p> Line 212  not be the real header.</p>
212    print STDOUT qq[</tbody></table></div>];    print STDOUT qq[</tbody></table></div>];
213  } # print_http_header_section  } # print_http_header_section
214    
215    sub print_syntax_error_html_section ($$) {
216      my ($input, $result) = @_;
217      
218      require Encode;
219      require Whatpm::HTML;
220    
221      $input->{charset} ||= 'ISO-8859-1'; ## TODO: for now.
222      
223      my $time1 = time;
224      my $t = Encode::decode ($input->{charset}, $input->{s});
225      $time{decode} = time - $time1;
226    
227      print STDOUT qq[
228    <div id="parse-errors" class="section">
229    <h2>Parse Errors</h2>
230    
231    <dl>];
232      push @nav, ['#parse-errors' => 'Parse Error'];
233    
234      my $onerror = sub {
235        my (%opt) = @_;
236        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level});
237        if ($opt{column} > 0) {
238          print STDOUT qq[<dt class="$cls"><a href="#line-$opt{line}">Line $opt{line}</a> column $opt{column}</dt>\n];
239        } else {
240          $opt{line} = $opt{line} - 1 || 1;
241          print STDOUT qq[<dt class="$cls"><a href="#line-$opt{line}">Line $opt{line}</a></dt>\n];
242        }
243        $type =~ tr/ /-/;
244        $type =~ s/\|/%7C/g;
245        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
246        print STDOUT qq[<dd class="$cls">$msg</dd>\n];
247    
248        add_error ('syntax', \%opt => $result);
249      };
250    
251      my $doc = $dom->create_document;
252      my $el;
253      $time1 = time;
254      if (defined $inner_html_element and length $inner_html_element) {
255        $el = $doc->create_element_ns
256            ('http://www.w3.org/1999/xhtml', [undef, $inner_html_element]);
257        Whatpm::HTML->set_inner_html ($el, $t, $onerror);
258      } else {
259        Whatpm::HTML->parse_string ($t => $doc, $onerror);
260      }
261      $time{parse} = time - $time1;
262    
263      print STDOUT qq[</dl></div>];
264    
265      return ($doc, $el);
266    } # print_syntax_error_html_section
267    
268    sub print_syntax_error_xml_section ($$) {
269      my ($input, $result) = @_;
270      
271      require Message::DOM::XMLParserTemp;
272      
273      print STDOUT qq[
274    <div id="parse-errors" class="section">
275    <h2>Parse Errors</h2>
276    
277    <dl>];
278      push @nav, ['#parse-errors' => 'Parse Error'];
279    
280      my $onerror = sub {
281        my $err = shift;
282        my $line = $err->location->line_number;
283        print STDOUT qq[<dt><a href="#line-$line">Line $line</a> column ];
284        print STDOUT $err->location->column_number, "</dt><dd>";
285        print STDOUT htescape $err->text, "</dd>\n";
286    
287        add_error ('syntax', {type => $err->text,
288                    level => [
289                              $err->SEVERITY_FATAL_ERROR => 'm',
290                              $err->SEVERITY_ERROR => 'm',
291                              $err->SEVERITY_WARNING => 's',
292                             ]->[$err->severity]} => $result);
293    
294        return 1;
295      };
296    
297      my $time1 = time;
298      open my $fh, '<', \($input->{s});
299      my $doc = Message::DOM::XMLParserTemp->parse_byte_stream
300          ($fh => $dom, $onerror, charset => $input->{charset});
301      $time{parse_xml} = time - $time1;
302    
303      print STDOUT qq[</dl></div>];
304    
305      return ($doc, undef);
306    } # print_syntax_error_xml_section
307    
308    sub print_syntax_error_manifest_section ($$) {
309      my ($input, $result) = @_;
310    
311      require Whatpm::CacheManifest;
312    
313      print STDOUT qq[
314    <div id="parse-errors" class="section">
315    <h2>Parse Errors</h2>
316    
317    <dl>];
318      push @nav, ['#parse-errors' => 'Parse Error'];
319    
320      my $onerror = sub {
321        my (%opt) = @_;
322        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level});
323        print STDOUT qq[<dt class="$cls">], get_error_label (\%opt), qq[</dt>];
324        $type =~ tr/ /-/;
325        $type =~ s/\|/%7C/g;
326        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
327        print STDOUT qq[<dd class="$cls">$msg</dd>\n];
328    
329        add_error ('syntax', \%opt => $result);
330      };
331    
332      my $time1 = time;
333      my $manifest = Whatpm::CacheManifest->parse_byte_string
334          ($input->{s}, $input->{uri}, $input->{base_uri}, $onerror);
335      $time{parse_manifest} = time - $time1;
336    
337      print STDOUT qq[</dl></div>];
338    
339      return $manifest;
340    } # print_syntax_error_manifest_section
341    
342  sub print_source_string_section ($$) {  sub print_source_string_section ($$) {
343    require Encode;    require Encode;
344    my $enc = Encode::find_encoding ($_[1]); ## TODO: charset name -> Perl name    my $enc = Encode::find_encoding ($_[1]); ## TODO: charset name -> Perl name
# Line 486  sub print_document_tree ($) { Line 441  sub print_document_tree ($) {
441    print STDOUT $r;    print STDOUT $r;
442  } # print_document_tree  } # print_document_tree
443    
444    sub print_structure_dump_dom_section ($$) {
445      my ($doc, $el) = @_;
446    
447      print STDOUT qq[
448    <div id="document-tree" class="section">
449    <h2>Document Tree</h2>
450    ];
451      push @nav, ['#document-tree' => 'Tree'];
452    
453      print_document_tree ($el || $doc);
454    
455      print STDOUT qq[</div>];
456    } # print_structure_dump_dom_section
457    
458    sub print_structure_dump_manifest_section ($) {
459      my $manifest = shift;
460    
461      print STDOUT qq[
462    <div id="dump-manifest" class="section">
463    <h2>Cache Manifest</h2>
464    ];
465      push @nav, ['#dump-manifest' => 'Caceh Manifest'];
466    
467      print STDOUT qq[<dl><dt>Explicit entries</dt>];
468      for my $uri (@{$manifest->[0]}) {
469        my $euri = htescape ($uri);
470        print STDOUT qq[<dd><code class=uri>&lt;<a href="$euri">$euri</a>></code></dd>];
471      }
472    
473      print STDOUT qq[<dt>Fallback entries</dt><dd>
474          <table><thead><tr><th scope=row>Oppotunistic Caching Namespace</th>
475          <th scope=row>Fallback Entry</tr><tbody>];
476      for my $uri (sort {$a cmp $b} keys %{$manifest->[1]}) {
477        my $euri = htescape ($uri);
478        my $euri2 = htescape ($manifest->[1]->{$uri});
479        print STDOUT qq[<tr><td><code class=uri>&lt;<a href="$euri">$euri</a>></code></td>
480            <td><code class=uri>&lt;<a href="$euri2">$euri2</a>></code></td>];
481      }
482    
483      print STDOUT qq[</table><dt>Online whitelist</dt>];
484      for my $uri (@{$manifest->[2]}) {
485        my $euri = htescape ($uri);
486        print STDOUT qq[<dd><code class=uri>&lt;<a href="$euri">$euri</a>></code></dd>];
487      }
488    
489      print STDOUT qq[</dl></div>];
490    } # print_structure_dump_manifest_section
491    
492    sub print_structure_error_dom_section ($$$) {
493      my ($doc, $el, $result) = @_;
494    
495      print STDOUT qq[<div id="document-errors" class="section">
496    <h2>Document Errors</h2>
497    
498    <dl>];
499      push @nav, ['#document-errors' => 'Document Error'];
500    
501      require Whatpm::ContentChecker;
502      my $onerror = sub {
503        my %opt = @_;
504        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level}, $opt{node});
505        $type =~ tr/ /-/;
506        $type =~ s/\|/%7C/g;
507        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
508        print STDOUT qq[<dt class="$cls">] . get_error_label (\%opt) .
509            qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";
510        add_error ('structure', \%opt => $result);
511      };
512    
513      my $elements;
514      my $time1 = time;
515      if ($el) {
516        $elements = Whatpm::ContentChecker->check_element ($el, $onerror);
517      } else {
518        $elements = Whatpm::ContentChecker->check_document ($doc, $onerror);
519      }
520      $time{check} = time - $time1;
521    
522      print STDOUT qq[</dl></div>];
523    
524      return $elements;
525    } # print_structure_error_dom_section
526    
527    sub print_structure_error_manifest_section ($$$) {
528      my ($manifest, $result) = @_;
529    
530      print STDOUT qq[<div id="document-errors" class="section">
531    <h2>Document Errors</h2>
532    
533    <dl>];
534      push @nav, ['#document-errors' => 'Document Error'];
535    
536      require Whatpm::CacheManifest;
537      Whatpm::CacheManifest->check_manifest ($manifest, sub {
538        my %opt = @_;
539        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level}, $opt{node});
540        $type =~ tr/ /-/;
541        $type =~ s/\|/%7C/g;
542        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
543        print STDOUT qq[<dt class="$cls">] . get_error_label (\%opt) .
544            qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";
545        add_error ('structure', \%opt => $result);
546      });
547    
548      print STDOUT qq[</div>];
549    } # print_structure_error_manifest_section
550    
551    sub print_table_section ($) {
552      my $tables = shift;
553      
554      push @nav, ['#tables' => 'Tables'];
555      print STDOUT qq[
556    <div id="tables" class="section">
557    <h2>Tables</h2>
558    
559    <!--[if IE]><script type="text/javascript" src="../excanvas.js"></script><![endif]-->
560    <script src="../table-script.js" type="text/javascript"></script>
561    <noscript>
562    <p><em>Structure of tables are visualized here if scripting is enabled.</em></p>
563    </noscript>
564    ];
565      
566      require JSON;
567      
568      my $i = 0;
569      for my $table_el (@$tables) {
570        $i++;
571        print STDOUT qq[<div class="section" id="table-$i"><h3>] .
572            get_node_link ($table_el) . q[</h3>];
573    
574        ## TODO: Make |ContentChecker| return |form_table| result
575        ## so that this script don't have to run the algorithm twice.
576        my $table = Whatpm::HTMLTable->form_table ($table_el);
577        
578        for (@{$table->{column_group}}, @{$table->{column}}, $table->{caption}) {
579          next unless $_;
580          delete $_->{element};
581        }
582        
583        for (@{$table->{row_group}}) {
584          next unless $_;
585          next unless $_->{element};
586          $_->{type} = $_->{element}->manakai_local_name;
587          delete $_->{element};
588        }
589        
590        for (@{$table->{cell}}) {
591          next unless $_;
592          for (@{$_}) {
593            next unless $_;
594            for (@$_) {
595              $_->{id} = refaddr $_->{element} if defined $_->{element};
596              delete $_->{element};
597              $_->{is_header} = $_->{is_header} ? 1 : 0;
598            }
599          }
600        }
601            
602        print STDOUT '</div><script type="text/javascript">tableToCanvas (';
603        print STDOUT JSON::objToJson ($table);
604        print STDOUT qq[, document.getElementById ('table-$i'));</script>];
605      }
606      
607      print STDOUT qq[</div>];
608    } # print_table_section
609    
610    sub print_id_section ($) {
611      my $ids = shift;
612      
613      push @nav, ['#identifiers' => 'IDs'];
614      print STDOUT qq[
615    <div id="identifiers" class="section">
616    <h2>Identifiers</h2>
617    
618    <dl>
619    ];
620      for my $id (sort {$a cmp $b} keys %$ids) {
621        print STDOUT qq[<dt><code>@{[htescape $id]}</code></dt>];
622        for (@{$ids->{$id}}) {
623          print STDOUT qq[<dd>].get_node_link ($_).qq[</dd>];
624        }
625      }
626      print STDOUT qq[</dl></div>];
627    } # print_id_section
628    
629    sub print_term_section ($) {
630      my $terms = shift;
631      
632      push @nav, ['#terms' => 'Terms'];
633      print STDOUT qq[
634    <div id="terms" class="section">
635    <h2>Terms</h2>
636    
637    <dl>
638    ];
639      for my $term (sort {$a cmp $b} keys %$terms) {
640        print STDOUT qq[<dt>@{[htescape $term]}</dt>];
641        for (@{$terms->{$term}}) {
642          print STDOUT qq[<dd>].get_node_link ($_).qq[</dd>];
643        }
644      }
645      print STDOUT qq[</dl></div>];
646    } # print_term_section
647    
648    sub print_class_section ($) {
649      my $classes = shift;
650      
651      push @nav, ['#classes' => 'Classes'];
652      print STDOUT qq[
653    <div id="classes" class="section">
654    <h2>Classes</h2>
655    
656    <dl>
657    ];
658      for my $class (sort {$a cmp $b} keys %$classes) {
659        print STDOUT qq[<dt><code>@{[htescape $class]}</code></dt>];
660        for (@{$classes->{$class}}) {
661          print STDOUT qq[<dd>].get_node_link ($_).qq[</dd>];
662        }
663      }
664      print STDOUT qq[</dl></div>];
665    } # print_class_section
666    
667    sub print_result_section ($) {
668      my $result = shift;
669    
670      print STDOUT qq[
671    <div id="result-summary" class="section">
672    <h2>Result</h2>];
673    
674      if ($result->{unsupported} and $result->{conforming_max}) {  
675        print STDOUT qq[<p class=uncertain id=result-para>The conformance
676            checker cannot decide whether the document is conforming or
677            not, since the document contains one or more unsupported
678            features.  The document might or might not be conforming.</p>];
679      } elsif ($result->{conforming_min}) {
680        print STDOUT qq[<p class=PASS id=result-para>No conformance-error is
681            found in this document.</p>];
682      } elsif ($result->{conforming_max}) {
683        print STDOUT qq[<p class=SEE-RESULT id=result-para>This document
684            is <strong>likely <em>non</em>-conforming</strong>, but in rare case
685            it might be conforming.</p>];
686      } else {
687        print STDOUT qq[<p class=FAIL id=result-para>This document is
688            <strong><em>non</em>-conforming</strong>.</p>];
689      }
690    
691      print STDOUT qq[<table>
692    <colgroup><col><colgroup><col><col><col><colgroup><col>
693    <thead>
694    <tr><th scope=col></th><th scope=col><em class=rfc2119>MUST</em>-level
695    Errors</th><th scope=col><em class=rfc2119>SHOULD</em>-level
696    Errors</th><th scope=col>Warnings</th><th scope=col>Score</th></tr>
697    </thead><tbody>];
698    
699      my $must_error = 0;
700      my $should_error = 0;
701      my $warning = 0;
702      my $score_min = 0;
703      my $score_max = 0;
704      my $score_base = 20;
705      my $score_unit = $score_base / 100;
706      for (
707        [Transfer => 'transfer', ''],
708        [Character => 'char', ''],
709        [Syntax => 'syntax', '#parse-errors'],
710        [Structure => 'structure', '#document-errors'],
711      ) {
712        $must_error += ($result->{$_->[1]}->{must} += 0);
713        $should_error += ($result->{$_->[1]}->{should} += 0);
714        $warning += ($result->{$_->[1]}->{warning} += 0);
715        $score_min += (($result->{$_->[1]}->{score_min} *= $score_unit) += $score_base);
716        $score_max += (($result->{$_->[1]}->{score_max} *= $score_unit) += $score_base);
717    
718        my $uncertain = $result->{$_->[1]}->{unsupported} ? '?' : '';
719        my $label = $_->[0];
720        if ($result->{$_->[1]}->{must} or
721            $result->{$_->[1]}->{should} or
722            $result->{$_->[1]}->{warning} or
723            $result->{$_->[1]}->{unsupported}) {
724          $label = qq[<a href="$_->[2]">$label</a>];
725        }
726    
727        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>];
728        if ($uncertain) {
729          print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : $result->{$_->[1]}->{should} ? 'SEE-RESULT' : '']}">&#x2212;&#x221E;..$result->{$_->[1]}->{score_max}</td>];
730        } elsif ($result->{$_->[1]}->{score_min} != $result->{$_->[1]}->{score_max}) {
731          print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : 'SEE-RESULT']}">$result->{$_->[1]}->{score_min}..$result->{$_->[1]}->{score_max}</td></tr>];
732        } else {
733          print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : '']}">$result->{$_->[1]}->{score_min}</td></tr>];
734        }
735      }
736    
737      $score_max += $score_base;
738    
739      print STDOUT qq[
740    <tr class=uncertain><th scope=row>Semantics</th><td>0?</td><td>0?</td><td>0?</td><td>&#x2212;&#x221E;..$score_base</td></tr>
741    </tbody>
742    <tfoot><tr class=uncertain><th scope=row>Total</th>
743    <td class="@{[$must_error ? 'FAIL' : '']}">$must_error?</td>
744    <td class="@{[$should_error ? 'SEE-RESULT' : '']}">$should_error?</td>
745    <td>$warning?</td>
746    <td class="@{[$must_error ? 'FAIL' : $should_error ? 'SEE-RESULT' : '']}"><strong>&#x2212;&#x221E;..$score_max</strong></td></tr></tfoot>
747    </table>
748    
749    <p><strong>Important</strong>: This conformance checking service
750    is <em>under development</em>.  The result above might be <em>wrong</em>.</p>
751    </div>];
752      push @nav, ['#result-summary' => 'Result'];
753    } # print_result_section
754    
755    sub print_result_unknown_type_section ($) {
756      my $input = shift;
757    
758      print STDOUT qq[
759    <div id="result-summary" class="section">
760    <p><em>Media type <code class="MIME" lang="en">@{[htescape $input->{media_type}]}</code> is not supported!</em></p>
761    </div>
762    ];
763      push @nav, ['#result-summary' => 'Result'];
764    } # print_result_unknown_type_section
765    
766    sub print_result_input_error_section ($) {
767      my $input = shift;
768      print STDOUT qq[<div class="section" id="result-summary">
769    <p><em><strong>Input Error</strong>: @{[htescape ($input->{error_status_text})]}</em></p>
770    </div>];
771      push @nav, ['#result-summary' => 'Result'];
772    } # print_Result_input_error_section
773    
774    sub get_error_label ($) {
775      my $err = shift;
776    
777      my $r = '';
778    
779      if (defined $err->{line}) {
780        if ($err->{column} > 0) {
781          $r = qq[<a href="#line-$err->{line}">Line $err->{line}</a> column $err->{column}];
782        } else {
783          $err->{line} = $err->{line} - 1 || 1;
784          $r = qq[<a href="#line-$err->{line}">Line $err->{line}</a>];
785        }
786      }
787    
788      if (defined $err->{node}) {
789        $r .= ' ' if length $r;
790        $r = get_node_path ($err->{node});
791      }
792    
793      if (defined $err->{index}) {
794        $r .= ' ' if length $r;
795        $r .= 'Index ' . (0+$err->{index});
796      }
797    
798      if (defined $err->{value}) {
799        $r .= ' ' if length $r;
800        $r .= '<q><code>' . htescape ($err->{value}) . '</code></q>';
801      }
802    
803      return $r;
804    } # get_error_label
805    
806  sub get_node_path ($) {  sub get_node_path ($) {
807    my $node = shift;    my $node = shift;
808    my @r;    my @r;
# Line 550  sub get_text ($) { Line 867  sub get_text ($) {
867        $msg =~ s{<var>{\@}</var>}{        $msg =~ s{<var>{\@}</var>}{
868          UNIVERSAL::can ($node, 'value') ? htescape ($node->value) : ''          UNIVERSAL::can ($node, 'value') ? htescape ($node->value) : ''
869        }ge;        }ge;
870          $msg =~ s{<var>{local-name}</var>}{
871            UNIVERSAL::can ($node, 'manakai_local_name')
872              ? htescape ($node->manakai_local_name) : ''
873          }ge;
874          $msg =~ s{<var>{element-local-name}</var>}{
875            (UNIVERSAL::can ($node, 'owner_element') and
876             $node->owner_element)
877              ? htescape ($node->owner_element->manakai_local_name)
878              : ''
879          }ge;
880        return ($type, $Msg->{$type}->[0], $msg);        return ($type, $Msg->{$type}->[0], $msg);
881      } elsif ($type =~ s/:([^:]*)$//) {      } elsif ($type =~ s/:([^:]*)$//) {
882        unshift @arg, $1;        unshift @arg, $1;
# Line 564  sub get_text ($) { Line 891  sub get_text ($) {
891  sub get_input_document ($$) {  sub get_input_document ($$) {
892    my ($http, $dom) = @_;    my ($http, $dom) = @_;
893    
894    my $request_uri = $http->parameter ('uri');    my $request_uri = $http->get_parameter ('uri');
895    my $r = {};    my $r = {};
896    if (defined $request_uri and length $request_uri) {    if (defined $request_uri and length $request_uri) {
897      my $uri = $dom->create_uri_reference ($request_uri);      my $uri = $dom->create_uri_reference ($request_uri);
# Line 613  EOH Line 940  EOH
940      $ua->max_size (1000_000);      $ua->max_size (1000_000);
941      my $req = HTTP::Request->new (GET => $request_uri);      my $req = HTTP::Request->new (GET => $request_uri);
942      my $res = $ua->request ($req);      my $res = $ua->request ($req);
943      if ($res->is_success or $http->parameter ('error-page')) {      ## TODO: 401 sets |is_success| true.
944        if ($res->is_success or $http->get_parameter ('error-page')) {
945        $r->{base_uri} = $res->base; ## NOTE: It does check |Content-Base|, |Content-Location|, and <base>. ## TODO: Use our own code!        $r->{base_uri} = $res->base; ## NOTE: It does check |Content-Base|, |Content-Location|, and <base>. ## TODO: Use our own code!
946        $r->{uri} = $res->request->uri;        $r->{uri} = $res->request->uri;
947        $r->{request_uri} = $request_uri;        $r->{request_uri} = $request_uri;
# Line 623  EOH Line 951  EOH
951        if (defined $ct and $ct =~ m#^([0-9A-Za-z._+-]+/[0-9A-Za-z._+-]+)#) {        if (defined $ct and $ct =~ m#^([0-9A-Za-z._+-]+/[0-9A-Za-z._+-]+)#) {
952          $r->{media_type} = lc $1;          $r->{media_type} = lc $1;
953        }        }
954        if (defined $ct and $ct =~ /;\s*charset\s*=\s*"?(\S+)"?/i) {        if (defined $ct and $ct =~ /;\s*charset\s*=\s*"?([^\s;"]+)"?/i) {
955          $r->{charset} = lc $1;          $r->{charset} = lc $1;
956          $r->{charset} =~ tr/\\//d;          $r->{charset} =~ tr/\\//d;
957        }        }
958    
959        my $input_charset = $http->parameter ('charset');        my $input_charset = $http->get_parameter ('charset');
960        if (defined $input_charset and length $input_charset) {        if (defined $input_charset and length $input_charset) {
961          $r->{charset_overridden}          $r->{charset_overridden}
962              = (not defined $r->{charset} or $r->{charset} ne $input_charset);              = (not defined $r->{charset} or $r->{charset} ne $input_charset);
# Line 649  EOH Line 977  EOH
977      $r->{header_status_code} = $res->code;      $r->{header_status_code} = $res->code;
978      $r->{header_status_text} = $res->message;      $r->{header_status_text} = $res->message;
979    } else {    } else {
980      $r->{s} = ''.$http->parameter ('s');      $r->{s} = ''.$http->get_parameter ('s');
981      $r->{uri} = q<thismessage:/>;      $r->{uri} = q<thismessage:/>;
982      $r->{request_uri} = q<thismessage:/>;      $r->{request_uri} = q<thismessage:/>;
983      $r->{base_uri} = q<thismessage:/>;      $r->{base_uri} = q<thismessage:/>;
984      $r->{charset} = ''.$http->parameter ('_charset_');      $r->{charset} = ''.$http->get_parameter ('_charset_');
985      $r->{charset} =~ s/\s+//g;      $r->{charset} =~ s/\s+//g;
986      $r->{charset} = 'utf-8' if $r->{charset} eq '';      $r->{charset} = 'utf-8' if $r->{charset} eq '';
987      $r->{header_field} = [];      $r->{header_field} = [];
988    }    }
989    
990    my $input_format = $http->parameter ('i');    my $input_format = $http->get_parameter ('i');
991    if (defined $input_format and length $input_format) {    if (defined $input_format and length $input_format) {
992      $r->{media_type_overridden}      $r->{media_type_overridden}
993          = (not defined $r->{media_type} or $input_format ne $r->{media_type});          = (not defined $r->{media_type} or $input_format ne $r->{media_type});
Legend:
Removed from v.1.15  
changed lines
  Added in v.1.22
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24