/[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.2 by wakaba, Wed Jun 27 12:35:24 2007 UTC revision 1.8 by wakaba, Sun Jul 1 10:02:24 2007 UTC
# Line 23  my $http = SuikaWiki::Input::HTTP->new; Line 23  my $http = SuikaWiki::Input::HTTP->new;
23    
24  ## TODO: _charset_  ## TODO: _charset_
25    
26      if ($http->meta_variable ('PATH_INFO') ne '/') {
27        print STDOUT "Status: 404 Not Found\nContent-Type: text/plain; charset=us-ascii\n\n400";
28        exit;
29      }
30    
31    my $input_format = $http->parameter ('i') || 'text/html';    my $input_format = $http->parameter ('i') || 'text/html';
32    my $inner_html_element = $http->parameter ('e');    my $inner_html_element = $http->parameter ('e');
33    my $input_uri = 'thismessage:/';    my $input_uri = 'thismessage:/';
# Line 33  my $http = SuikaWiki::Input::HTTP->new; Line 38  my $http = SuikaWiki::Input::HTTP->new;
38      exit;      exit;
39    }    }
40    
41      load_text_catalog ('en'); ## TODO: conneg
42    
43      my @nav;
44    print STDOUT qq[Content-Type: text/html; charset=utf-8    print STDOUT qq[Content-Type: text/html; charset=utf-8
45    
46  <!DOCTYPE html>  <!DOCTYPE html>
47  <html lang="en">  <html lang="en">
48  <head>  <head>
49  <title>Web Document Conformance Checker (BETA)</title>  <title>Web Document Conformance Checker (BETA)</title>
50  <link rel="stylesheet" href="/www/style/html/xhtml">  <link rel="stylesheet" href="../cc-style.css" type="text/css">
 <style>  
   q {  
     white-space: pre;  
     white-space: -moz-pre-wrap;  
     white-space: pre-wrap;  
   }  
 </style>  
51  </head>  </head>
52  <body>  <body>
53  <h1>Web Document Conformance Checker (<em>beta</em>)</h1>  <h1>Web Document Conformance Checker (<em>beta</em>)</h1>
54    
55    <div id="document-info" class="section">
56  <dl>  <dl>
57  <dt>Document URI</dt>  <dt>Document URI</dt>
58      <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]}">@{[htescape $input_uri]}</a>&gt;</code></dd>
59  <dt>Internet Media Type</dt>  <dt>Internet Media Type</dt>
60      <dd><code class="MIME" lang="en">@{[htescape $input_format]}</code></dd>      <dd><code class="MIME" lang="en">@{[htescape $input_format]}</code></dd>
61  ]; # no </dl> yet  ]; # no </dl> yet
62      push @nav, ['#document-info' => 'Information'];
63    
64    require Message::DOM::DOMImplementation;    require Message::DOM::DOMImplementation;
65    my $dom = Message::DOM::DOMImplementation->____new;    my $dom = Message::DOM::DOMImplementation->____new;
# Line 73  my $http = SuikaWiki::Input::HTTP->new; Line 76  my $http = SuikaWiki::Input::HTTP->new;
76  <dt>Character Encoding</dt>  <dt>Character Encoding</dt>
77      <dd>(none)</dd>      <dd>(none)</dd>
78  </dl>  </dl>
79    </div>
80    
81  <div id="source-string" class="section">  <div id="source-string" class="section">
82    <h2>Document Source</h2>
83  ];  ];
84        push @nav, ['#source-string' => 'Source'];
85      print_source_string (\$s);      print_source_string (\$s);
86      print STDOUT qq[      print STDOUT qq[
87  </div>  </div>
# Line 83  my $http = SuikaWiki::Input::HTTP->new; Line 89  my $http = SuikaWiki::Input::HTTP->new;
89  <div id="parse-errors" class="section">  <div id="parse-errors" class="section">
90  <h2>Parse Errors</h2>  <h2>Parse Errors</h2>
91    
92  <ul>  <dl>
93  ];  ];
94      push @nav, ['#parse-errors' => 'Parse Error'];
95    
96    my $onerror = sub {    my $onerror = sub {
97      my (%opt) = @_;      my (%opt) = @_;
98        my ($cls, $msg) = get_text ($opt{type}, $opt{level});
99      if ($opt{column} > 0) {      if ($opt{column} > 0) {
100        print STDOUT qq[<li><a href="#line-$opt{line}">Line $opt{line}</a> column $opt{column}: ];        print STDOUT qq[<dt class="$cls"><a href="#line-$opt{line}">Line $opt{line}</a> column $opt{column}</dt>\n];
101      } else {      } else {
102        $opt{line}--;        $opt{line} = $opt{line} - 1 || 1;
103        print STDOUT qq[<li><a href="#line-$opt{line}">Line $opt{line}</a>: ];        print STDOUT qq[<dt class="$cls"><a href="#line-$opt{line}">Line $opt{line}</a></dt>\n];
104      }      }
105      print STDOUT qq[@{[htescape $opt{type}]}</li>\n];      $opt{type} =~ tr/ /-/;
106        $opt{type} =~ s/\|/%7C/g;
107        $msg .= qq[ [<a href="../error-description#$opt{type}">Description</a>]];
108        print STDOUT qq[<dd class="$cls">$msg</dd>\n];
109    };    };
110    
111    $doc = $dom->create_document;    $doc = $dom->create_document;
# Line 107  my $http = SuikaWiki::Input::HTTP->new; Line 118  my $http = SuikaWiki::Input::HTTP->new;
118    }    }
119    
120    print STDOUT qq[    print STDOUT qq[
121  </ul>  </dl>
122  </div>  </div>
123  ];  ];
124    } elsif ($input_format eq 'application/xhtml+xml') {    } elsif ($input_format eq 'application/xhtml+xml') {
# Line 120  my $http = SuikaWiki::Input::HTTP->new; Line 131  my $http = SuikaWiki::Input::HTTP->new;
131  <dt>Character Encoding</dt>  <dt>Character Encoding</dt>
132      <dd>(none)</dd>      <dd>(none)</dd>
133  </dl>  </dl>
134    </div>
135    
136  <div id="source-string" class="section">  <div id="source-string" class="section">
137    <h2>Document Source</h2>
138  ];  ];
139        push @nav, ['#source-string' => 'Source'];
140      print_source_string (\$t);      print_source_string (\$t);
141      print STDOUT qq[      print STDOUT qq[
142  </div>  </div>
# Line 130  my $http = SuikaWiki::Input::HTTP->new; Line 144  my $http = SuikaWiki::Input::HTTP->new;
144  <div id="parse-errors" class="section">  <div id="parse-errors" class="section">
145  <h2>Parse Errors</h2>  <h2>Parse Errors</h2>
146    
147  <ul>  <dl>];
148  ];    push @nav, ['#parse-errors' => 'Parse Error'];
149    
150    my $onerror = sub {    my $onerror = sub {
151      my $err = shift;      my $err = shift;
152      my $line = $err->location->line_number;      my $line = $err->location->line_number;
153      print STDOUT qq[<li><a href="#line-$line">Line $line</a> column ];      print STDOUT qq[<dt><a href="#line-$line">Line $line</a> column ];
154      print STDOUT $err->location->column_number, ": ";      print STDOUT $err->location->column_number, "</dt><dd>";
155      print STDOUT htescape $err->text, "</li>\n";      print STDOUT htescape $err->text, "</dd>\n";
156      return 1;      return 1;
157    };    };
158    
# Line 146  my $http = SuikaWiki::Input::HTTP->new; Line 160  my $http = SuikaWiki::Input::HTTP->new;
160    $doc = Message::DOM::XMLParserTemp->parse_byte_stream    $doc = Message::DOM::XMLParserTemp->parse_byte_stream
161        ($fh => $dom, $onerror, charset => 'utf-8');        ($fh => $dom, $onerror, charset => 'utf-8');
162    
163      print STDOUT qq[      print STDOUT qq[</dl>
 </ul>  
164  </div>  </div>
165  ];  ];
166    } else {    } else {
167      print STDOUT qq[      print STDOUT qq[
168  </dl>  </dl>
169    </div>
170    
171    <div id="result-summary" class="section">
172  <p><em>Media type <code class="MIME" lang="en">@{[htescape $input_format]}</code> is not supported!</em></p>  <p><em>Media type <code class="MIME" lang="en">@{[htescape $input_format]}</code> is not supported!</em></p>
173    </div>
174  ];  ];
175        push @nav, ['#result-summary' => 'Result'];
176    }    }
177    
178    
# Line 164  my $http = SuikaWiki::Input::HTTP->new; Line 181  my $http = SuikaWiki::Input::HTTP->new;
181  <div id="document-tree" class="section">  <div id="document-tree" class="section">
182  <h2>Document Tree</h2>  <h2>Document Tree</h2>
183  ];  ];
184        push @nav, ['#document-tree' => 'Tree'];
185    
186      print_document_tree ($el || $doc);      print_document_tree ($el || $doc);
187    
# Line 173  my $http = SuikaWiki::Input::HTTP->new; Line 191  my $http = SuikaWiki::Input::HTTP->new;
191  <div id="document-errors" class="section">  <div id="document-errors" class="section">
192  <h2>Document Errors</h2>  <h2>Document Errors</h2>
193    
194  <ul>  <dl>];
195  ];      push @nav, ['#document-errors' => 'Document Error'];
196    
197      require Whatpm::ContentChecker;      require Whatpm::ContentChecker;
198      my $onerror = sub {      my $onerror = sub {
199        my %opt = @_;        my %opt = @_;
200        print STDOUT qq[<li><a href="#node-@{[refaddr $opt{node}]}">],        my ($cls, $msg) = get_text ($opt{type}, $opt{level});
201            htescape get_node_path ($opt{node}),        $opt{type} = $opt{level} . ':' . $opt{type} if defined $opt{level};
202            "</a>: ", htescape $opt{type}, "</li>\n";        $opt{type} =~ tr/ /-/;
203          $opt{type} =~ s/\|/%7C/g;
204          $msg .= qq[ [<a href="../error-description#$opt{type}">Description</a>]];
205          print STDOUT qq[<dt class="$cls">] . get_node_link ($opt{node}) .
206              qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";
207      };      };
208    
209        my $elements;
210      if ($el) {      if ($el) {
211        Whatpm::ContentChecker->check_element ($el, $onerror);        $elements = Whatpm::ContentChecker->check_element ($el, $onerror);
212      } else {      } else {
213        Whatpm::ContentChecker->check_document ($doc, $onerror);        $elements = Whatpm::ContentChecker->check_document ($doc, $onerror);
214      }      }
215    
216      print STDOUT qq[      print STDOUT qq[</dl>
 </ul>  
217  </div>  </div>
218  ];  ];
219    
220        if (@{$elements->{table}}) {
221          require JSON;
222    
223          print STDOUT qq[
224    <div id="tables" class="section">
225    <h2>Tables</h2>
226    
227    <!--[if IE]><script type="text/javascript" src="../excanvas.js"></script><![endif]-->
228    <script src="../table-script.js" type="text/javascript"></script>
229    <noscript>
230    <p><em>Structure of tables are visualized here if scripting is enabled.</em></p>
231    </noscript>
232    ];
233    
234          my $i = 0;
235          for my $table_el (@{$elements->{table}}) {
236            $i++;
237            print STDOUT qq[<div class="section" id="table-$i"><h3>] .
238                get_node_link ($table_el) . q[</h3>];
239            
240            my $table = Whatpm::HTMLTable->form_table ($table_el);
241            
242            for (@{$table->{column_group}}, @{$table->{column}}, $table->{caption}) {
243              next unless $_;
244              delete $_->{element};
245            }
246            
247            for (@{$table->{row_group}}) {
248              next unless $_;
249              next unless $_->{element};
250              $_->{type} = $_->{element}->manakai_local_name;
251              delete $_->{element};
252            }
253            
254            for (@{$table->{cell}}) {
255              next unless $_;
256              for (@{$_}) {
257                next unless $_;
258                for (@$_) {
259                  $_->{id} = refaddr $_->{element} if defined $_->{element};
260                  delete $_->{element};
261                }
262              }
263            }
264            
265            print STDOUT '</div><script type="text/javascript">tableToCanvas (';
266            print STDOUT JSON::objToJson ($table);
267            print STDOUT qq[, document.getElementById ('table-$i'));</script>];
268          }
269        
270          print STDOUT qq[</div>];
271        }
272    
273        if (keys %{$elements->{term}}) {
274          print STDOUT qq[
275    <div id="terms" class="section">
276    <h2>Terms</h2>
277    
278    <dl>
279    ];
280          for my $term (sort {$a cmp $b} keys %{$elements->{term}}) {
281            print STDOUT qq[<dt>@{[htescape $term]}</dt>];
282            for (@{$elements->{term}->{$term}}) {
283              print STDOUT qq[<dd>].get_node_link ($_).qq[</dd>];
284            }
285          }
286          print STDOUT qq[</dl></div>];
287        }
288    }    }
289    
290    ## TODO: Show result    ## TODO: Show result
291    
292      print STDOUT qq[
293    <ul class="navigation" id="nav-items">
294    ];
295      for (@nav) {
296        print STDOUT qq[<li><a href="$_->[0]">$_->[1]</a></li>];
297      }
298    print STDOUT qq[    print STDOUT qq[
299    </ul>
300  </body>  </body>
301  </html>  </html>
302  ];  ];
# Line 208  sub print_source_string ($) { Line 307  sub print_source_string ($) {
307    my $s = $_[0];    my $s = $_[0];
308    my $i = 1;    my $i = 1;
309    print STDOUT qq[<ol lang="">\n];    print STDOUT qq[<ol lang="">\n];
310    while ($$s =~ /\G([^\x0A]*?)\x0D?\x0A/gc) {    if (length $$s) {
311      print STDOUT qq[<li id="line-$i">], htescape $1, "</li>\n";      while ($$s =~ /\G([^\x0A]*?)\x0D?\x0A/gc) {
312      $i++;        print STDOUT qq[<li id="line-$i">], htescape $1, "</li>\n";
313    }        $i++;
314    if ($$s =~ /\G([^\x0A]+)/gc) {      }
315      print STDOUT qq[<li id="line-$i">], htescape $1, "</li>\n";      if ($$s =~ /\G([^\x0A]+)/gc) {
316          print STDOUT qq[<li id="line-$i">], htescape $1, "</li>\n";
317        }
318      } else {
319        print STDOUT q[<li id="line-1"></li>];
320    }    }
321    print STDOUT "</ol>";    print STDOUT "</ol>";
322  } # print_input_string  } # print_input_string
# Line 233  sub print_document_tree ($) { Line 336  sub print_document_tree ($) {
336      my $node_id = 'node-'.refaddr $child;      my $node_id = 'node-'.refaddr $child;
337      my $nt = $child->node_type;      my $nt = $child->node_type;
338      if ($nt == $child->ELEMENT_NODE) {      if ($nt == $child->ELEMENT_NODE) {
339        $r .= qq'<li id="$node_id"><code>' . htescape ($child->tag_name) .        my $child_nsuri = $child->namespace_uri;
340          $r .= qq[<li id="$node_id" class="tree-element"><code title="@{[defined $child_nsuri ? $child_nsuri : '']}">] . htescape ($child->tag_name) .
341            '</code>'; ## ISSUE: case            '</code>'; ## ISSUE: case
342    
343        if ($child->has_attributes) {        if ($child->has_attributes) {
344          $r .= '<ul class="attributes">';          $r .= '<ul class="attributes">';
345          for my $attr (sort {$a->[0] cmp $b->[0]} map { [$_->name, $_->value, 'node-'.refaddr $_] }          for my $attr (sort {$a->[0] cmp $b->[0]} map { [$_->name, $_->value, $_->namespace_uri, 'node-'.refaddr $_] }
346                        @{$child->attributes}) {                        @{$child->attributes}) {
347            $r .= qq'<li id="$attr->[2]"><code>' . htescape ($attr->[0]) . '</code> = '; ## ISSUE: case?            $r .= qq[<li id="$attr->[3]" class="tree-attribute"><code title="@{[defined $_->[2] ? $_->[2] : '']}">] . htescape ($attr->[0]) . '</code> = '; ## ISSUE: case?
348            $r .= '<q>' . htescape ($attr->[1]) . '</q></li>'; ## TODO: children            $r .= '<q>' . htescape ($attr->[1]) . '</q></li>'; ## TODO: children
349          }          }
350          $r .= '</ul>';          $r .= '</ul>';
351        }        }
352    
353        if ($node->has_child_nodes) {        if ($child->has_child_nodes) {
354          $r .= '<ol class="children">';          $r .= '<ol class="children">';
355          unshift @node, @{$child->child_nodes}, '</ol>';          unshift @node, @{$child->child_nodes}, '</ol></li>';
356          } else {
357            $r .= '</li>';
358        }        }
359      } elsif ($nt == $child->TEXT_NODE) {      } elsif ($nt == $child->TEXT_NODE) {
360        $r .= qq'<li id="$node_id"><q>' . htescape ($child->data) . '</q></li>';        $r .= qq'<li id="$node_id" class="tree-text"><q lang="">' . htescape ($child->data) . '</q></li>';
361      } elsif ($nt == $child->CDATA_SECTION_NODE) {      } elsif ($nt == $child->CDATA_SECTION_NODE) {
362        $r .= qq'<li id="$node_id"><code>&lt;[CDATA[</code><q>' . htescape ($child->data) . '</q><code>]]&gt;</code></li>';        $r .= qq'<li id="$node_id" class="tree-cdata"><code>&lt;[CDATA[</code><q lang="">' . htescape ($child->data) . '</q><code>]]&gt;</code></li>';
363      } elsif ($nt == $child->COMMENT_NODE) {      } elsif ($nt == $child->COMMENT_NODE) {
364        $r .= qq'<li id="$node_id"><code>&lt;!--</code><q>' . htescape ($child->data) . '</q><code>--&gt;</code></li>';        $r .= qq'<li id="$node_id" class="tree-comment"><code>&lt;!--</code><q lang="">' . htescape ($child->data) . '</q><code>--&gt;</code></li>';
365      } elsif ($nt == $child->DOCUMENT_NODE) {      } elsif ($nt == $child->DOCUMENT_NODE) {
366        $r .= qq'<li id="$node_id">Document</li>';        $r .= qq'<li id="$node_id" class="tree-document">Document';
367          $r .= qq[<ul class="attributes">];
368          $r .= qq[<li>@{[scalar get_text ('manakaiIsHTML:'.($child->manakai_is_html?1:0))]}</li>];
369          $r .= qq[<li>@{[scalar get_text ('manakaiCompatMode:'.$child->manakai_compat_mode)]}</li>];
370          $r .= qq[</ul>];
371        if ($child->has_child_nodes) {        if ($child->has_child_nodes) {
372          $r .= '<ol>';          $r .= '<ol class="children">';
373          unshift @node, @{$child->child_nodes}, '</ol>';          unshift @node, @{$child->child_nodes}, '</ol></li>';
374        }        }
375      } elsif ($nt == $child->DOCUMENT_TYPE_NODE) {      } elsif ($nt == $child->DOCUMENT_TYPE_NODE) {
376        $r .= qq'<li id="$node_id"><code>&lt;!DOCTYPE&gt;</code><ul>';        $r .= qq'<li id="$node_id" class="tree-doctype"><code>&lt;!DOCTYPE&gt;</code><ul class="attributes">';
377        $r .= '<li>Name = <q>@{[htescape ($child->name)]}</q></li>';        $r .= qq[<li class="tree-doctype-name">Name = <q>@{[htescape ($child->name)]}</q></li>];
378        $r .= '<li>Public identifier = <q>@{[htescape ($child->public_id)]}</q></li>';        $r .= qq[<li class="tree-doctype-publicid">Public identifier = <q>@{[htescape ($child->public_id)]}</q></li>];
379        $r .= '<li>System identifier = <q>@{[htescape ($child->system_id)]}</q></li>';        $r .= qq[<li class="tree-doctype-systemid">System identifier = <q>@{[htescape ($child->system_id)]}</q></li>];
380        $r .= '</ul></li>';        $r .= '</ul></li>';
381      } elsif ($nt == $child->PROCESSING_INSTRUCTION_NODE) {      } elsif ($nt == $child->PROCESSING_INSTRUCTION_NODE) {
382        $r .= qq'<li id="$node_id"><code>&lt;?@{[htescape ($child->target)]}?&gt;</code>';        $r .= qq'<li id="$node_id" class="tree-id"><code>&lt;?@{[htescape ($child->target)]}</code> <q>@{[htescape ($child->data)]}</q><code>?&gt;</code></li>';
       $r .= '<ul><li>@{[htescape ($child->data)]}</li></ul></li>';  
383      } else {      } else {
384        $r .= qq'<li id="$node_id">@{[$child->node_type]} @{[htescape ($child->node_name)]}</li>'; # error        $r .= qq'<li id="$node_id" class="tree-unknown">@{[$child->node_type]} @{[htescape ($child->node_name)]}</li>'; # error
385      }      }
386    }    }
387    
# Line 306  sub get_node_path ($) { Line 415  sub get_node_path ($) {
415    return join '/', @r;    return join '/', @r;
416  } # get_node_path  } # get_node_path
417    
418    sub get_node_link ($) {
419      return qq[<a href="#node-@{[refaddr $_[0]]}">] .
420          htescape (get_node_path ($_[0])) . qq[</a>];
421    } # get_node_link
422    
423    {
424      my $Msg = {};
425    
426    sub load_text_catalog ($) {
427      my $lang = shift; # MUST be a canonical lang name
428      open my $file, '<', "cc-msg.$lang.txt" or die "$0: cc-msg.$lang.txt: $!";
429      while (<$file>) {
430        if (s/^([^;]+);([^;]*);//) {
431          my ($type, $cls, $msg) = ($1, $2, $_);
432          $msg =~ tr/\x0D\x0A//d;
433          $Msg->{$type} = [$cls, $msg];
434        }
435      }
436    } # load_text_catalog
437    
438    sub get_text ($) {
439      my ($type, $level) = @_;
440      $type = $level . ':' . $type if defined $level;
441      my @arg;
442      {
443        if (defined $Msg->{$type}) {
444          my $msg = $Msg->{$type}->[1];
445          $msg =~ s/\$([0-9]+)/defined $arg[$1] ? htescape ($arg[$1]) : '(undef)'/ge;
446          return ($Msg->{$type}->[0], $msg);
447        } elsif ($type =~ s/:([^:]*)$//) {
448          unshift @arg, $1;
449          redo;
450        }
451      }
452      return ('', htescape ($_[0]));
453    } # get_text
454    
455    }
456    
457  =head1 AUTHOR  =head1 AUTHOR
458    
459  Wakaba <w@suika.fam.cx>.  Wakaba <w@suika.fam.cx>.
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.8
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24