test/html-whatpm/parser-manakai.cgi

#!/usr/bin/perl
use strict;

use lib qw[/home/httpd/html/www/markup/html/whatpm
           /home/wakaba/work/manakai2/lib];
use CGI::Carp qw[fatalsToBrowser];
use Time::HiRes qw/time/;

use Message::CGI::HTTP;
my $http = Message::CGI::HTTP->new;

## TODO: _charset_

my @mode = split m#/#, scalar $http->get_meta_variable ('PATH_INFO'), -1;
shift @mode if @mode and $mode[0] == '';
## TODO: decode unreserved characters

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