WebHACC/Language/DOM.pm

package WebHACC::Language::DOM;
use strict;
require WebHACC::Language::Base;
push our @ISA, 'WebHACC::Language::Base';

use Scalar::Util qw[refaddr];

sub generate_structure_dump_section ($) {
  my $self = shift;
  
  my $out = $self->output;

  $out->start_section (role => 'tree');

  $out->start_tag ('ol', class => 'xoxo');

  my @node = ($self->{structure});
  while (@node) {
    my $child = shift @node;
    unless (ref $child) {
      $out->html ($child);
      next;
    }

    my $node_id = 'node-'.refaddr $child;
    my $nt = $child->node_type;
    if ($nt == $child->ELEMENT_NODE) {
      my $child_nsuri = $child->namespace_uri;
      $out->start_tag ('li', id => $node_id, class => 'tree-element');
      $out->start_tag ('code',
                       title => defined $child_nsuri ? $child_nsuri : '');
      $out->text ($child->tag_name); ## TODO: case
      $out->end_tag ('code');

      if ($child->has_attributes) {
        $out->start_tag ('ul', class => 'attributes');
        for my $attr (sort {$a->[0] cmp $b->[0]} map { [$_->name, $_->value, $_->namespace_uri, 'node-'.refaddr $_] }
                      @{$child->attributes}) {
          $out->start_tag ('li', id => $attr->[3], class => 'tree-attribute');
          $out->start_tag ('code',
                           title => defined $attr->[2] ? $attr->[2] : '');
          $out->html ($attr->[0]); ## ISSUE: case
          $out->end_tag ('code');
          $out->text (' = ');
          $out->start_tag ('q');
          $out->text ($attr->[1]); ## TODO: children
          $out->end_tag ('q');
        }
        $out->end_tag ('ul');
      }

      if ($child->has_child_nodes) {
        $out->start_tag ('ol', class => 'children');
        unshift @node, @{$child->child_nodes}, '</ol></li>';
      }
    } elsif ($nt == $child->TEXT_NODE) {
      $out->start_tag ('li', id => $node_id, class => 'tree-text');
      $out->start_tag ('q', lang => '');
      $out->text ($child->data);
      $out->end_tag ('q');
    } elsif ($nt == $child->CDATA_SECTION_NODE) {
      $out->start_tag ('li', id => $node_id, class => 'tree-cdata');
      $out->start_tag ('code');
      $out->text ('<![CDATA[');
      $out->end_tag ('code');
      $out->start_tag ('q', lang => '');
      $out->text ($child->data);
      $out->end_tag ('q');
      $out->start_tag ('code');
      $out->text (']]>');
      $out->end_tag ('code');
    } elsif ($nt == $child->COMMENT_NODE) {
      $out->start_tag ('li', id => $node_id, class => 'tree-cdata');
      $out->start_tag ('code');
      $out->text ('<!--');
      $out->end_tag ('code');
      $out->start_tag ('q', lang => '');
      $out->text ($child->data);
      $out->end_tag ('q');
      $out->start_tag ('code');
      $out->text ('-->');
      $out->end_tag ('code');
    } elsif ($nt == $child->DOCUMENT_NODE) {
      $out->start_tag ('li', id => $node_id, class => 'tree-document');
      $out->text ('Document');
      $out->start_tag ('ul', class => 'attributes');
      my $cp = $child->manakai_charset;
      if (defined $cp) {
        $out->html (qq[<li><code>charset</code> parameter = <code>]);
        $out->text ($cp);
        $out->html ('</code>');
      }
      $out->html (qq[<li><code>inputEncoding</code> = ]);
      my $ie = $child->input_encoding;
      if (defined $ie) {
        $out->code ($ie);
        if ($child->manakai_has_bom) {
          $out->html (qq[ (with <code class=charname><abbr>BOM</abbr></code>)]);
        }
      } else {
        $out->html (qq[(<code>null</code>)]);
      }
      $out->html (qq[<li>@{[scalar main::get_text ('manakaiIsHTML:'.($child->manakai_is_html?1:0))]}</li>]);
      $out->html (qq[<li>@{[scalar main::get_text ('manakaiCompatMode:'.$child->manakai_compat_mode)]}</li>]);
      unless ($child->manakai_is_html) {
        $out->html (qq[<li>XML version = ]);
        $out->code ($child->xml_version);
        if (defined $child->xml_encoding) {
          $out->html (qq[<li>XML encoding = ]);
          $out->code ($child->xml_encoding);
        } else {
          $out->html (qq[<li>XML encoding = (null)</li>]);
        }
        $out->html (qq[<li>XML standalone = @{[$child->xml_standalone ? 'true' : 'false']}</li>]);
      }
      $out->end_tag ('ul');
      if ($child->has_child_nodes) {
        $out->start_tag ('ol', class => 'children');
        unshift @node, @{$child->child_nodes}, '</ol></li>';
      }
    } elsif ($nt == $child->DOCUMENT_TYPE_NODE) {
      $out->start_tag ('li', id => $node_id, class => 'tree-doctype');
      $out->code ('<!DOCTYPE>');
      $out->start_tag ('ul', class => 'attributes');

      $out->start_tag ('li', class => 'tree-doctype-name');
      $out->text ('Name = ');
      $out->code ($child->name);

      $out->start_tag ('li', class => 'tree-doctype-publicid');
      $out->text ('Public identifier = ');
      $out->code ($child->public_id);

      $out->start_tag ('li', class => 'tree-doctype-systemid');
      $out->text ('System identifier = ');
      $out->code ($child->system_id);

      $out->end_tag ('ul');
    } elsif ($nt == $child->PROCESSING_INSTRUCTION_NODE) {
      $out->start_tag ('li', id => $node_id, class => 'tree-id');
      $out->code ('<?');
      $out->code ($child->target);
      $out->text (' ');
      $out->code ($child->data);
      $out->code ('?>');
    } else { # error
      $out->start_tag ('li', id => $node_id, class => 'tree-unknown');
      $out->text ($child->node_type . ' ' . $child->node_name);
    }
  }
  $out->end_tag ('ol');

  $out->end_section;
} # generate_structure_dump_section

sub generate_structure_error_section ($) {
  my $self = shift;
  
  my $out = $self->output;
  $out->start_section (role => 'structure-errors');
  $out->start_error_list (role => 'structure-errors');

  my $input = $self->input;
  my $result = $self->result;

  require Whatpm::ContentChecker;
  my $onerror = sub {
    $result->add_error (@_, layer => 'structure');
  };

  my $onsubdoc = $self->onsubdoc;
  if ($self->{structure}->node_type == $self->{structure}->ELEMENT_NODE) {
    $self->{add_info} = Whatpm::ContentChecker->check_element
        ($self->{structure}, $onerror, $onsubdoc);
  } else {
    $self->{add_info} = Whatpm::ContentChecker->check_document
        ($self->{structure}, $onerror, $onsubdoc);
  }

  $out->end_error_list (role => 'structure-errors');
  $out->end_section;
} # generate_structure_error_section

sub generate_additional_sections ($) {
  my $self = shift;
  $self->SUPER::generate_additional_sections;
  $self->generate_table_section;
} # generate_additional_sections

sub generate_table_section ($) {
  my $self = shift;

  my $tables = $self->{add_info}->{table} || [];
  return unless @$tables;

  my $out = $self->output;
  $out->start_section (id => 'tables', title => 'Tables');

  $out->html (q[<!--[if IE]><script type="text/javascript" src="../excanvas.js"></script><![endif]-->
<script src="../table-script.js" type="text/javascript"></script>
<noscript>
<p><em>Structure of tables are visualized here if scripting is enabled.</em></p>
</noscript>]);
  
  require JSON;
  
  my $i = 0;
  for my $table (@$tables) {
    $i++;
    $out->start_section (id => 'table-' . $i,
                         title => 'Table #' . $i);

    $out->start_tag ('dl');
    $out->dt ('Table Element');
    $out->start_tag ('dd');
    $out->node_link ($table->{element});
    $out->end_tag ('dl');
    delete $table->{element};

    for (@{$table->{column_group}}, @{$table->{column}}, $table->{caption},
         @{$table->{row}}) {
      next unless $_;
      delete $_->{element};
    }
    
    for (@{$table->{row_group}}) {
      next unless $_;
      next unless $_->{element};
      $_->{type} = $_->{element}->manakai_local_name;
      delete $_->{element};
    }
    
    for (@{$table->{cell}}) {
      next unless $_;
      for (@{$_}) {
        next unless $_;
        for (@$_) {
          $_->{id} = refaddr $_->{element} if defined $_->{element};
          delete $_->{element};
          $_->{is_header} = $_->{is_header} ? 1 : 0;
        }
      }
    }

    my $id_prefix = $self->input->id_prefix;
    $out->script (q[tableToCanvas (] .
        JSON::objToJson ($table) .
        q[, document.getElementById ('] . $id_prefix . 'table-' . $i . q[')] .
        q[, '] . $id_prefix . q[');]);

    $out->end_section;
  }

  $out->end_section;
} # print_table_section

sub print_listing_section ($$$) {
  my ($opt, $input, $ids) = @_;
  
#  push @nav, ['#' . $input->{id_prefix} . $opt->{id} => $opt->{label}]
#      unless $input->{nested};
  print STDOUT qq[
<div id="$input->{id_prefix}$opt->{id}" class="section">
<h2>$opt->{heading}</h2>

<dl>
];
  for my $id (sort {$a cmp $b} keys %$ids) {
    print STDOUT qq[<dt><code>@{[htescape $id]}</code></dt>];
    for (@{$ids->{$id}}) {
      print STDOUT qq[<dd>].get_node_link ($input, $_).qq[</dd>];
    }
  }
  print STDOUT qq[</dl></div>];
} # print_listing_section


sub print_rdf_section ($$$) {
  my ($input, $rdfs) = @_;
  
#  push @nav, ['#' . $input->{id_prefix} . 'rdf' => 'RDF']
#      unless $input->{nested};
  print STDOUT qq[
<div id="$input->{id_prefix}rdf" class="section">
<h2>RDF Triples</h2>

<dl>];
  my $i = 0;
  for my $rdf (@$rdfs) {
    print STDOUT qq[<dt id="$input->{id_prefix}rdf-@{[$i++]}">];
    print STDOUT get_node_link ($input, $rdf->[0]);
    print STDOUT qq[<dd><dl>];
    for my $triple (@{$rdf->[1]}) {
      print STDOUT '<dt>' . get_node_link ($input, $triple->[0]) . '<dd>';
      print STDOUT get_rdf_resource_html ($triple->[1]);
      print STDOUT ' ';
      print STDOUT get_rdf_resource_html ($triple->[2]);
      print STDOUT ' ';
      print STDOUT get_rdf_resource_html ($triple->[3]);
    }
    print STDOUT qq[</dl>];
  }
  print STDOUT qq[</dl></div>];
} # print_rdf_section

sub get_rdf_resource_html ($) {
  my $resource = shift;
  if (defined $resource->{uri}) {
    my $euri = htescape ($resource->{uri});
    return '<code class=uri>&lt;<a href="' . $euri . '">' . $euri .
        '</a>></code>';
  } elsif (defined $resource->{bnodeid}) {
    return htescape ('_:' . $resource->{bnodeid});
  } elsif ($resource->{nodes}) {
    return '(rdf:XMLLiteral)';
  } elsif (defined $resource->{value}) {
    my $elang = htescape (defined $resource->{language}
                              ? $resource->{language} : '');
    my $r = qq[<q lang="$elang">] . htescape ($resource->{value}) . '</q>';
    if (defined $resource->{datatype}) {
      my $euri = htescape ($resource->{datatype});
      $r .= '^^<code class=uri>&lt;<a href="' . $euri . '">' . $euri .
          '</a>></code>';
    } elsif (length $resource->{language}) {
      $r .= '@' . htescape ($resource->{language});
    }
    return $r;
  } else {
    return '??';
  }
} # get_rdf_resource_html

1;
1	wakaba	1.1	package WebHACC::Language::DOM;
2			use strict;
3			require WebHACC::Language::Base;
4			push our @ISA, 'WebHACC::Language::Base';
5
6			use Scalar::Util qw[refaddr];
7
8			sub generate_structure_dump_section ($) {
9			my $self = shift;
10
11			my $out = $self->output;
12
13	wakaba	1.3	$out->start_section (role => 'tree');
14	wakaba	1.1
15			$out->start_tag ('ol', class => 'xoxo');
16
17			my @node = ($self->{structure});
18			while (@node) {
19			my $child = shift @node;
20			unless (ref $child) {
21			$out->html ($child);
22			next;
23			}
24
25			my $node_id = 'node-'.refaddr $child;
26			my $nt = $child->node_type;
27			if ($nt == $child->ELEMENT_NODE) {
28			my $child_nsuri = $child->namespace_uri;
29			$out->start_tag ('li', id => $node_id, class => 'tree-element');
30			$out->start_tag ('code',
31			title => defined $child_nsuri ? $child_nsuri : '');
32			$out->text ($child->tag_name); ## TODO: case
33			$out->end_tag ('code');
34
35			if ($child->has_attributes) {
36			$out->start_tag ('ul', class => 'attributes');
37			for my $attr (sort {$a->[0] cmp $b->[0]} map { [$_->name, $_->value, $_->namespace_uri, 'node-'.refaddr $_] }
38			@{$child->attributes}) {
39			$out->start_tag ('li', id => $attr->[3], class => 'tree-attribute');
40			$out->start_tag ('code',
41			title => defined $attr->[2] ? $attr->[2] : '');
42			$out->html ($attr->[0]); ## ISSUE: case
43			$out->end_tag ('code');
44			$out->text (' = ');
45			$out->start_tag ('q');
46			$out->text ($attr->[1]); ## TODO: children
47			$out->end_tag ('q');
48			}
49			$out->end_tag ('ul');
50			}
51
52			if ($child->has_child_nodes) {
53			$out->start_tag ('ol', class => 'children');
54			unshift @node, @{$child->child_nodes}, '</ol></li>';
55			}
56			} elsif ($nt == $child->TEXT_NODE) {
57			$out->start_tag ('li', id => $node_id, class => 'tree-text');
58			$out->start_tag ('q', lang => '');
59			$out->text ($child->data);
60			$out->end_tag ('q');
61			} elsif ($nt == $child->CDATA_SECTION_NODE) {
62			$out->start_tag ('li', id => $node_id, class => 'tree-cdata');
63			$out->start_tag ('code');
64			$out->text ('<![CDATA[');
65			$out->end_tag ('code');
66			$out->start_tag ('q', lang => '');
67			$out->text ($child->data);
68			$out->end_tag ('q');
69			$out->start_tag ('code');
70			$out->text (']]>');
71			$out->end_tag ('code');
72			} elsif ($nt == $child->COMMENT_NODE) {
73			$out->start_tag ('li', id => $node_id, class => 'tree-cdata');
74			$out->start_tag ('code');
75			$out->text ('<!--');
76			$out->end_tag ('code');
77			$out->start_tag ('q', lang => '');
78			$out->text ($child->data);
79			$out->end_tag ('q');
80			$out->start_tag ('code');
81			$out->text ('-->');
82			$out->end_tag ('code');
83			} elsif ($nt == $child->DOCUMENT_NODE) {
84			$out->start_tag ('li', id => $node_id, class => 'tree-document');
85			$out->text ('Document');
86			$out->start_tag ('ul', class => 'attributes');
87			my $cp = $child->manakai_charset;
88			if (defined $cp) {
89			$out->html (qq[<li><code>charset</code> parameter = <code>]);
90			$out->text ($cp);
91			$out->html ('</code>');
92			}
93			$out->html (qq[<li><code>inputEncoding</code> = ]);
94			my $ie = $child->input_encoding;
95			if (defined $ie) {
96			$out->code ($ie);
97			if ($child->manakai_has_bom) {
98			$out->html (qq[ (with <code class=charname><abbr>BOM</abbr></code>)]);
99			}
100			} else {
101			$out->html (qq[(<code>null</code>)]);
102			}
103			$out->html (qq[<li>@{[scalar main::get_text ('manakaiIsHTML:'.($child->manakai_is_html?1:0))]}</li>]);
104			$out->html (qq[<li>@{[scalar main::get_text ('manakaiCompatMode:'.$child->manakai_compat_mode)]}</li>]);
105			unless ($child->manakai_is_html) {
106			$out->html (qq[<li>XML version = ]);
107			$out->code ($child->xml_version);
108			if (defined $child->xml_encoding) {
109			$out->html (qq[<li>XML encoding = ]);
110			$out->code ($child->xml_encoding);
111			} else {
112			$out->html (qq[<li>XML encoding = (null)</li>]);
113			}
114			$out->html (qq[<li>XML standalone = @{[$child->xml_standalone ? 'true' : 'false']}</li>]);
115			}
116			$out->end_tag ('ul');
117			if ($child->has_child_nodes) {
118			$out->start_tag ('ol', class => 'children');
119			unshift @node, @{$child->child_nodes}, '</ol></li>';
120			}
121			} elsif ($nt == $child->DOCUMENT_TYPE_NODE) {
122			$out->start_tag ('li', id => $node_id, class => 'tree-doctype');
123			$out->code ('<!DOCTYPE>');
124			$out->start_tag ('ul', class => 'attributes');
125
126			$out->start_tag ('li', class => 'tree-doctype-name');
127			$out->text ('Name = ');
128			$out->code ($child->name);
129
130			$out->start_tag ('li', class => 'tree-doctype-publicid');
131			$out->text ('Public identifier = ');
132			$out->code ($child->public_id);
133
134			$out->start_tag ('li', class => 'tree-doctype-systemid');
135			$out->text ('System identifier = ');
136			$out->code ($child->system_id);
137
138			$out->end_tag ('ul');
139			} elsif ($nt == $child->PROCESSING_INSTRUCTION_NODE) {
140			$out->start_tag ('li', id => $node_id, class => 'tree-id');
141			$out->code ('<?');
142			$out->code ($child->target);
143			$out->text (' ');
144			$out->code ($child->data);
145			$out->code ('?>');
146			} else { # error
147			$out->start_tag ('li', id => $node_id, class => 'tree-unknown');
148			$out->text ($child->node_type . ' ' . $child->node_name);
149			}
150			}
151			$out->end_tag ('ol');
152
153			$out->end_section;
154			} # generate_structure_dump_section
155
156			sub generate_structure_error_section ($) {
157			my $self = shift;
158
159			my $out = $self->output;
160	wakaba	1.3	$out->start_section (role => 'structure-errors');
161			$out->start_error_list (role => 'structure-errors');
162	wakaba	1.1
163			my $input = $self->input;
164			my $result = $self->result;
165
166			require Whatpm::ContentChecker;
167			my $onerror = sub {
168	wakaba	1.2	$result->add_error (@_, layer => 'structure');
169	wakaba	1.1	};
170
171			my $onsubdoc = $self->onsubdoc;
172			if ($self->{structure}->node_type == $self->{structure}->ELEMENT_NODE) {
173			$self->{add_info} = Whatpm::ContentChecker->check_element
174			($self->{structure}, $onerror, $onsubdoc);
175			} else {
176			$self->{add_info} = Whatpm::ContentChecker->check_document
177			($self->{structure}, $onerror, $onsubdoc);
178			}
179
180	wakaba	1.3	$out->end_error_list (role => 'structure-errors');
181	wakaba	1.1	$out->end_section;
182			} # generate_structure_error_section
183	wakaba	1.3
184			sub generate_additional_sections ($) {
185			my $self = shift;
186			$self->SUPER::generate_additional_sections;
187			$self->generate_table_section;
188			} # generate_additional_sections
189
190			sub generate_table_section ($) {
191			my $self = shift;
192
193			my $tables = $self->{add_info}->{table} \|\| [];
194			return unless @$tables;
195
196			my $out = $self->output;
197			$out->start_section (id => 'tables', title => 'Tables');
198
199			$out->html (q[<!--[if IE]><script type="text/javascript" src="../excanvas.js"></script><![endif]-->
200			<script src="../table-script.js" type="text/javascript"></script>
201			<noscript>
202			<p><em>Structure of tables are visualized here if scripting is enabled.</em></p>
203			</noscript>]);
204
205			require JSON;
206
207			my $i = 0;
208			for my $table (@$tables) {
209			$i++;
210			$out->start_section (id => 'table-' . $i,
211			title => 'Table #' . $i);
212
213			$out->start_tag ('dl');
214			$out->dt ('Table Element');
215			$out->start_tag ('dd');
216			$out->node_link ($table->{element});
217			$out->end_tag ('dl');
218			delete $table->{element};
219
220			for (@{$table->{column_group}}, @{$table->{column}}, $table->{caption},
221			@{$table->{row}}) {
222			next unless $_;
223			delete $_->{element};
224			}
225
226			for (@{$table->{row_group}}) {
227			next unless $_;
228			next unless $_->{element};
229			$_->{type} = $_->{element}->manakai_local_name;
230			delete $_->{element};
231			}
232
233			for (@{$table->{cell}}) {
234			next unless $_;
235			for (@{$_}) {
236			next unless $_;
237			for (@$_) {
238			$_->{id} = refaddr $_->{element} if defined $_->{element};
239			delete $_->{element};
240			$_->{is_header} = $_->{is_header} ? 1 : 0;
241			}
242			}
243			}
244
245			my $id_prefix = $self->input->id_prefix;
246			$out->script (q[tableToCanvas (] .
247			JSON::objToJson ($table) .
248			q[, document.getElementById ('] . $id_prefix . 'table-' . $i . q[')] .
249			q[, '] . $id_prefix . q[');]);
250
251			$out->end_section;
252			}
253
254			$out->end_section;
255			} # print_table_section
256
257			sub print_listing_section ($$$) {
258			my ($opt, $input, $ids) = @_;
259
260			# push @nav, ['#' . $input->{id_prefix} . $opt->{id} => $opt->{label}]
261			# unless $input->{nested};
262			print STDOUT qq[
263			<div id="$input->{id_prefix}$opt->{id}" class="section">
264			<h2>$opt->{heading}</h2>
265
266			<dl>
267			];
268			for my $id (sort {$a cmp $b} keys %$ids) {
269			print STDOUT qq[<dt><code>@{[htescape $id]}</code></dt>];
270			for (@{$ids->{$id}}) {
271			print STDOUT qq[<dd>].get_node_link ($input, $_).qq[</dd>];
272			}
273			}
274			print STDOUT qq[</dl></div>];
275			} # print_listing_section
276
277
278			sub print_rdf_section ($$$) {
279			my ($input, $rdfs) = @_;
280
281			# push @nav, ['#' . $input->{id_prefix} . 'rdf' => 'RDF']
282			# unless $input->{nested};
283			print STDOUT qq[
284			<div id="$input->{id_prefix}rdf" class="section">
285			<h2>RDF Triples</h2>
286
287			<dl>];
288			my $i = 0;
289			for my $rdf (@$rdfs) {
290			print STDOUT qq[<dt id="$input->{id_prefix}rdf-@{[$i++]}">];
291			print STDOUT get_node_link ($input, $rdf->[0]);
292			print STDOUT qq[<dd><dl>];
293			for my $triple (@{$rdf->[1]}) {
294			print STDOUT '<dt>' . get_node_link ($input, $triple->[0]) . '<dd>';
295			print STDOUT get_rdf_resource_html ($triple->[1]);
296			print STDOUT ' ';
297			print STDOUT get_rdf_resource_html ($triple->[2]);
298			print STDOUT ' ';
299			print STDOUT get_rdf_resource_html ($triple->[3]);
300			}
301			print STDOUT qq[</dl>];
302			}
303			print STDOUT qq[</dl></div>];
304			} # print_rdf_section
305
306			sub get_rdf_resource_html ($) {
307			my $resource = shift;
308			if (defined $resource->{uri}) {
309			my $euri = htescape ($resource->{uri});
310			return '<code class=uri><<a href="' . $euri . '">' . $euri .
311			'</a>></code>';
312			} elsif (defined $resource->{bnodeid}) {
313			return htescape ('_:' . $resource->{bnodeid});
314			} elsif ($resource->{nodes}) {
315			return '(rdf:XMLLiteral)';
316			} elsif (defined $resource->{value}) {
317			my $elang = htescape (defined $resource->{language}
318			? $resource->{language} : '');
319			my $r = qq[<q lang="$elang">] . htescape ($resource->{value}) . '</q>';
320			if (defined $resource->{datatype}) {
321			my $euri = htescape ($resource->{datatype});
322			$r .= '^^<code class=uri><<a href="' . $euri . '">' . $euri .
323			'</a>></code>';
324			} elsif (length $resource->{language}) {
325			$r .= '@' . htescape ($resource->{language});
326			}
327			return $r;
328			} else {
329			return '??';
330			}
331			} # get_rdf_resource_html
332	wakaba	1.1
333			1;