whatpm/Whatpm/ContentChecker.pm

package Whatpm::ContentChecker;
use strict;

require Whatpm::URIChecker;

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

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

my $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,
                           type => 'XML error:invalid xml:space value');
      }
    },
    lang => sub {
      ## 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)
      ## TODO: xml:lang MUST NOT in HTML document
    },
    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 => 'syntax error');
      }
      ## 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}) {
        $self->{onerror}->(node => $attr, type => 'xml:id error:duplicate ID');
      } else {
        $self->{id}->{$value} = 1;
      }
    },
  },
  $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,
             type => 'NC:Reserved Prefixes and Namespace Names:=xml');
      } elsif ($value eq $XMLNS_NS) {
        $self->{onerror}
          ->(node => $attr,
             type => 'NC:Reserved Prefixes and Namespace Names:=xmlns');
      }
      if ($ln eq 'xml' and $value ne $XML_NS) {
        $self->{onerror}
          ->(node => $attr,
             type => 'NC:Reserved Prefixes and Namespace Names:xmlns:xml=');
      } elsif ($ln eq 'xmlns') {
        $self->{onerror}
          ->(node => $attr,
             type => 'NC: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,
             type => 'NC:Reserved Prefixes and Namespace Names:=xml');
      } elsif ($value eq $XMLNS_NS) {
        $self->{onerror}
          ->(node => $attr,
             type => 'NC: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
my $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

my $ElementDefault = {
  checker => sub {
    my ($self, $todo) = @_;
    $self->{onerror}->(node => $todo->{node}, type => 'element not supported');
    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, type => 'attribute not supported');
      }
    }
  },
};

my $Element = {};

my $HTML_NS = q<http://www.w3.org/1999/xhtml>;

my $HTMLMetadataElements = {
  $HTML_NS => {
    qw/link 1 meta 1 style 1 script 1 event-source 1 command 1 base 1 title 1/,
  },
};

my $HTMLSectioningElements = {
  $HTML_NS => {qw/body 1 section 1 nav 1 article 1 blockquote 1 aside 1/},
};

my $HTMLBlockLevelElements = {
  $HTML_NS => {
    qw/
      section 1 nav 1 article 1 blockquote 1 aside 1 
      h1 1 h2 1 h3 1 h4 1 h5 1 h6 1 header 1 footer 1
      address 1 p 1 hr 1 dialog 1 pre 1 ol 1 ul 1 dl 1
      ins 1 del 1 figure 1 map 1 table 1 script 1 noscript 1
      event-source 1 details 1 datagrid 1 menu 1 div 1 font 1
    /,
  },
};

my $HTMLStrictlyInlineLevelElements = {
  $HTML_NS => {
    qw/
      br 1 a 1 q 1 cite 1 em 1 strong 1 small 1 m 1 dfn 1 abbr 1
      time 1 meter 1 progress 1 code 1 var 1 samp 1 kbd 1
      sub 1 sup 1 span 1 i 1 b 1 bdo 1 ins 1 del 1 img 1
      iframe 1 embed 1 object 1 video 1 audio 1 canvas 1 area 1
      script 1 noscript 1 event-source 1 command 1 font 1
    /,
  },
};

my $HTMLStructuredInlineLevelElements = {
  $HTML_NS => {qw/blockquote 1 pre 1 ol 1 ul 1 dl 1 table 1 menu 1/},
};

my $HTMLInteractiveElements = {
  $HTML_NS => {a => 1, details => 1, datagrid => 1},
};
## NOTE: |html:a| and |html:datagrid| are not allowed as a descendant
## of interactive elements

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

#my $HTMLSemiTransparentElements = {
#  $HTML_NS => {qw/video 1 audio 1/},
#};

my $HTMLEmbededElements = {
  $HTML_NS => {qw/img 1 iframe 1 embed 1 object 1 video 1 audio 1 canvas 1/},
};

## Empty
my $HTMLEmptyChecker = 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) {
      ## NOTE: |minuses| list is not checked since redundant
      $self->{onerror}->(node => $node, type => 'element not allowed');
      my ($sib, $ch) = $self->_check_get_children ($node);
      unshift @nodes, @$sib;
      push @$new_todos, @$ch;
    } elsif ($nt == 3 or $nt == 4) {
      if ($node->data =~ /[^\x09-\x0D\x20]/) {
        $self->{onerror}->(node => $node, type => 'character not allowed');
      }
    } elsif ($nt == 5) {
      unshift @nodes, @{$node->child_nodes};
    }
  }
  return ($new_todos);
};

## Text
my $HTMLTextChecker = 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) {
      ## NOTE: |minuses| list is not checked since redundant
      $self->{onerror}->(node => $node, type => 'element not allowed');
      my ($sib, $ch) = $self->_check_get_children ($node);
      unshift @nodes, @$sib;
      push @$new_todos, @$ch;
    } elsif ($nt == 5) {
      unshift @nodes, @{$node->child_nodes};
    }
  }
  return ($new_todos);
};

## Zero or more |html:style| elements,
## followed by zero or more block-level elements
my $HTMLStylableBlockChecker = sub {
  my ($self, $todo) = @_;
  my $el = $todo->{node};
  my $new_todos = [];
  my @nodes = (@{$el->child_nodes});
  
  my $has_non_style;
  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;
      my $not_allowed = $self->{minuses}->{$node_ns}->{$node_ln};
      if ($node_ns eq $HTML_NS and $node_ln eq 'style') {
        $not_allowed = 1 if $has_non_style;
      } elsif ($HTMLBlockLevelElements->{$node_ns}->{$node_ln}) {
        $has_non_style = 1;
      } else {
        $has_non_style = 1;
        $not_allowed = 1;
      }
      $self->{onerror}->(node => $node, type => 'element not allowed')
        if $not_allowed;
      my ($sib, $ch) = $self->_check_get_children ($node);
      unshift @nodes, @$sib;
      push @$new_todos, @$ch;
    } elsif ($nt == 3 or $nt == 4) {
      if ($node->data =~ /[^\x09-\x0D\x20]/) {
        $self->{onerror}->(node => $node, type => 'character not allowed');
      }
    } elsif ($nt == 5) {
      unshift @nodes, @{$node->child_nodes};
    }
  }
  return ($new_todos);
}; # $HTMLStylableBlockChecker

## Zero or more block-level elements
my $HTMLBlockChecker = 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;
      my $not_allowed = $self->{minuses}->{$node_ns}->{$node_ln};
      $not_allowed = 1
        unless $HTMLBlockLevelElements->{$node_ns}->{$node_ln};
      $self->{onerror}->(node => $node, type => 'element not allowed')
        if $not_allowed;
      my ($sib, $ch) = $self->_check_get_children ($node);
      unshift @nodes, @$sib;
      push @$new_todos, @$ch;
    } elsif ($nt == 3 or $nt == 4) {
      if ($node->data =~ /[^\x09-\x0D\x20]/) {
        $self->{onerror}->(node => $node, type => 'character not allowed');
      }
    } elsif ($nt == 5) {
      unshift @nodes, @{$node->child_nodes};
    }
  }
  return ($new_todos);
}; # $HTMLBlockChecker

## Inline-level content
my $HTMLInlineChecker = 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;
      my $not_allowed = $self->{minuses}->{$node_ns}->{$node_ln};
      $not_allowed = 1
        unless $HTMLStrictlyInlineLevelElements->{$node_ns}->{$node_ln} or
          $HTMLStructuredInlineLevelElements->{$node_ns}->{$node_ln};
      $self->{onerror}->(node => $node, type => 'element not allowed')
        if $not_allowed;
      my ($sib, $ch) = $self->_check_get_children ($node);
      unshift @nodes, @$sib;
      push @$new_todos, @$ch;
    } elsif ($nt == 5) {
      unshift @nodes, @{$node->child_nodes};
    }
  }

  for (@$new_todos) {
    $_->{inline} = 1;
  }
  return ($new_todos);
}; # $HTMLInlineChecker

my $HTMLSignificantInlineChecker = $HTMLInlineChecker;
## TODO: check significant content

## Strictly inline-level content
my $HTMLStrictlyInlineChecker = 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;
      my $not_allowed = $self->{minuses}->{$node_ns}->{$node_ln};
      $not_allowed = 1
        unless $HTMLStrictlyInlineLevelElements->{$node_ns}->{$node_ln};
      $self->{onerror}->(node => $node, type => 'element not allowed')
        if $not_allowed;
      my ($sib, $ch) = $self->_check_get_children ($node);
      unshift @nodes, @$sib;
      push @$new_todos, @$ch;
    } elsif ($nt == 5) {
      unshift @nodes, @{$node->child_nodes};
    }
  }

  for (@$new_todos) {
    $_->{inline} = 1;
    $_->{strictly_inline} = 1;
  }
  return ($new_todos);
}; # $HTMLStrictlyInlineChecker

my $HTMLSignificantStrictlyInlineChecker = $HTMLStrictlyInlineChecker;
## TODO: check significant content

## Inline-level or strictly inline-kevek content
my $HTMLInlineOrStrictlyInlineChecker = 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;
      my $not_allowed = $self->{minuses}->{$node_ns}->{$node_ln};
      if ($todo->{strictly_inline}) {
        $not_allowed = 1
          unless $HTMLStrictlyInlineLevelElements->{$node_ns}->{$node_ln};
      } else {
        $not_allowed = 1
          unless $HTMLStrictlyInlineLevelElements->{$node_ns}->{$node_ln} or
            $HTMLStructuredInlineLevelElements->{$node_ns}->{$node_ln};
      }
      $self->{onerror}->(node => $node, type => 'element not allowed')
        if $not_allowed;
      my ($sib, $ch) = $self->_check_get_children ($node);
      unshift @nodes, @$sib;
      push @$new_todos, @$ch;
    } elsif ($nt == 5) {
      unshift @nodes, @{$node->child_nodes};
    }
  }

  for (@$new_todos) {
    $_->{inline} = 1;
    $_->{strictly_inline} = 1;
  }
  return ($new_todos);
}; # $HTMLInlineOrStrictlyInlineChecker

my $HTMLSignificantInlineOrStrictlyInlineChecker
    = $HTMLInlineOrStrictlyInlineChecker;
## TODO: check significant content

my $HTMLBlockOrInlineChecker = sub {
  my ($self, $todo) = @_;
  my $el = $todo->{node};
  my $new_todos = [];
  my @nodes = (@{$el->child_nodes});
  
  my $content = 'block-or-inline'; # or 'block' or 'inline'
  my @block_not_inline;
  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;
      my $not_allowed = $self->{minuses}->{$node_ns}->{$node_ln};
      if ($content eq 'block') {
        $not_allowed = 1
          unless $HTMLBlockLevelElements->{$node_ns}->{$node_ln};
      } elsif ($content eq 'inline') {
        $not_allowed = 1
          unless $HTMLStrictlyInlineLevelElements->{$node_ns}->{$node_ln} or
            $HTMLStructuredInlineLevelElements->{$node_ns}->{$node_ln};
      } else {
        my $is_block = $HTMLBlockLevelElements->{$node_ns}->{$node_ln};
        my $is_inline
          = $HTMLStrictlyInlineLevelElements->{$node_ns}->{$node_ln} ||
            $HTMLStructuredInlineLevelElements->{$node_ns}->{$node_ln};
        
        push @block_not_inline, $node
          if $is_block and not $is_inline and not $not_allowed;
        unless ($is_block) {
          $content = 'inline';
          for (@block_not_inline) {
            $self->{onerror}->(node => $_, type => 'element not allowed');
          }
          $not_allowed = 1 unless $is_inline;
        }
      }
      $self->{onerror}->(node => $node, type => 'element not allowed')
        if $not_allowed;
      my ($sib, $ch) = $self->_check_get_children ($node);
      unshift @nodes, @$sib;
      push @$new_todos, @$ch;
    } elsif ($nt == 3 or $nt == 4) {
      if ($node->data =~ /[^\x09-\x0D\x20]/) {
        if ($content eq 'block') {
          $self->{onerror}->(node => $node, type => 'character not allowed');
        } else {
          $content = 'inline';
          for (@block_not_inline) {
            $self->{onerror}->(node => $_, type => 'element not allowed');
          }
        }
      }
    } elsif ($nt == 5) {
      unshift @nodes, @{$node->child_nodes};
    }
  }

  if ($content eq 'inline') {
    for (@$new_todos) {
      $_->{inline} = 1;
    }
  }
  return ($new_todos);
};

## Zero or more XXX element, then either block-level or inline-level
my $GetHTMLZeroOrMoreThenBlockOrInlineChecker = sub ($$) {
  my ($elnsuri, $ellname) = @_;
  return sub {
    my ($self, $todo) = @_;
    my $el = $todo->{node};
    my $new_todos = [];
    my @nodes = (@{$el->child_nodes});
    
    my $has_non_style;
    my $content = 'block-or-inline'; # or 'block' or 'inline'
    my @block_not_inline;
    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;
        my $not_allowed = $self->{minuses}->{$node_ns}->{$node_ln};
        if ($node_ns eq $elnsuri and $node_ln eq $ellname) {
          $not_allowed = 1 if $has_non_style;
        } elsif ($content eq 'block') {
          $has_non_style = 1;
          $not_allowed = 1
            unless $HTMLBlockLevelElements->{$node_ns}->{$node_ln};
        } elsif ($content eq 'inline') {
          $has_non_style = 1;
          $not_allowed = 1
            unless $HTMLStrictlyInlineLevelElements->{$node_ns}->{$node_ln} or
              $HTMLStructuredInlineLevelElements->{$node_ns}->{$node_ln};
        } else {
          $has_non_style = 1;
          my $is_block = $HTMLBlockLevelElements->{$node_ns}->{$node_ln};
          my $is_inline
            = $HTMLStrictlyInlineLevelElements->{$node_ns}->
1	wakaba	1.1	package Whatpm::ContentChecker;
2			use strict;
3
4	wakaba	1.18	require Whatpm::URIChecker;
5
6	wakaba	1.13	## ISSUE: How XML and XML Namespaces conformance can (or cannot)
7			## be applied to an in-memory representation (i.e. DOM)?
8
9	wakaba	1.9	my $XML_NS = q<http://www.w3.org/XML/1998/namespace>;
10			my $XMLNS_NS = q<http://www.w3.org/2000/xmlns/>;
11
12			my $AttrChecker = {
13			$XML_NS => {
14	wakaba	1.13	space => sub {
15			my ($self, $attr) = @_;
16			my $value = $attr->value;
17			if ($value eq 'default' or $value eq 'preserve') {
18			#
19			} else {
20			## NOTE: An XML "error"
21			$self->{onerror}->(node => $attr,
22			type => 'XML error:invalid xml:space value');
23			}
24			},
25			lang => sub {
26			## NOTE: "The values of the attribute are language identifiers
27			## as defined by [IETF RFC 3066], Tags for the Identification
28			## of Languages, or its successor; in addition, the empty string
29			## may be specified." ("may" in lower case)
30			## TODO: xml:lang MUST NOT in HTML document
31			},
32			base => sub {
33			my ($self, $attr) = @_;
34			my $value = $attr->value;
35			if ($value =~ /[^\x{0000}-\x{10FFFF}]/) { ## ISSUE: Should we disallow noncharacters?
36			$self->{onerror}->(node => $attr,
37			type => 'syntax error');
38			}
39	wakaba	1.18	## NOTE: Conformance to URI standard is not checked since there is
40			## no author requirement on conformance in the XML Base specification.
41	wakaba	1.13	},
42			id => sub {
43			my ($self, $attr) = @_;
44			my $value = $attr->value;
45			$value =~ s/[\x09\x0A\x0D\x20]+/ /g;
46			$value =~ s/^\x20//;
47			$value =~ s/\x20$//;
48			## TODO: NCName in XML 1.0 or 1.1
49			## TODO: declared type is ID?
50			if ($self->{id}->{$value}) {
51			$self->{onerror}->(node => $attr, type => 'xml:id error:duplicate ID');
52			} else {
53			$self->{id}->{$value} = 1;
54			}
55			},
56	wakaba	1.9	},
57			$XMLNS_NS => {
58	wakaba	1.13	'' => sub {
59			my ($self, $attr) = @_;
60			my $ln = $attr->manakai_local_name;
61			my $value = $attr->value;
62			if ($value eq $XML_NS and $ln ne 'xml') {
63			$self->{onerror}
64			->(node => $attr,
65			type => 'NC:Reserved Prefixes and Namespace Names:=xml');
66			} elsif ($value eq $XMLNS_NS) {
67			$self->{onerror}
68			->(node => $attr,
69			type => 'NC:Reserved Prefixes and Namespace Names:=xmlns');
70			}
71			if ($ln eq 'xml' and $value ne $XML_NS) {
72			$self->{onerror}
73			->(node => $attr,
74			type => 'NC:Reserved Prefixes and Namespace Names:xmlns:xml=');
75			} elsif ($ln eq 'xmlns') {
76			$self->{onerror}
77			->(node => $attr,
78			type => 'NC:Reserved Prefixes and Namespace Names:xmlns:xmlns=');
79			}
80			## TODO: If XML 1.0 and empty
81			},
82			xmlns => sub {
83			my ($self, $attr) = @_;
84			## TODO: In XML 1.0, URI reference [RFC 3986] or an empty string
85			## TODO: In XML 1.1, IRI reference [RFC 3987] or an empty string
86	wakaba	1.18	## TODO: relative references are deprecated
87	wakaba	1.13	my $value = $attr->value;
88			if ($value eq $XML_NS) {
89			$self->{onerror}
90			->(node => $attr,
91			type => 'NC:Reserved Prefixes and Namespace Names:=xml');
92			} elsif ($value eq $XMLNS_NS) {
93			$self->{onerror}
94			->(node => $attr,
95			type => 'NC:Reserved Prefixes and Namespace Names:=xmlns');
96			}
97			},
98	wakaba	1.9	},
99			};
100
101	wakaba	1.14	## ISSUE: Should we really allow these attributes?
102	wakaba	1.13	$AttrChecker->{''}->{'xml:space'} = $AttrChecker->{$XML_NS}->{space};
103			$AttrChecker->{''}->{'xml:lang'} = $AttrChecker->{$XML_NS}->{lang};
104			$AttrChecker->{''}->{'xml:base'} = $AttrChecker->{$XML_NS}->{base};
105			$AttrChecker->{''}->{'xml:id'} = $AttrChecker->{$XML_NS}->{id};
106
107	wakaba	1.3	## ANY
108			my $AnyChecker = sub {
109	wakaba	1.4	my ($self, $todo) = @_;
110			my $el = $todo->{node};
111			my $new_todos = [];
112	wakaba	1.3	my @nodes = (@{$el->child_nodes});
113			while (@nodes) {
114			my $node = shift @nodes;
115			$self->_remove_minuses ($node) and next if ref $node eq 'HASH';
116
117			my $nt = $node->node_type;
118			if ($nt == 1) {
119			my $node_ns = $node->namespace_uri;
120			$node_ns = '' unless defined $node_ns;
121			my $node_ln = $node->manakai_local_name;
122			if ($self->{minuses}->{$node_ns}->{$node_ln}) {
123			$self->{onerror}->(node => $node, type => 'element not allowed');
124			}
125	wakaba	1.4	push @$new_todos, {type => 'element', node => $node};
126	wakaba	1.3	} elsif ($nt == 5) {
127			unshift @nodes, @{$node->child_nodes};
128			}
129			}
130	wakaba	1.4	return ($new_todos);
131	wakaba	1.3	}; # $AnyChecker
132
133	wakaba	1.1	my $ElementDefault = {
134			checker => sub {
135	wakaba	1.4	my ($self, $todo) = @_;
136			$self->{onerror}->(node => $todo->{node}, type => 'element not supported');
137			return $AnyChecker->($self, $todo);
138	wakaba	1.1	},
139	wakaba	1.9	attrs_checker => sub {
140			my ($self, $todo) = @_;
141			for my $attr (@{$todo->{node}->attributes}) {
142			my $attr_ns = $attr->namespace_uri;
143			$attr_ns = '' unless defined $attr_ns;
144			my $attr_ln = $attr->manakai_local_name;
145			my $checker = $AttrChecker->{$attr_ns}->{$attr_ln}
146			\|\| $AttrChecker->{$attr_ns}->{''};
147			if ($checker) {
148			$checker->($self, $attr);
149	wakaba	1.17	} else {
150			$self->{onerror}->(node => $attr, type => 'attribute not supported');
151	wakaba	1.9	}
152			}
153			},
154	wakaba	1.1	};
155
156			my $Element = {};
157
158			my $HTML_NS = q<http://www.w3.org/1999/xhtml>;
159
160	wakaba	1.7	my $HTMLMetadataElements = {
161			$HTML_NS => {
162			qw/link 1 meta 1 style 1 script 1 event-source 1 command 1 base 1 title 1/,
163			},
164			};
165	wakaba	1.1
166	wakaba	1.2	my $HTMLSectioningElements = {
167			$HTML_NS => {qw/body 1 section 1 nav 1 article 1 blockquote 1 aside 1/},
168			};
169	wakaba	1.1
170	wakaba	1.7	my $HTMLBlockLevelElements = {
171			$HTML_NS => {
172			qw/
173			section 1 nav 1 article 1 blockquote 1 aside 1
174			h1 1 h2 1 h3 1 h4 1 h5 1 h6 1 header 1 footer 1
175			address 1 p 1 hr 1 dialog 1 pre 1 ol 1 ul 1 dl 1
176			ins 1 del 1 figure 1 map 1 table 1 script 1 noscript 1
177			event-source 1 details 1 datagrid 1 menu 1 div 1 font 1
178			/,
179			},
180			};
181
182			my $HTMLStrictlyInlineLevelElements = {
183			$HTML_NS => {
184			qw/
185			br 1 a 1 q 1 cite 1 em 1 strong 1 small 1 m 1 dfn 1 abbr 1
186			time 1 meter 1 progress 1 code 1 var 1 samp 1 kbd 1
187			sub 1 sup 1 span 1 i 1 b 1 bdo 1 ins 1 del 1 img 1
188			iframe 1 embed 1 object 1 video 1 audio 1 canvas 1 area 1
189			script 1 noscript 1 event-source 1 command 1 font 1
190			/,
191			},
192			};
193
194			my $HTMLStructuredInlineLevelElements = {
195			$HTML_NS => {qw/blockquote 1 pre 1 ol 1 ul 1 dl 1 table 1 menu 1/},
196			};
197	wakaba	1.1
198	wakaba	1.6	my $HTMLInteractiveElements = {
199			$HTML_NS => {a => 1, details => 1, datagrid => 1},
200			};
201			## NOTE: \|html:a\| and \|html:datagrid\| are not allowed as a descendant
202			## of interactive elements
203	wakaba	1.1
204	wakaba	1.7	my $HTMLTransparentElements = {
205			$HTML_NS => {qw/ins 1 font 1 noscript 1/},
206			## NOTE: \|html:noscript\| is transparent if scripting is disabled.
207			};
208
209			#my $HTMLSemiTransparentElements = {
210			# $HTML_NS => {qw/video 1 audio 1/},
211			#};
212
213			my $HTMLEmbededElements = {
214			$HTML_NS => {qw/img 1 iframe 1 embed 1 object 1 video 1 audio 1 canvas 1/},
215			};
216	wakaba	1.1
217			## Empty
218			my $HTMLEmptyChecker = sub {
219	wakaba	1.4	my ($self, $todo) = @_;
220			my $el = $todo->{node};
221			my $new_todos = [];
222	wakaba	1.1	my @nodes = (@{$el->child_nodes});
223
224			while (@nodes) {
225			my $node = shift @nodes;
226	wakaba	1.2	$self->_remove_minuses ($node) and next if ref $node eq 'HASH';
227
228	wakaba	1.1	my $nt = $node->node_type;
229			if ($nt == 1) {
230	wakaba	1.2	## NOTE: \|minuses\| list is not checked since redundant
231			$self->{onerror}->(node => $node, type => 'element not allowed');
232			my ($sib, $ch) = $self->_check_get_children ($node);
233			unshift @nodes, @$sib;
234	wakaba	1.4	push @$new_todos, @$ch;
235	wakaba	1.1	} elsif ($nt == 3 or $nt == 4) {
236	wakaba	1.3	if ($node->data =~ /[^\x09-\x0D\x20]/) {
237			$self->{onerror}->(node => $node, type => 'character not allowed');
238			}
239	wakaba	1.1	} elsif ($nt == 5) {
240			unshift @nodes, @{$node->child_nodes};
241			}
242			}
243	wakaba	1.4	return ($new_todos);
244	wakaba	1.1	};
245
246			## Text
247			my $HTMLTextChecker = sub {
248	wakaba	1.4	my ($self, $todo) = @_;
249			my $el = $todo->{node};
250			my $new_todos = [];
251	wakaba	1.1	my @nodes = (@{$el->child_nodes});
252
253			while (@nodes) {
254			my $node = shift @nodes;
255	wakaba	1.2	$self->_remove_minuses ($node) and next if ref $node eq 'HASH';
256
257	wakaba	1.1	my $nt = $node->node_type;
258			if ($nt == 1) {
259	wakaba	1.2	## NOTE: \|minuses\| list is not checked since redundant
260			$self->{onerror}->(node => $node, type => 'element not allowed');
261			my ($sib, $ch) = $self->_check_get_children ($node);
262			unshift @nodes, @$sib;
263	wakaba	1.4	push @$new_todos, @$ch;
264	wakaba	1.1	} elsif ($nt == 5) {
265			unshift @nodes, @{$node->child_nodes};
266			}
267			}
268	wakaba	1.4	return ($new_todos);
269	wakaba	1.1	};
270
271			## Zero or more \|html:style\| elements,
272			## followed by zero or more block-level elements
273			my $HTMLStylableBlockChecker = sub {
274	wakaba	1.4	my ($self, $todo) = @_;
275			my $el = $todo->{node};
276			my $new_todos = [];
277	wakaba	1.1	my @nodes = (@{$el->child_nodes});
278
279			my $has_non_style;
280			while (@nodes) {
281			my $node = shift @nodes;
282	wakaba	1.2	$self->_remove_minuses ($node) and next if ref $node eq 'HASH';
283
284	wakaba	1.1	my $nt = $node->node_type;
285			if ($nt == 1) {
286	wakaba	1.2	my $node_ns = $node->namespace_uri;
287			$node_ns = '' unless defined $node_ns;
288			my $node_ln = $node->manakai_local_name;
289	wakaba	1.6	my $not_allowed = $self->{minuses}->{$node_ns}->{$node_ln};
290	wakaba	1.8	if ($node_ns eq $HTML_NS and $node_ln eq 'style') {
291	wakaba	1.6	$not_allowed = 1 if $has_non_style;
292	wakaba	1.7	} elsif ($HTMLBlockLevelElements->{$node_ns}->{$node_ln}) {
293			$has_non_style = 1;
294	wakaba	1.1	} else {
295			$has_non_style = 1;
296	wakaba	1.7	$not_allowed = 1;
297	wakaba	1.1	}
298	wakaba	1.6	$self->{onerror}->(node => $node, type => 'element not allowed')
299			if $not_allowed;
300	wakaba	1.2	my ($sib, $ch) = $self->_check_get_children ($node);
301			unshift @nodes, @$sib;
302	wakaba	1.4	push @$new_todos, @$ch;
303	wakaba	1.1	} elsif ($nt == 3 or $nt == 4) {
304			if ($node->data =~ /[^\x09-\x0D\x20]/) {
305	wakaba	1.2	$self->{onerror}->(node => $node, type => 'character not allowed');
306	wakaba	1.1	}
307			} elsif ($nt == 5) {
308			unshift @nodes, @{$node->child_nodes};
309			}
310			}
311	wakaba	1.4	return ($new_todos);
312	wakaba	1.1	}; # $HTMLStylableBlockChecker
313
314			## Zero or more block-level elements
315			my $HTMLBlockChecker = sub {
316	wakaba	1.4	my ($self, $todo) = @_;
317			my $el = $todo->{node};
318			my $new_todos = [];
319	wakaba	1.1	my @nodes = (@{$el->child_nodes});
320
321			while (@nodes) {
322			my $node = shift @nodes;
323	wakaba	1.2	$self->_remove_minuses ($node) and next if ref $node eq 'HASH';
324
325	wakaba	1.1	my $nt = $node->node_type;
326			if ($nt == 1) {
327	wakaba	1.2	my $node_ns = $node->namespace_uri;
328			$node_ns = '' unless defined $node_ns;
329			my $node_ln = $node->manakai_local_name;
330	wakaba	1.6	my $not_allowed = $self->{minuses}->{$node_ns}->{$node_ln};
331	wakaba	1.7	$not_allowed = 1
332			unless $HTMLBlockLevelElements->{$node_ns}->{$node_ln};
333	wakaba	1.6	$self->{onerror}->(node => $node, type => 'element not allowed')
334			if $not_allowed;
335	wakaba	1.2	my ($sib, $ch) = $self->_check_get_children ($node);
336			unshift @nodes, @$sib;
337	wakaba	1.4	push @$new_todos, @$ch;
338	wakaba	1.1	} elsif ($nt == 3 or $nt == 4) {
339			if ($node->data =~ /[^\x09-\x0D\x20]/) {
340	wakaba	1.2	$self->{onerror}->(node => $node, type => 'character not allowed');
341	wakaba	1.1	}
342			} elsif ($nt == 5) {
343			unshift @nodes, @{$node->child_nodes};
344			}
345			}
346	wakaba	1.4	return ($new_todos);
347	wakaba	1.1	}; # $HTMLBlockChecker
348
349			## Inline-level content
350			my $HTMLInlineChecker = sub {
351	wakaba	1.4	my ($self, $todo) = @_;
352			my $el = $todo->{node};
353			my $new_todos = [];
354	wakaba	1.1	my @nodes = (@{$el->child_nodes});
355
356			while (@nodes) {
357			my $node = shift @nodes;
358	wakaba	1.2	$self->_remove_minuses ($node) and next if ref $node eq 'HASH';
359
360	wakaba	1.1	my $nt = $node->node_type;
361			if ($nt == 1) {
362	wakaba	1.2	my $node_ns = $node->namespace_uri;
363			$node_ns = '' unless defined $node_ns;
364			my $node_ln = $node->manakai_local_name;
365	wakaba	1.6	my $not_allowed = $self->{minuses}->{$node_ns}->{$node_ln};
366	wakaba	1.7	$not_allowed = 1
367			unless $HTMLStrictlyInlineLevelElements->{$node_ns}->{$node_ln} or
368			$HTMLStructuredInlineLevelElements->{$node_ns}->{$node_ln};
369	wakaba	1.6	$self->{onerror}->(node => $node, type => 'element not allowed')
370			if $not_allowed;
371	wakaba	1.2	my ($sib, $ch) = $self->_check_get_children ($node);
372			unshift @nodes, @$sib;
373	wakaba	1.4	push @$new_todos, @$ch;
374	wakaba	1.1	} elsif ($nt == 5) {
375			unshift @nodes, @{$node->child_nodes};
376			}
377			}
378	wakaba	1.4
379			for (@$new_todos) {
380			$_->{inline} = 1;
381			}
382			return ($new_todos);
383			}; # $HTMLInlineChecker
384	wakaba	1.1
385			my $HTMLSignificantInlineChecker = $HTMLInlineChecker;
386			## TODO: check significant content
387
388			## Strictly inline-level content
389			my $HTMLStrictlyInlineChecker = sub {
390	wakaba	1.4	my ($self, $todo) = @_;
391			my $el = $todo->{node};
392			my $new_todos = [];
393	wakaba	1.1	my @nodes = (@{$el->child_nodes});
394
395			while (@nodes) {
396			my $node = shift @nodes;
397	wakaba	1.2	$self->_remove_minuses ($node) and next if ref $node eq 'HASH';
398
399	wakaba	1.1	my $nt = $node->node_type;
400			if ($nt == 1) {
401	wakaba	1.2	my $node_ns = $node->namespace_uri;
402			$node_ns = '' unless defined $node_ns;
403			my $node_ln = $node->manakai_local_name;
404	wakaba	1.6	my $not_allowed = $self->{minuses}->{$node_ns}->{$node_ln};
405	wakaba	1.7	$not_allowed = 1
406			unless $HTMLStrictlyInlineLevelElements->{$node_ns}->{$node_ln};
407	wakaba	1.6	$self->{onerror}->(node => $node, type => 'element not allowed')
408			if $not_allowed;
409	wakaba	1.2	my ($sib, $ch) = $self->_check_get_children ($node);
410			unshift @nodes, @$sib;
411	wakaba	1.4	push @$new_todos, @$ch;
412	wakaba	1.1	} elsif ($nt == 5) {
413			unshift @nodes, @{$node->child_nodes};
414			}
415			}
416	wakaba	1.4
417			for (@$new_todos) {
418			$_->{inline} = 1;
419			$_->{strictly_inline} = 1;
420			}
421			return ($new_todos);
422	wakaba	1.1	}; # $HTMLStrictlyInlineChecker
423
424			my $HTMLSignificantStrictlyInlineChecker = $HTMLStrictlyInlineChecker;
425			## TODO: check significant content
426
427	wakaba	1.4	## Inline-level or strictly inline-kevek content
428			my $HTMLInlineOrStrictlyInlineChecker = sub {
429			my ($self, $todo) = @_;
430			my $el = $todo->{node};
431			my $new_todos = [];
432			my @nodes = (@{$el->child_nodes});
433
434			while (@nodes) {
435			my $node = shift @nodes;
436			$self->_remove_minuses ($node) and next if ref $node eq 'HASH';
437
438			my $nt = $node->node_type;
439			if ($nt == 1) {
440			my $node_ns = $node->namespace_uri;
441			$node_ns = '' unless defined $node_ns;
442			my $node_ln = $node->manakai_local_name;
443	wakaba	1.6	my $not_allowed = $self->{minuses}->{$node_ns}->{$node_ln};
444	wakaba	1.7	if ($todo->{strictly_inline}) {
445			$not_allowed = 1
446			unless $HTMLStrictlyInlineLevelElements->{$node_ns}->{$node_ln};
447			} else {
448			$not_allowed = 1
449			unless $HTMLStrictlyInlineLevelElements->{$node_ns}->{$node_ln} or
450			$HTMLStructuredInlineLevelElements->{$node_ns}->{$node_ln};
451			}
452	wakaba	1.6	$self->{onerror}->(node => $node, type => 'element not allowed')
453			if $not_allowed;
454	wakaba	1.4	my ($sib, $ch) = $self->_check_get_children ($node);
455			unshift @nodes, @$sib;
456			push @$new_todos, @$ch;
457			} elsif ($nt == 5) {
458			unshift @nodes, @{$node->child_nodes};
459			}
460			}
461
462			for (@$new_todos) {
463			$_->{inline} = 1;
464			$_->{strictly_inline} = 1;
465			}
466			return ($new_todos);
467			}; # $HTMLInlineOrStrictlyInlineChecker
468
469	wakaba	1.6	my $HTMLSignificantInlineOrStrictlyInlineChecker
470			= $HTMLInlineOrStrictlyInlineChecker;
471			## TODO: check significant content
472
473	wakaba	1.1	my $HTMLBlockOrInlineChecker = sub {
474	wakaba	1.4	my ($self, $todo) = @_;
475			my $el = $todo->{node};
476			my $new_todos = [];
477	wakaba	1.1	my @nodes = (@{$el->child_nodes});
478
479			my $content = 'block-or-inline'; # or 'block' or 'inline'
480			my @block_not_inline;
481			while (@nodes) {
482			my $node = shift @nodes;
483	wakaba	1.2	$self->_remove_minuses ($node) and next if ref $node eq 'HASH';
484
485	wakaba	1.1	my $nt = $node->node_type;
486			if ($nt == 1) {
487	wakaba	1.2	my $node_ns = $node->namespace_uri;
488			$node_ns = '' unless defined $node_ns;
489			my $node_ln = $node->manakai_local_name;
490	wakaba	1.6	my $not_allowed = $self->{minuses}->{$node_ns}->{$node_ln};
491	wakaba	1.1	if ($content eq 'block') {
492	wakaba	1.7	$not_allowed = 1
493			unless $HTMLBlockLevelElements->{$node_ns}->{$node_ln};
494	wakaba	1.1	} elsif ($content eq 'inline') {
495	wakaba	1.7	$not_allowed = 1
496			unless $HTMLStrictlyInlineLevelElements->{$node_ns}->{$node_ln} or
497			$HTMLStructuredInlineLevelElements->{$node_ns}->{$node_ln};
498	wakaba	1.1	} else {
499	wakaba	1.7	my $is_block = $HTMLBlockLevelElements->{$node_ns}->{$node_ln};
500			my $is_inline
501			= $HTMLStrictlyInlineLevelElements->{$node_ns}->{$node_ln} \|\|
502			$HTMLStructuredInlineLevelElements->{$node_ns}->{$node_ln};
503	wakaba	1.1
504	wakaba	1.6	push @block_not_inline, $node
505			if $is_block and not $is_inline and not $not_allowed;
506	wakaba	1.1	unless ($is_block) {
507			$content = 'inline';
508			for (@block_not_inline) {
509	wakaba	1.2	$self->{onerror}->(node => $_, type => 'element not allowed');
510	wakaba	1.1	}
511	wakaba	1.6	$not_allowed = 1 unless $is_inline;
512	wakaba	1.1	}
513			}
514	wakaba	1.6	$self->{onerror}->(node => $node, type => 'element not allowed')
515			if $not_allowed;
516	wakaba	1.2	my ($sib, $ch) = $self->_check_get_children ($node);
517			unshift @nodes, @$sib;
518	wakaba	1.4	push @$new_todos, @$ch;
519	wakaba	1.1	} elsif ($nt == 3 or $nt == 4) {
520			if ($node->data =~ /[^\x09-\x0D\x20]/) {
521			if ($content eq 'block') {
522	wakaba	1.2	$self->{onerror}->(node => $node, type => 'character not allowed');
523	wakaba	1.1	} else {
524			$content = 'inline';
525			for (@block_not_inline) {
526	wakaba	1.2	$self->{onerror}->(node => $_, type => 'element not allowed');
527	wakaba	1.1	}
528			}
529			}
530			} elsif ($nt == 5) {
531			unshift @nodes, @{$node->child_nodes};
532			}
533			}
534	wakaba	1.4
535			if ($content eq 'inline') {
536			for (@$new_todos) {
537			$_->{inline} = 1;
538			}
539			}
540			return ($new_todos);
541	wakaba	1.1	};
542
543	wakaba	1.2	## Zero or more XXX element, then either block-level or inline-level
544			my $GetHTMLZeroOrMoreThenBlockOrInlineChecker = sub ($$) {
545			my ($elnsuri, $ellname) = @_;
546			return sub {
547	wakaba	1.4	my ($self, $todo) = @_;
548			my $el = $todo->{node};
549			my $new_todos = [];
550	wakaba	1.2	my @nodes = (@{$el->child_nodes});
551
552			my $has_non_style;
553			my $content = 'block-or-inline'; # or 'block' or 'inline'
554			my @block_not_inline;
555			while (@nodes) {
556			my $node = shift @nodes;
557			$self->_remove_minuses ($node) and next if ref $node eq 'HASH';
558
559			my $nt = $node->node_type;
560			if ($nt == 1) {
561			my $node_ns = $node->namespace_uri;
562			$node_ns = '' unless defined $node_ns;
563			my $node_ln = $node->manakai_local_name;
564	wakaba	1.6	my $not_allowed = $self->{minuses}->{$node_ns}->{$node_ln};
565	wakaba	1.8	if ($node_ns eq $elnsuri and $node_ln eq $ellname) {
566	wakaba	1.6	$not_allowed = 1 if $has_non_style;
567	wakaba	1.2	} elsif ($content eq 'block') {
568			$has_non_style = 1;
569	wakaba	1.7	$not_allowed = 1
570			unless $HTMLBlockLevelElements->{$node_ns}->{$node_ln};
571	wakaba	1.2	} elsif ($content eq 'inline') {
572			$has_non_style = 1;
573	wakaba	1.7	$not_allowed = 1
574			unless $HTMLStrictlyInlineLevelElements->{$node_ns}->{$node_ln} or
575			$HTMLStructuredInlineLevelElements->{$node_ns}->{$node_ln};
576	wakaba	1.2	} else {
577			$has_non_style = 1;
578	wakaba	1.7	my $is_block = $HTMLBlockLevelElements->{$node_ns}->{$node_ln};
579			my $is_inline
580			= $HTMLStrictlyInlineLevelElements->{$node_ns}->