/[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.25 by wakaba, Sun Nov 18 05:30:03 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 62  my $http = SuikaWiki::Input::HTTP->new; Line 62  my $http = SuikaWiki::Input::HTTP->new;
62  <dt>Request URI</dt>  <dt>Request URI</dt>
63      <dd><code class="URI" lang="">&lt;<a href="@{[htescape $input->{request_uri}]}">@{[htescape $input->{request_uri}]}</a>&gt;</code></dd>      <dd><code class="URI" lang="">&lt;<a href="@{[htescape $input->{request_uri}]}">@{[htescape $input->{request_uri}]}</a>&gt;</code></dd>
64  <dt>Document URI</dt>  <dt>Document URI</dt>
65      <dd><code class="URI" lang="">&lt;<a href="@{[htescape $input->{uri}]}">@{[htescape $input->{uri}]}</a>&gt;</code></dd>      <dd><code class="URI" lang="">&lt;<a href="@{[htescape $input->{uri}]}" id=anchor-document-uri>@{[htescape $input->{uri}]}</a>&gt;</code>
66        <script>
67          document.title = '<'
68              + document.getElementById ('anchor-document-uri').href + '> \\u2014 '
69              + document.title;
70        </script></dd>
71  ]; # no </dl> yet  ]; # no </dl> yet
72    push @nav, ['#document-info' => 'Information'];    push @nav, ['#document-info' => 'Information'];
73    
74  if (defined $input->{s}) {  if (defined $input->{s}) {
75      $char_length = length $input->{s};
76    
77    print STDOUT qq[    print STDOUT qq[
78  <dt>Base URI</dt>  <dt>Base URI</dt>
79      <dd><code class="URI" lang="">&lt;<a href="@{[htescape $input->{base_uri}]}">@{[htescape $input->{base_uri}]}</a>&gt;</code></dd>      <dd><code class="URI" lang="">&lt;<a href="@{[htescape $input->{base_uri}]}">@{[htescape $input->{base_uri}]}</a>&gt;</code></dd>
80  <dt>Internet Media Type</dt>  <dt>Internet Media Type</dt>
81      <dd><code class="MIME" lang="en">@{[htescape $input->{media_type}]}</code>      <dd><code class="MIME" lang="en">@{[htescape $input->{media_type}]}</code>
82      @{[$input->{media_type_overridden} ? '<em>(overridden)</em>' : '']}</dd>      @{[$input->{media_type_overridden} ? '<em>(overridden)</em>' : defined $input->{official_type} ? $input->{media_type} eq $input->{official_type} ? '' : '<em>(sniffed; official type is: <code class=MIME lang=en>'.htescape ($input->{official_type}).'</code>)' : '<em>(sniffed)</em>']}</dd>
83  <dt>Character Encoding</dt>  <dt>Character Encoding</dt>
84      <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)']}
85      @{[$input->{charset_overridden} ? '<em>(overridden)</em>' : '']}</dd>      @{[$input->{charset_overridden} ? '<em>(overridden)</em>' : '']}</dd>
86    <dt>Length</dt>
87        <dd>$char_length byte@{[$char_length == 1 ? '' : 's']}</dd>
88  </dl>  </dl>
89  </div>  </div>
90  ];  ];
91    
92    print_http_header_section ($input);    my $result = {conforming_min => 1, conforming_max => 1};
93      print_http_header_section ($input, $result);
94    
95    my $doc;    my $doc;
96    my $el;    my $el;
97      my $manifest;
98    
99    if ($input->{media_type} eq 'text/html') {    if ($input->{media_type} eq 'text/html') {
100      require Encode;      ($doc, $el) = print_syntax_error_html_section ($input, $result);
101      require Whatpm::HTML;      print_source_string_section
102            (\($input->{s}), $input->{charset} || $doc->input_encoding);
     $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>  
 ];  
   
     print_source_string_section (\($input->{s}), $input->{charset});  
103    } elsif ({    } elsif ({
104              'text/xml' => 1,              'text/xml' => 1,
105                'application/atom+xml' => 1,
106                'application/rss+xml' => 1,
107                'application/svg+xml' => 1,
108              'application/xhtml+xml' => 1,              'application/xhtml+xml' => 1,
109              'application/xml' => 1,              'application/xml' => 1,
110             }->{$input->{media_type}}) {             }->{$input->{media_type}}) {
111      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>  
   
 ];  
112      print_source_string_section (\($input->{s}), $doc->input_encoding);      print_source_string_section (\($input->{s}), $doc->input_encoding);
113      } elsif ($input->{media_type} eq 'text/cache-manifest') {
114    ## TODO: MUST be text/cache-manifest
115        $manifest = print_syntax_error_manifest_section ($input, $result);
116        print_source_string_section (\($input->{s}), 'utf-8');
117    } else {    } else {
118      ## TODO: Change HTTP status code??      ## TODO: Change HTTP status code??
119      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'];  
120    }    }
121    
   
122    if (defined $doc or defined $el) {    if (defined $doc or defined $el) {
123      print STDOUT qq[      print_structure_dump_dom_section ($doc, $el);
124  <div id="document-tree" class="section">      my $elements = print_structure_error_dom_section ($doc, $el, $result);
125  <h2>Document Tree</h2>      print_table_section ($elements->{table}) if @{$elements->{table}};
126  ];      print_id_section ($elements->{id}) if keys %{$elements->{id}};
127      push @nav, ['#document-tree' => 'Tree'];      print_term_section ($elements->{term}) if keys %{$elements->{term}};
128        print_class_section ($elements->{class}) if keys %{$elements->{class}};
129      print_document_tree ($el || $doc);    } elsif (defined $manifest) {
130        print_structure_dump_manifest_section ($manifest);
131      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>];  
     }  
132    }    }
133    
134    ## TODO: Show result    print_result_section ($result);
135  } else {  } else {
136    print STDOUT qq[    print STDOUT qq[</dl></div>];
137  </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'];  
   
138  }  }
139    
140    print STDOUT qq[    print STDOUT qq[
# Line 348  if (defined $input->{s}) { Line 149  if (defined $input->{s}) {
149  </html>  </html>
150  ];  ];
151    
152      for (qw/decode parse parse_html parse_xml parse_manifest
153              check check_manifest/) {
154        next unless defined $time{$_};
155        open my $file, '>>', ".cc-$_.txt" or die ".cc-$_.txt: $!";
156        print $file $char_length, "\t", $time{$_}, "\n";
157      }
158    
159  exit;  exit;
160    
161  sub print_http_header_section ($) {  sub add_error ($$$) {
162    my $input = shift;    my ($layer, $err, $result) = @_;
163      if (defined $err->{level}) {
164        if ($err->{level} eq 's') {
165          $result->{$layer}->{should}++;
166          $result->{$layer}->{score_min} -= 2;
167          $result->{conforming_min} = 0;
168        } elsif ($err->{level} eq 'w' or $err->{level} eq 'g') {
169          $result->{$layer}->{warning}++;
170        } elsif ($err->{level} eq 'unsupported') {
171          $result->{$layer}->{unsupported}++;
172          $result->{unsupported} = 1;
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      } else {
181        $result->{$layer}->{must}++;
182        $result->{$layer}->{score_max} -= 2;
183        $result->{$layer}->{score_min} -= 2;
184        $result->{conforming_min} = 0;
185        $result->{conforming_max} = 0;
186      }
187    } # add_error
188    
189    sub print_http_header_section ($$) {
190      my ($input, $result) = @_;
191    return unless defined $input->{header_status_code} or    return unless defined $input->{header_status_code} or
192        defined $input->{header_status_text} or        defined $input->{header_status_text} or
193        @{$input->{header_field}};        @{$input->{header_field}};
# Line 384  not be the real header.</p> Line 220  not be the real header.</p>
220    print STDOUT qq[</tbody></table></div>];    print STDOUT qq[</tbody></table></div>];
221  } # print_http_header_section  } # print_http_header_section
222    
223    sub print_syntax_error_html_section ($$) {
224      my ($input, $result) = @_;
225      
226      require Encode;
227      require Whatpm::HTML;
228      
229      print STDOUT qq[
230    <div id="parse-errors" class="section">
231    <h2>Parse Errors</h2>
232    
233    <dl>];
234      push @nav, ['#parse-errors' => 'Parse Error'];
235    
236      my $onerror = sub {
237        my (%opt) = @_;
238        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level});
239        if ($opt{column} > 0) {
240          print STDOUT qq[<dt class="$cls"><a href="#line-$opt{line}">Line $opt{line}</a> column $opt{column}</dt>\n];
241        } else {
242          $opt{line} = $opt{line} - 1 || 1;
243          print STDOUT qq[<dt class="$cls"><a href="#line-$opt{line}">Line $opt{line}</a></dt>\n];
244        }
245        $type =~ tr/ /-/;
246        $type =~ s/\|/%7C/g;
247        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
248        print STDOUT qq[<dd class="$cls">], get_error_level_label (\%opt);
249        print STDOUT qq[$msg</dd>\n];
250    
251        add_error ('syntax', \%opt => $result);
252      };
253    
254      my $doc = $dom->create_document;
255      my $el;
256      if (defined $inner_html_element and length $inner_html_element) {
257        $input->{charset} ||= 'ISO-8859-1'; ## TODO: for now.
258        my $time1 = time;
259        my $t = Encode::decode ($input->{charset}, $input->{s});
260        $time{decode} = time - $time1;
261        
262        $el = $doc->create_element_ns
263            ('http://www.w3.org/1999/xhtml', [undef, $inner_html_element]);
264        $time1 = time;
265        Whatpm::HTML->set_inner_html ($el, $t, $onerror);
266        $time{parse} = time - $time1;
267      } else {
268        my $time1 = time;
269        Whatpm::HTML->parse_byte_string
270            ($input->{charset}, $input->{s} => $doc, $onerror);
271        $time{parse_html} = time - $time1;
272      }
273      
274      print STDOUT qq[</dl></div>];
275    
276      return ($doc, $el);
277    } # print_syntax_error_html_section
278    
279    sub print_syntax_error_xml_section ($$) {
280      my ($input, $result) = @_;
281      
282      require Message::DOM::XMLParserTemp;
283      
284      print STDOUT qq[
285    <div id="parse-errors" class="section">
286    <h2>Parse Errors</h2>
287    
288    <dl>];
289      push @nav, ['#parse-errors' => 'Parse Error'];
290    
291      my $onerror = sub {
292        my $err = shift;
293        my $line = $err->location->line_number;
294        print STDOUT qq[<dt><a href="#line-$line">Line $line</a> column ];
295        print STDOUT $err->location->column_number, "</dt><dd>";
296        print STDOUT htescape $err->text, "</dd>\n";
297    
298        add_error ('syntax', {type => $err->text,
299                    level => [
300                              $err->SEVERITY_FATAL_ERROR => 'm',
301                              $err->SEVERITY_ERROR => 'm',
302                              $err->SEVERITY_WARNING => 's',
303                             ]->[$err->severity]} => $result);
304    
305        return 1;
306      };
307    
308      my $time1 = time;
309      open my $fh, '<', \($input->{s});
310      my $doc = Message::DOM::XMLParserTemp->parse_byte_stream
311          ($fh => $dom, $onerror, charset => $input->{charset});
312      $time{parse_xml} = time - $time1;
313    
314      print STDOUT qq[</dl></div>];
315    
316      return ($doc, undef);
317    } # print_syntax_error_xml_section
318    
319    sub print_syntax_error_manifest_section ($$) {
320      my ($input, $result) = @_;
321    
322      require Whatpm::CacheManifest;
323    
324      print STDOUT qq[
325    <div id="parse-errors" class="section">
326    <h2>Parse Errors</h2>
327    
328    <dl>];
329      push @nav, ['#parse-errors' => 'Parse Error'];
330    
331      my $onerror = sub {
332        my (%opt) = @_;
333        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level});
334        print STDOUT qq[<dt class="$cls">], get_error_label (\%opt), qq[</dt>];
335        $type =~ tr/ /-/;
336        $type =~ s/\|/%7C/g;
337        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
338        print STDOUT qq[<dd class="$cls">], get_error_level_label (\%opt);
339        print STDOUT qq[$msg</dd>\n];
340    
341        add_error ('syntax', \%opt => $result);
342      };
343    
344      my $time1 = time;
345      my $manifest = Whatpm::CacheManifest->parse_byte_string
346          ($input->{s}, $input->{uri}, $input->{base_uri}, $onerror);
347      $time{parse_manifest} = time - $time1;
348    
349      print STDOUT qq[</dl></div>];
350    
351      return $manifest;
352    } # print_syntax_error_manifest_section
353    
354  sub print_source_string_section ($$) {  sub print_source_string_section ($$) {
355    require Encode;    require Encode;
356    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 453  sub print_document_tree ($) {
453    print STDOUT $r;    print STDOUT $r;
454  } # print_document_tree  } # print_document_tree
455    
456    sub print_structure_dump_dom_section ($$) {
457      my ($doc, $el) = @_;
458    
459      print STDOUT qq[
460    <div id="document-tree" class="section">
461    <h2>Document Tree</h2>
462    ];
463      push @nav, ['#document-tree' => 'Tree'];
464    
465      print_document_tree ($el || $doc);
466    
467      print STDOUT qq[</div>];
468    } # print_structure_dump_dom_section
469    
470    sub print_structure_dump_manifest_section ($) {
471      my $manifest = shift;
472    
473      print STDOUT qq[
474    <div id="dump-manifest" class="section">
475    <h2>Cache Manifest</h2>
476    ];
477      push @nav, ['#dump-manifest' => 'Caceh Manifest'];
478    
479      print STDOUT qq[<dl><dt>Explicit entries</dt>];
480      for my $uri (@{$manifest->[0]}) {
481        my $euri = htescape ($uri);
482        print STDOUT qq[<dd><code class=uri>&lt;<a href="$euri">$euri</a>></code></dd>];
483      }
484    
485      print STDOUT qq[<dt>Fallback entries</dt><dd>
486          <table><thead><tr><th scope=row>Oppotunistic Caching Namespace</th>
487          <th scope=row>Fallback Entry</tr><tbody>];
488      for my $uri (sort {$a cmp $b} keys %{$manifest->[1]}) {
489        my $euri = htescape ($uri);
490        my $euri2 = htescape ($manifest->[1]->{$uri});
491        print STDOUT qq[<tr><td><code class=uri>&lt;<a href="$euri">$euri</a>></code></td>
492            <td><code class=uri>&lt;<a href="$euri2">$euri2</a>></code></td>];
493      }
494    
495      print STDOUT qq[</table><dt>Online whitelist</dt>];
496      for my $uri (@{$manifest->[2]}) {
497        my $euri = htescape ($uri);
498        print STDOUT qq[<dd><code class=uri>&lt;<a href="$euri">$euri</a>></code></dd>];
499      }
500    
501      print STDOUT qq[</dl></div>];
502    } # print_structure_dump_manifest_section
503    
504    sub print_structure_error_dom_section ($$$) {
505      my ($doc, $el, $result) = @_;
506    
507      print STDOUT qq[<div id="document-errors" class="section">
508    <h2>Document Errors</h2>
509    
510    <dl>];
511      push @nav, ['#document-errors' => 'Document Error'];
512    
513      require Whatpm::ContentChecker;
514      my $onerror = sub {
515        my %opt = @_;
516        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level}, $opt{node});
517        $type =~ tr/ /-/;
518        $type =~ s/\|/%7C/g;
519        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
520        print STDOUT qq[<dt class="$cls">] . get_error_label (\%opt) .
521            qq[</dt>\n<dd class="$cls">], get_error_level_label (\%opt);
522        print STDOUT $msg, "</dd>\n";
523        add_error ('structure', \%opt => $result);
524      };
525    
526      my $elements;
527      my $time1 = time;
528      if ($el) {
529        $elements = Whatpm::ContentChecker->check_element ($el, $onerror);
530      } else {
531        $elements = Whatpm::ContentChecker->check_document ($doc, $onerror);
532      }
533      $time{check} = time - $time1;
534    
535      print STDOUT qq[</dl></div>];
536    
537      return $elements;
538    } # print_structure_error_dom_section
539    
540    sub print_structure_error_manifest_section ($$$) {
541      my ($manifest, $result) = @_;
542    
543      print STDOUT qq[<div id="document-errors" class="section">
544    <h2>Document Errors</h2>
545    
546    <dl>];
547      push @nav, ['#document-errors' => 'Document Error'];
548    
549      require Whatpm::CacheManifest;
550      Whatpm::CacheManifest->check_manifest ($manifest, sub {
551        my %opt = @_;
552        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level}, $opt{node});
553        $type =~ tr/ /-/;
554        $type =~ s/\|/%7C/g;
555        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
556        print STDOUT qq[<dt class="$cls">] . get_error_label (\%opt) .
557            qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";
558        add_error ('structure', \%opt => $result);
559      });
560    
561      print STDOUT qq[</div>];
562    } # print_structure_error_manifest_section
563    
564    sub print_table_section ($) {
565      my $tables = shift;
566      
567      push @nav, ['#tables' => 'Tables'];
568      print STDOUT qq[
569    <div id="tables" class="section">
570    <h2>Tables</h2>
571    
572    <!--[if IE]><script type="text/javascript" src="../excanvas.js"></script><![endif]-->
573    <script src="../table-script.js" type="text/javascript"></script>
574    <noscript>
575    <p><em>Structure of tables are visualized here if scripting is enabled.</em></p>
576    </noscript>
577    ];
578      
579      require JSON;
580      
581      my $i = 0;
582      for my $table_el (@$tables) {
583        $i++;
584        print STDOUT qq[<div class="section" id="table-$i"><h3>] .
585            get_node_link ($table_el) . q[</h3>];
586    
587        ## TODO: Make |ContentChecker| return |form_table| result
588        ## so that this script don't have to run the algorithm twice.
589        my $table = Whatpm::HTMLTable->form_table ($table_el);
590        
591        for (@{$table->{column_group}}, @{$table->{column}}, $table->{caption}) {
592          next unless $_;
593          delete $_->{element};
594        }
595        
596        for (@{$table->{row_group}}) {
597          next unless $_;
598          next unless $_->{element};
599          $_->{type} = $_->{element}->manakai_local_name;
600          delete $_->{element};
601        }
602        
603        for (@{$table->{cell}}) {
604          next unless $_;
605          for (@{$_}) {
606            next unless $_;
607            for (@$_) {
608              $_->{id} = refaddr $_->{element} if defined $_->{element};
609              delete $_->{element};
610              $_->{is_header} = $_->{is_header} ? 1 : 0;
611            }
612          }
613        }
614            
615        print STDOUT '</div><script type="text/javascript">tableToCanvas (';
616        print STDOUT JSON::objToJson ($table);
617        print STDOUT qq[, document.getElementById ('table-$i'));</script>];
618      }
619      
620      print STDOUT qq[</div>];
621    } # print_table_section
622    
623    sub print_id_section ($) {
624      my $ids = shift;
625      
626      push @nav, ['#identifiers' => 'IDs'];
627      print STDOUT qq[
628    <div id="identifiers" class="section">
629    <h2>Identifiers</h2>
630    
631    <dl>
632    ];
633      for my $id (sort {$a cmp $b} keys %$ids) {
634        print STDOUT qq[<dt><code>@{[htescape $id]}</code></dt>];
635        for (@{$ids->{$id}}) {
636          print STDOUT qq[<dd>].get_node_link ($_).qq[</dd>];
637        }
638      }
639      print STDOUT qq[</dl></div>];
640    } # print_id_section
641    
642    sub print_term_section ($) {
643      my $terms = shift;
644      
645      push @nav, ['#terms' => 'Terms'];
646      print STDOUT qq[
647    <div id="terms" class="section">
648    <h2>Terms</h2>
649    
650    <dl>
651    ];
652      for my $term (sort {$a cmp $b} keys %$terms) {
653        print STDOUT qq[<dt>@{[htescape $term]}</dt>];
654        for (@{$terms->{$term}}) {
655          print STDOUT qq[<dd>].get_node_link ($_).qq[</dd>];
656        }
657      }
658      print STDOUT qq[</dl></div>];
659    } # print_term_section
660    
661    sub print_class_section ($) {
662      my $classes = shift;
663      
664      push @nav, ['#classes' => 'Classes'];
665      print STDOUT qq[
666    <div id="classes" class="section">
667    <h2>Classes</h2>
668    
669    <dl>
670    ];
671      for my $class (sort {$a cmp $b} keys %$classes) {
672        print STDOUT qq[<dt><code>@{[htescape $class]}</code></dt>];
673        for (@{$classes->{$class}}) {
674          print STDOUT qq[<dd>].get_node_link ($_).qq[</dd>];
675        }
676      }
677      print STDOUT qq[</dl></div>];
678    } # print_class_section
679    
680    sub print_result_section ($) {
681      my $result = shift;
682    
683      print STDOUT qq[
684    <div id="result-summary" class="section">
685    <h2>Result</h2>];
686    
687      if ($result->{unsupported} and $result->{conforming_max}) {  
688        print STDOUT qq[<p class=uncertain id=result-para>The conformance
689            checker cannot decide whether the document is conforming or
690            not, since the document contains one or more unsupported
691            features.  The document might or might not be conforming.</p>];
692      } elsif ($result->{conforming_min}) {
693        print STDOUT qq[<p class=PASS id=result-para>No conformance-error is
694            found in this document.</p>];
695      } elsif ($result->{conforming_max}) {
696        print STDOUT qq[<p class=SEE-RESULT id=result-para>This document
697            is <strong>likely <em>non</em>-conforming</strong>, but in rare case
698            it might be conforming.</p>];
699      } else {
700        print STDOUT qq[<p class=FAIL id=result-para>This document is
701            <strong><em>non</em>-conforming</strong>.</p>];
702      }
703    
704      print STDOUT qq[<table>
705    <colgroup><col><colgroup><col><col><col><colgroup><col>
706    <thead>
707    <tr><th scope=col></th>
708    <th scope=col><a href="../error-description#level-m"><em class=rfc2119>MUST</em>‐level
709    Errors</a></th>
710    <th scope=col><a href="../error-description#level-s"><em class=rfc2119>SHOULD</em>‐level
711    Errors</a></th>
712    <th scope=col><a href="../error-description#level-w">Warnings</a></th>
713    <th scope=col>Score</th></tr></thead><tbody>];
714    
715      my $must_error = 0;
716      my $should_error = 0;
717      my $warning = 0;
718      my $score_min = 0;
719      my $score_max = 0;
720      my $score_base = 20;
721      my $score_unit = $score_base / 100;
722      for (
723        [Transfer => 'transfer', ''],
724        [Character => 'char', ''],
725        [Syntax => 'syntax', '#parse-errors'],
726        [Structure => 'structure', '#document-errors'],
727      ) {
728        $must_error += ($result->{$_->[1]}->{must} += 0);
729        $should_error += ($result->{$_->[1]}->{should} += 0);
730        $warning += ($result->{$_->[1]}->{warning} += 0);
731        $score_min += (($result->{$_->[1]}->{score_min} *= $score_unit) += $score_base);
732        $score_max += (($result->{$_->[1]}->{score_max} *= $score_unit) += $score_base);
733    
734        my $uncertain = $result->{$_->[1]}->{unsupported} ? '?' : '';
735        my $label = $_->[0];
736        if ($result->{$_->[1]}->{must} or
737            $result->{$_->[1]}->{should} or
738            $result->{$_->[1]}->{warning} or
739            $result->{$_->[1]}->{unsupported}) {
740          $label = qq[<a href="$_->[2]">$label</a>];
741        }
742    
743        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>];
744        if ($uncertain) {
745          print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : $result->{$_->[1]}->{should} ? 'SEE-RESULT' : '']}">&#x2212;&#x221E;..$result->{$_->[1]}->{score_max}</td>];
746        } elsif ($result->{$_->[1]}->{score_min} != $result->{$_->[1]}->{score_max}) {
747          print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : 'SEE-RESULT']}">$result->{$_->[1]}->{score_min}..$result->{$_->[1]}->{score_max}</td></tr>];
748        } else {
749          print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : '']}">$result->{$_->[1]}->{score_min}</td></tr>];
750        }
751      }
752    
753      $score_max += $score_base;
754    
755      print STDOUT qq[
756    <tr class=uncertain><th scope=row>Semantics</th><td>0?</td><td>0?</td><td>0?</td><td>&#x2212;&#x221E;..$score_base</td></tr>
757    </tbody>
758    <tfoot><tr class=uncertain><th scope=row>Total</th>
759    <td class="@{[$must_error ? 'FAIL' : '']}">$must_error?</td>
760    <td class="@{[$should_error ? 'SEE-RESULT' : '']}">$should_error?</td>
761    <td>$warning?</td>
762    <td class="@{[$must_error ? 'FAIL' : $should_error ? 'SEE-RESULT' : '']}"><strong>&#x2212;&#x221E;..$score_max</strong></td></tr></tfoot>
763    </table>
764    
765    <p><strong>Important</strong>: This conformance checking service
766    is <em>under development</em>.  The result above might be <em>wrong</em>.</p>
767    </div>];
768      push @nav, ['#result-summary' => 'Result'];
769    } # print_result_section
770    
771    sub print_result_unknown_type_section ($$) {
772      my ($input, $result) = @_;
773    
774      my $euri = htescape ($input->{uri});
775      print STDOUT qq[
776    <div id="parse-errors" class="section">
777    <h2>Errors</h2>
778    
779    <dl>
780    <dt class=unsupported><code>&lt;<a href="$euri">$euri</a>&gt;</code></dt>
781        <dd class=unsupported><strong><a href="../error-description#level-u">Not
782            supported</a></strong>:
783        Media type
784        <code class="MIME" lang="en">@{[htescape $input->{media_type}]}</code>
785        is not supported.</dd>
786    </dl>
787    </div>
788    ];
789      push @nav, ['#parse-errors' => 'Errors'];
790      add_error (char => {level => 'unsupported'} => $result);
791      add_error (syntax => {level => 'unsupported'} => $result);
792      add_error (structure => {level => 'unsupported'} => $result);
793    } # print_result_unknown_type_section
794    
795    sub print_result_input_error_section ($) {
796      my $input = shift;
797      print STDOUT qq[<div class="section" id="result-summary">
798    <p><em><strong>Input Error</strong>: @{[htescape ($input->{error_status_text})]}</em></p>
799    </div>];
800      push @nav, ['#result-summary' => 'Result'];
801    } # print_Result_input_error_section
802    
803    sub get_error_label ($) {
804      my $err = shift;
805    
806      my $r = '';
807    
808      if (defined $err->{line}) {
809        if ($err->{column} > 0) {
810          $r = qq[<a href="#line-$err->{line}">Line $err->{line}</a> column $err->{column}];
811        } else {
812          $err->{line} = $err->{line} - 1 || 1;
813          $r = qq[<a href="#line-$err->{line}">Line $err->{line}</a>];
814        }
815      }
816    
817      if (defined $err->{node}) {
818        $r .= ' ' if length $r;
819        $r = get_node_link ($err->{node});
820      }
821    
822      if (defined $err->{index}) {
823        $r .= ' ' if length $r;
824        $r .= 'Index ' . (0+$err->{index});
825      }
826    
827      if (defined $err->{value}) {
828        $r .= ' ' if length $r;
829        $r .= '<q><code>' . htescape ($err->{value}) . '</code></q>';
830      }
831    
832      return $r;
833    } # get_error_label
834    
835    sub get_error_level_label ($) {
836      my $err = shift;
837    
838      my $r = '';
839    
840      if (not defined $err->{level} or $err->{level} eq 'm') {
841        $r = qq[<strong><a href="../error-description#level-m"><em class=rfc2119>MUST</em>‐level
842            error</a></strong>: ];
843      } elsif ($err->{level} eq 's') {
844        $r = qq[<strong><a href="../error-description#level-s"><em class=rfc2119>SHOULD</em>‐level
845            error</a></strong>: ];
846      } elsif ($err->{level} eq 'w') {
847        $r = qq[<strong><a href="../error-description#level-w">Warning</a></strong>:
848            ];
849      } elsif ($err->{level} eq 'unsupported') {
850        $r = qq[<strong><a href="../error-description#level-u">Not
851            supported</a></strong>: ];
852      } else {
853        my $elevel = htescape ($err->{level});
854        $r = qq[<strong><a href="../error-description#level-$elevel">$elevel</a></strong>:
855            ];
856      }
857    
858      return $r;
859    } # get_error_level_label
860    
861  sub get_node_path ($) {  sub get_node_path ($) {
862    my $node = shift;    my $node = shift;
863    my @r;    my @r;
# Line 550  sub get_text ($) { Line 922  sub get_text ($) {
922        $msg =~ s{<var>{\@}</var>}{        $msg =~ s{<var>{\@}</var>}{
923          UNIVERSAL::can ($node, 'value') ? htescape ($node->value) : ''          UNIVERSAL::can ($node, 'value') ? htescape ($node->value) : ''
924        }ge;        }ge;
925          $msg =~ s{<var>{local-name}</var>}{
926            UNIVERSAL::can ($node, 'manakai_local_name')
927              ? htescape ($node->manakai_local_name) : ''
928          }ge;
929          $msg =~ s{<var>{element-local-name}</var>}{
930            (UNIVERSAL::can ($node, 'owner_element') and
931             $node->owner_element)
932              ? htescape ($node->owner_element->manakai_local_name)
933              : ''
934          }ge;
935        return ($type, $Msg->{$type}->[0], $msg);        return ($type, $Msg->{$type}->[0], $msg);
936      } elsif ($type =~ s/:([^:]*)$//) {      } elsif ($type =~ s/:([^:]*)$//) {
937        unshift @arg, $1;        unshift @arg, $1;
# Line 564  sub get_text ($) { Line 946  sub get_text ($) {
946  sub get_input_document ($$) {  sub get_input_document ($$) {
947    my ($http, $dom) = @_;    my ($http, $dom) = @_;
948    
949    my $request_uri = $http->parameter ('uri');    my $request_uri = $http->get_parameter ('uri');
950    my $r = {};    my $r = {};
951    if (defined $request_uri and length $request_uri) {    if (defined $request_uri and length $request_uri) {
952      my $uri = $dom->create_uri_reference ($request_uri);      my $uri = $dom->create_uri_reference ($request_uri);
# Line 613  EOH Line 995  EOH
995      $ua->max_size (1000_000);      $ua->max_size (1000_000);
996      my $req = HTTP::Request->new (GET => $request_uri);      my $req = HTTP::Request->new (GET => $request_uri);
997      my $res = $ua->request ($req);      my $res = $ua->request ($req);
998      if ($res->is_success or $http->parameter ('error-page')) {      ## TODO: 401 sets |is_success| true.
999        if ($res->is_success or $http->get_parameter ('error-page')) {
1000        $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!
1001        $r->{uri} = $res->request->uri;        $r->{uri} = $res->request->uri;
1002        $r->{request_uri} = $request_uri;        $r->{request_uri} = $request_uri;
1003    
1004        ## TODO: More strict parsing...        ## TODO: More strict parsing...
1005        my $ct = $res->header ('Content-Type');        my $ct = $res->header ('Content-Type');
1006        if (defined $ct and $ct =~ m#^([0-9A-Za-z._+-]+/[0-9A-Za-z._+-]+)#) {        if (defined $ct and $ct =~ /;\s*charset\s*=\s*"?([^\s;"]+)"?/i) {
         $r->{media_type} = lc $1;  
       }  
       if (defined $ct and $ct =~ /;\s*charset\s*=\s*"?(\S+)"?/i) {  
1007          $r->{charset} = lc $1;          $r->{charset} = lc $1;
1008          $r->{charset} =~ tr/\\//d;          $r->{charset} =~ tr/\\//d;
1009        }        }
1010    
1011        my $input_charset = $http->parameter ('charset');        my $input_charset = $http->get_parameter ('charset');
1012        if (defined $input_charset and length $input_charset) {        if (defined $input_charset and length $input_charset) {
1013          $r->{charset_overridden}          $r->{charset_overridden}
1014              = (not defined $r->{charset} or $r->{charset} ne $input_charset);              = (not defined $r->{charset} or $r->{charset} ne $input_charset);
1015          $r->{charset} = $input_charset;          $r->{charset} = $input_charset;
1016        }        }
1017    
1018          ## TODO: Support for HTTP Content-Encoding
1019    
1020        $r->{s} = ''.$res->content;        $r->{s} = ''.$res->content;
1021    
1022          require Whatpm::ContentType;
1023          ($r->{official_type}, $r->{media_type})
1024              = Whatpm::ContentType->get_sniffed_type
1025                  (get_file_head => sub {
1026                     return substr $r->{s}, 0, shift;
1027                   },
1028                   http_content_type_byte => $ct,
1029                   has_http_content_encoding =>
1030                       defined $res->header ('Content-Encoding'),
1031                   supported_image_types => {});
1032      } else {      } else {
1033        $r->{uri} = $res->request->uri;        $r->{uri} = $res->request->uri;
1034        $r->{request_uri} = $request_uri;        $r->{request_uri} = $request_uri;
# Line 649  EOH Line 1042  EOH
1042      $r->{header_status_code} = $res->code;      $r->{header_status_code} = $res->code;
1043      $r->{header_status_text} = $res->message;      $r->{header_status_text} = $res->message;
1044    } else {    } else {
1045      $r->{s} = ''.$http->parameter ('s');      $r->{s} = ''.$http->get_parameter ('s');
1046      $r->{uri} = q<thismessage:/>;      $r->{uri} = q<thismessage:/>;
1047      $r->{request_uri} = q<thismessage:/>;      $r->{request_uri} = q<thismessage:/>;
1048      $r->{base_uri} = q<thismessage:/>;      $r->{base_uri} = q<thismessage:/>;
1049      $r->{charset} = ''.$http->parameter ('_charset_');      $r->{charset} = ''.$http->get_parameter ('_charset_');
1050      $r->{charset} =~ s/\s+//g;      $r->{charset} =~ s/\s+//g;
1051      $r->{charset} = 'utf-8' if $r->{charset} eq '';      $r->{charset} = 'utf-8' if $r->{charset} eq '';
1052      $r->{header_field} = [];      $r->{header_field} = [];
1053    
1054        require Whatpm::ContentType;
1055        ($r->{official_type}, $r->{media_type})
1056            = Whatpm::ContentType->get_sniffed_type
1057                (get_file_head => sub {
1058                   return substr $r->{s}, 0, shift;
1059                 },
1060                 http_content_type_byte => undef,
1061                 has_http_content_encoding => 0,
1062                 supported_image_types => {});
1063    }    }
1064    
1065    my $input_format = $http->parameter ('i');    my $input_format = $http->get_parameter ('i');
1066    if (defined $input_format and length $input_format) {    if (defined $input_format and length $input_format) {
1067      $r->{media_type_overridden}      $r->{media_type_overridden}
1068          = (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.25
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24