/[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.21 by wakaba, Tue Sep 11 08:25:23 2007 UTC
# Line 2  Line 2 
2  use strict;  use strict;
3    
4  use lib qw[/home/httpd/html/www/markup/html/whatpm  use lib qw[/home/httpd/html/www/markup/html/whatpm
5             /home/wakaba/work/manakai/lib             /home/wakaba/work/manakai2/lib];
            /home/wakaba/public_html/-temp/wiki/lib];  
6  use CGI::Carp qw[fatalsToBrowser];  use CGI::Carp qw[fatalsToBrowser];
7  use Scalar::Util qw[refaddr];  use Scalar::Util qw[refaddr];
8    use Time::HiRes qw/time/;
 use SuikaWiki::Input::HTTP; ## TODO: Use some better CGI module  
9    
10  sub htescape ($) {  sub htescape ($) {
11    my $s = $_[0];    my $s = $_[0];
# Line 21  sub htescape ($) { Line 19  sub htescape ($) {
19    return $s;    return $s;
20  } # htescape  } # htescape
21    
22  my $http = SuikaWiki::Input::HTTP->new;    use Message::CGI::HTTP;
23      my $http = Message::CGI::HTTP->new;
 ## TODO: _charset_  
24    
25    if ($http->meta_variable ('PATH_INFO') ne '/') {    if ($http->get_meta_variable ('PATH_INFO') ne '/') {
26      print STDOUT "Status: 404 Not Found\nContent-Type: text/plain; charset=us-ascii\n\n400";      print STDOUT "Status: 404 Not Found\nContent-Type: text/plain; charset=us-ascii\n\n400";
27      exit;      exit;
28    }    }
# Line 54  my $http = SuikaWiki::Input::HTTP->new; Line 51  my $http = SuikaWiki::Input::HTTP->new;
51    
52    $| = 0;    $| = 0;
53    my $input = get_input_document ($http, $dom);    my $input = get_input_document ($http, $dom);
54    my $inner_html_element = $http->parameter ('e');    my $inner_html_element = $http->get_parameter ('e');
55      my $char_length = 0;
56      my %time;
57    
58    print qq[    print qq[
59  <div id="document-info" class="section">  <div id="document-info" class="section">
# Line 67  my $http = SuikaWiki::Input::HTTP->new; Line 66  my $http = SuikaWiki::Input::HTTP->new;
66    push @nav, ['#document-info' => 'Information'];    push @nav, ['#document-info' => 'Information'];
67    
68  if (defined $input->{s}) {  if (defined $input->{s}) {
69      $char_length = length $input->{s};
70    
71    print STDOUT qq[    print STDOUT qq[
72  <dt>Base URI</dt>  <dt>Base URI</dt>
# Line 77  if (defined $input->{s}) { Line 77  if (defined $input->{s}) {
77  <dt>Character Encoding</dt>  <dt>Character Encoding</dt>
78      <dd>@{[defined $input->{charset} ? '<code class="charset" lang="en">'.htescape ($input->{charset}).'</code>' : '(none)']}      <dd>@{[defined $input->{charset} ? '<code class="charset" lang="en">'.htescape ($input->{charset}).'</code>' : '(none)']}
79      @{[$input->{charset_overridden} ? '<em>(overridden)</em>' : '']}</dd>      @{[$input->{charset_overridden} ? '<em>(overridden)</em>' : '']}</dd>
80    <dt>Length</dt>
81        <dd>$char_length byte@{[$char_length == 1 ? '' : 's']}</dd>
82  </dl>  </dl>
83  </div>  </div>
84  ];  ];
85    
86    print_http_header_section ($input);    my $result = {conforming_min => 1, conforming_max => 1};
87      print_http_header_section ($input, $result);
88    
89    my $doc;    my $doc;
90    my $el;    my $el;
91    
92    if ($input->{media_type} eq 'text/html') {    if ($input->{media_type} eq 'text/html') {
93      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>  
 ];  
   
94      print_source_string_section (\($input->{s}), $input->{charset});      print_source_string_section (\($input->{s}), $input->{charset});
95    } elsif ({    } elsif ({
96              'text/xml' => 1,              'text/xml' => 1,
97                'application/atom+xml' => 1,
98                'application/rss+xml' => 1,
99                'application/svg+xml' => 1,
100              'application/xhtml+xml' => 1,              'application/xhtml+xml' => 1,
101              'application/xml' => 1,              'application/xml' => 1,
102             }->{$input->{media_type}}) {             }->{$input->{media_type}}) {
103      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>  
   
 ];  
104      print_source_string_section (\($input->{s}), $doc->input_encoding);      print_source_string_section (\($input->{s}), $doc->input_encoding);
105    } else {    } else {
106      ## TODO: Change HTTP status code??      ## TODO: Change HTTP status code??
107      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'];  
108    }    }
109    
   
110    if (defined $doc or defined $el) {    if (defined $doc or defined $el) {
111      print STDOUT qq[      print_structure_dump_section ($doc, $el);
112  <div id="document-tree" class="section">      my $elements = print_structure_error_section ($doc, $el, $result);
113  <h2>Document Tree</h2>      print_table_section ($elements->{table}) if @{$elements->{table}};
114  ];      print_id_section ($elements->{id}) if keys %{$elements->{id}};
115      push @nav, ['#document-tree' => 'Tree'];      print_term_section ($elements->{term}) if keys %{$elements->{term}};
116        print_class_section ($elements->{class}) if keys %{$elements->{class}};
     print_document_tree ($el || $doc);  
   
     print STDOUT qq[  
 </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>];  
     }  
117    }    }
118    
119    ## TODO: Show result    print_result_section ($result);
120  } else {  } else {
121    print STDOUT qq[    print STDOUT qq[</dl></div>];
122  </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'];  
   
123  }  }
124    
125    print STDOUT qq[    print STDOUT qq[
# Line 348  if (defined $input->{s}) { Line 134  if (defined $input->{s}) {
134  </html>  </html>
135  ];  ];
136    
137      for (qw/decode parse parse_xml check/) {
138        next unless defined $time{$_};
139        open my $file, '>>', ".cc-$_.txt" or die ".cc-$_.txt: $!";
140        print $file $char_length, "\t", $time{$_}, "\n";
141      }
142    
143  exit;  exit;
144    
145  sub print_http_header_section ($) {  sub add_error ($$$) {
146    my $input = shift;    my ($layer, $err, $result) = @_;
147      if (defined $err->{level}) {
148        if ($err->{level} eq 's') {
149          $result->{$layer}->{should}++;
150          $result->{$layer}->{score_min} -= 2;
151          $result->{conforming_min} = 0;
152        } elsif ($err->{level} eq 'w' or $err->{level} eq 'g') {
153          $result->{$layer}->{warning}++;
154        } elsif ($err->{level} eq 'unsupported') {
155          $result->{$layer}->{unsupported}++;
156          $result->{unsupported} = 1;
157        } else {
158          $result->{$layer}->{must}++;
159          $result->{$layer}->{score_max} -= 2;
160          $result->{$layer}->{score_min} -= 2;
161          $result->{conforming_min} = 0;
162          $result->{conforming_max} = 0;
163        }
164      } else {
165        $result->{$layer}->{must}++;
166        $result->{$layer}->{score_max} -= 2;
167        $result->{$layer}->{score_min} -= 2;
168        $result->{conforming_min} = 0;
169        $result->{conforming_max} = 0;
170      }
171    } # add_error
172    
173    sub print_http_header_section ($$) {
174      my ($input, $result) = @_;
175    return unless defined $input->{header_status_code} or    return unless defined $input->{header_status_code} or
176        defined $input->{header_status_text} or        defined $input->{header_status_text} or
177        @{$input->{header_field}};        @{$input->{header_field}};
# Line 384  not be the real header.</p> Line 204  not be the real header.</p>
204    print STDOUT qq[</tbody></table></div>];    print STDOUT qq[</tbody></table></div>];
205  } # print_http_header_section  } # print_http_header_section
206    
207    sub print_syntax_error_html_section ($$) {
208      my ($input, $result) = @_;
209      
210      require Encode;
211      require Whatpm::HTML;
212    
213      $input->{charset} ||= 'ISO-8859-1'; ## TODO: for now.
214      
215      my $time1 = time;
216      my $t = Encode::decode ($input->{charset}, $input->{s});
217      $time{decode} = time - $time1;
218    
219      print STDOUT qq[
220    <div id="parse-errors" class="section">
221    <h2>Parse Errors</h2>
222    
223    <dl>];
224      push @nav, ['#parse-errors' => 'Parse Error'];
225    
226      my $onerror = sub {
227        my (%opt) = @_;
228        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level});
229        if ($opt{column} > 0) {
230          print STDOUT qq[<dt class="$cls"><a href="#line-$opt{line}">Line $opt{line}</a> column $opt{column}</dt>\n];
231        } else {
232          $opt{line} = $opt{line} - 1 || 1;
233          print STDOUT qq[<dt class="$cls"><a href="#line-$opt{line}">Line $opt{line}</a></dt>\n];
234        }
235        $type =~ tr/ /-/;
236        $type =~ s/\|/%7C/g;
237        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
238        print STDOUT qq[<dd class="$cls">$msg</dd>\n];
239    
240        add_error ('syntax', \%opt => $result);
241      };
242    
243      my $doc = $dom->create_document;
244      my $el;
245      $time1 = time;
246      if (defined $inner_html_element and length $inner_html_element) {
247        $el = $doc->create_element_ns
248            ('http://www.w3.org/1999/xhtml', [undef, $inner_html_element]);
249        Whatpm::HTML->set_inner_html ($el, $t, $onerror);
250      } else {
251        Whatpm::HTML->parse_string ($t => $doc, $onerror);
252      }
253      $time{parse} = time - $time1;
254    
255      print STDOUT qq[</dl></div>];
256    
257      return ($doc, $el);
258    } # print_syntax_error_html_section
259    
260    sub print_syntax_error_xml_section ($$) {
261      my ($input, $result) = @_;
262      
263      require Message::DOM::XMLParserTemp;
264      
265      print STDOUT qq[
266    <div id="parse-errors" class="section">
267    <h2>Parse Errors</h2>
268    
269    <dl>];
270      push @nav, ['#parse-errors' => 'Parse Error'];
271    
272      my $onerror = sub {
273        my $err = shift;
274        my $line = $err->location->line_number;
275        print STDOUT qq[<dt><a href="#line-$line">Line $line</a> column ];
276        print STDOUT $err->location->column_number, "</dt><dd>";
277        print STDOUT htescape $err->text, "</dd>\n";
278    
279        add_error ('syntax', {type => $err->text,
280                    level => [
281                              $err->SEVERITY_FATAL_ERROR => 'm',
282                              $err->SEVERITY_ERROR => 'm',
283                              $err->SEVERITY_WARNING => 's',
284                             ]->[$err->severity]} => $result);
285    
286        return 1;
287      };
288    
289      my $time1 = time;
290      open my $fh, '<', \($input->{s});
291      my $doc = Message::DOM::XMLParserTemp->parse_byte_stream
292          ($fh => $dom, $onerror, charset => $input->{charset});
293      $time{parse_xml} = time - $time1;
294    
295      print STDOUT qq[</dl></div>];
296    
297      return ($doc, undef);
298    } # print_syntax_error_xml_section
299    
300  sub print_source_string_section ($$) {  sub print_source_string_section ($$) {
301    require Encode;    require Encode;
302    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 399  sub print_document_tree ($) {
399    print STDOUT $r;    print STDOUT $r;
400  } # print_document_tree  } # print_document_tree
401    
402    sub print_structure_dump_section ($$) {
403      my ($doc, $el) = @_;
404    
405      print STDOUT qq[
406    <div id="document-tree" class="section">
407    <h2>Document Tree</h2>
408    ];
409      push @nav, ['#document-tree' => 'Tree'];
410    
411      print_document_tree ($el || $doc);
412    
413      print STDOUT qq[</div>];
414    } # print_structure_dump_section
415    
416    sub print_structure_error_section ($$$) {
417      my ($doc, $el, $result) = @_;
418    
419      print STDOUT qq[<div id="document-errors" class="section">
420    <h2>Document Errors</h2>
421    
422    <dl>];
423      push @nav, ['#document-errors' => 'Document Error'];
424    
425      require Whatpm::ContentChecker;
426      my $onerror = sub {
427        my %opt = @_;
428        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level}, $opt{node});
429        $type =~ tr/ /-/;
430        $type =~ s/\|/%7C/g;
431        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
432        print STDOUT qq[<dt class="$cls">] . get_node_link ($opt{node}) .
433            qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";
434        add_error ('structure', \%opt => $result);
435      };
436    
437      my $elements;
438      my $time1 = time;
439      if ($el) {
440        $elements = Whatpm::ContentChecker->check_element ($el, $onerror);
441      } else {
442        $elements = Whatpm::ContentChecker->check_document ($doc, $onerror);
443      }
444      $time{check} = time - $time1;
445    
446      print STDOUT qq[</dl></div>];
447    
448      return $elements;
449    } # print_structure_error_section
450    
451    sub print_table_section ($) {
452      my $tables = shift;
453      
454      push @nav, ['#tables' => 'Tables'];
455      print STDOUT qq[
456    <div id="tables" class="section">
457    <h2>Tables</h2>
458    
459    <!--[if IE]><script type="text/javascript" src="../excanvas.js"></script><![endif]-->
460    <script src="../table-script.js" type="text/javascript"></script>
461    <noscript>
462    <p><em>Structure of tables are visualized here if scripting is enabled.</em></p>
463    </noscript>
464    ];
465      
466      require JSON;
467      
468      my $i = 0;
469      for my $table_el (@$tables) {
470        $i++;
471        print STDOUT qq[<div class="section" id="table-$i"><h3>] .
472            get_node_link ($table_el) . q[</h3>];
473    
474        ## TODO: Make |ContentChecker| return |form_table| result
475        ## so that this script don't have to run the algorithm twice.
476        my $table = Whatpm::HTMLTable->form_table ($table_el);
477        
478        for (@{$table->{column_group}}, @{$table->{column}}, $table->{caption}) {
479          next unless $_;
480          delete $_->{element};
481        }
482        
483        for (@{$table->{row_group}}) {
484          next unless $_;
485          next unless $_->{element};
486          $_->{type} = $_->{element}->manakai_local_name;
487          delete $_->{element};
488        }
489        
490        for (@{$table->{cell}}) {
491          next unless $_;
492          for (@{$_}) {
493            next unless $_;
494            for (@$_) {
495              $_->{id} = refaddr $_->{element} if defined $_->{element};
496              delete $_->{element};
497              $_->{is_header} = $_->{is_header} ? 1 : 0;
498            }
499          }
500        }
501            
502        print STDOUT '</div><script type="text/javascript">tableToCanvas (';
503        print STDOUT JSON::objToJson ($table);
504        print STDOUT qq[, document.getElementById ('table-$i'));</script>];
505      }
506      
507      print STDOUT qq[</div>];
508    } # print_table_section
509    
510    sub print_id_section ($) {
511      my $ids = shift;
512      
513      push @nav, ['#identifiers' => 'IDs'];
514      print STDOUT qq[
515    <div id="identifiers" class="section">
516    <h2>Identifiers</h2>
517    
518    <dl>
519    ];
520      for my $id (sort {$a cmp $b} keys %$ids) {
521        print STDOUT qq[<dt><code>@{[htescape $id]}</code></dt>];
522        for (@{$ids->{$id}}) {
523          print STDOUT qq[<dd>].get_node_link ($_).qq[</dd>];
524        }
525      }
526      print STDOUT qq[</dl></div>];
527    } # print_id_section
528    
529    sub print_term_section ($) {
530      my $terms = shift;
531      
532      push @nav, ['#terms' => 'Terms'];
533      print STDOUT qq[
534    <div id="terms" class="section">
535    <h2>Terms</h2>
536    
537    <dl>
538    ];
539      for my $term (sort {$a cmp $b} keys %$terms) {
540        print STDOUT qq[<dt>@{[htescape $term]}</dt>];
541        for (@{$terms->{$term}}) {
542          print STDOUT qq[<dd>].get_node_link ($_).qq[</dd>];
543        }
544      }
545      print STDOUT qq[</dl></div>];
546    } # print_term_section
547    
548    sub print_class_section ($) {
549      my $classes = shift;
550      
551      push @nav, ['#classes' => 'Classes'];
552      print STDOUT qq[
553    <div id="classes" class="section">
554    <h2>Classes</h2>
555    
556    <dl>
557    ];
558      for my $class (sort {$a cmp $b} keys %$classes) {
559        print STDOUT qq[<dt><code>@{[htescape $class]}</code></dt>];
560        for (@{$classes->{$class}}) {
561          print STDOUT qq[<dd>].get_node_link ($_).qq[</dd>];
562        }
563      }
564      print STDOUT qq[</dl></div>];
565    } # print_class_section
566    
567    sub print_result_section ($) {
568      my $result = shift;
569    
570      print STDOUT qq[
571    <div id="result-summary" class="section">
572    <h2>Result</h2>];
573    
574      if ($result->{unsupported} and $result->{conforming_max}) {  
575        print STDOUT qq[<p class=uncertain id=result-para>The conformance
576            checker cannot decide whether the document is conforming or
577            not, since the document contains one or more unsupported
578            features.  The document might or might not be conforming.</p>];
579      } elsif ($result->{conforming_min}) {
580        print STDOUT qq[<p class=PASS id=result-para>No conformance-error is
581            found in this document.</p>];
582      } elsif ($result->{conforming_max}) {
583        print STDOUT qq[<p class=SEE-RESULT id=result-para>This document
584            is <strong>likely <em>non</em>-conforming</strong>, but in rare case
585            it might be conforming.</p>];
586      } else {
587        print STDOUT qq[<p class=FAIL id=result-para>This document is
588            <strong><em>non</em>-conforming</strong>.</p>];
589      }
590    
591      print STDOUT qq[<table>
592    <colgroup><col><colgroup><col><col><col><colgroup><col>
593    <thead>
594    <tr><th scope=col></th><th scope=col><em class=rfc2119>MUST</em>-level
595    Errors</th><th scope=col><em class=rfc2119>SHOULD</em>-level
596    Errors</th><th scope=col>Warnings</th><th scope=col>Score</th></tr>
597    </thead><tbody>];
598    
599      my $must_error = 0;
600      my $should_error = 0;
601      my $warning = 0;
602      my $score_min = 0;
603      my $score_max = 0;
604      my $score_base = 20;
605      my $score_unit = $score_base / 100;
606      for (
607        [Transfer => 'transfer', ''],
608        [Character => 'char', ''],
609        [Syntax => 'syntax', '#parse-errors'],
610        [Structure => 'structure', '#document-errors'],
611      ) {
612        $must_error += ($result->{$_->[1]}->{must} += 0);
613        $should_error += ($result->{$_->[1]}->{should} += 0);
614        $warning += ($result->{$_->[1]}->{warning} += 0);
615        $score_min += (($result->{$_->[1]}->{score_min} *= $score_unit) += $score_base);
616        $score_max += (($result->{$_->[1]}->{score_max} *= $score_unit) += $score_base);
617    
618        my $uncertain = $result->{$_->[1]}->{unsupported} ? '?' : '';
619        my $label = $_->[0];
620        if ($result->{$_->[1]}->{must} or
621            $result->{$_->[1]}->{should} or
622            $result->{$_->[1]}->{warning} or
623            $result->{$_->[1]}->{unsupported}) {
624          $label = qq[<a href="$_->[2]">$label</a>];
625        }
626    
627        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>];
628        if ($uncertain) {
629          print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : $result->{$_->[1]}->{should} ? 'SEE-RESULT' : '']}">&#x2212;&#x221E;..$result->{$_->[1]}->{score_max}</td>];
630        } elsif ($result->{$_->[1]}->{score_min} != $result->{$_->[1]}->{score_max}) {
631          print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : 'SEE-RESULT']}">$result->{$_->[1]}->{score_min}..$result->{$_->[1]}->{score_max}</td></tr>];
632        } else {
633          print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : '']}">$result->{$_->[1]}->{score_min}</td></tr>];
634        }
635      }
636    
637      $score_max += $score_base;
638    
639      print STDOUT qq[
640    <tr class=uncertain><th scope=row>Semantics</th><td>0?</td><td>0?</td><td>0?</td><td>&#x2212;&#x221E;..$score_base</td></tr>
641    </tbody>
642    <tfoot><tr class=uncertain><th scope=row>Total</th>
643    <td class="@{[$must_error ? 'FAIL' : '']}">$must_error?</td>
644    <td class="@{[$should_error ? 'SEE-RESULT' : '']}">$should_error?</td>
645    <td>$warning?</td>
646    <td class="@{[$must_error ? 'FAIL' : $should_error ? 'SEE-RESULT' : '']}"><strong>&#x2212;&#x221E;..$score_max</strong></td></tr></tfoot>
647    </table>
648    
649    <p><strong>Important</strong>: This conformance checking service
650    is <em>under development</em>.  The result above might be <em>wrong</em>.</p>
651    </div>];
652      push @nav, ['#result-summary' => 'Result'];
653    } # print_result_section
654    
655    sub print_result_unknown_type_section ($) {
656      my $input = shift;
657    
658      print STDOUT qq[
659    <div id="result-summary" class="section">
660    <p><em>Media type <code class="MIME" lang="en">@{[htescape $input->{media_type}]}</code> is not supported!</em></p>
661    </div>
662    ];
663      push @nav, ['#result-summary' => 'Result'];
664    } # print_result_unknown_type_section
665    
666    sub print_result_input_error_section ($) {
667      my $input = shift;
668      print STDOUT qq[<div class="section" id="result-summary">
669    <p><em><strong>Input Error</strong>: @{[htescape ($input->{error_status_text})]}</em></p>
670    </div>];
671      push @nav, ['#result-summary' => 'Result'];
672    } # print_Result_input_error_section
673    
674  sub get_node_path ($) {  sub get_node_path ($) {
675    my $node = shift;    my $node = shift;
676    my @r;    my @r;
# Line 550  sub get_text ($) { Line 735  sub get_text ($) {
735        $msg =~ s{<var>{\@}</var>}{        $msg =~ s{<var>{\@}</var>}{
736          UNIVERSAL::can ($node, 'value') ? htescape ($node->value) : ''          UNIVERSAL::can ($node, 'value') ? htescape ($node->value) : ''
737        }ge;        }ge;
738          $msg =~ s{<var>{local-name}</var>}{
739            UNIVERSAL::can ($node, 'manakai_local_name')
740              ? htescape ($node->manakai_local_name) : ''
741          }ge;
742          $msg =~ s{<var>{element-local-name}</var>}{
743            (UNIVERSAL::can ($node, 'owner_element') and
744             $node->owner_element)
745              ? htescape ($node->owner_element->manakai_local_name)
746              : ''
747          }ge;
748        return ($type, $Msg->{$type}->[0], $msg);        return ($type, $Msg->{$type}->[0], $msg);
749      } elsif ($type =~ s/:([^:]*)$//) {      } elsif ($type =~ s/:([^:]*)$//) {
750        unshift @arg, $1;        unshift @arg, $1;
# Line 564  sub get_text ($) { Line 759  sub get_text ($) {
759  sub get_input_document ($$) {  sub get_input_document ($$) {
760    my ($http, $dom) = @_;    my ($http, $dom) = @_;
761    
762    my $request_uri = $http->parameter ('uri');    my $request_uri = $http->get_parameter ('uri');
763    my $r = {};    my $r = {};
764    if (defined $request_uri and length $request_uri) {    if (defined $request_uri and length $request_uri) {
765      my $uri = $dom->create_uri_reference ($request_uri);      my $uri = $dom->create_uri_reference ($request_uri);
# Line 613  EOH Line 808  EOH
808      $ua->max_size (1000_000);      $ua->max_size (1000_000);
809      my $req = HTTP::Request->new (GET => $request_uri);      my $req = HTTP::Request->new (GET => $request_uri);
810      my $res = $ua->request ($req);      my $res = $ua->request ($req);
811      if ($res->is_success or $http->parameter ('error-page')) {      ## TODO: 401 sets |is_success| true.
812        if ($res->is_success or $http->get_parameter ('error-page')) {
813        $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!
814        $r->{uri} = $res->request->uri;        $r->{uri} = $res->request->uri;
815        $r->{request_uri} = $request_uri;        $r->{request_uri} = $request_uri;
# Line 628  EOH Line 824  EOH
824          $r->{charset} =~ tr/\\//d;          $r->{charset} =~ tr/\\//d;
825        }        }
826    
827        my $input_charset = $http->parameter ('charset');        my $input_charset = $http->get_parameter ('charset');
828        if (defined $input_charset and length $input_charset) {        if (defined $input_charset and length $input_charset) {
829          $r->{charset_overridden}          $r->{charset_overridden}
830              = (not defined $r->{charset} or $r->{charset} ne $input_charset);              = (not defined $r->{charset} or $r->{charset} ne $input_charset);
# Line 649  EOH Line 845  EOH
845      $r->{header_status_code} = $res->code;      $r->{header_status_code} = $res->code;
846      $r->{header_status_text} = $res->message;      $r->{header_status_text} = $res->message;
847    } else {    } else {
848      $r->{s} = ''.$http->parameter ('s');      $r->{s} = ''.$http->get_parameter ('s');
849      $r->{uri} = q<thismessage:/>;      $r->{uri} = q<thismessage:/>;
850      $r->{request_uri} = q<thismessage:/>;      $r->{request_uri} = q<thismessage:/>;
851      $r->{base_uri} = q<thismessage:/>;      $r->{base_uri} = q<thismessage:/>;
852      $r->{charset} = ''.$http->parameter ('_charset_');      $r->{charset} = ''.$http->get_parameter ('_charset_');
853      $r->{charset} =~ s/\s+//g;      $r->{charset} =~ s/\s+//g;
854      $r->{charset} = 'utf-8' if $r->{charset} eq '';      $r->{charset} = 'utf-8' if $r->{charset} eq '';
855      $r->{header_field} = [];      $r->{header_field} = [];
856    }    }
857    
858    my $input_format = $http->parameter ('i');    my $input_format = $http->get_parameter ('i');
859    if (defined $input_format and length $input_format) {    if (defined $input_format and length $input_format) {
860      $r->{media_type_overridden}      $r->{media_type_overridden}
861          = (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.21
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24