test/html-whatpm/parser-manakai.cgi

#!/usr/bin/perl
use strict;

use lib qw[/home/httpd/html/www/markup/html/whatpm
           /home/wakaba/work/manakai/lib
           /home/wakaba/public_html/-temp/wiki/lib];
use CGI::Carp qw[fatalsToBrowser];
use Time::HiRes qw/time/;

use SuikaWiki::Input::HTTP; ## TODO: Use some better CGI module

my $http = SuikaWiki::Input::HTTP->new;

## TODO: _charset_

my $mode = $http->meta_variable ('PATH_INFO');
## TODO: decode unreserved characters

  my $s = $http->parameter ('s');
  if (length $s > 1000_000) {
    print STDOUT "Status: 400 Document Too Long\nContent-Type: text/plain; charset=us-ascii\n\nToo long";
    exit;
  }
  my $char_length = length $s;
  my %time;
  my $time1;
  my $time2;

  require Message::DOM::DOMImplementation;
  my $dom = Message::DOM::DOMImplementation->____new;
  $| = 1;
  my $doc;

if ($mode eq '/html/html' or $mode eq '/html/test') {
  print STDOUT "Content-Type: text/plain; charset=utf-8\n\n";

  require Encode;
  require Whatpm::HTML;

  $time1 = time;
  $s = Encode::decode ('utf-8', $s);
  $time2 = time;
  $time{decode} = $time2 - $time1;
  

  print STDOUT "#errors\n";

  my $onerror = sub {
    my (%opt) = @_;
    print STDOUT "$opt{line},$opt{column},$opt{type}\n";
  };

  $time1 = time;
  $doc = Whatpm::HTML->parse_string ($s => $dom->create_document, $onerror);
  $time2 = time;
  $time{parse} = $time2 - $time1;

  print "#document\n";

  my $out;
  $time1 = time;
  if ($mode eq '/html/html') {
    $out = Whatpm::HTML->get_inner_html ($doc);
  } else { # test
    $out = test_serialize ($doc);
  }
  $time2 = time;
  $time{serialize} = $time2 - $time1;
  print STDOUT Encode::encode ('utf-8', $$out);
  print STDOUT "\n";
} elsif ($mode eq '/xhtml/html' or $mode eq '/xhtml/test') {
  print STDOUT "Content-Type: text/plain; charset=utf-8\n\n";

  require Message::DOM::XMLParserTemp;
  print STDOUT "#errors\n";

  my $onerror = sub {
    my $err = shift;
    print STDOUT $err->location->line_number, ",";
    print STDOUT $err->location->column_number, " ";
    print STDOUT $err->text, "\n";
    return 1;
  };

  open my $fh, '<', \$s;
  my $time1 = time;
  $doc = Message::DOM::XMLParserTemp->parse_byte_stream
      ($fh => $dom, $onerror, charset => 'utf-8');
  my $time2 = time;
  $time{parse_xml} = $time2 - $time1;

  print "#document\n";

  my $out;
  if ($mode eq '/xhtml/html') {
    ## TODO: Use XHTML serializer
    #$out = Whatpm::HTML->get_inner_html ($doc);
  } else { # test
    $time1 = time;
    $out = test_serialize ($doc);
    $time2 = time;
    $time{serialize_test} = $time2 - $time1;
  }
  print STDOUT Encode::encode ('utf-8', $$out);
  print STDOUT "\n";
} else {
  print STDOUT "Status: 404 Not Found\nContent-Type: text/plain; charset=us-ascii\n\n404";
  exit;
}

  if ($http->parameter ('dom5')) {
    require Whatpm::ContentChecker;
    print STDOUT "#domerrors\n";
    $time1 = time;
    Whatpm::ContentChecker->check_document ($doc, sub {
      my %opt = @_;
      print STDOUT get_node_path ($opt{node}) . ';' . $opt{type} . "\n";
    });
    $time2 = time;
    $time{check} = $time2 - $time1;
  }

  print STDOUT "#log\n";
  for (qw/decode parse parse_xml serialize_html serialize_xml serialize_test
          check/) {
    next unless defined $time{$_};
    print STDOUT {
      decode => 'bytes->chars',
      parse => 'html5(chars)->dom5',
      parse_xml => 'xml1(chars)->dom5',
      serialize_html => 'dom5->html5',
      serialize_xml => 'dom5->xml',
      serialize_test => 'dom5->test',
      check => 'dom5 check',
    }->{$_};
    print STDOUT "\t", $time{$_}, "s\n";
    open my $file, '>>', ".manakai-$_.txt" or die ".manakai-$_.txt: $!";
    print $file $char_length, "\t", $time{$_}, "\n";
  }

exit;

sub test_serialize ($) {
  my $node = shift;
  my $r = '';

  my @node = map { [$_, ''] } @{$node->child_nodes};
  while (@node) {
    my $child = shift @node;
    my $nt = $child->[0]->node_type;
    if ($nt == $child->[0]->ELEMENT_NODE) {
      $r .= '| ' . $child->[1] . '<' . $child->[0]->tag_name . ">\x0A"; ## ISSUE: case?

      for my $attr (sort {$a->[0] cmp $b->[0]} map { [$_->name, $_->value] }
                    @{$child->[0]->attributes}) {
        $r .= '| ' . $child->[1] . '  ' . $attr->[0] . '="'; ## ISSUE: case?
        $r .= $attr->[1] . '"' . "\x0A";
      }
      
      unshift @node,
        map { [$_, $child->[1] . '  '] } @{$child->[0]->child_nodes};
    } elsif ($nt == $child->[0]->TEXT_NODE) {
      $r .= '| ' . $child->[1] . '"' . $child->[0]->data . '"' . "\x0A";
    } elsif ($nt == $child->[0]->CDATA_SECTION_NODE) {
      $r .= '| ' . $child->[1] . '<![CDATA[' . $child->[0]->data . "]]>\x0A";
    } elsif ($nt == $child->[0]->COMMENT_NODE) {
      $r .= '| ' . $child->[1] . '<!-- ' . $child->[0]->data . " -->\x0A";
    } elsif ($nt == $child->[0]->DOCUMENT_TYPE_NODE) {
      $r .= '| ' . $child->[1] . '<!DOCTYPE ' . $child->[0]->name . ">\x0A";
    } elsif ($nt == $child->[0]->PROCESSING_INSTRUCTION_NODE) {
      $r .= '| ' . $child->[1] . '<?' . $child->[0]->target . ' ' .
          $child->[0]->data . "?>\x0A";
    } else {
      $r .= '| ' . $child->[1] . $child->[0]->node_type . "\x0A"; # error
    }
  }
  
  return \$r;
} # test_serialize

sub get_node_path ($) {
  my $node = shift;
  my @r;
  while (defined $node) {
    my $rs;
    if ($node->node_type == 1) {
      $rs = $node->manakai_local_name;
      $node = $node->parent_node;
    } elsif ($node->node_type == 2) {
      $rs = '@' . $node->manakai_local_name;
      $node = $node->owner_element;
    } elsif ($node->node_type == 3) {
      $rs = '"' . $node->data . '"';
      $node = $node->parent_node;
    } elsif ($node->node_type == 9) {
      $rs = '';
      $node = $node->parent_node;
    } else {
      $rs = '#' . $node->node_type;
      $node = $node->parent_node;
    }
    unshift @r, $rs;
  }
  return join '/', @r;
} # get_node_path

=head1 AUTHOR

Wakaba <w@suika.fam.cx>.

=head1 LICENSE

Copyright 2007 Wakaba <w@suika.fam.cx>

This library is free software; you can redistribute it
and/or modify it under the same terms as Perl itself.

=cut

## $Date: 2007/05/28 14:04:57 $
1	wakaba	1.1	#!/usr/bin/perl
2			use strict;
3
4			use lib qw[/home/httpd/html/www/markup/html/whatpm
5			/home/wakaba/work/manakai/lib
6			/home/wakaba/public_html/-temp/wiki/lib];
7			use CGI::Carp qw[fatalsToBrowser];
8			use Time::HiRes qw/time/;
9
10			use SuikaWiki::Input::HTTP; ## TODO: Use some better CGI module
11
12			my $http = SuikaWiki::Input::HTTP->new;
13
14			## TODO: _charset_
15
16			my $mode = $http->meta_variable ('PATH_INFO');
17			## TODO: decode unreserved characters
18
19			my $s = $http->parameter ('s');
20			if (length $s > 1000_000) {
21			print STDOUT "Status: 400 Document Too Long\nContent-Type: text/plain; charset=us-ascii\n\nToo long";
22			exit;
23			}
24			my $char_length = length $s;
25			my %time;
26			my $time1;
27			my $time2;
28
29			require Message::DOM::DOMImplementation;
30			my $dom = Message::DOM::DOMImplementation->____new;
31			$\| = 1;
32			my $doc;
33
34			if ($mode eq '/html/html' or $mode eq '/html/test') {
35			print STDOUT "Content-Type: text/plain; charset=utf-8\n\n";
36
37			require Encode;
38			require Whatpm::HTML;
39
40			$time1 = time;
41			$s = Encode::decode ('utf-8', $s);
42			$time2 = time;
43			$time{decode} = $time2 - $time1;
44
45
46			print STDOUT "#errors\n";
47
48			my $onerror = sub {
49			my (%opt) = @_;
50			print STDOUT "$opt{line},$opt{column},$opt{type}\n";
51			};
52
53			$time1 = time;
54			$doc = Whatpm::HTML->parse_string ($s => $dom->create_document, $onerror);
55			$time2 = time;
56			$time{parse} = $time2 - $time1;
57
58			print "#document\n";
59
60			my $out;
61			$time1 = time;
62			if ($mode eq '/html/html') {
63			$out = Whatpm::HTML->get_inner_html ($doc);
64			} else { # test
65			$out = test_serialize ($doc);
66			}
67			$time2 = time;
68			$time{serialize} = $time2 - $time1;
69			print STDOUT Encode::encode ('utf-8', $$out);
70			print STDOUT "\n";
71			} elsif ($mode eq '/xhtml/html' or $mode eq '/xhtml/test') {
72			print STDOUT "Content-Type: text/plain; charset=utf-8\n\n";
73
74			require Message::DOM::XMLParserTemp;
75			print STDOUT "#errors\n";
76
77			my $onerror = sub {
78			my $err = shift;
79			print STDOUT $err->location->line_number, ",";
80			print STDOUT $err->location->column_number, " ";
81			print STDOUT $err->text, "\n";
82			return 1;
83			};
84
85			open my $fh, '<', \$s;
86			my $time1 = time;
87			$doc = Message::DOM::XMLParserTemp->parse_byte_stream
88			($fh => $dom, $onerror, charset => 'utf-8');
89			my $time2 = time;
90			$time{parse_xml} = $time2 - $time1;
91
92			print "#document\n";
93
94			my $out;
95			if ($mode eq '/xhtml/html') {
96			## TODO: Use XHTML serializer
97			#$out = Whatpm::HTML->get_inner_html ($doc);
98			} else { # test
99			$time1 = time;
100			$out = test_serialize ($doc);
101			$time2 = time;
102			$time{serialize_test} = $time2 - $time1;
103			}
104			print STDOUT Encode::encode ('utf-8', $$out);
105			print STDOUT "\n";
106			} else {
107			print STDOUT "Status: 404 Not Found\nContent-Type: text/plain; charset=us-ascii\n\n404";
108			exit;
109			}
110
111			if ($http->parameter ('dom5')) {
112			require Whatpm::ContentChecker;
113			print STDOUT "#domerrors\n";
114			$time1 = time;
115			Whatpm::ContentChecker->check_document ($doc, sub {
116			my %opt = @_;
117			print STDOUT get_node_path ($opt{node}) . ';' . $opt{type} . "\n";
118			});
119			$time2 = time;
120			$time{check} = $time2 - $time1;
121			}
122
123			print STDOUT "#log\n";
124			for (qw/decode parse parse_xml serialize_html serialize_xml serialize_test
125			check/) {
126			next unless defined $time{$_};
127			print STDOUT {
128			decode => 'bytes->chars',
129			parse => 'html5(chars)->dom5',
130			parse_xml => 'xml1(chars)->dom5',
131			serialize_html => 'dom5->html5',
132			serialize_xml => 'dom5->xml',
133			serialize_test => 'dom5->test',
134			check => 'dom5 check',
135			}->{$_};
136			print STDOUT "\t", $time{$_}, "s\n";
137			open my $file, '>>', ".manakai-$_.txt" or die ".manakai-$_.txt: $!";
138			print $file $char_length, "\t", $time{$_}, "\n";
139			}
140
141			exit;
142
143			sub test_serialize ($) {
144			my $node = shift;
145			my $r = '';
146
147			my @node = map { [$_, ''] } @{$node->child_nodes};
148			while (@node) {
149			my $child = shift @node;
150			my $nt = $child->[0]->node_type;
151			if ($nt == $child->[0]->ELEMENT_NODE) {
152			$r .= '\| ' . $child->[1] . '<' . $child->[0]->tag_name . ">\x0A"; ## ISSUE: case?
153
154			for my $attr (sort {$a->[0] cmp $b->[0]} map { [$_->name, $_->value] }
155			@{$child->[0]->attributes}) {
156			$r .= '\| ' . $child->[1] . ' ' . $attr->[0] . '="'; ## ISSUE: case?
157			$r .= $attr->[1] . '"' . "\x0A";
158			}
159
160			unshift @node,
161			map { [$_, $child->[1] . ' '] } @{$child->[0]->child_nodes};
162			} elsif ($nt == $child->[0]->TEXT_NODE) {
163			$r .= '\| ' . $child->[1] . '"' . $child->[0]->data . '"' . "\x0A";
164			} elsif ($nt == $child->[0]->CDATA_SECTION_NODE) {
165			$r .= '\| ' . $child->[1] . '<![CDATA[' . $child->[0]->data . "]]>\x0A";
166			} elsif ($nt == $child->[0]->COMMENT_NODE) {
167			$r .= '\| ' . $child->[1] . '<!-- ' . $child->[0]->data . " -->\x0A";
168			} elsif ($nt == $child->[0]->DOCUMENT_TYPE_NODE) {
169			$r .= '\| ' . $child->[1] . '<!DOCTYPE ' . $child->[0]->name . ">\x0A";
170			} elsif ($nt == $child->[0]->PROCESSING_INSTRUCTION_NODE) {
171			$r .= '\| ' . $child->[1] . '<?' . $child->[0]->target . ' ' .
172			$child->[0]->data . "?>\x0A";
173			} else {
174			$r .= '\| ' . $child->[1] . $child->[0]->node_type . "\x0A"; # error
175			}
176			}
177
178			return \$r;
179			} # test_serialize
180
181			sub get_node_path ($) {
182			my $node = shift;
183			my @r;
184			while (defined $node) {
185			my $rs;
186			if ($node->node_type == 1) {
187			$rs = $node->manakai_local_name;
188			$node = $node->parent_node;
189			} elsif ($node->node_type == 2) {
190			$rs = '@' . $node->manakai_local_name;
191			$node = $node->owner_element;
192			} elsif ($node->node_type == 3) {
193			$rs = '"' . $node->data . '"';
194			$node = $node->parent_node;
195			} elsif ($node->node_type == 9) {
196			$rs = '';
197			$node = $node->parent_node;
198			} else {
199			$rs = '#' . $node->node_type;
200			$node = $node->parent_node;
201			}
202			unshift @r, $rs;
203			}
204			return join '/', @r;
205			} # get_node_path
206
207			=head1 AUTHOR
208
209			Wakaba <w@suika.fam.cx>.
210
211			=head1 LICENSE
212
213			Copyright 2007 Wakaba <w@suika.fam.cx>
214
215			This library is free software; you can redistribute it
216			and/or modify it under the same terms as Perl itself.
217
218			=cut
219
220			## $Date: 2007/05/28 14:04:57 $