/[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.10 by wakaba, Mon Jul 16 08:38:48 2007 UTC revision 1.15 by wakaba, Sat Jul 21 04:58:17 2007 UTC
# Line 15  sub htescape ($) { Line 15  sub htescape ($) {
15    $s =~ s/</&lt;/g;    $s =~ s/</&lt;/g;
16    $s =~ s/>/&gt;/g;    $s =~ s/>/&gt;/g;
17    $s =~ s/"/&quot;/g;    $s =~ s/"/&quot;/g;
18    $s =~ s!([\x00-\x09\x0B-\x1F\x7F-\x80])!sprintf '<var>U+%04X</var>', ord $1!ge;    $s =~ s{([\x00-\x09\x0B-\x1F\x7F-\xA0\x{FEFF}\x{FFFC}-\x{FFFF}])}{
19        sprintf '<var>U+%04X</var>', ord $1;
20      }ge;
21    return $s;    return $s;
22  } # htescape  } # htescape
23    
# Line 28  my $http = SuikaWiki::Input::HTTP->new; Line 30  my $http = SuikaWiki::Input::HTTP->new;
30      exit;      exit;
31    }    }
32    
33      binmode STDOUT, ':utf8';
34      $| = 1;
35    
36    require Message::DOM::DOMImplementation;    require Message::DOM::DOMImplementation;
37    my $dom = Message::DOM::DOMImplementation->new;    my $dom = Message::DOM::DOMImplementation->new;
38    
   my $input = get_input_document ($http, $dom);  
   my $inner_html_element = $http->parameter ('e');  
   
39    load_text_catalog ('en'); ## TODO: conneg    load_text_catalog ('en'); ## TODO: conneg
40    
41    my @nav;    my @nav;
# Line 46  my $http = SuikaWiki::Input::HTTP->new; Line 48  my $http = SuikaWiki::Input::HTTP->new;
48  <link rel="stylesheet" href="../cc-style.css" type="text/css">  <link rel="stylesheet" href="../cc-style.css" type="text/css">
49  </head>  </head>
50  <body>  <body>
51  <h1>Web Document Conformance Checker (<em>beta</em>)</h1>  <h1><a href="../cc-interface">Web Document Conformance Checker</a>
52    (<em>beta</em>)</h1>
53    ];
54    
55      $| = 0;
56      my $input = get_input_document ($http, $dom);
57      my $inner_html_element = $http->parameter ('e');
58    
59      print qq[
60  <div id="document-info" class="section">  <div id="document-info" class="section">
61  <dl>  <dl>
62  <dt>Request URI</dt>  <dt>Request URI</dt>
# Line 94  if (defined $input->{s}) { Line 103  if (defined $input->{s}) {
103    
104    my $onerror = sub {    my $onerror = sub {
105      my (%opt) = @_;      my (%opt) = @_;
106      my ($cls, $msg) = get_text ($opt{type}, $opt{level});      my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level});
107      if ($opt{column} > 0) {      if ($opt{column} > 0) {
108        print STDOUT qq[<dt class="$cls"><a href="#line-$opt{line}">Line $opt{line}</a> column $opt{column}</dt>\n];        print STDOUT qq[<dt class="$cls"><a href="#line-$opt{line}">Line $opt{line}</a> column $opt{column}</dt>\n];
109      } else {      } else {
110        $opt{line} = $opt{line} - 1 || 1;        $opt{line} = $opt{line} - 1 || 1;
111        print STDOUT qq[<dt class="$cls"><a href="#line-$opt{line}">Line $opt{line}</a></dt>\n];        print STDOUT qq[<dt class="$cls"><a href="#line-$opt{line}">Line $opt{line}</a></dt>\n];
112      }      }
113      $opt{type} =~ tr/ /-/;      $type =~ tr/ /-/;
114      $opt{type} =~ s/\|/%7C/g;      $type =~ s/\|/%7C/g;
115      $msg .= qq[ [<a href="../error-description#$opt{type}">Description</a>]];      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
116      print STDOUT qq[<dd class="$cls">$msg</dd>\n];      print STDOUT qq[<dd class="$cls">$msg</dd>\n];
117    };    };
118    
# Line 185  if (defined $input->{s}) { Line 194  if (defined $input->{s}) {
194      require Whatpm::ContentChecker;      require Whatpm::ContentChecker;
195      my $onerror = sub {      my $onerror = sub {
196        my %opt = @_;        my %opt = @_;
197        my ($cls, $msg) = get_text ($opt{type}, $opt{level});        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level}, $opt{node});
198        $opt{type} = $opt{level} . ':' . $opt{type} if defined $opt{level};        $type =~ tr/ /-/;
199        $opt{type} =~ tr/ /-/;        $type =~ s/\|/%7C/g;
200        $opt{type} =~ s/\|/%7C/g;        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
       $msg .= qq[ [<a href="../error-description#$opt{type}">Description</a>]];  
201        print STDOUT qq[<dt class="$cls">] . get_node_link ($opt{node}) .        print STDOUT qq[<dt class="$cls">] . get_node_link ($opt{node}) .
202            qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";            qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";
203      };      };
# Line 208  if (defined $input->{s}) { Line 216  if (defined $input->{s}) {
216      if (@{$elements->{table}}) {      if (@{$elements->{table}}) {
217        require JSON;        require JSON;
218    
219          push @nav, ['#tables' => 'Tables'];
220        print STDOUT qq[        print STDOUT qq[
221  <div id="tables" class="section">  <div id="tables" class="section">
222  <h2>Tables</h2>  <h2>Tables</h2>
# Line 224  if (defined $input->{s}) { Line 233  if (defined $input->{s}) {
233          $i++;          $i++;
234          print STDOUT qq[<div class="section" id="table-$i"><h3>] .          print STDOUT qq[<div class="section" id="table-$i"><h3>] .
235              get_node_link ($table_el) . q[</h3>];              get_node_link ($table_el) . q[</h3>];
236            
237            ## TODO: Make |ContentChecker| return |form_table| result
238            ## so that this script don't have to run the algorithm twice.
239          my $table = Whatpm::HTMLTable->form_table ($table_el);          my $table = Whatpm::HTMLTable->form_table ($table_el);
240                    
241          for (@{$table->{column_group}}, @{$table->{column}}, $table->{caption}) {          for (@{$table->{column_group}}, @{$table->{column}}, $table->{caption}) {
# Line 246  if (defined $input->{s}) { Line 257  if (defined $input->{s}) {
257              for (@$_) {              for (@$_) {
258                $_->{id} = refaddr $_->{element} if defined $_->{element};                $_->{id} = refaddr $_->{element} if defined $_->{element};
259                delete $_->{element};                delete $_->{element};
260                  $_->{is_header} = $_->{is_header} ? 1 : 0;
261              }              }
262            }            }
263          }          }
# Line 258  if (defined $input->{s}) { Line 270  if (defined $input->{s}) {
270        print STDOUT qq[</div>];        print STDOUT qq[</div>];
271      }      }
272    
273        if (keys %{$elements->{id}}) {
274          push @nav, ['#identifiers' => 'IDs'];
275          print STDOUT qq[
276    <div id="identifiers" class="section">
277    <h2>Identifiers</h2>
278    
279    <dl>
280    ];
281          for my $id (sort {$a cmp $b} keys %{$elements->{id}}) {
282            print STDOUT qq[<dt><code>@{[htescape $id]}</code></dt>];
283            for (@{$elements->{id}->{$id}}) {
284              print STDOUT qq[<dd>].get_node_link ($_).qq[</dd>];
285            }
286          }
287          print STDOUT qq[</dl></div>];
288        }
289    
290      if (keys %{$elements->{term}}) {      if (keys %{$elements->{term}}) {
291          push @nav, ['#terms' => 'Terms'];
292        print STDOUT qq[        print STDOUT qq[
293  <div id="terms" class="section">  <div id="terms" class="section">
294  <h2>Terms</h2>  <h2>Terms</h2>
# Line 273  if (defined $input->{s}) { Line 303  if (defined $input->{s}) {
303        }        }
304        print STDOUT qq[</dl></div>];        print STDOUT qq[</dl></div>];
305      }      }
306    
307        if (keys %{$elements->{class}}) {
308          push @nav, ['#classes' => 'Classes'];
309          print STDOUT qq[
310    <div id="classes" class="section">
311    <h2>Classes</h2>
312    
313    <dl>
314    ];
315          for my $class (sort {$a cmp $b} keys %{$elements->{class}}) {
316            print STDOUT qq[<dt><code>@{[htescape $class]}</code></dt>];
317            for (@{$elements->{class}->{$class}}) {
318              print STDOUT qq[<dd>].get_node_link ($_).qq[</dd>];
319            }
320          }
321          print STDOUT qq[</dl></div>];
322        }
323    }    }
324    
325    ## TODO: Show result    ## TODO: Show result
# Line 487  sub load_text_catalog ($) { Line 534  sub load_text_catalog ($) {
534  } # load_text_catalog  } # load_text_catalog
535    
536  sub get_text ($) {  sub get_text ($) {
537    my ($type, $level) = @_;    my ($type, $level, $node) = @_;
538    $type = $level . ':' . $type if defined $level;    $type = $level . ':' . $type if defined $level;
539    my @arg;    my @arg;
540    {    {
# Line 496  sub get_text ($) { Line 543  sub get_text ($) {
543        $msg =~ s{<var>\$([0-9]+)</var>}{        $msg =~ s{<var>\$([0-9]+)</var>}{
544          defined $arg[$1] ? htescape ($arg[$1]) : '(undef)';          defined $arg[$1] ? htescape ($arg[$1]) : '(undef)';
545        }ge;        }ge;
546        return ($Msg->{$type}->[0], $msg);        $msg =~ s{<var>{\@([A-Za-z0-9:_.-]+)}</var>}{
547            UNIVERSAL::can ($node, 'get_attribute_ns')
548                ? htescape ($node->get_attribute_ns (undef, $1)) : ''
549          }ge;
550          $msg =~ s{<var>{\@}</var>}{
551            UNIVERSAL::can ($node, 'value') ? htescape ($node->value) : ''
552          }ge;
553          return ($type, $Msg->{$type}->[0], $msg);
554      } elsif ($type =~ s/:([^:]*)$//) {      } elsif ($type =~ s/:([^:]*)$//) {
555        unshift @arg, $1;        unshift @arg, $1;
556        redo;        redo;
557      }      }
558    }    }
559    return ('', htescape ($_[0]));    return ($type, '', htescape ($_[0]));
560  } # get_text  } # get_text
561    
562  }  }
Legend:
Removed from v.1.10  
changed lines
  Added in v.1.15
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24