/[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.5 by wakaba, Sat Jun 30 08:26:08 2007 UTC
# Line 33  my $http = SuikaWiki::Input::HTTP->new; Line 33  my $http = SuikaWiki::Input::HTTP->new;
33      exit;      exit;
34    }    }
35    
36      my @nav;
37    print STDOUT qq[Content-Type: text/html; charset=utf-8    print STDOUT qq[Content-Type: text/html; charset=utf-8
38    
39  <!DOCTYPE html>  <!DOCTYPE html>
40  <html lang="en">  <html lang="en">
41  <head>  <head>
42  <title>Web Document Conformance Checker (BETA)</title>  <title>Web Document Conformance Checker (BETA)</title>
43  <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>  
44  </head>  </head>
45  <body>  <body>
46  <h1>Web Document Conformance Checker (<em>beta</em>)</h1>  <h1>Web Document Conformance Checker (<em>beta</em>)</h1>
47    
48    <div id="document-info" class="section">
49  <dl>  <dl>
50  <dt>Document URI</dt>  <dt>Document URI</dt>
51      <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>
52  <dt>Internet Media Type</dt>  <dt>Internet Media Type</dt>
53      <dd><code class="MIME" lang="en">@{[htescape $input_format]}</code></dd>      <dd><code class="MIME" lang="en">@{[htescape $input_format]}</code></dd>
54  ]; # no </dl> yet  ]; # no </dl> yet
55      push @nav, ['#document-info' => 'Information'];
56    
57    require Message::DOM::DOMImplementation;    require Message::DOM::DOMImplementation;
58    my $dom = Message::DOM::DOMImplementation->____new;    my $dom = Message::DOM::DOMImplementation->____new;
# Line 73  my $http = SuikaWiki::Input::HTTP->new; Line 69  my $http = SuikaWiki::Input::HTTP->new;
69  <dt>Character Encoding</dt>  <dt>Character Encoding</dt>
70      <dd>(none)</dd>      <dd>(none)</dd>
71  </dl>  </dl>
72    </div>
73    
74  <div id="source-string" class="section">  <div id="source-string" class="section">
75    <h2>Document Source</h2>
76  ];  ];
77        push @nav, ['#source-string' => 'Source'];
78      print_source_string (\$s);      print_source_string (\$s);
79      print STDOUT qq[      print STDOUT qq[
80  </div>  </div>
# Line 83  my $http = SuikaWiki::Input::HTTP->new; Line 82  my $http = SuikaWiki::Input::HTTP->new;
82  <div id="parse-errors" class="section">  <div id="parse-errors" class="section">
83  <h2>Parse Errors</h2>  <h2>Parse Errors</h2>
84    
85  <ul>  <dl>
86  ];  ];
87      push @nav, ['#parse-errors' => 'Parse Error'];
88    
89    my $onerror = sub {    my $onerror = sub {
90      my (%opt) = @_;      my (%opt) = @_;
91      if ($opt{column} > 0) {      if ($opt{column} > 0) {
92        print STDOUT qq[<li><a href="#line-$opt{line}">Line $opt{line}</a> column $opt{column}: ];        print STDOUT qq[<dt><a href="#line-$opt{line}">Line $opt{line}</a> column $opt{column}</dt>\n];
93      } else {      } else {
94        $opt{line}--;        $opt{line}--;
95        print STDOUT qq[<li><a href="#line-$opt{line}">Line $opt{line}</a>: ];        print STDOUT qq[<dt><a href="#line-$opt{line}">Line $opt{line}</a></dt>\n];
96      }      }
97      print STDOUT qq[@{[htescape $opt{type}]}</li>\n];      print STDOUT qq[<dd>@{[htescape $opt{type}]}</dd>\n];
98    };    };
99    
100    $doc = $dom->create_document;    $doc = $dom->create_document;
# Line 107  my $http = SuikaWiki::Input::HTTP->new; Line 107  my $http = SuikaWiki::Input::HTTP->new;
107    }    }
108    
109    print STDOUT qq[    print STDOUT qq[
110  </ul>  </dl>
111  </div>  </div>
112  ];  ];
113    } elsif ($input_format eq 'application/xhtml+xml') {    } elsif ($input_format eq 'application/xhtml+xml') {
# Line 120  my $http = SuikaWiki::Input::HTTP->new; Line 120  my $http = SuikaWiki::Input::HTTP->new;
120  <dt>Character Encoding</dt>  <dt>Character Encoding</dt>
121      <dd>(none)</dd>      <dd>(none)</dd>
122  </dl>  </dl>
123    </div>
124    
125  <div id="source-string" class="section">  <div id="source-string" class="section">
126    <h2>Document Source</h2>
127  ];  ];
128        push @nav, ['#source-string' => 'Source'];
129      print_source_string (\$t);      print_source_string (\$t);
130      print STDOUT qq[      print STDOUT qq[
131  </div>  </div>
# Line 130  my $http = SuikaWiki::Input::HTTP->new; Line 133  my $http = SuikaWiki::Input::HTTP->new;
133  <div id="parse-errors" class="section">  <div id="parse-errors" class="section">
134  <h2>Parse Errors</h2>  <h2>Parse Errors</h2>
135    
136  <ul>  <dl>
137  ];  ];
138      push @nav, ['#parse-errors' => 'Parse Error'];
139    
140    my $onerror = sub {    my $onerror = sub {
141      my $err = shift;      my $err = shift;
142      my $line = $err->location->line_number;      my $line = $err->location->line_number;
143      print STDOUT qq[<li><a href="#line-$line">Line $line</a> column ];      print STDOUT qq[<dt><a href="#line-$line">Line $line</a> column ];
144      print STDOUT $err->location->column_number, ": ";      print STDOUT $err->location->column_number, "</dt><dd>";
145      print STDOUT htescape $err->text, "</li>\n";      print STDOUT htescape $err->text, "</dd>\n";
146      return 1;      return 1;
147    };    };
148    
# Line 147  my $http = SuikaWiki::Input::HTTP->new; Line 151  my $http = SuikaWiki::Input::HTTP->new;
151        ($fh => $dom, $onerror, charset => 'utf-8');        ($fh => $dom, $onerror, charset => 'utf-8');
152    
153      print STDOUT qq[      print STDOUT qq[
154  </ul>  </dl>
155  </div>  </div>
156  ];  ];
157    } else {    } else {
158      print STDOUT qq[      print STDOUT qq[
159  </dl>  </dl>
160    </div>
161    
162    <div id="result-summary" class="section">
163  <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>
164    </div>
165  ];  ];
166        push @nav, ['#result-summary' => 'Result'];
167    }    }
168    
169    
# Line 164  my $http = SuikaWiki::Input::HTTP->new; Line 172  my $http = SuikaWiki::Input::HTTP->new;
172  <div id="document-tree" class="section">  <div id="document-tree" class="section">
173  <h2>Document Tree</h2>  <h2>Document Tree</h2>
174  ];  ];
175        push @nav, ['#document-tree' => 'Tree'];
176    
177      print_document_tree ($el || $doc);      print_document_tree ($el || $doc);
178    
# Line 173  my $http = SuikaWiki::Input::HTTP->new; Line 182  my $http = SuikaWiki::Input::HTTP->new;
182  <div id="document-errors" class="section">  <div id="document-errors" class="section">
183  <h2>Document Errors</h2>  <h2>Document Errors</h2>
184    
185  <ul>  <dl>
186  ];  ];
187        push @nav, ['#document-errors' => 'Document Error'];
188    
189      require Whatpm::ContentChecker;      require Whatpm::ContentChecker;
190      my $onerror = sub {      my $onerror = sub {
191        my %opt = @_;        my %opt = @_;
192        print STDOUT qq[<li><a href="#node-@{[refaddr $opt{node}]}">],        print STDOUT qq[<dt><a href="#node-@{[refaddr $opt{node}]}">],
193            htescape get_node_path ($opt{node}),            htescape get_node_path ($opt{node}),
194            "</a>: ", htescape $opt{type}, "</li>\n";            "</a></dt>\n<dd>", htescape $opt{type}, "</dd>\n";
195      };      };
196    
197        my $elements;
198      if ($el) {      if ($el) {
199        Whatpm::ContentChecker->check_element ($el, $onerror);        $elements = Whatpm::ContentChecker->check_element ($el, $onerror);
200      } else {      } else {
201        Whatpm::ContentChecker->check_document ($doc, $onerror);        $elements = Whatpm::ContentChecker->check_document ($doc, $onerror);
202      }      }
203    
204      print STDOUT qq[      print STDOUT qq[
205  </ul>  </dl>
206  </div>  </div>
207  ];  ];
208    
209        if (@{$elements->{table}}) {
210          require JSON;
211    
212          print STDOUT qq[
213    <div id="tables" class="section">
214    <h2>Tables</h2>
215    
216    <!--[if IE]><script type="text/javascript" src="../excanvas.js"></script><![endif]-->
217    <script src="../table-script.js" type="text/javascript"></script>
218    <noscript>
219    <p><em>Structure of tables are visualized here if scripting is enabled.</em></p>
220    </noscript>
221    ];
222    
223          my $i = 0;
224          for my $table_el (@{$elements->{table}}) {
225            $i++;
226            print STDOUT qq[<div class="section" id="table-$i"><h3>];
227            print STDOUT qq[<a href="#node-@{[refaddr $table_el]}">],
228              htescape get_node_path ($table_el);
229            print STDOUT qq[</a></h3>\n];
230            
231            my $table = Whatpm::HTMLTable->form_table ($table_el);
232            
233            for (@{$table->{column_group}}, @{$table->{column}}, $table->{caption}) {
234              next unless $_;
235              delete $_->{element};
236            }
237            
238            for (@{$table->{row_group}}) {
239              next unless $_;
240              next unless $_->{element};
241              $_->{type} = $_->{element}->manakai_local_name;
242              delete $_->{element};
243            }
244            
245            for (@{$table->{cell}}) {
246              next unless $_;
247              for (@{$_}) {
248                next unless $_;
249                for (@$_) {
250                  $_->{id} = refaddr $_->{element} if defined $_->{element};
251                  delete $_->{element};
252                }
253              }
254            }
255            
256            print STDOUT '</div><script type="text/javascript">tableToCanvas (';
257            print STDOUT JSON::objToJson ($table);
258            print STDOUT qq[, document.getElementById ('table-$i'));</script>];
259          }
260        
261          print STDOUT qq[</div>];
262        }
263    }    }
264    
265    ## TODO: Show result    ## TODO: Show result
266    
267      print STDOUT qq[
268    <ul class="navigation" id="nav-items">
269    ];
270      for (@nav) {
271        print STDOUT qq[<li><a href="$_->[0]">$_->[1]</a></li>];
272      }
273    print STDOUT qq[    print STDOUT qq[
274    </ul>
275  </body>  </body>
276  </html>  </html>
277  ];  ];
# Line 233  sub print_document_tree ($) { Line 307  sub print_document_tree ($) {
307      my $node_id = 'node-'.refaddr $child;      my $node_id = 'node-'.refaddr $child;
308      my $nt = $child->node_type;      my $nt = $child->node_type;
309      if ($nt == $child->ELEMENT_NODE) {      if ($nt == $child->ELEMENT_NODE) {
310        $r .= qq'<li id="$node_id"><code>' . htescape ($child->tag_name) .        my $child_nsuri = $child->namespace_uri;
311          $r .= qq[<li id="$node_id" class="tree-element"><code title="@{[defined $child_nsuri ? $child_nsuri : '']}">] . htescape ($child->tag_name) .
312            '</code>'; ## ISSUE: case            '</code>'; ## ISSUE: case
313    
314        if ($child->has_attributes) {        if ($child->has_attributes) {
315          $r .= '<ul class="attributes">';          $r .= '<ul class="attributes">';
316          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 $_] }
317                        @{$child->attributes}) {                        @{$child->attributes}) {
318            $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?
319            $r .= '<q>' . htescape ($attr->[1]) . '</q></li>'; ## TODO: children            $r .= '<q>' . htescape ($attr->[1]) . '</q></li>'; ## TODO: children
320          }          }
321          $r .= '</ul>';          $r .= '</ul>';
# Line 251  sub print_document_tree ($) { Line 326  sub print_document_tree ($) {
326          unshift @node, @{$child->child_nodes}, '</ol>';          unshift @node, @{$child->child_nodes}, '</ol>';
327        }        }
328      } elsif ($nt == $child->TEXT_NODE) {      } elsif ($nt == $child->TEXT_NODE) {
329        $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>';
330      } elsif ($nt == $child->CDATA_SECTION_NODE) {      } elsif ($nt == $child->CDATA_SECTION_NODE) {
331        $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>';
332      } elsif ($nt == $child->COMMENT_NODE) {      } elsif ($nt == $child->COMMENT_NODE) {
333        $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>';
334      } elsif ($nt == $child->DOCUMENT_NODE) {      } elsif ($nt == $child->DOCUMENT_NODE) {
335        $r .= qq'<li id="$node_id">Document</li>';        $r .= qq'<li id="$node_id" class="tree-document">Document</li>';
336        if ($child->has_child_nodes) {        if ($child->has_child_nodes) {
337          $r .= '<ol>';          $r .= '<ol>';
338          unshift @node, @{$child->child_nodes}, '</ol>';          unshift @node, @{$child->child_nodes}, '</ol>';
339        }        }
340      } elsif ($nt == $child->DOCUMENT_TYPE_NODE) {      } elsif ($nt == $child->DOCUMENT_TYPE_NODE) {
341        $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">';
342        $r .= '<li>Name = <q>@{[htescape ($child->name)]}</q></li>';        $r .= qq[<li class="tree-doctype-name">Name = <q>@{[htescape ($child->name)]}</q></li>];
343        $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>];
344        $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>];
345        $r .= '</ul></li>';        $r .= '</ul></li>';
346      } elsif ($nt == $child->PROCESSING_INSTRUCTION_NODE) {      } elsif ($nt == $child->PROCESSING_INSTRUCTION_NODE) {
347        $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>';  
348      } else {      } else {
349        $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
350      }      }
351    }    }
352    
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.5
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24