/[suikacvs]/test/html-whatpm/parser.cgi
Suika

Diff of /test/html-whatpm/parser.cgi

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by wakaba, Tue May 1 09:25:31 2007 UTC revision 1.4 by wakaba, Sun May 20 08:14:48 2007 UTC
# Line 1  Line 1 
1  #!/usr/bin/perl  #!/usr/bin/perl
2  use strict;  use strict;
3    
4  use lib qw[.. /home/wakaba/public_html/-temp/wiki/lib];  use lib qw[/home/httpd/html/www/markup/html/whatpm
5               /home/wakaba/public_html/-temp/wiki/lib];
6    
7  use SuikaWiki::Input::HTTP; ## TODO: Use some better CGI module  use SuikaWiki::Input::HTTP; ## TODO: Use some better CGI module
8    
# Line 12  my $http = SuikaWiki::Input::HTTP->new; Line 13  my $http = SuikaWiki::Input::HTTP->new;
13  my $mode = $http->meta_variable ('PATH_INFO');  my $mode = $http->meta_variable ('PATH_INFO');
14  ## TODO: decode unreserved characters  ## TODO: decode unreserved characters
15    
16  if ($mode eq '/html' or $mode eq '/error-and-html') {  if ($mode eq '/html' or $mode eq '/test') {
17    require Encode;    require Encode;
18    require What::HTML;    require Whatpm::HTML;
19    require What::NanoDOM;    require Whatpm::NanoDOM;
20    
21    my $s = $http->parameter ('s');    my $s = $http->parameter ('s');
22    if (length $s > 1000_000) {    if (length $s > 1000_000) {
# Line 27  if ($mode eq '/html' or $mode eq '/error Line 28  if ($mode eq '/html' or $mode eq '/error
28    
29    print STDOUT "Content-Type: text/plain; charset=utf-8\n\n";    print STDOUT "Content-Type: text/plain; charset=utf-8\n\n";
30    
31    my $onerror = $mode eq '/error-and-html' ? sub {    print STDOUT "#errors\n";
     print STDOUT "0,0,", $_[0], "\n";  
   } : sub { };  
32    
33    my $doc = What::HTML->parse_string    my $onerror = sub {
34        ($s => What::NanoDOM::Document->new, $onerror);      my (%opt) = @_;
35        print STDOUT "$opt{line},$opt{column},$opt{type}\n";
36    if ($mode eq '/error-and-html') {    };
37      print "--\n";  
38      my $doc = Whatpm::HTML->parse_string
39          ($s => Whatpm::NanoDOM::Document->new, $onerror);
40    
41      print "#document\n";
42    
43      my $out;
44      if ($mode eq '/html') {
45        $out = Whatpm::HTML->get_inner_html ($doc);
46      } else { # test
47        $out = test_serialize ($doc);
48    }    }
49      print STDOUT Encode::encode ('utf-8', $$out);
50      print STDOUT "\n";
51    
52    my $html = What::HTML->get_inner_html ($doc);    if ($http->parameter ('dom5')) {
53    print STDOUT Encode::encode ('utf-8', $$html);      require Whatpm::ContentChecker;
54        print STDOUT "#domerrors\n";
55        my $docel = $doc->document_element;
56        my $docel_nsuri = $docel->namespace_uri;
57        if (defined $docel_nsuri and
58            $docel_nsuri eq q<http://www.w3.org/1999/xhtml> and
59            $docel->manakai_local_name eq 'html') {
60          #
61        } else {
62          print STDOUT get_node_path ($docel) . ";element not allowed\n";
63        }
64        my $cc = Whatpm::ContentChecker->new;
65        $cc->check_element ($docel, sub {
66          my %opt = @_;
67          print STDOUT get_node_path ($opt{node}) . ';' . $opt{type} . "\n";
68        });
69      }
70  } else {  } else {
71    print STDOUT "Status: 404 Not Found\nContent-Type: text/plain; charset=us-ascii\n\n404";    print STDOUT "Status: 404 Not Found\nContent-Type: text/plain; charset=us-ascii\n\n404";
72  }  }
73    
74    exit;
75    
76    sub test_serialize ($) {
77      my $node = shift;
78      my $r = '';
79    
80      my @node = map { [$_, ''] } @{$node->child_nodes};
81      while (@node) {
82        my $child = shift @node;
83        my $nt = $child->[0]->node_type;
84        if ($nt == $child->[0]->ELEMENT_NODE) {
85          $r .= '| ' . $child->[1] . '<' . $child->[0]->tag_name . ">\x0A"; ## ISSUE: case?
86    
87          for my $attr (sort {$a->[0] cmp $b->[0]} map { [$_->name, $_->value] }
88                        @{$child->[0]->attributes}) {
89            $r .= '| ' . $child->[1] . '  ' . $attr->[0] . '="'; ## ISSUE: case?
90            $r .= $attr->[1] . '"' . "\x0A";
91          }
92          
93          unshift @node,
94            map { [$_, $child->[1] . '  '] } @{$child->[0]->child_nodes};
95        } elsif ($nt == $child->[0]->TEXT_NODE) {
96          $r .= '| ' . $child->[1] . '"' . $child->[0]->data . '"' . "\x0A";
97        } elsif ($nt == $child->[0]->COMMENT_NODE) {
98          $r .= '| ' . $child->[1] . '<!-- ' . $child->[0]->data . " -->\x0A";
99        } elsif ($nt == $child->[0]->DOCUMENT_TYPE_NODE) {
100          $r .= '| ' . $child->[1] . '<!DOCTYPE ' . $child->[0]->name . ">\x0A";
101        } else {
102          $r .= '| ' . $child->[1] . $child->[0]->node_type . "\x0A"; # error
103        }
104      }
105      
106      return \$r;
107    } # test_serialize
108    
109    sub get_node_path ($) {
110      my $node = shift;
111      my @r;
112      while (defined $node) {
113        my $rs;
114        if ($node->node_type == 1) {
115          $rs = $node->manakai_local_name;
116          $node = $node->parent_node;
117        } elsif ($node->node_type == 2) {
118          $rs = '@' . $node->manakai_local_name;
119          $node = $node->owner_element;
120        } elsif ($node->node_type == 3) {
121          $rs = '"' . $node->data . '"';
122          $node = $node->parent_node;
123        } elsif ($node->node_type == 9) {
124          $rs = '';
125          $node = $node->parent_node;
126        } else {
127          $rs = '#' . $node->node_type;
128          $node = $node->parent_node;
129        }
130        unshift @r, $rs;
131      }
132      return join '/', @r;
133    } # get_node_path
134    
135    =head1 AUTHOR
136    
137    Wakaba <w@suika.fam.cx>.
138    
139    =head1 LICENSE
140    
141    Copyright 2007 Wakaba <w@suika.fam.cx>
142    
143    This library is free software; you can redistribute it
144    and/or modify it under the same terms as Perl itself.
145    
146    =cut
147    
148    ## $Date$
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.4
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24