test/html-whatpm/parser.cgi

#!/usr/bin/perl
use strict;

use lib qw[/home/httpd/html/www/markup/html/whatpm
           /home/wakaba/public_html/-temp/wiki/lib];

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

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

  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;
  }

  $s = Encode::decode ('utf-8', $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";
  };

  my $doc = Whatpm::HTML->parse_string
      ($s => Whatpm::NanoDOM::Document->new, $onerror);

  print "#document\n";

  my $out;
  if ($mode eq '/html') {
    $out = Whatpm::HTML->get_inner_html ($doc);
  } else { # test
    $out = test_serialize ($doc);
  }
  print STDOUT Encode::encode ('utf-8', $$out);
  print STDOUT "\n";

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