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

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

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

revision 1.16 by wakaba, Sat Aug 11 13:54:55 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/manakai2/lib];             /home/wakaba/work/manakai2/lib];
# Line 54  sub htescape ($) { Line 55  sub htescape ($) {
55    my $inner_html_element = $http->get_parameter ('e');    my $inner_html_element = $http->get_parameter ('e');
56    my $char_length = 0;    my $char_length = 0;
57    my %time;    my %time;
   my $time1;  
   my $time2;  
58    
59    print qq[    print qq[
60  <div id="document-info" class="section">  <div id="document-info" class="section">
# Line 85  if (defined $input->{s}) { Line 84  if (defined $input->{s}) {
84  </div>  </div>
85  ];  ];
86    
87    print_http_header_section ($input);    my $result = {conforming_min => 1, conforming_max => 1};
88      print_http_header_section ($input, $result);
89    
90    my $doc;    my $doc;
91    my $el;    my $el;
92      my $manifest;
93    
94    if ($input->{media_type} eq 'text/html') {    if ($input->{media_type} eq 'text/html') {
95      require Encode;      ($doc, $el) = print_syntax_error_html_section ($input, $result);
     require Whatpm::HTML;  
   
     $input->{charset} ||= 'ISO-8859-1'; ## TODO: for now.  
   
     $time1 = time;  
     my $t = Encode::decode ($input->{charset}, $input->{s});  
     $time2 = time;  
     $time{decode} = $time2 - $time1;  
   
     print STDOUT qq[  
 <div id="parse-errors" class="section">  
 <h2>Parse Errors</h2>  
   
 <dl>];  
   push @nav, ['#parse-errors' => 'Parse Error'];  
   
   my $onerror = sub {  
     my (%opt) = @_;  
     my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level});  
     if ($opt{column} > 0) {  
       print STDOUT qq[<dt class="$cls"><a href="#line-$opt{line}">Line $opt{line}</a> column $opt{column}</dt>\n];  
     } else {  
       $opt{line} = $opt{line} - 1 || 1;  
       print STDOUT qq[<dt class="$cls"><a href="#line-$opt{line}">Line $opt{line}</a></dt>\n];  
     }  
     $type =~ tr/ /-/;  
     $type =~ s/\|/%7C/g;  
     $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];  
     print STDOUT qq[<dd class="$cls">$msg</dd>\n];  
   };  
   
   $doc = $dom->create_document;  
   $time1 = time;  
   if (defined $inner_html_element and length $inner_html_element) {  
     $el = $doc->create_element_ns  
         ('http://www.w3.org/1999/xhtml', [undef, $inner_html_element]);  
     Whatpm::HTML->set_inner_html ($el, $t, $onerror);  
   } else {  
     Whatpm::HTML->parse_string ($t => $doc, $onerror);  
   }  
   $time2 = time;  
   $time{parse} = $time2 - $time1;  
   
   print STDOUT qq[</dl>  
 </div>  
 ];  
   
96      print_source_string_section (\($input->{s}), $input->{charset});      print_source_string_section (\($input->{s}), $input->{charset});
97    } elsif ({    } elsif ({
98              'text/xml' => 1,              'text/xml' => 1,
# Line 148  if (defined $input->{s}) { Line 102  if (defined $input->{s}) {
102              'application/xhtml+xml' => 1,              'application/xhtml+xml' => 1,
103              'application/xml' => 1,              'application/xml' => 1,
104             }->{$input->{media_type}}) {             }->{$input->{media_type}}) {
105      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;  
   };  
   
   $time1 = time;  
   open my $fh, '<', \($input->{s});  
   $doc = Message::DOM::XMLParserTemp->parse_byte_stream  
       ($fh => $dom, $onerror, charset => $input->{charset});  
   $time2 = time;  
   $time{parse_xml} = $time2 - $time1;  
   
     print STDOUT qq[</dl>  
 </div>  
   
 ];  
106      print_source_string_section (\($input->{s}), $doc->input_encoding);      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 {    } else {
112      ## TODO: Change HTTP status code??      ## TODO: Change HTTP status code??
113      print STDOUT qq[      print_result_unknown_type_section ($input, $result);
 <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'];  
114    }    }
115    
   
116    if (defined $doc or defined $el) {    if (defined $doc or defined $el) {
117      print STDOUT qq[      print_structure_dump_dom_section ($doc, $el);
118  <div id="document-tree" class="section">      my $elements = print_structure_error_dom_section ($doc, $el, $result);
119  <h2>Document Tree</h2>      print_table_section ($elements->{table}) if @{$elements->{table}};
120  ];      print_id_section ($elements->{id}) if keys %{$elements->{id}};
121      push @nav, ['#document-tree' => 'Tree'];      print_term_section ($elements->{term}) if keys %{$elements->{term}};
122        print_class_section ($elements->{class}) if keys %{$elements->{class}};
123      print_document_tree ($el || $doc);    } elsif (defined $manifest) {
124        print_structure_dump_manifest_section ($manifest);
125      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";  
     };  
   
     $time1 = time;  
     my $elements;  
     if ($el) {  
       $elements = Whatpm::ContentChecker->check_element ($el, $onerror);  
     } else {  
       $elements = Whatpm::ContentChecker->check_document ($doc, $onerror);  
     }  
     $time2 = time;  
     $time{check} = $time2 - $time1;  
   
     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>];  
     }  
126    }    }
127    
128    ## TODO: Show result    print_result_section ($result);
129  } else {  } else {
130    print STDOUT qq[    print STDOUT qq[</dl></div>];
131  </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'];  
   
132  }  }
133    
134    print STDOUT qq[    print STDOUT qq[
# Line 367  if (defined $input->{s}) { Line 143  if (defined $input->{s}) {
143  </html>  </html>
144  ];  ];
145    
146    for (qw/decode parse parse_xml check/) {    for (qw/decode parse parse_html parse_xml parse_manifest
147              check check_manifest/) {
148      next unless defined $time{$_};      next unless defined $time{$_};
149      open my $file, '>>', ".cc-$_.txt" or die ".cc-$_.txt: $!";      open my $file, '>>', ".cc-$_.txt" or die ".cc-$_.txt: $!";
150      print $file $char_length, "\t", $time{$_}, "\n";      print $file $char_length, "\t", $time{$_}, "\n";
# Line 375  if (defined $input->{s}) { Line 152  if (defined $input->{s}) {
152    
153  exit;  exit;
154    
155  sub print_http_header_section ($) {  sub add_error ($$$) {
156    my $input = shift;    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    return unless defined $input->{header_status_code} or
186        defined $input->{header_status_text} or        defined $input->{header_status_text} or
187        @{$input->{header_field}};        @{$input->{header_field}};
# Line 409  not be the real header.</p> Line 214  not be the real header.</p>
214    print STDOUT qq[</tbody></table></div>];    print STDOUT qq[</tbody></table></div>];
215  } # print_http_header_section  } # 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">
225    <h2>Parse Errors</h2>
226    
227    <dl>];
228      push @nav, ['#parse-errors' => 'Parse Error'];
229    
230      my $onerror = sub {
231        my (%opt) = @_;
232        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level});
233        if ($opt{column} > 0) {
234          print STDOUT qq[<dt class="$cls"><a href="#line-$opt{line}">Line $opt{line}</a> column $opt{column}</dt>\n];
235        } else {
236          $opt{line} = $opt{line} - 1 || 1;
237          print STDOUT qq[<dt class="$cls"><a href="#line-$opt{line}">Line $opt{line}</a></dt>\n];
238        }
239        $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      my $doc = $dom->create_document;
249      my $el;
250      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
257            ('http://www.w3.org/1999/xhtml', [undef, $inner_html_element]);
258        $time1 = time;
259        Whatpm::HTML->set_inner_html ($el, $t, $onerror);
260        $time{parse} = time - $time1;
261      } else {
262        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      return ($doc, $el);
271    } # print_syntax_error_html_section
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">
280    <h2>Parse Errors</h2>
281    
282    <dl>];
283      push @nav, ['#parse-errors' => 'Parse Error'];
284    
285      my $onerror = sub {
286        my $err = shift;
287        my $line = $err->location->line_number;
288        print STDOUT qq[<dt><a href="#line-$line">Line $line</a> column ];
289        print STDOUT $err->location->column_number, "</dt><dd>";
290        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;
300      };
301    
302      my $time1 = time;
303      open my $fh, '<', \($input->{s});
304      my $doc = Message::DOM::XMLParserTemp->parse_byte_stream
305          ($fh => $dom, $onerror, charset => $input->{charset});
306      $time{parse_xml} = time - $time1;
307    
308      print STDOUT qq[</dl></div>];
309    
310      return ($doc, undef);
311    } # print_syntax_error_xml_section
312    
313    sub print_syntax_error_manifest_section ($$) {
314      my ($input, $result) = @_;
315    
316      require Whatpm::CacheManifest;
317    
318      print STDOUT qq[
319    <div id="parse-errors" class="section">
320    <h2>Parse Errors</h2>
321    
322    <dl>];
323      push @nav, ['#parse-errors' => 'Parse Error'];
324    
325      my $onerror = sub {
326        my (%opt) = @_;
327        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        add_error ('syntax', \%opt => $result);
336      };
337    
338      my $time1 = time;
339      my $manifest = Whatpm::CacheManifest->parse_byte_string
340          ($input->{s}, $input->{uri}, $input->{base_uri}, $onerror);
341      $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 ($$) {  sub print_source_string_section ($$) {
349    require Encode;    require Encode;
350    my $enc = Encode::find_encoding ($_[1]); ## TODO: charset name -> Perl name    my $enc = Encode::find_encoding ($_[1]); ## TODO: charset name -> Perl name
# Line 511  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 575  sub get_text ($) { Line 916  sub get_text ($) {
916        $msg =~ s{<var>{\@}</var>}{        $msg =~ s{<var>{\@}</var>}{
917          UNIVERSAL::can ($node, 'value') ? htescape ($node->value) : ''          UNIVERSAL::can ($node, 'value') ? htescape ($node->value) : ''
918        }ge;        }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);        return ($type, $Msg->{$type}->[0], $msg);
930      } elsif ($type =~ s/:([^:]*)$//) {      } elsif ($type =~ s/:([^:]*)$//) {
931        unshift @arg, $1;        unshift @arg, $1;
# Line 649  EOH Line 1000  EOH
1000        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._+-]+)#) {
1001          $r->{media_type} = lc $1;          $r->{media_type} = lc $1;
1002        }        }
1003        if (defined $ct and $ct =~ /;\s*charset\s*=\s*"?(\S+)"?/i) {        if (defined $ct and $ct =~ /;\s*charset\s*=\s*"?([^\s;"]+)"?/i) {
1004          $r->{charset} = lc $1;          $r->{charset} = lc $1;
1005          $r->{charset} =~ tr/\\//d;          $r->{charset} =~ tr/\\//d;
1006        }        }
Legend:
Removed from v.1.16  
changed lines
  Added in v.1.24
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24