/[suikacvs]/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.6 by wakaba, Sat Jun 30 14:51:10 2007 UTC revision 1.7 by wakaba, Sun Jul 1 06:21:46 2007 UTC
# Line 33  my $http = SuikaWiki::Input::HTTP->new; Line 33  my $http = SuikaWiki::Input::HTTP->new;
33      exit;      exit;
34    }    }
35    
36      load_text_catalog ('en'); ## TODO: conneg
37    
38    my @nav;    my @nav;
39    print STDOUT qq[Content-Type: text/html; charset=utf-8    print STDOUT qq[Content-Type: text/html; charset=utf-8
40    
# Line 88  my $http = SuikaWiki::Input::HTTP->new; Line 90  my $http = SuikaWiki::Input::HTTP->new;
90    
91    my $onerror = sub {    my $onerror = sub {
92      my (%opt) = @_;      my (%opt) = @_;
93        my ($cls, $msg) = get_text ($opt{type}, $opt{level});
94      if ($opt{column} > 0) {      if ($opt{column} > 0) {
95        print STDOUT qq[<dt><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];
96      } else {      } else {
97        $opt{line}--;        $opt{line} = $opt{line} - 1 || 1;
98        print STDOUT qq[<dt><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];
99      }      }
100      print STDOUT qq[<dd>@{[htescape $opt{type}]}</dd>\n];      print STDOUT qq[<dd class="$cls">$msg</dd>\n];
101    };    };
102    
103    $doc = $dom->create_document;    $doc = $dom->create_document;
# Line 133  my $http = SuikaWiki::Input::HTTP->new; Line 136  my $http = SuikaWiki::Input::HTTP->new;
136  <div id="parse-errors" class="section">  <div id="parse-errors" class="section">
137  <h2>Parse Errors</h2>  <h2>Parse Errors</h2>
138    
139  <dl>  <dl>];
 ];  
140    push @nav, ['#parse-errors' => 'Parse Error'];    push @nav, ['#parse-errors' => 'Parse Error'];
141    
142    my $onerror = sub {    my $onerror = sub {
# Line 150  my $http = SuikaWiki::Input::HTTP->new; Line 152  my $http = SuikaWiki::Input::HTTP->new;
152    $doc = Message::DOM::XMLParserTemp->parse_byte_stream    $doc = Message::DOM::XMLParserTemp->parse_byte_stream
153        ($fh => $dom, $onerror, charset => 'utf-8');        ($fh => $dom, $onerror, charset => 'utf-8');
154    
155      print STDOUT qq[      print STDOUT qq[</dl>
 </dl>  
156  </div>  </div>
157  ];  ];
158    } else {    } else {
# Line 182  my $http = SuikaWiki::Input::HTTP->new; Line 183  my $http = SuikaWiki::Input::HTTP->new;
183  <div id="document-errors" class="section">  <div id="document-errors" class="section">
184  <h2>Document Errors</h2>  <h2>Document Errors</h2>
185    
186  <dl>  <dl>];
 ];  
187      push @nav, ['#document-errors' => 'Document Error'];      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[<dt>] . get_node_link ($opt{node}) .        my ($cls, $msg) = get_text ($opt{type}, $opt{level});
193            "</dt>\n<dd>", htescape $opt{type}, "</dd>\n";        print STDOUT qq[<dt class="$cls">] . get_node_link ($opt{node}) .
194              qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";
195      };      };
196    
197      my $elements;      my $elements;
# Line 200  my $http = SuikaWiki::Input::HTTP->new; Line 201  my $http = SuikaWiki::Input::HTTP->new;
201        $elements = Whatpm::ContentChecker->check_document ($doc, $onerror);        $elements = Whatpm::ContentChecker->check_document ($doc, $onerror);
202      }      }
203    
204      print STDOUT qq[      print STDOUT qq[</dl>
 </dl>  
205  </div>  </div>
206  ];  ];
207    
# Line 295  sub print_source_string ($) { Line 295  sub print_source_string ($) {
295    my $s = $_[0];    my $s = $_[0];
296    my $i = 1;    my $i = 1;
297    print STDOUT qq[<ol lang="">\n];    print STDOUT qq[<ol lang="">\n];
298    while ($$s =~ /\G([^\x0A]*?)\x0D?\x0A/gc) {    if (length $$s) {
299      print STDOUT qq[<li id="line-$i">], htescape $1, "</li>\n";      while ($$s =~ /\G([^\x0A]*?)\x0D?\x0A/gc) {
300      $i++;        print STDOUT qq[<li id="line-$i">], htescape $1, "</li>\n";
301    }        $i++;
302    if ($$s =~ /\G([^\x0A]+)/gc) {      }
303      print STDOUT qq[<li id="line-$i">], htescape $1, "</li>\n";      if ($$s =~ /\G([^\x0A]+)/gc) {
304          print STDOUT qq[<li id="line-$i">], htescape $1, "</li>\n";
305        }
306      } else {
307        print STDOUT q[<li id="line-1"></li>];
308    }    }
309    print STDOUT "</ol>";    print STDOUT "</ol>";
310  } # print_input_string  } # print_input_string
# Line 334  sub print_document_tree ($) { Line 338  sub print_document_tree ($) {
338          $r .= '</ul>';          $r .= '</ul>';
339        }        }
340    
341        if ($node->has_child_nodes) {        if ($child->has_child_nodes) {
342          $r .= '<ol class="children">';          $r .= '<ol class="children">';
343          unshift @node, @{$child->child_nodes}, '</ol></li>';          unshift @node, @{$child->child_nodes}, '</ol></li>';
344        } else {        } else {
# Line 348  sub print_document_tree ($) { Line 352  sub print_document_tree ($) {
352        $r .= qq'<li id="$node_id" class="tree-comment"><code>&lt;!--</code><q lang="">' . 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>';
353      } elsif ($nt == $child->DOCUMENT_NODE) {      } elsif ($nt == $child->DOCUMENT_NODE) {
354        $r .= qq'<li id="$node_id" class="tree-document">Document';        $r .= qq'<li id="$node_id" class="tree-document">Document';
355          $r .= qq[<ul class="attributes">];
356          $r .= qq[<li>@{[scalar get_text ('manakaiIsHTML:'.($child->manakai_is_html?1:0))]}</li>];
357          $r .= qq[<li>@{[scalar get_text ('manakaiCompatMode:'.$child->manakai_compat_mode)]}</li>];
358          $r .= qq[</ul>];
359        if ($child->has_child_nodes) {        if ($child->has_child_nodes) {
360          $r .= '<ol>';          $r .= '<ol class="children">';
361          unshift @node, @{$child->child_nodes}, '</ol></li>';          unshift @node, @{$child->child_nodes}, '</ol></li>';
362        }        }
363      } elsif ($nt == $child->DOCUMENT_TYPE_NODE) {      } elsif ($nt == $child->DOCUMENT_TYPE_NODE) {
# Line 400  sub get_node_link ($) { Line 408  sub get_node_link ($) {
408        htescape (get_node_path ($_[0])) . qq[</a>];        htescape (get_node_path ($_[0])) . qq[</a>];
409  } # get_node_link  } # get_node_link
410    
411    {
412      my $Msg = {};
413    
414    sub load_text_catalog ($) {
415      my $lang = shift; # MUST be a canonical lang name
416      open my $file, '<', "cc-msg.$lang.txt" or die "$0: cc-msg.$lang.txt: $!";
417      while (<$file>) {
418        if (s/^([^;]+);([^;]*);//) {
419          my ($type, $cls, $msg) = ($1, $2, $_);
420          $msg =~ tr/\x0D\x0A//d;
421          $Msg->{$type} = [$cls, $msg];
422        }
423      }
424    } # load_text_catalog
425    
426    sub get_text ($) {
427      my ($type, $level) = @_;
428      $type = $level . ':' . $type if defined $level;
429      my @arg;
430      {
431        if (defined $Msg->{$type}) {
432          my $msg = $Msg->{$type}->[1];
433          $msg =~ s/\$([0-9]+)/defined $arg[$1] ? htescape ($arg[$1]) : '(undef)'/ge;
434          return ($Msg->{$type}->[0], $msg);
435        } elsif ($type =~ s/:([^:]*)$//) {
436          unshift @arg, $1;
437          redo;
438        }
439      }
440      return ('', htescape ($_[0]));
441    } # get_text
442    
443    }
444    
445  =head1 AUTHOR  =head1 AUTHOR
446    
447  Wakaba <w@suika.fam.cx>.  Wakaba <w@suika.fam.cx>.
Legend:
Removed from v.1.6  
changed lines
  Added in v.1.7
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24