Whatpm/HTML/Dumper.pm

package Whatpm::HTML::Dumper;
use strict;
our $VERSION=do{my @r=(q$Revision: 1.5 $=~/\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',

    q<urn:x-suika-fam-cx:markup:suikawiki:0:9:> => 'sw',
    q<urn:x-suika-fam-cx:markup:suikawiki:0:10:> => 'sw10',
  };

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