test/html-whatpm/parser.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 = $http->get_meta_variable ('PATH_INFO');
## TODO: decode unreserved characters

if ($mode eq '/html' or $mode eq '/test') {
  require Encode;
  require Whatpm::HTML;
  require Whatpm::NanoDOM;

  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 $time1 = time;
  $s = Encode::decode ('utf-8', $s);
  my $time2 = time;
  my %time = (decode => $time2 - $time1);
  my $char_length = length $s;
  
  print STDOUT "Content-Type: text/plain; charset=utf-8\n\n";

  print STDOUT "#errors\n";

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

  $time1 = time;
  my $doc = Whatpm::HTML->parse_string
      ($s => Whatpm::NanoDOM::Document->new, $onerror);
  $time2 = time;
  $time{parse} = $time2 - $time1;

  print "#document\n";

  my $out;
  $time1 = time;
  if ($mode eq '/html') {
    require Whatpm::HTML::Serializer;
    $out = Whatpm::HTML::Serializer->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";

  if ($http->get_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";
  print STDOUT "byte->char\t", $time{decode}, "s\n";
  print STDOUT "html5->dom5\t", $time{parse}, "s\n";
  print STDOUT "dom5->serialize\t", $time{serialize}, "s\n";
  print STDOUT "dom5 check\t", $time{check}, "s\n" if defined $time{check};
  for (qw/decode parse serialize check/) {
    next unless defined $time{$_};
    open my $file, '>>', ".$_.txt" or die ".$_.txt: $!";
    print $file $char_length, "\t", $time{$_}, "\n";
  }
} else {
  print STDOUT "Status: 404 Not Found\nContent-Type: text/plain; charset=us-ascii\n\n404";
}

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