/[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.8 by wakaba, Sat Aug 11 13:54:55 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/work/manakai2/lib];
6    use CGI::Carp qw[fatalsToBrowser];
7    use Time::HiRes qw/time/;
8    
9  use SuikaWiki::Input::HTTP; ## TODO: Use some better CGI module  use Message::CGI::HTTP;
10    my $http = Message::CGI::HTTP->new;
 my $http = SuikaWiki::Input::HTTP->new;  
11    
12  ## TODO: _charset_  ## TODO: _charset_
13    
14  my $mode = $http->meta_variable ('PATH_INFO');  my $mode = $http->get_meta_variable ('PATH_INFO');
15  ## TODO: decode unreserved characters  ## TODO: decode unreserved characters
16    
17  if ($mode eq '/html' or $mode eq '/error-and-html') {  if ($mode eq '/html' or $mode eq '/test') {
18    require Encode;    require Encode;
19    require What::HTML;    require Whatpm::HTML;
20    require What::NanoDOM;    require Whatpm::NanoDOM;
21    
22    my $s = $http->parameter ('s');    my $s = $http->get_parameter ('s');
23    if (length $s > 1000_000) {    if (length $s > 1000_000) {
24      print STDOUT "Status: 400 Document Too Long\nContent-Type: text/plain; charset=us-ascii\n\nToo long";      print STDOUT "Status: 400 Document Too Long\nContent-Type: text/plain; charset=us-ascii\n\nToo long";
25      exit;      exit;
26    }    }
27    
28      my $time1 = time;
29    $s = Encode::decode ('utf-8', $s);    $s = Encode::decode ('utf-8', $s);
30      my $time2 = time;
31      my %time = (decode => $time2 - $time1);
32      my $char_length = length $s;
33      
34    print STDOUT "Content-Type: text/plain; charset=utf-8\n\n";    print STDOUT "Content-Type: text/plain; charset=utf-8\n\n";
35    
36    my $onerror = $mode eq '/error-and-html' ? sub {    print STDOUT "#errors\n";
     print STDOUT "0,0,", $_[0], "\n";  
   } : sub { };  
37    
38    my $doc = What::HTML->parse_string    my $onerror = sub {
39        ($s => What::NanoDOM::Document->new, $onerror);      my (%opt) = @_;
40        print STDOUT "$opt{line},$opt{column},$opt{type}\n";
41    if ($mode eq '/error-and-html') {    };
42      print "--\n";  
43      $time1 = time;
44      my $doc = Whatpm::HTML->parse_string
45          ($s => Whatpm::NanoDOM::Document->new, $onerror);
46      $time2 = time;
47      $time{parse} = $time2 - $time1;
48    
49      print "#document\n";
50    
51      my $out;
52      $time1 = time;
53      if ($mode eq '/html') {
54        $out = Whatpm::HTML->get_inner_html ($doc);
55      } else { # test
56        $out = test_serialize ($doc);
57      }
58      $time2 = time;
59      $time{serialize} = $time2 - $time1;
60      print STDOUT Encode::encode ('utf-8', $$out);
61      print STDOUT "\n";
62    
63      if ($http->get_parameter ('dom5')) {
64        require Whatpm::ContentChecker;
65        print STDOUT "#domerrors\n";
66        $time1 = time;
67        Whatpm::ContentChecker->check_document ($doc, sub {
68          my %opt = @_;
69          print STDOUT get_node_path ($opt{node}) . ';' . $opt{type} . "\n";
70        });
71        $time2 = time;
72        $time{check} = $time2 - $time1;
73    }    }
74    
75    my $html = What::HTML->get_inner_html ($doc);    print STDOUT "#log\n";
76    print STDOUT Encode::encode ('utf-8', $$html);    print STDOUT "byte->char\t", $time{decode}, "s\n";
77      print STDOUT "html5->dom5\t", $time{parse}, "s\n";
78      print STDOUT "dom5->serialize\t", $time{serialize}, "s\n";
79      print STDOUT "dom5 check\t", $time{check}, "s\n" if defined $time{check};
80      for (qw/decode parse serialize check/) {
81        next unless defined $time{$_};
82        open my $file, '>>', ".$_.txt" or die ".$_.txt: $!";
83        print $file $char_length, "\t", $time{$_}, "\n";
84      }
85  } else {  } else {
86    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";
87  }  }
88    
89    exit;
90    
91    sub test_serialize ($) {
92      my $node = shift;
93      my $r = '';
94    
95      my @node = map { [$_, ''] } @{$node->child_nodes};
96      while (@node) {
97        my $child = shift @node;
98        my $nt = $child->[0]->node_type;
99        if ($nt == $child->[0]->ELEMENT_NODE) {
100          $r .= '| ' . $child->[1] . '<' . $child->[0]->tag_name . ">\x0A"; ## ISSUE: case?
101    
102          for my $attr (sort {$a->[0] cmp $b->[0]} map { [$_->name, $_->value] }
103                        @{$child->[0]->attributes}) {
104            $r .= '| ' . $child->[1] . '  ' . $attr->[0] . '="'; ## ISSUE: case?
105            $r .= $attr->[1] . '"' . "\x0A";
106          }
107          
108          unshift @node,
109            map { [$_, $child->[1] . '  '] } @{$child->[0]->child_nodes};
110        } elsif ($nt == $child->[0]->TEXT_NODE) {
111          $r .= '| ' . $child->[1] . '"' . $child->[0]->data . '"' . "\x0A";
112        } elsif ($nt == $child->[0]->COMMENT_NODE) {
113          $r .= '| ' . $child->[1] . '<!-- ' . $child->[0]->data . " -->\x0A";
114        } elsif ($nt == $child->[0]->DOCUMENT_TYPE_NODE) {
115          $r .= '| ' . $child->[1] . '<!DOCTYPE ' . $child->[0]->name . ">\x0A";
116        } else {
117          $r .= '| ' . $child->[1] . $child->[0]->node_type . "\x0A"; # error
118        }
119      }
120      
121      return \$r;
122    } # test_serialize
123    
124    sub get_node_path ($) {
125      my $node = shift;
126      my @r;
127      while (defined $node) {
128        my $rs;
129        if ($node->node_type == 1) {
130          $rs = $node->manakai_local_name;
131          $node = $node->parent_node;
132        } elsif ($node->node_type == 2) {
133          $rs = '@' . $node->manakai_local_name;
134          $node = $node->owner_element;
135        } elsif ($node->node_type == 3) {
136          $rs = '"' . $node->data . '"';
137          $node = $node->parent_node;
138        } elsif ($node->node_type == 9) {
139          $rs = '';
140          $node = $node->parent_node;
141        } else {
142          $rs = '#' . $node->node_type;
143          $node = $node->parent_node;
144        }
145        unshift @r, $rs;
146      }
147      return join '/', @r;
148    } # get_node_path
149    
150    =head1 AUTHOR
151    
152    Wakaba <w@suika.fam.cx>.
153    
154    =head1 LICENSE
155    
156    Copyright 2007 Wakaba <w@suika.fam.cx>
157    
158    This library is free software; you can redistribute it
159    and/or modify it under the same terms as Perl itself.
160    
161    =cut
162    
163    ## $Date$
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.8
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24