/[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.24 by wakaba, Sun Nov 11 06:57:16 2007 UTC
# Line 1  Line 1 
1  #!/usr/bin/perl  #!/usr/bin/perl
2  use strict;  use strict;
3    use utf8;
4    
5  use lib qw[/home/httpd/html/www/markup/html/whatpm  use lib qw[/home/httpd/html/www/markup/html/whatpm
6             /home/wakaba/work/manakai/lib             /home/wakaba/work/manakai2/lib];
            /home/wakaba/public_html/-temp/wiki/lib];  
7  use CGI::Carp qw[fatalsToBrowser];  use CGI::Carp qw[fatalsToBrowser];
8  use Scalar::Util qw[refaddr];  use Scalar::Util qw[refaddr];
9    use Time::HiRes qw/time/;
 use SuikaWiki::Input::HTTP; ## TODO: Use some better CGI module  
10    
11  sub htescape ($) {  sub htescape ($) {
12    my $s = $_[0];    my $s = $_[0];
# Line 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    }    }
# Line 54  my $http = SuikaWiki::Input::HTTP->new; Line 52  my $http = SuikaWiki::Input::HTTP->new;
52    
53    $| = 0;    $| = 0;
54    my $input = get_input_document ($http, $dom);    my $input = get_input_document ($http, $dom);
55    my $inner_html_element = $http->parameter ('e');    my $inner_html_element = $http->get_parameter ('e');
56      my $char_length = 0;
57      my %time;
58    
59    print qq[    print qq[
60  <div id="document-info" class="section">  <div id="document-info" class="section">
# Line 67  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 77  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, $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";  
     };  
   
     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>];  
     }  
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 348  if (defined $input->{s}) { Line 143  if (defined $input->{s}) {
143  </html>  </html>
144  ];  ];
145    
146      for (qw/decode parse parse_html parse_xml parse_manifest
147              check check_manifest/) {
148        next unless defined $time{$_};
149        open my $file, '>>', ".cc-$_.txt" or die ".cc-$_.txt: $!";
150        print $file $char_length, "\t", $time{$_}, "\n";
151      }
152    
153  exit;  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 384  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 486  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 550  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 564  sub get_text ($) { Line 940  sub get_text ($) {
940  sub get_input_document ($$) {  sub get_input_document ($$) {
941    my ($http, $dom) = @_;    my ($http, $dom) = @_;
942    
943    my $request_uri = $http->parameter ('uri');    my $request_uri = $http->get_parameter ('uri');
944    my $r = {};    my $r = {};
945    if (defined $request_uri and length $request_uri) {    if (defined $request_uri and length $request_uri) {
946      my $uri = $dom->create_uri_reference ($request_uri);      my $uri = $dom->create_uri_reference ($request_uri);
# Line 613  EOH Line 989  EOH
989      $ua->max_size (1000_000);      $ua->max_size (1000_000);
990      my $req = HTTP::Request->new (GET => $request_uri);      my $req = HTTP::Request->new (GET => $request_uri);
991      my $res = $ua->request ($req);      my $res = $ua->request ($req);
992      if ($res->is_success or $http->parameter ('error-page')) {      ## TODO: 401 sets |is_success| true.
993        if ($res->is_success or $http->get_parameter ('error-page')) {
994        $r->{base_uri} = $res->base; ## NOTE: It does check |Content-Base|, |Content-Location|, and <base>. ## TODO: Use our own code!        $r->{base_uri} = $res->base; ## NOTE: It does check |Content-Base|, |Content-Location|, and <base>. ## TODO: Use our own code!
995        $r->{uri} = $res->request->uri;        $r->{uri} = $res->request->uri;
996        $r->{request_uri} = $request_uri;        $r->{request_uri} = $request_uri;
# Line 623  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        }        }
1007    
1008        my $input_charset = $http->parameter ('charset');        my $input_charset = $http->get_parameter ('charset');
1009        if (defined $input_charset and length $input_charset) {        if (defined $input_charset and length $input_charset) {
1010          $r->{charset_overridden}          $r->{charset_overridden}
1011              = (not defined $r->{charset} or $r->{charset} ne $input_charset);              = (not defined $r->{charset} or $r->{charset} ne $input_charset);
# Line 649  EOH Line 1026  EOH
1026      $r->{header_status_code} = $res->code;      $r->{header_status_code} = $res->code;
1027      $r->{header_status_text} = $res->message;      $r->{header_status_text} = $res->message;
1028    } else {    } else {
1029      $r->{s} = ''.$http->parameter ('s');      $r->{s} = ''.$http->get_parameter ('s');
1030      $r->{uri} = q<thismessage:/>;      $r->{uri} = q<thismessage:/>;
1031      $r->{request_uri} = q<thismessage:/>;      $r->{request_uri} = q<thismessage:/>;
1032      $r->{base_uri} = q<thismessage:/>;      $r->{base_uri} = q<thismessage:/>;
1033      $r->{charset} = ''.$http->parameter ('_charset_');      $r->{charset} = ''.$http->get_parameter ('_charset_');
1034      $r->{charset} =~ s/\s+//g;      $r->{charset} =~ s/\s+//g;
1035      $r->{charset} = 'utf-8' if $r->{charset} eq '';      $r->{charset} = 'utf-8' if $r->{charset} eq '';
1036      $r->{header_field} = [];      $r->{header_field} = [];
1037    }    }
1038    
1039    my $input_format = $http->parameter ('i');    my $input_format = $http->get_parameter ('i');
1040    if (defined $input_format and length $input_format) {    if (defined $input_format and length $input_format) {
1041      $r->{media_type_overridden}      $r->{media_type_overridden}
1042          = (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.24
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24