whatpm/Whatpm/ContentChecker.pm

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

require Whatpm::URIChecker;

## ISSUE: How XML and XML Namespaces conformance can (or cannot)
## be applied to an in-memory representation (i.e. DOM)?

my $HTML_NS = q<http://www.w3.org/1999/xhtml>;
my $XML_NS = q<http://www.w3.org/XML/1998/namespace>;
my $XMLNS_NS = q<http://www.w3.org/2000/xmlns/>;

my $Namespace = {
  q<http://www.w3.org/2005/Atom> => {module => 'Whatpm::ContentChecker::Atom'},
  $HTML_NS => {module => 'Whatpm::ContentChecker::HTML'},
  $XML_NS => {loaded => 1},
  $XMLNS_NS => {loaded => 1},
};

our $AttrChecker = {
  $XML_NS => {
    space => sub {
      my ($self, $attr) = @_;
      my $value = $attr->value;
      if ($value eq 'default' or $value eq 'preserve') {
        #
      } else {
        ## NOTE: An XML "error"
        $self->{onerror}->(node => $attr, level => 'error',
                           type => 'invalid attribute value');
      }
    },
    lang => sub {
      my ($self, $attr) = @_;
      my $value = $attr->value;
      if ($value eq '') {
        #
      } else {
        require Whatpm::LangTag;
        Whatpm::LangTag->check_rfc3066_language_tag ($value, sub {
          my %opt = @_;
          my $type = 'LangTag:'.$opt{type};
          $type .= ':' . $opt{subtag} if defined $opt{subtag};
          $self->{onerror}->(node => $attr, type => $type,
                             value => $opt{value}, level => $opt{level});
        });
      }

      ## NOTE: "The values of the attribute are language identifiers
      ## as defined by [IETF RFC 3066], Tags for the Identification
      ## of Languages, or its successor; in addition, the empty string
      ## may be specified." ("may" in lower case)
      ## NOTE: Is an RFC 3066-valid (but RFC 4647-invalid) language tag
      ## allowed today?

      ## TODO: test data

      if ($attr->owner_document->manakai_is_html) { # MUST NOT
        $self->{onerror}->(node => $attr, type => 'in HTML:xml:lang');
## TODO: Test data...
      }
    },
    base => sub {
      my ($self, $attr) = @_;
      my $value = $attr->value;
      if ($value =~ /[^\x{0000}-\x{10FFFF}]/) { ## ISSUE: Should we disallow noncharacters?
        $self->{onerror}->(node => $attr,
                           type => 'invalid attribute value');
      }
      ## NOTE: Conformance to URI standard is not checked since there is
      ## no author requirement on conformance in the XML Base specification.
    },
    id => sub {
      my ($self, $attr) = @_;
      my $value = $attr->value;
      $value =~ s/[\x09\x0A\x0D\x20]+/ /g;
      $value =~ s/^\x20//;
      $value =~ s/\x20$//;
      ## TODO: NCName in XML 1.0 or 1.1
      ## TODO: declared type is ID?
      if ($self->{id}->{$value}) { ## NOTE: An xml:id error
        $self->{onerror}->(node => $attr, level => 'error', 
                           type => 'duplicate ID');
        push @{$self->{id}->{$value}}, $attr;
      } else {
        $self->{id}->{$value} = [$attr];
      }
    },
  },
  $XMLNS_NS => {
    '' => sub {
      my ($self, $attr) = @_;
      my $ln = $attr->manakai_local_name;
      my $value = $attr->value;
      if ($value eq $XML_NS and $ln ne 'xml') {
        $self->{onerror}
          ->(node => $attr, level => 'NC',
             type => 'Reserved Prefixes and Namespace Names:=xml');
      } elsif ($value eq $XMLNS_NS) {
        $self->{onerror}
          ->(node => $attr, level => 'NC',
             type => 'Reserved Prefixes and Namespace Names:=xmlns');
      }
      if ($ln eq 'xml' and $value ne $XML_NS) {
        $self->{onerror}
          ->(node => $attr, level => 'NC',
             type => 'Reserved Prefixes and Namespace Names:xmlns:xml=');
      } elsif ($ln eq 'xmlns') {
        $self->{onerror}
          ->(node => $attr, level => 'NC',
             type => 'Reserved Prefixes and Namespace Names:xmlns:xmlns=');
      }
      ## TODO: If XML 1.0 and empty
    },
    xmlns => sub {
      my ($self, $attr) = @_;
      ## TODO: In XML 1.0, URI reference [RFC 3986] or an empty string
      ## TODO: In XML 1.1, IRI reference [RFC 3987] or an empty string
      ## TODO: relative references are deprecated
      my $value = $attr->value;
      if ($value eq $XML_NS) {
        $self->{onerror}
          ->(node => $attr, level => 'NC',
             type => 'Reserved Prefixes and Namespace Names:=xml');
      } elsif ($value eq $XMLNS_NS) {
        $self->{onerror}
          ->(node => $attr, level => 'NC',
             type => 'Reserved Prefixes and Namespace Names:=xmlns');
      }
    },
  },
};

## ISSUE: Should we really allow these attributes?
$AttrChecker->{''}->{'xml:space'} = $AttrChecker->{$XML_NS}->{space};
$AttrChecker->{''}->{'xml:lang'} = $AttrChecker->{$XML_NS}->{lang};
$AttrChecker->{''}->{'xml:base'} = $AttrChecker->{$XML_NS}->{base};
$AttrChecker->{''}->{'xml:id'} = $AttrChecker->{$XML_NS}->{id};

## ANY
our $AnyChecker = sub {
  my ($self, $todo) = @_;
  my $el = $todo->{node};
  my $new_todos = [];
  my @nodes = (@{$el->child_nodes});
  while (@nodes) {
    my $node = shift @nodes;
    $self->_remove_minuses ($node) and next if ref $node eq 'HASH';

    my $nt = $node->node_type;
    if ($nt == 1) {
      my $node_ns = $node->namespace_uri;
      $node_ns = '' unless defined $node_ns;
      my $node_ln = $node->manakai_local_name;
      if ($self->{minuses}->{$node_ns}->{$node_ln}) {
        $self->{onerror}->(node => $node, type => 'element not allowed');
      }
      push @$new_todos, {type => 'element', node => $node};
    } elsif ($nt == 5) {
      unshift @nodes, @{$node->child_nodes};
    }
  }
  return ($new_todos);
}; # $AnyChecker

our $ElementDefault = {
  checker => sub {
    my ($self, $todo) = @_;
    $self->{onerror}->(node => $todo->{node}, level => 'unsupported',
                       type => 'element');
    return $AnyChecker->($self, $todo);
  },
  attrs_checker => sub {
    my ($self, $todo) = @_;
    for my $attr (@{$todo->{node}->attributes}) {
      my $attr_ns = $attr->namespace_uri;
      $attr_ns = '' unless defined $attr_ns;
      my $attr_ln = $attr->manakai_local_name;
      my $checker = $AttrChecker->{$attr_ns}->{$attr_ln}
        || $AttrChecker->{$attr_ns}->{''};
      if ($checker) {
        $checker->($self, $attr);
      } else {
        $self->{onerror}->(node => $attr, level => 'unsupported',
                           type => 'attribute');
      }
    }
  },
};

my $HTMLTransparentElements = {
  $HTML_NS => {qw/ins 1 font 1 noscript 1/},
  ## NOTE: |html:noscript| is transparent if scripting is disabled
  ## and not in |head|.
};

our $Element = {};

sub check_document ($$$) {
  my ($self, $doc, $onerror) = @_;
  $self = bless {}, $self unless ref $self;
  $self->{onerror} = $onerror;

  my $docel = $doc->document_element;
  unless (defined $docel) {
    ## ISSUE: Should we check content of Document node?
    $onerror->(node => $doc, type => 'no document element');
    ## ISSUE: Is this non-conforming (to what spec)?  Or just a warning?
    return {
            class => {},
            id => {}, table => [], term => {},
           };
  }

  ## ISSUE: Unexpanded entity references and HTML5 conformance
  
  my $docel_nsuri = $docel->namespace_uri;
  $docel_nsuri = '' unless defined $docel_nsuri;
  unless ($Namespace->{$docel_nsuri}->{loaded}) {
    if ($Namespace->{$docel_nsuri}->{module}) {
      eval qq{ require $Namespace->{$docel_nsuri}->{module} } or die $@;
    } else {
      $Namespace->{$docel_nsuri}->{loaded} = 1;
    }
  }
  my $docel_def = $Element->{$docel_nsuri}->{$docel->manakai_local_name} ||
    $Element->{$docel_nsuri}->{''} ||
    $ElementDefault;
  if ($docel_def->{is_root}) {
    #
  } else {
    $onerror->(node => $docel, type => 'element not allowed');
  }

  ## TODO: Check for other items other than document element
  ## (second (errorous) element, text nodes, PI nodes, doctype nodes)

  return $self->check_element ($docel, $onerror);
} # check_document

sub check_element ($$$) {
  my ($self, $el, $onerror) = @_;
  $self = bless {}, $self unless ref $self;
  $self->{onerror} = $onerror;

  $self->{minuses} = {};
  $self->{id} = {};
  $self->{term} = {};
  $self->{usemap} = [];
  $self->{contextmenu} = [];
  $self->{map} = {};
  $self->{menu} = {};
  $self->{has_link_type} = {};
  #$self->{has_uri_attr};
  #$self->{has_hyperlink_element};
  $self->{return} = {
    class => {},
    id => $self->{id}, table => [], term => $self->{term},
  };

  my @todo = ({type => 'element', node => $el});
  while (@todo) {
    my $todo = shift @todo;
    if ($todo->{type} eq 'element') {
      my $prefix = $todo->{node}->prefix;
      if (defined $prefix and $prefix eq 'xmlns') {
        $self->{onerror}
          ->(node => $todo->{node}, level => 'NC',
             type => 'Reserved Prefixes and Namespace Names:<xmlns:>');
      }
      my $nsuri = $todo->{node}->namespace_uri;
      $nsuri = '' unless defined $nsuri;
      unless ($Namespace->{$nsuri}->{loaded}) {
        if ($Namespace->{$nsuri}->{module}) {
          eval qq{ require $Namespace->{$nsuri}->{module} } or die $@;
        } else {
          $Namespace->{$nsuri}->{loaded} = 1;
        }
      }
      my $ln = $todo->{node}->manakai_local_name;
      my $eldef = $Element->{$nsuri}->{$ln} ||
        $Element->{$nsuri}->{''} ||
          $ElementDefault;
      $eldef->{attrs_checker}->($self, $todo);
      my ($new_todos) = $eldef->{checker}->($self, $todo);
      unshift @todo, @$new_todos;
    } elsif ($todo->{type} eq 'element-attributes') {
      my $prefix = $todo->{node}->prefix;
      if (defined $prefix and $prefix eq 'xmlns') {
        $self->{onerror}
          ->(node => $todo->{node}, level => 'NC',
             type => 'Reserved Prefixes and Namespace Names:<xmlns:>');
      }
      my $nsuri = $todo->{node}->namespace_uri;
      $nsuri = '' unless defined $nsuri;
      unless ($Namespace->{$nsuri}->{loaded}) {
        if ($Namespace->{$nsuri}->{module}) {
          eval qq{ require $Namespace->{$nsuri}->{module} } or die $@;
        } else {
          $Namespace->{$nsuri}->{loaded} = 1;
        }
      }
      my $ln = $todo->{node}->manakai_local_name;
      my $eldef = $Element->{$nsuri}->{$ln} ||
        $Element->{$nsuri}->{''} ||
          $ElementDefault;
      $eldef->{attrs_checker}->($self, $todo);
    } elsif ($todo->{type} eq 'plus') {
      $self->_remove_minuses ($todo);
    } elsif ($todo->{type} eq 'code') {
      $todo->{code}->();
    } else {
      die "$0: Internal error: Unsupported checking action type |$todo->{type}|";
    }
  }

  for (@{$self->{usemap}}) {
    unless ($self->{map}->{$_->[0]}) {
      $self->{onerror}->(node => $_->[1], type => 'no referenced map');
    }
  }

  for (@{$self->{contextmenu}}) {
    unless ($self->{menu}->{$_->[0]}) {
      $self->{onerror}->(node => $_->[1], type => 'no referenced menu');
    }
  }

  delete $self->{minuses};
  delete $self->{onerror};
  delete $self->{id};
  delete $self->{usemap};
  delete $self->{map};
  return $self->{return};
} # check_element

sub _add_minuses ($@) {
  my $self = shift;
  my $r = {};
  for my $list (@_) {
    for my $ns (keys %$list) {
      for my $ln (keys %{$list->{$ns}}) {
        unless ($self->{minuses}->{$ns}->{$ln}) {
          $self->{minuses}->{$ns}->{$ln} = 1;
          $r->{$ns}->{$ln} = 1;
        }
      }
    }
  }
  return {type => 'plus', list => $r};
} # _add_minuses

sub _remove_minuses ($$) {
  my ($self, $todo) = @_;
  for my $ns (keys %{$todo->{list}}) {
    for my $ln (keys %{$todo->{list}->{$ns}}) {
      delete $self->{minuses}->{$ns}->{$ln} if $todo->{list}->{$ns}->{$ln};
    }
  }
  1;
} # _remove_minuses

sub _check_get_children ($$$) {
  my ($self, $node, $parent_todo) = @_;
  my $new_todos = [];
  my $sib = [];
  TP: {
    my $node_ns = $node->namespace_uri;
    $node_ns = '' unless defined $node_ns;
    my $node_ln = $node->manakai_local_name;
    if ($HTMLTransparentElements->{$node_ns}->{$node_ln}) {
      if ($node_ns eq $HTML_NS and $node_ln eq 'noscript') {
        if ($parent_todo->{flag}->{in_head}) {
          #
        } else {
          my $end = $self->_add_minuses ({$HTML_NS, {noscript => 1}});
          push @$sib, $end;
          
          unshift @$sib, @{$node->child_nodes};
          push @$new_todos, {type => 'element-attributes', node => $node};
          last TP;
        }
      } else {
        unshift @$sib, @{$node->child_nodes};
        push @$new_todos, {type => 'element-attributes', node => $node};
        last TP;
      }
    }
    if ($node_ns eq $HTML_NS and ($node_ln eq 'video' or $node_ln eq 'audio')) {
      if ($node->has_attribute_ns (undef, 'src')) {
        unshift @$sib, @{$node->child_nodes};
        push @$new_todos, {type => 'element-attributes', node => $node};
        last TP;
      } else {
        my @cn = @{$node->child_nodes};
        CN: while (@cn) {
          my $cn = shift @cn;
          my $cnt = $cn->node_type;
          if ($cnt == 1) {
            my $cn_nsuri = $cn->namespace_uri;
            $cn_nsuri = '' unless defined $cn_nsuri;
            if ($cn_nsuri eq $HTML_NS and $cn->manakai_local_name eq 'source') {
              #
            } else {
              last CN;
            }
          } elsif ($cnt == 3 or $cnt == 4) {
            if ($cn->data =~ /[^\x09-\x0D\x20]/) {
              last CN;
            }
          }
        } # CN
        unshift @$sib, @cn;
      }
    }
    push @$new_todos, {type => 'element', node => $node};
  } # TP
  
  for my $new_todo (@$new_todos) {
    $new_todo->{flag} = {%{$parent_todo->{flag} or {}}};
  }
  
  return ($sib, $new_todos);
} # _check_get_children

=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

1;
# $Date: 2007/08/17 11:53:52 $
1	package Whatpm::ContentChecker;
2	use strict;
3	our $VERSION=do{my @r=(q$Revision: 1.46 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
4
5	require Whatpm::URIChecker;
6
7	## ISSUE: How XML and XML Namespaces conformance can (or cannot)
8	## be applied to an in-memory representation (i.e. DOM)?
9
10	my $HTML_NS = q<http://www.w3.org/1999/xhtml>;
11	my $XML_NS = q<http://www.w3.org/XML/1998/namespace>;
12	my $XMLNS_NS = q<http://www.w3.org/2000/xmlns/>;
13
14	my $Namespace = {
15	q<http://www.w3.org/2005/Atom> => {module => 'Whatpm::ContentChecker::Atom'},
16	$HTML_NS => {module => 'Whatpm::ContentChecker::HTML'},
17	$XML_NS => {loaded => 1},
18	$XMLNS_NS => {loaded => 1},
19	};
20
21	our $AttrChecker = {
22	$XML_NS => {
23	space => sub {
24	my ($self, $attr) = @_;
25	my $value = $attr->value;
26	if ($value eq 'default' or $value eq 'preserve') {
27	#
28	} else {
29	## NOTE: An XML "error"
30	$self->{onerror}->(node => $attr, level => 'error',
31	type => 'invalid attribute value');
32	}
33	},
34	lang => sub {
35	my ($self, $attr) = @_;
36	my $value = $attr->value;
37	if ($value eq '') {
38	#
39	} else {
40	require Whatpm::LangTag;
41	Whatpm::LangTag->check_rfc3066_language_tag ($value, sub {
42	my %opt = @_;
43	my $type = 'LangTag:'.$opt{type};
44	$type .= ':' . $opt{subtag} if defined $opt{subtag};
45	$self->{onerror}->(node => $attr, type => $type,
46	value => $opt{value}, level => $opt{level});
47	});
48	}
49
50	## NOTE: "The values of the attribute are language identifiers
51	## as defined by [IETF RFC 3066], Tags for the Identification
52	## of Languages, or its successor; in addition, the empty string
53	## may be specified." ("may" in lower case)
54	## NOTE: Is an RFC 3066-valid (but RFC 4647-invalid) language tag
55	## allowed today?
56
57	## TODO: test data
58
59	if ($attr->owner_document->manakai_is_html) { # MUST NOT
60	$self->{onerror}->(node => $attr, type => 'in HTML:xml:lang');
61	## TODO: Test data...
62	}
63	},
64	base => sub {
65	my ($self, $attr) = @_;
66	my $value = $attr->value;
67	if ($value =~ /[^\x{0000}-\x{10FFFF}]/) { ## ISSUE: Should we disallow noncharacters?
68	$self->{onerror}->(node => $attr,
69	type => 'invalid attribute value');
70	}
71	## NOTE: Conformance to URI standard is not checked since there is
72	## no author requirement on conformance in the XML Base specification.
73	},
74	id => sub {
75	my ($self, $attr) = @_;
76	my $value = $attr->value;
77	$value =~ s/[\x09\x0A\x0D\x20]+/ /g;
78	$value =~ s/^\x20//;
79	$value =~ s/\x20$//;
80	## TODO: NCName in XML 1.0 or 1.1
81	## TODO: declared type is ID?
82	if ($self->{id}->{$value}) { ## NOTE: An xml:id error
83	$self->{onerror}->(node => $attr, level => 'error',
84	type => 'duplicate ID');
85	push @{$self->{id}->{$value}}, $attr;
86	} else {
87	$self->{id}->{$value} = [$attr];
88	}
89	},
90	},
91	$XMLNS_NS => {
92	'' => sub {
93	my ($self, $attr) = @_;
94	my $ln = $attr->manakai_local_name;
95	my $value = $attr->value;
96	if ($value eq $XML_NS and $ln ne 'xml') {
97	$self->{onerror}
98	->(node => $attr, level => 'NC',
99	type => 'Reserved Prefixes and Namespace Names:=xml');
100	} elsif ($value eq $XMLNS_NS) {
101	$self->{onerror}
102	->(node => $attr, level => 'NC',
103	type => 'Reserved Prefixes and Namespace Names:=xmlns');
104	}
105	if ($ln eq 'xml' and $value ne $XML_NS) {
106	$self->{onerror}
107	->(node => $attr, level => 'NC',
108	type => 'Reserved Prefixes and Namespace Names:xmlns:xml=');
109	} elsif ($ln eq 'xmlns') {
110	$self->{onerror}
111	->(node => $attr, level => 'NC',
112	type => 'Reserved Prefixes and Namespace Names:xmlns:xmlns=');
113	}
114	## TODO: If XML 1.0 and empty
115	},
116	xmlns => sub {
117	my ($self, $attr) = @_;
118	## TODO: In XML 1.0, URI reference [RFC 3986] or an empty string
119	## TODO: In XML 1.1, IRI reference [RFC 3987] or an empty string
120	## TODO: relative references are deprecated
121	my $value = $attr->value;
122	if ($value eq $XML_NS) {
123	$self->{onerror}
124	->(node => $attr, level => 'NC',
125	type => 'Reserved Prefixes and Namespace Names:=xml');
126	} elsif ($value eq $XMLNS_NS) {
127	$self->{onerror}
128	->(node => $attr, level => 'NC',
129	type => 'Reserved Prefixes and Namespace Names:=xmlns');
130	}
131	},
132	},
133	};
134
135	## ISSUE: Should we really allow these attributes?
136	$AttrChecker->{''}->{'xml:space'} = $AttrChecker->{$XML_NS}->{space};
137	$AttrChecker->{''}->{'xml:lang'} = $AttrChecker->{$XML_NS}->{lang};
138	$AttrChecker->{''}->{'xml:base'} = $AttrChecker->{$XML_NS}->{base};
139	$AttrChecker->{''}->{'xml:id'} = $AttrChecker->{$XML_NS}->{id};
140
141	## ANY
142	our $AnyChecker = sub {
143	my ($self, $todo) = @_;
144	my $el = $todo->{node};
145	my $new_todos = [];
146	my @nodes = (@{$el->child_nodes});
147	while (@nodes) {
148	my $node = shift @nodes;
149	$self->_remove_minuses ($node) and next if ref $node eq 'HASH';
150
151	my $nt = $node->node_type;
152	if ($nt == 1) {
153	my $node_ns = $node->namespace_uri;
154	$node_ns = '' unless defined $node_ns;
155	my $node_ln = $node->manakai_local_name;
156	if ($self->{minuses}->{$node_ns}->{$node_ln}) {
157	$self->{onerror}->(node => $node, type => 'element not allowed');
158	}
159	push @$new_todos, {type => 'element', node => $node};
160	} elsif ($nt == 5) {
161	unshift @nodes, @{$node->child_nodes};
162	}
163	}
164	return ($new_todos);
165	}; # $AnyChecker
166
167	our $ElementDefault = {
168	checker => sub {
169	my ($self, $todo) = @_;
170	$self->{onerror}->(node => $todo->{node}, level => 'unsupported',
171	type => 'element');
172	return $AnyChecker->($self, $todo);
173	},
174	attrs_checker => sub {
175	my ($self, $todo) = @_;
176	for my $attr (@{$todo->{node}->attributes}) {
177	my $attr_ns = $attr->namespace_uri;
178	$attr_ns = '' unless defined $attr_ns;
179	my $attr_ln = $attr->manakai_local_name;
180	my $checker = $AttrChecker->{$attr_ns}->{$attr_ln}
181	\|\| $AttrChecker->{$attr_ns}->{''};
182	if ($checker) {
183	$checker->($self, $attr);
184	} else {
185	$self->{onerror}->(node => $attr, level => 'unsupported',
186	type => 'attribute');
187	}
188	}
189	},
190	};
191
192	my $HTMLTransparentElements = {
193	$HTML_NS => {qw/ins 1 font 1 noscript 1/},
194	## NOTE: \|html:noscript\| is transparent if scripting is disabled
195	## and not in \|head\|.
196	};
197
198	our $Element = {};
199
200	sub check_document ($$$) {
201	my ($self, $doc, $onerror) = @_;
202	$self = bless {}, $self unless ref $self;
203	$self->{onerror} = $onerror;
204
205	my $docel = $doc->document_element;
206	unless (defined $docel) {
207	## ISSUE: Should we check content of Document node?
208	$onerror->(node => $doc, type => 'no document element');
209	## ISSUE: Is this non-conforming (to what spec)? Or just a warning?
210	return {
211	class => {},
212	id => {}, table => [], term => {},
213	};
214	}
215
216	## ISSUE: Unexpanded entity references and HTML5 conformance
217
218	my $docel_nsuri = $docel->namespace_uri;
219	$docel_nsuri = '' unless defined $docel_nsuri;
220	unless ($Namespace->{$docel_nsuri}->{loaded}) {
221	if ($Namespace->{$docel_nsuri}->{module}) {
222	eval qq{ require $Namespace->{$docel_nsuri}->{module} } or die $@;
223	} else {
224	$Namespace->{$docel_nsuri}->{loaded} = 1;
225	}
226	}
227	my $docel_def = $Element->{$docel_nsuri}->{$docel->manakai_local_name} \|\|
228	$Element->{$docel_nsuri}->{''} \|\|
229	$ElementDefault;
230	if ($docel_def->{is_root}) {
231	#
232	} else {
233	$onerror->(node => $docel, type => 'element not allowed');
234	}
235
236	## TODO: Check for other items other than document element
237	## (second (errorous) element, text nodes, PI nodes, doctype nodes)
238
239	return $self->check_element ($docel, $onerror);
240	} # check_document
241
242	sub check_element ($$$) {
243	my ($self, $el, $onerror) = @_;
244	$self = bless {}, $self unless ref $self;
245	$self->{onerror} = $onerror;
246
247	$self->{minuses} = {};
248	$self->{id} = {};
249	$self->{term} = {};
250	$self->{usemap} = [];
251	$self->{contextmenu} = [];
252	$self->{map} = {};
253	$self->{menu} = {};
254	$self->{has_link_type} = {};
255	#$self->{has_uri_attr};
256	#$self->{has_hyperlink_element};
257	$self->{return} = {
258	class => {},
259	id => $self->{id}, table => [], term => $self->{term},
260	};
261
262	my @todo = ({type => 'element', node => $el});
263	while (@todo) {
264	my $todo = shift @todo;
265	if ($todo->{type} eq 'element') {
266	my $prefix = $todo->{node}->prefix;
267	if (defined $prefix and $prefix eq 'xmlns') {
268	$self->{onerror}
269	->(node => $todo->{node}, level => 'NC',
270	type => 'Reserved Prefixes and Namespace Names:<xmlns:>');
271	}
272	my $nsuri = $todo->{node}->namespace_uri;
273	$nsuri = '' unless defined $nsuri;
274	unless ($Namespace->{$nsuri}->{loaded}) {
275	if ($Namespace->{$nsuri}->{module}) {
276	eval qq{ require $Namespace->{$nsuri}->{module} } or die $@;
277	} else {
278	$Namespace->{$nsuri}->{loaded} = 1;
279	}
280	}
281	my $ln = $todo->{node}->manakai_local_name;
282	my $eldef = $Element->{$nsuri}->{$ln} \|\|
283	$Element->{$nsuri}->{''} \|\|
284	$ElementDefault;
285	$eldef->{attrs_checker}->($self, $todo);
286	my ($new_todos) = $eldef->{checker}->($self, $todo);
287	unshift @todo, @$new_todos;
288	} elsif ($todo->{type} eq 'element-attributes') {
289	my $prefix = $todo->{node}->prefix;
290	if (defined $prefix and $prefix eq 'xmlns') {
291	$self->{onerror}
292	->(node => $todo->{node}, level => 'NC',
293	type => 'Reserved Prefixes and Namespace Names:<xmlns:>');
294	}
295	my $nsuri = $todo->{node}->namespace_uri;
296	$nsuri = '' unless defined $nsuri;
297	unless ($Namespace->{$nsuri}->{loaded}) {
298	if ($Namespace->{$nsuri}->{module}) {
299	eval qq{ require $Namespace->{$nsuri}->{module} } or die $@;
300	} else {
301	$Namespace->{$nsuri}->{loaded} = 1;
302	}
303	}
304	my $ln = $todo->{node}->manakai_local_name;
305	my $eldef = $Element->{$nsuri}->{$ln} \|\|
306	$Element->{$nsuri}->{''} \|\|
307	$ElementDefault;
308	$eldef->{attrs_checker}->($self, $todo);
309	} elsif ($todo->{type} eq 'plus') {
310	$self->_remove_minuses ($todo);
311	} elsif ($todo->{type} eq 'code') {
312	$todo->{code}->();
313	} else {
314	die "$0: Internal error: Unsupported checking action type \|$todo->{type}\|";
315	}
316	}
317
318	for (@{$self->{usemap}}) {
319	unless ($self->{map}->{$_->[0]}) {
320	$self->{onerror}->(node => $_->[1], type => 'no referenced map');
321	}
322	}
323
324	for (@{$self->{contextmenu}}) {
325	unless ($self->{menu}->{$_->[0]}) {
326	$self->{onerror}->(node => $_->[1], type => 'no referenced menu');
327	}
328	}
329
330	delete $self->{minuses};
331	delete $self->{onerror};
332	delete $self->{id};
333	delete $self->{usemap};
334	delete $self->{map};
335	return $self->{return};
336	} # check_element
337
338	sub _add_minuses ($@) {
339	my $self = shift;
340	my $r = {};
341	for my $list (@_) {
342	for my $ns (keys %$list) {
343	for my $ln (keys %{$list->{$ns}}) {
344	unless ($self->{minuses}->{$ns}->{$ln}) {
345	$self->{minuses}->{$ns}->{$ln} = 1;
346	$r->{$ns}->{$ln} = 1;
347	}
348	}
349	}
350	}
351	return {type => 'plus', list => $r};
352	} # _add_minuses
353
354	sub _remove_minuses ($$) {
355	my ($self, $todo) = @_;
356	for my $ns (keys %{$todo->{list}}) {
357	for my $ln (keys %{$todo->{list}->{$ns}}) {
358	delete $self->{minuses}->{$ns}->{$ln} if $todo->{list}->{$ns}->{$ln};
359	}
360	}
361	1;
362	} # _remove_minuses
363
364	sub _check_get_children ($$$) {
365	my ($self, $node, $parent_todo) = @_;
366	my $new_todos = [];
367	my $sib = [];
368	TP: {
369	my $node_ns = $node->namespace_uri;
370	$node_ns = '' unless defined $node_ns;
371	my $node_ln = $node->manakai_local_name;
372	if ($HTMLTransparentElements->{$node_ns}->{$node_ln}) {
373	if ($node_ns eq $HTML_NS and $node_ln eq 'noscript') {
374	if ($parent_todo->{flag}->{in_head}) {
375	#
376	} else {
377	my $end = $self->_add_minuses ({$HTML_NS, {noscript => 1}});
378	push @$sib, $end;
379
380	unshift @$sib, @{$node->child_nodes};
381	push @$new_todos, {type => 'element-attributes', node => $node};
382	last TP;
383	}
384	} else {
385	unshift @$sib, @{$node->child_nodes};
386	push @$new_todos, {type => 'element-attributes', node => $node};
387	last TP;
388	}
389	}
390	if ($node_ns eq $HTML_NS and ($node_ln eq 'video' or $node_ln eq 'audio')) {
391	if ($node->has_attribute_ns (undef, 'src')) {
392	unshift @$sib, @{$node->child_nodes};
393	push @$new_todos, {type => 'element-attributes', node => $node};
394	last TP;
395	} else {
396	my @cn = @{$node->child_nodes};
397	CN: while (@cn) {
398	my $cn = shift @cn;
399	my $cnt = $cn->node_type;
400	if ($cnt == 1) {
401	my $cn_nsuri = $cn->namespace_uri;
402	$cn_nsuri = '' unless defined $cn_nsuri;
403	if ($cn_nsuri eq $HTML_NS and $cn->manakai_local_name eq 'source') {
404	#
405	} else {
406	last CN;
407	}
408	} elsif ($cnt == 3 or $cnt == 4) {
409	if ($cn->data =~ /[^\x09-\x0D\x20]/) {
410	last CN;
411	}
412	}
413	} # CN
414	unshift @$sib, @cn;
415	}
416	}
417	push @$new_todos, {type => 'element', node => $node};
418	} # TP
419
420	for my $new_todo (@$new_todos) {
421	$new_todo->{flag} = {%{$parent_todo->{flag} or {}}};
422	}
423
424	return ($sib, $new_todos);
425	} # _check_get_children
426
427	=head1 LICENSE
428
429	Copyright 2007 Wakaba <w@suika.fam.cx>
430
431	This library is free software; you can redistribute it
432	and/or modify it under the same terms as Perl itself.
433
434	=cut
435
436	1;
437	# $Date: 2007/08/17 11:53:52 $