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 = split m#/#, scalar $http->meta_variable ('PATH_INFO'), -1;
shift @mode if @mode and $mode[0] == '';
## 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;
  my $el;

if (@mode == 3 and $mode[0] eq 'html' and
    ($mode[2] eq 'html' or $mode[2] eq '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";
  };

  $doc = $dom->create_document;
  $doc->manakai_is_html (1);
  $time1 = time;
  if (length $mode[1]) {
    $el = $doc->create_element_ns
        ('http://www.w3.org/1999/xhtml', [undef, $mode[1]]);
    Whatpm::HTML->set_inner_html ($el, $s, $onerror);
  } else {
    Whatpm::HTML->parse_string ($s => $doc, $onerror);
  }
  $time2 = time;
  $time{parse} = $time2 - $time1;

  print "#document\n";

  my $out;
  if ($mode[2] eq 'html') {
    $time1 = time;
    $out = \( ($el or $doc)->inner_html );
    $time2 = time;
    $time{serialize_html} = $time2 - $time1;
  } else { # test
    $time1 = time;
    $out = test_serialize ($el || $doc);
    $time2 = time;
    $time{serialize_test} = $time2 - $time1;
  }
  print STDOUT Encode::encode ('utf-8', $$out);
  print STDOUT "\n";
} elsif (@mode == 3 and $mode[0] eq 'xhtml' and
         ($mode[2] eq 'html' or $mode[2] eq '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[2] eq 'html') {
    $time1 = time;
    $out = \( $doc->inner_html ); ## TODO: $el case
    $time2 = time;
    $time{serialize_xml} = $time2 - $time1;
  } 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";
} elsif (@mode == 3 and $mode[0] eq 'h2h' and $mode[1] eq '' and
         ($mode[2] eq 'html' or $mode[2] eq 'test')) {
  print STDOUT "Content-Type: text/plain; charset=utf-8\n\n";

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

  require Whatpm::H2H;
  $doc = $dom->create_document;
  Whatpm::H2H->parse_string ($s => $doc);

  print "#document\n";

  my $out;
  if ($mode[2] eq 'html') {
    $time1 = time;
    $out = \( $doc->inner_html );
    $time2 = time;
    $time{serialize_xml} = $time2 - $time1;
  } 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;
    my $onerror = sub {
      my %opt = @_;
      print STDOUT get_node_path ($opt{node}) . ';' . $opt{type} . "\n";
    };
    print STDOUT "#domerrors\n";
    $time1 = time;
    if ($el) {
      Whatpm::ContentChecker->check_element ($el, $onerror);
    } else {
      Whatpm::ContentChecker->check_document ($doc, $onerror);
    }
    $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(char)',
      serialize_xml => 'dom5->xml1(char)',
      serialize_test => 'dom5->test(char)',
      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/07/15 06:14:30 $
1	wakaba	1.3	#!/usr/bin/perl
2	wakaba	1.1	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	wakaba	1.2	my @mode = split m#/#, scalar $http->meta_variable ('PATH_INFO'), -1;
17			shift @mode if @mode and $mode[0] == '';
18	wakaba	1.1	## TODO: decode unreserved characters
19
20			my $s = $http->parameter ('s');
21			if (length $s > 1000_000) {
22			print STDOUT "Status: 400 Document Too Long\nContent-Type: text/plain; charset=us-ascii\n\nToo long";
23			exit;
24			}
25			my $char_length = length $s;
26			my %time;
27			my $time1;
28			my $time2;
29
30			require Message::DOM::DOMImplementation;
31	wakaba	1.4	my $dom = Message::DOM::DOMImplementation->new;
32	wakaba	1.2	# $\| = 1;
33	wakaba	1.1	my $doc;
34	wakaba	1.2	my $el;
35	wakaba	1.1
36	wakaba	1.2	if (@mode == 3 and $mode[0] eq 'html' and
37			($mode[2] eq 'html' or $mode[2] eq 'test')) {
38	wakaba	1.1	print STDOUT "Content-Type: text/plain; charset=utf-8\n\n";
39
40			require Encode;
41			require Whatpm::HTML;
42
43			$time1 = time;
44			$s = Encode::decode ('utf-8', $s);
45			$time2 = time;
46			$time{decode} = $time2 - $time1;
47
48
49			print STDOUT "#errors\n";
50
51			my $onerror = sub {
52			my (%opt) = @_;
53			print STDOUT "$opt{line},$opt{column},$opt{type}\n";
54			};
55
56	wakaba	1.2	$doc = $dom->create_document;
57	wakaba	1.4	$doc->manakai_is_html (1);
58	wakaba	1.1	$time1 = time;
59	wakaba	1.2	if (length $mode[1]) {
60			$el = $doc->create_element_ns
61			('http://www.w3.org/1999/xhtml', [undef, $mode[1]]);
62			Whatpm::HTML->set_inner_html ($el, $s, $onerror);
63			} else {
64			Whatpm::HTML->parse_string ($s => $doc, $onerror);
65			}
66	wakaba	1.1	$time2 = time;
67			$time{parse} = $time2 - $time1;
68
69			print "#document\n";
70
71			my $out;
72	wakaba	1.2	if ($mode[2] eq 'html') {
73			$time1 = time;
74	wakaba	1.4	$out = \( ($el or $doc)->inner_html );
75	wakaba	1.2	$time2 = time;
76			$time{serialize_html} = $time2 - $time1;
77	wakaba	1.1	} else { # test
78	wakaba	1.2	$time1 = time;
79			$out = test_serialize ($el \|\| $doc);
80			$time2 = time;
81			$time{serialize_test} = $time2 - $time1;
82	wakaba	1.1	}
83			print STDOUT Encode::encode ('utf-8', $$out);
84			print STDOUT "\n";
85	wakaba	1.2	} elsif (@mode == 3 and $mode[0] eq 'xhtml' and
86			($mode[2] eq 'html' or $mode[2] eq 'test')) {
87	wakaba	1.1	print STDOUT "Content-Type: text/plain; charset=utf-8\n\n";
88
89			require Message::DOM::XMLParserTemp;
90			print STDOUT "#errors\n";
91
92			my $onerror = sub {
93			my $err = shift;
94			print STDOUT $err->location->line_number, ",";
95	wakaba	1.2	print STDOUT $err->location->column_number, ",";
96	wakaba	1.1	print STDOUT $err->text, "\n";
97			return 1;
98			};
99
100			open my $fh, '<', \$s;
101			my $time1 = time;
102			$doc = Message::DOM::XMLParserTemp->parse_byte_stream
103			($fh => $dom, $onerror, charset => 'utf-8');
104			my $time2 = time;
105			$time{parse_xml} = $time2 - $time1;
106
107			print "#document\n";
108
109			my $out;
110	wakaba	1.2	if ($mode[2] eq 'html') {
111	wakaba	1.4	$time1 = time;
112			$out = \( $doc->inner_html ); ## TODO: $el case
113			$time2 = time;
114			$time{serialize_xml} = $time2 - $time1;
115	wakaba	1.1	} else { # test
116			$time1 = time;
117			$out = test_serialize ($doc);
118			$time2 = time;
119			$time{serialize_test} = $time2 - $time1;
120			}
121			print STDOUT Encode::encode ('utf-8', $$out);
122			print STDOUT "\n";
123	wakaba	1.5	} elsif (@mode == 3 and $mode[0] eq 'h2h' and $mode[1] eq '' and
124			($mode[2] eq 'html' or $mode[2] eq 'test')) {
125			print STDOUT "Content-Type: text/plain; charset=utf-8\n\n";
126
127			require Encode;
128			$time1 = time;
129			$s = Encode::decode ('utf-8', $s);
130			$time2 = time;
131			$time{decode} = $time2 - $time1;
132
133			require Whatpm::H2H;
134			$doc = $dom->create_document;
135			Whatpm::H2H->parse_string ($s => $doc);
136
137			print "#document\n";
138
139			my $out;
140			if ($mode[2] eq 'html') {
141			$time1 = time;
142			$out = \( $doc->inner_html );
143			$time2 = time;
144			$time{serialize_xml} = $time2 - $time1;
145			} else { # test
146			$time1 = time;
147			$out = test_serialize ($doc);
148			$time2 = time;
149			$time{serialize_test} = $time2 - $time1;
150			}
151			print STDOUT Encode::encode ('utf-8', $$out);
152			print STDOUT "\n";
153	wakaba	1.1	} else {
154			print STDOUT "Status: 404 Not Found\nContent-Type: text/plain; charset=us-ascii\n\n404";
155			exit;
156			}
157
158			if ($http->parameter ('dom5')) {
159			require Whatpm::ContentChecker;
160	wakaba	1.2	my $onerror = sub {
161			my %opt = @_;
162			print STDOUT get_node_path ($opt{node}) . ';' . $opt{type} . "\n";
163			};
164	wakaba	1.1	print STDOUT "#domerrors\n";
165			$time1 = time;
166	wakaba	1.2	if ($el) {
167			Whatpm::ContentChecker->check_element ($el, $onerror);
168			} else {
169			Whatpm::ContentChecker->check_document ($doc, $onerror);
170			}
171	wakaba	1.1	$time2 = time;
172			$time{check} = $time2 - $time1;
173			}
174
175			print STDOUT "#log\n";
176			for (qw/decode parse parse_xml serialize_html serialize_xml serialize_test
177			check/) {
178			next unless defined $time{$_};
179			print STDOUT {
180			decode => 'bytes->chars',
181			parse => 'html5(chars)->dom5',
182			parse_xml => 'xml1(chars)->dom5',
183	wakaba	1.2	serialize_html => 'dom5->html5(char)',
184			serialize_xml => 'dom5->xml1(char)',
185			serialize_test => 'dom5->test(char)',
186	wakaba	1.1	check => 'dom5 check',
187			}->{$_};
188			print STDOUT "\t", $time{$_}, "s\n";
189			open my $file, '>>', ".manakai-$_.txt" or die ".manakai-$_.txt: $!";
190			print $file $char_length, "\t", $time{$_}, "\n";
191			}
192
193			exit;
194
195			sub test_serialize ($) {
196			my $node = shift;
197			my $r = '';
198
199			my @node = map { [$_, ''] } @{$node->child_nodes};
200			while (@node) {
201			my $child = shift @node;
202			my $nt = $child->[0]->node_type;
203			if ($nt == $child->[0]->ELEMENT_NODE) {
204			$r .= '\| ' . $child->[1] . '<' . $child->[0]->tag_name . ">\x0A"; ## ISSUE: case?
205
206			for my $attr (sort {$a->[0] cmp $b->[0]} map { [$_->name, $_->value] }
207			@{$child->[0]->attributes}) {
208			$r .= '\| ' . $child->[1] . ' ' . $attr->[0] . '="'; ## ISSUE: case?
209			$r .= $attr->[1] . '"' . "\x0A";
210			}
211
212			unshift @node,
213			map { [$_, $child->[1] . ' '] } @{$child->[0]->child_nodes};
214			} elsif ($nt == $child->[0]->TEXT_NODE) {
215			$r .= '\| ' . $child->[1] . '"' . $child->[0]->data . '"' . "\x0A";
216			} elsif ($nt == $child->[0]->CDATA_SECTION_NODE) {
217			$r .= '\| ' . $child->[1] . '<![CDATA[' . $child->[0]->data . "]]>\x0A";
218			} elsif ($nt == $child->[0]->COMMENT_NODE) {
219			$r .= '\| ' . $child->[1] . '<!-- ' . $child->[0]->data . " -->\x0A";
220			} elsif ($nt == $child->[0]->DOCUMENT_TYPE_NODE) {
221			$r .= '\| ' . $child->[1] . '<!DOCTYPE ' . $child->[0]->name . ">\x0A";
222			} elsif ($nt == $child->[0]->PROCESSING_INSTRUCTION_NODE) {
223			$r .= '\| ' . $child->[1] . '<?' . $child->[0]->target . ' ' .
224			$child->[0]->data . "?>\x0A";
225			} else {
226			$r .= '\| ' . $child->[1] . $child->[0]->node_type . "\x0A"; # error
227			}
228			}
229
230			return \$r;
231			} # test_serialize
232
233			sub get_node_path ($) {
234			my $node = shift;
235			my @r;
236			while (defined $node) {
237			my $rs;
238			if ($node->node_type == 1) {
239			$rs = $node->manakai_local_name;
240			$node = $node->parent_node;
241			} elsif ($node->node_type == 2) {
242			$rs = '@' . $node->manakai_local_name;
243			$node = $node->owner_element;
244			} elsif ($node->node_type == 3) {
245			$rs = '"' . $node->data . '"';
246			$node = $node->parent_node;
247			} elsif ($node->node_type == 9) {
248			$rs = '';
249			$node = $node->parent_node;
250			} else {
251			$rs = '#' . $node->node_type;
252			$node = $node->parent_node;
253			}
254			unshift @r, $rs;
255			}
256			return join '/', @r;
257			} # get_node_path
258
259			=head1 AUTHOR
260
261			Wakaba <w@suika.fam.cx>.
262
263			=head1 LICENSE
264
265			Copyright 2007 Wakaba <w@suika.fam.cx>
266
267			This library is free software; you can redistribute it
268			and/or modify it under the same terms as Perl itself.
269
270			=cut
271
272	wakaba	1.5	## $Date: 2007/07/15 06:14:30 $