Whatpm/HTML/Dumper.pm

package Whatpm::HTML::Dumper;
use strict;
our $VERSION=do{my @r=(q$Revision: 1.4 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};

require Exporter;
push our @ISA, 'Exporter';

our @EXPORT = qw(dumptree);

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

  my $ns_id = {
    q<http://www.w3.org/1999/xhtml> => 'html',
    q<http://www.w3.org/2000/svg> => 'svg',
    q<http://www.w3.org/1998/Math/MathML> => 'math',
    q<http://www.w3.org/1999/xlink> => 'xlink',
    q<http://www.w3.org/XML/1998/namespace> => 'xml',
    q<http://www.w3.org/2000/xmlns/> => 'xmlns',
  };

  my @node = map { [$_, ''] } @{$node->child_nodes};
  while (@node) {
    my $child = shift @node;
    my $nt = $child->[0]->node_type;
    if ($nt == $child->[0]->ELEMENT_NODE) {
      my $ns = $child->[0]->namespace_uri;
      unless (defined $ns) {
        $ns = '{} ';
      } elsif ($ns eq q<http://www.w3.org/1999/xhtml>) {
        $ns = '';
      } elsif ($ns_id->{$ns}) {
        $ns = $ns_id->{$ns} . ' ';
      } else {
        $ns = '{' . $ns . '} ';
      }
      $r .= $child->[1] . '<' . $ns . $child->[0]->manakai_local_name . ">\x0A";

      for my $attr (sort {$a->[0] cmp $b->[0]} map { [do {
                      my $ns = $_->namespace_uri;
                      unless (defined $ns) {
                        $ns = '';
                      } elsif ($ns_id->{$ns}) {
                        $ns = $ns_id->{$ns} . ' ';
                      } else {
                        $ns = '{' . $ns . '} ';
                      }
                      $ns . $_->manakai_local_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;
      my $pubid = $child->[0]->public_id;
      my $sysid = $child->[0]->system_id;
      if (length $pubid or length $sysid) {
        $r .= ' "' . $pubid . '"';
        $r .= ' "' . $sysid . '"';
      }
      $r .= ">\x0A";
      unshift @node,
          map { [$_, $child->[1] . '  '] }
          sort { $a->node_name cmp $b->node_name }
          values %{$child->[0]->element_types};
      unshift @node,
          map { [$_, $child->[1] . '  '] }
          sort { $a->node_name cmp $b->node_name }
          values %{$child->[0]->entities};
      unshift @node,
          map { [$_, $child->[1] . '  '] }
          sort { $a->node_name cmp $b->node_name }
          values %{$child->[0]->notations};
      unshift @node,
          map { [$_, $child->[1] . '  '] } @{$child->[0]->child_nodes};
    } elsif ($nt == $child->[0]->PROCESSING_INSTRUCTION_NODE) {
      $r .= $child->[1] . '<?' . $child->[0]->target . ' ';
      $r .= $child->[0]->data . "?>\x0A";
    } elsif ($nt == $child->[0]->ENTITY_NODE) {
      $r .= $child->[1] . '<!ENTITY ' . $child->[0]->node_name . ' "';
      $r .= $child->[0]->text_content;
      $r .= '" "';
      $r .= $child->[0]->public_id if defined $child->[0]->public_id;
      $r .= '" "';
      $r .= $child->[0]->system_id if defined $child->[0]->system_id;
      $r .= '" ';
      $r .= $child->[0]->notation_name if defined $child->[0]->notation_name;
      $r .= ">\x0A";
      unshift @node,
          map { [$_, $child->[1] . '  '] } @{$child->[0]->child_nodes};
    } elsif ($nt == $child->[0]->NOTATION_NODE) {
      $r .= $child->[1] . '<!NOTATION ' . $child->[0]->node_name . ' "';
      $r .= $child->[0]->public_id if defined $child->[0]->public_id;
      $r .= '" "';
      $r .= $child->[0]->system_id if defined $child->[0]->system_id;
      $r .= qq[">\x0A];
    } elsif ($nt == $child->[0]->ELEMENT_TYPE_DEFINITION_NODE) {
      $r .= $child->[1] . '<!ELEMENT ' . $child->[0]->node_name . ' ';
      $r .= $child->[0]->content_model_text;
      $r .= ">\x0A";
      unshift @node,
          map { [$_, $child->[1] . '  '] }
          sort { $a->node_name cmp $b->node_name }
          values %{$child->[0]->attribute_definitions};
    } elsif ($nt == $child->[0]->ATTRIBUTE_DEFINITION_NODE) {
      $r .= $child->[1] . $child->[0]->node_name . ' ';
      $r .= [
        0, 'CDATA', 'ID', 'IDREF', 'IDREFS', 'ENTITY', 'ENTITIES',
        'NMTOKEN', 'NMTOKENS', 'NOTATION', 'ENUMERATION', 11,
      ]->[$child->[0]->declared_type] || $child->[0]->declared_type;
      $r .= ' (' . join ('|', @{$child->[0]->allowed_tokens}) . ') ';
      $r .= [
        0, 'FIXED', 'REQUIRED', 'IMPLIED', 'EXPLICIT',
      ]->[$child->[0]->default_type] || $child->[0]->default_type;
      $r .= ' "' . $child->[0]->text_content . '"';
      $r .= "\x0A";
    } else {
      $r .= $child->[1] . $child->[0]->node_type . "\x0A"; # error
    }
  }
  
  return $r;
} # dumptree

## NOTE: Based on <http://wiki.whatwg.org/wiki/Parser_tests>.
## TDOO: Document

1;
## $Date: 2008/10/18 08:05:29 $
1	wakaba	1.1	package Whatpm::HTML::Dumper;
2			use strict;
3	wakaba	1.5	our $VERSION=do{my @r=(q$Revision: 1.4 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
4	wakaba	1.1
5			require Exporter;
6			push our @ISA, 'Exporter';
7
8			our @EXPORT = qw(dumptree);
9
10			sub dumptree ($) {
11			my $node = shift;
12			my $r = '';
13
14			my $ns_id = {
15			q<http://www.w3.org/1999/xhtml> => 'html',
16			q<http://www.w3.org/2000/svg> => 'svg',
17			q<http://www.w3.org/1998/Math/MathML> => 'math',
18			q<http://www.w3.org/1999/xlink> => 'xlink',
19			q<http://www.w3.org/XML/1998/namespace> => 'xml',
20	wakaba	1.2	q<http://www.w3.org/2000/xmlns/> => 'xmlns',
21	wakaba	1.1	};
22
23			my @node = map { [$_, ''] } @{$node->child_nodes};
24			while (@node) {
25			my $child = shift @node;
26			my $nt = $child->[0]->node_type;
27			if ($nt == $child->[0]->ELEMENT_NODE) {
28			my $ns = $child->[0]->namespace_uri;
29			unless (defined $ns) {
30			$ns = '{} ';
31			} elsif ($ns eq q<http://www.w3.org/1999/xhtml>) {
32			$ns = '';
33			} elsif ($ns_id->{$ns}) {
34			$ns = $ns_id->{$ns} . ' ';
35			} else {
36			$ns = '{' . $ns . '} ';
37			}
38			$r .= $child->[1] . '<' . $ns . $child->[0]->manakai_local_name . ">\x0A";
39
40			for my $attr (sort {$a->[0] cmp $b->[0]} map { [do {
41			my $ns = $_->namespace_uri;
42			unless (defined $ns) {
43			$ns = '';
44			} elsif ($ns_id->{$ns}) {
45			$ns = $ns_id->{$ns} . ' ';
46			} else {
47			$ns = '{' . $ns . '} ';
48			}
49			$ns . $_->manakai_local_name;
50			}, $_->value] }
51			@{$child->[0]->attributes}) {
52			$r .= $child->[1] . ' ' . $attr->[0] . '="'; ## ISSUE: case?
53			$r .= $attr->[1] . '"' . "\x0A";
54			}
55
56			unshift @node,
57			map { [$_, $child->[1] . ' '] } @{$child->[0]->child_nodes};
58			} elsif ($nt == $child->[0]->TEXT_NODE) {
59			$r .= $child->[1] . '"' . $child->[0]->data . '"' . "\x0A";
60			} elsif ($nt == $child->[0]->COMMENT_NODE) {
61			$r .= $child->[1] . '<!-- ' . $child->[0]->data . " -->\x0A";
62			} elsif ($nt == $child->[0]->DOCUMENT_TYPE_NODE) {
63			$r .= $child->[1] . '<!DOCTYPE ' . $child->[0]->name;
64			my $pubid = $child->[0]->public_id;
65			my $sysid = $child->[0]->system_id;
66			if (length $pubid or length $sysid) {
67			$r .= ' "' . $pubid . '"';
68			$r .= ' "' . $sysid . '"';
69			}
70			$r .= ">\x0A";
71			unshift @node,
72	wakaba	1.3	map { [$_, $child->[1] . ' '] }
73			sort { $a->node_name cmp $b->node_name }
74			values %{$child->[0]->element_types};
75			unshift @node,
76			map { [$_, $child->[1] . ' '] }
77			sort { $a->node_name cmp $b->node_name }
78			values %{$child->[0]->entities};
79			unshift @node,
80			map { [$_, $child->[1] . ' '] }
81			sort { $a->node_name cmp $b->node_name }
82			values %{$child->[0]->notations};
83			unshift @node,
84			map { [$_, $child->[1] . ' '] } @{$child->[0]->child_nodes};
85	wakaba	1.1	} elsif ($nt == $child->[0]->PROCESSING_INSTRUCTION_NODE) {
86			$r .= $child->[1] . '<?' . $child->[0]->target . ' ';
87			$r .= $child->[0]->data . "?>\x0A";
88	wakaba	1.3	} elsif ($nt == $child->[0]->ENTITY_NODE) {
89			$r .= $child->[1] . '<!ENTITY ' . $child->[0]->node_name . ' "';
90	wakaba	1.5	$r .= $child->[0]->text_content;
91			$r .= '" "';
92	wakaba	1.3	$r .= $child->[0]->public_id if defined $child->[0]->public_id;
93			$r .= '" "';
94			$r .= $child->[0]->system_id if defined $child->[0]->system_id;
95			$r .= '" ';
96			$r .= $child->[0]->notation_name if defined $child->[0]->notation_name;
97			$r .= ">\x0A";
98			unshift @node,
99			map { [$_, $child->[1] . ' '] } @{$child->[0]->child_nodes};
100			} elsif ($nt == $child->[0]->NOTATION_NODE) {
101			$r .= $child->[1] . '<!NOTATION ' . $child->[0]->node_name . ' "';
102			$r .= $child->[0]->public_id if defined $child->[0]->public_id;
103			$r .= '" "';
104			$r .= $child->[0]->system_id if defined $child->[0]->system_id;
105			$r .= qq[">\x0A];
106			} elsif ($nt == $child->[0]->ELEMENT_TYPE_DEFINITION_NODE) {
107			$r .= $child->[1] . '<!ELEMENT ' . $child->[0]->node_name . ' ';
108			$r .= $child->[0]->content_model_text;
109			$r .= ">\x0A";
110			unshift @node,
111			map { [$_, $child->[1] . ' '] }
112			sort { $a->node_name cmp $b->node_name }
113			values %{$child->[0]->attribute_definitions};
114			} elsif ($nt == $child->[0]->ATTRIBUTE_DEFINITION_NODE) {
115			$r .= $child->[1] . $child->[0]->node_name . ' ';
116			$r .= [
117			0, 'CDATA', 'ID', 'IDREF', 'IDREFS', 'ENTITY', 'ENTITIES',
118			'NMTOKEN', 'NMTOKENS', 'NOTATION', 'ENUMERATION', 11,
119			]->[$child->[0]->declared_type] \|\| $child->[0]->declared_type;
120	wakaba	1.4	$r .= ' (' . join ('\|', @{$child->[0]->allowed_tokens}) . ') ';
121	wakaba	1.3	$r .= [
122			0, 'FIXED', 'REQUIRED', 'IMPLIED', 'EXPLICIT',
123			]->[$child->[0]->default_type] \|\| $child->[0]->default_type;
124	wakaba	1.4	$r .= ' "' . $child->[0]->text_content . '"';
125	wakaba	1.3	$r .= "\x0A";
126	wakaba	1.1	} else {
127			$r .= $child->[1] . $child->[0]->node_type . "\x0A"; # error
128			}
129			}
130
131			return $r;
132			} # dumptree
133
134			## NOTE: Based on <http://wiki.whatwg.org/wiki/Parser_tests>.
135			## TDOO: Document
136
137			1;
138	wakaba	1.5	## $Date: 2008/10/18 08:05:29 $