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