/[suikacvs]/markup/html/whatpm/Whatpm/ContentChecker/Atom.pm
Suika

Diff of /markup/html/whatpm/Whatpm/ContentChecker/Atom.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.7 by wakaba, Sun Nov 25 08:04:20 2007 UTC revision 1.8 by wakaba, Sun Mar 2 11:16:34 2008 UTC
# Line 7  require Whatpm::URIChecker; Line 7  require Whatpm::URIChecker;
7  my $ATOM_NS = q<http://www.w3.org/2005/Atom>;  my $ATOM_NS = q<http://www.w3.org/2005/Atom>;
8  my $LINK_REL = q<http://www.iana.org/assignments/relation/>;  my $LINK_REL = q<http://www.iana.org/assignments/relation/>;
9    
10    sub FEATURE_RFC4287 () {
11      Whatpm::ContentChecker::FEATURE_STATUS_CR |
12      Whatpm::ContentChecker::FEATURE_ALLOWED
13    }
14    
15  ## MUST be well-formed XML (RFC 4287 references XML 1.0 REC 20040204)  ## MUST be well-formed XML (RFC 4287 references XML 1.0 REC 20040204)
16    
17  ## NOTE: Commants and PIs are not explicitly allowed.  ## NOTE: Commants and PIs are not explicitly allowed.
# Line 16  our $AttrChecker; Line 21  our $AttrChecker;
21  ## Any element MAY have xml:base, xml:lang  ## Any element MAY have xml:base, xml:lang
22  my $GetAtomAttrsChecker = sub {  my $GetAtomAttrsChecker = sub {
23    my $element_specific_checker = shift;    my $element_specific_checker = shift;
24      my $element_specific_status = shift;
25    return sub {    return sub {
26      my ($self, $todo) = @_;      my ($self, $todo, $element_state) = @_;
27      for my $attr (@{$todo->{node}->attributes}) {      for my $attr (@{$todo->{node}->attributes}) {
28        my $attr_ns = $attr->namespace_uri;        my $attr_ns = $attr->namespace_uri;
29        $attr_ns = '' unless defined $attr_ns;        $attr_ns = '' unless defined $attr_ns;
# Line 30  my $GetAtomAttrsChecker = sub { Line 36  my $GetAtomAttrsChecker = sub {
36              || $AttrChecker->{$attr_ns}->{''};              || $AttrChecker->{$attr_ns}->{''};
37        }        }
38        if ($checker) {        if ($checker) {
39          $checker->($self, $attr, $todo);          $checker->($self, $attr, $todo, $element_state);
40          } elsif ($attr_ln eq '') {
41            #
42        } else {        } else {
43          $self->{onerror}->(node => $attr, level => 'unsupported',          $self->{onerror}->(node => $attr, level => 'unsupported',
44                             type => 'attribute');                             type => 'attribute');
45          ## ISSUE: No comformance createria for unknown attributes in the spec          ## ISSUE: No comformance createria for unknown attributes in the spec
46        }        }
47    
48          if ($attr_ns eq '') {
49            $self->_attr_status_info ($attr, $element_specific_status->{$attr_ln});
50          }
51          ## TODO: global attribute
52      }      }
53    };    };
54  }; # $GetAtomAttrsChecker  }; # $GetAtomAttrsChecker
# Line 56  my $AtomLanguageTagAttrChecker = sub { Line 69  my $AtomLanguageTagAttrChecker = sub {
69    ## ISSUE: RFC 4646 (3066bis)?    ## ISSUE: RFC 4646 (3066bis)?
70  }; # $AtomLanguageTagAttrChecker  }; # $AtomLanguageTagAttrChecker
71    
72  my $AtomTextConstruct = {  my %AtomChecker = (
73    attrs_checker => $GetAtomAttrsChecker->({    %Whatpm::ContentChecker::AnyChecker,
74      type => sub { 1 }, # checked in |checker|    status => FEATURE_RFC4287,
75    }),    check_attrs => $GetAtomAttrsChecker->({}, {}),
76    checker => sub {  );
77      my ($self, $todo) = @_;  
78    my %AtomTextConstruct = (
79      my $attr = $todo->{node}->get_attribute_node_ns (undef, 'type');    %AtomChecker,
80      my $value = 'text';    check_start => sub {
81      if ($attr) {      my ($self, $item, $element_state) = @_;
82        $value = $attr->value;      $element_state->{type} = 'text';
83        if ($value eq 'text' or $value eq 'html' or $value eq 'xhtml') {      $element_state->{value} = '';
84          # MUST    },
85      check_attrs => $GetAtomAttrsChecker->({
86        type => sub {
87          my ($self, $attr, $item, $element_state) = @_;
88          my $value = $attr->value;
89          if ($value eq 'text' or $value eq 'html' or $value eq 'xhtml') { # MUST
90            $element_state->{type} = $value;
91        } else {        } else {
92            ## NOTE: IMT MUST NOT be used here.
93          $self->{onerror}->(node => $attr, type => 'keyword:invalid');          $self->{onerror}->(node => $attr, type => 'keyword:invalid');
94        }        }
95        # IMT MUST NOT be used      }, # checked in |checker|
96      }    }, {
97        type => FEATURE_RFC4287,
98      if ($value eq 'text') {    }),
99        my @nodes = (@{$todo->{node}->child_nodes});    check_child_element => sub {
100        my $new_todos = [];      my ($self, $item, $child_el, $child_nsuri, $child_ln,
101                  $child_is_transparent, $element_state) = @_;
102        while (@nodes) {      if ($self->{minus_elements}->{$child_nsuri}->{$child_ln}) {
103          my $node = shift @nodes;        $self->{onerror}->(node => $child_el,
104          $self->_remove_minuses ($node) and next if ref $node eq 'HASH';                           type => 'element not allowed:minus',
105                                     level => $self->{must_level});
106          my $nt = $node->node_type;      } elsif ($self->{plus_elements}->{$child_nsuri}->{$child_ln}) {
107          if ($nt == 1) {        #
108            # MUST NOT      } else {
109            $self->{onerror}->(node => $node, type => 'element not allowed');        if ($element_state->{type} eq 'text' or
110            my ($sib, $ch) = $self->_check_get_children ($node, $todo);            $element_state->{type} eq 'html') { # MUST NOT
111            unshift @nodes, @$sib;          $self->{onerror}->(node => $child_el,
112            push @$new_todos, @$ch;                             type => 'element not allowed:atom|TextConstruct',
113          } elsif ($nt == 5) {                             level => $self->{must_level});
114            unshift @nodes, @{$node->child_nodes};        } elsif ($element_state->{type} eq 'xhtml') {
115          }          if ($child_nsuri eq q<http://www.w3.org/1999/xhtml> and
116        }              $child_ln eq 'div') { # MUST
117              if ($element_state->{has_div}) {
118        return ($new_todos);              $self->{onerror}
119      } elsif ($value eq 'html') {                  ->(node => $child_el,
120        my @nodes = (@{$todo->{node}->child_nodes});                     type => 'element not allowed:atom|TextConstruct',
121        my $new_todos = [];                     level => $self->{must_level});
         
       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) {  
           # MUST NOT  
           $self->{onerror}->(node => $node, type => 'element not allowed');  
           my ($sib, $ch) = $self->_check_get_children ($node, $todo);  
           unshift @nodes, @$sib;  
           push @$new_todos, @$ch;  
         } elsif ($nt == 5) {  
           unshift @nodes, @{$node->child_nodes};  
         }  
       }  
   
       ## TODO: SHOULD be suitable for handling as HTML [HTML4]  
       # markup MUST be escaped  
       ## TODO: HTML SHOULD be valid as if within <div>  
   
       return ($new_todos);  
     } elsif ($value eq 'xhtml') {  
       my @nodes = (@{$todo->{node}->child_nodes});  
       my $new_todos = [];  
         
       my $has_div;  
       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) {  
           # MUST  
           my $nsuri = $node->namespace_uri;  
           if (defined $nsuri and  
               $nsuri eq q<http://www.w3.org/1999/xhtml> and  
               $node->manakai_local_name eq 'div' and  
               not $has_div) {  
             ## TODO: SHOULD be suitable for handling as HTML [XHTML10]  
             $has_div = 1;  
122            } else {            } else {
123              $self->{onerror}->(node => $node, type => 'element not allowed');              $element_state->{has_div} = 1;
124                ## TODO: SHOULD be suitable for handling as HTML [XHTML10]
125            }            }
126            my ($sib, $ch) = $self->_check_get_children ($node, $todo);          } else {
127            unshift @nodes, @$sib;            $self->{onerror}->(node => $child_el,
128            push @$new_todos, @$ch;                               type => 'element not allowed:atom|TextConstruct',
129          } elsif ($nt == 3 or $nt == 4) {                               level => $self->{must_level});
           ## TODO: Are white spaces allowed?  
           $self->{onerror}->(node => $node, type => 'character not allowed');  
         } elsif ($nt == 5) {  
           unshift @nodes, @{$node->child_nodes};  
130          }          }
131          } else {
132            die "atom:TextConstruct type error: $element_state->{type}";
133        }        }
134        }
135        unless ($has_div) {    },
136          $self->{onerror}->(node => $todo->{node},    check_child_text => sub {
137                             type => 'element missing:div');      my ($self, $item, $child_node, $has_significant, $element_state) = @_;
138        if ($element_state->{type} eq 'text') {
139          #
140        } elsif ($element_state->{type} eq 'html') {
141          $element_state->{value} .= $child_node->text_content;
142          ## NOTE: Markup MUST be escaped.
143        } elsif ($element_state->{type} eq 'xhtml') {
144          if ($has_significant) {
145            $self->{onerror}->(node => $child_node,
146                               type => 'character not allowed:atom|TextConstruct',
147                               level => $self->{must_level});
148        }        }
149        } else {
150        return ($new_todos);        die "atom:TextConstruct type error: $element_state->{type}";
151      }      }
       
152    },    },
153  }; # $AtomTextConstruct    ## type=html
154          ## TODO: SHOULD be suitable for handling as HTML [HTML4]
155          ## TODO: HTML SHOULD be valid as if within <div>
156      check_end => sub {
157        my ($self, $item, $element_state) = @_;
158        if ($element_state->{type} eq 'xhtml' and
159            not $element_state->{has_div}) {
160          $self->{onerror}->(node => $item->{node},
161                             type => 'element missing:div',
162                             level => $self->{must_level});
163        }
164    
165  my $AtomPersonConstruct = {      $AtomChecker{check_end}->(@_);
166    attrs_checker => $GetAtomAttrsChecker->({}),    },
167    checker => sub {  ); # %AtomTextConstruct
     my ($self, $todo) = @_;  
168    
169      my @nodes = (@{$todo->{node}->child_nodes});  my %AtomPersonConstruct = (
170      my $new_todos = [];    %AtomChecker,
171            check_child_element => sub {
172      my $has_name;      my ($self, $item, $child_el, $child_nsuri, $child_ln,
173      my $has_uri;          $child_is_transparent, $element_state) = @_;
174      my $has_email;      if ($self->{minus_elements}->{$child_nsuri}->{$child_ln}) {
175      while (@nodes) {        $self->{onerror}->(node => $child_el,
176        my $node = shift @nodes;                           type => 'element not allowed:minus',
177        $self->_remove_minuses ($node) and next if ref $node eq 'HASH';                           level => $self->{must_level});
178                } elsif ($self->{plus_elements}->{$child_nsuri}->{$child_ln}) {
179        my $nt = $node->node_type;        #
180        if ($nt == 1) {      } elsif ($child_nsuri eq $ATOM_NS) {
181          # MUST        if ($child_ln eq 'name') {
182          my $nsuri = $node->namespace_uri;          if ($element_state->{has_name}) {
183          $nsuri = '' unless defined $nsuri;            $self->{onerror}
184          my $not_allowed;                ->(node => $child_el,
185          if ($nsuri eq $ATOM_NS) {                   type => 'element not allowed:atom|PersonConstruct',
186            my $ln = $node->manakai_local_name;                   level => $self->{must_level});
           if ($ln eq 'name') {  
             unless ($has_name) {  
               $has_name = 1;  
             } else {  
               $not_allowed = 1;  
             }  
           } elsif ($ln eq 'uri') {  
             unless ($has_uri) {  
               $has_uri = 1;  
             } else {  
               $not_allowed = 1; # MUST NOT  
             }  
           } elsif ($ln eq 'email') {  
             unless ($has_email) {  
               $has_email = 1;  
             } else {  
               $not_allowed = 1; # MUST NOT  
             }  
           } else {  
             $not_allowed = 1;  
           }  
187          } else {          } else {
188            ## TODO: extension element            $element_state->{has_name} = 1;
189            $not_allowed = 1;          }
190          } elsif ($child_ln eq 'uri') {
191            if ($element_state->{has_uri}) {
192              $self->{onerror}
193                  ->(node => $child_el,
194                     type => 'element not allowed:atom|PersonConstruct',
195                     level => $self->{must_level});
196            } else {
197              $element_state->{has_uri} = 1;
198          }          }
199          $self->{onerror}->(node => $node, type => 'element not allowed')        } elsif ($child_ln eq 'email') {
200              if $not_allowed;          if ($element_state->{has_email}) {
201          my ($sib, $ch) = $self->_check_get_children ($node, $todo);            $self->{onerror}
202          unshift @nodes, @$sib;                ->(node => $child_el,
203          push @$new_todos, @$ch;                   type => 'element not allowed:atom|PersonConstruct',
204        } elsif ($nt == 3 or $nt == 4) {                   level => $self->{must_level});
205          ## TODO: Are white spaces allowed?          } else {
206          $self->{onerror}->(node => $node, type => 'character not allowed');            $element_state->{has_email} = 1;
         if ($node->data =~ /[^\x09-\x0D\x20]/) {  
           $todo->{flag}->{has_descendant}->{significant} = 1;  
207          }          }
208        } elsif ($nt == 5) {        } else {
209          unshift @nodes, @{$node->child_nodes};          $self->{onerror}
210                ->(node => $child_el,
211                   type => 'element not allowed:atom|PersonConstruct',
212                   level => $self->{must_level});
213        }        }
214        } else {
215          $self->{onerror}
216              ->(node => $child_el,
217                 type => 'element not allowed:atom|PersonConstruct',
218                 level => $self->{must_level});
219      }      }
220        ## TODO: extension element
221      },
222      check_child_text => sub {
223        my ($self, $item, $child_node, $has_significant, $element_state) = @_;
224        if ($has_significant) {
225          $self->{onerror}->(node => $child_node,
226                             type => 'character not allowed:atom|PersonConstruct',
227                             level => $self->{must_level});
228        }
229      },
230      check_end => sub {
231        my ($self, $item, $element_state) = @_;
232    
233      unless ($has_name) { # MUST      unless ($element_state->{has_name}) {
234        $self->{onerror}->(node => $todo->{node},        $self->{onerror}->(node => $item->{node},
235                           type => 'element missing:atom.name');                           type => 'element missing:atom|name',
236                             level => $self->{must_level});
237      }      }
238    
239      return ($new_todos);      $AtomChecker{check_end}->(@_);
240    },    },
241  }; # $AtomPersonConstruct  ); # %AtomPersonConstruct
242    
243  our $Element;  our $Element;
244    
245    $Element->{$ATOM_NS}->{''} = {
246      %AtomChecker,
247      status => 0,
248    };
249    
250  $Element->{$ATOM_NS}->{name} = {  $Element->{$ATOM_NS}->{name} = {
251      %AtomChecker,
252    
253    ## NOTE: Strictly speaking, structure and semantics for atom:name    ## NOTE: Strictly speaking, structure and semantics for atom:name
254    ## element outside of Person construct is not defined.    ## element outside of Person construct is not defined.
   attrs_checker => $GetAtomAttrsChecker->({}),  
   checker => sub {  
     my ($self, $todo) = @_;  
   
     my @nodes = (@{$todo->{node}->child_nodes});  
     my $new_todos = [];  
   
     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: No constraint.  
         my ($sib, $ch) = $self->_check_get_children ($node, $todo);  
         unshift @nodes, @$sib;  
         push @$new_todos, @$ch;  
       } elsif ($nt == 3 or $nt == 4) {  
         $todo->{flag}->{has_descendant}->{significant} = 1;  
       } elsif ($nt == 5) {  
         unshift @nodes, @{$node->child_nodes};  
       }  
     }  
255    
256      return ($new_todos);    ## NOTE: No constraint.
   },  
257  };  };
258    
259  $Element->{$ATOM_NS}->{uri} = {  $Element->{$ATOM_NS}->{uri} = {
260      %AtomChecker,
261    
262    ## NOTE: Strictly speaking, structure and semantics for atom:uri    ## NOTE: Strictly speaking, structure and semantics for atom:uri
263    ## element outside of Person construct is not defined.    ## element outside of Person construct is not defined.
264    attrs_checker => $GetAtomAttrsChecker->({}),  
265    checker => sub {    ## NOTE: Elements are not explicitly disallowed.
266      my ($self, $todo) = @_;  
267      check_start => sub {
268      my @nodes = (@{$todo->{node}->child_nodes});      my ($self, $item, $element_state) = @_;
269      my $new_todos = [];      $element_state->{value} = '';
270      },
271      my $s = '';    check_child_text => sub {
272      while (@nodes) {      my ($self, $item, $child_node, $has_significant, $element_state) = @_;
273        my $node = shift @nodes;      $element_state->{value} .= $child_node->data;
274        $self->_remove_minuses ($node) and next if ref $node eq 'HASH';    },
275              check_end => sub {
276        my $nt = $node->node_type;      my ($self, $item, $element_state) = @_;
       if ($nt == 1) {  
         my $node_ns = $node->namespace_uri;  
         $node_ns = '' unless defined $node_ns;  
         my $node_ln = $node->manakai_local_name;  
         unless ($self->{pluses}->{$node_ns}->{$node_ln}) {  
           ## NOTE: Not explicitly disallowed.  
           $self->{onerror}->(node => $node, type => 'element not allowed');  
         }  
         my ($sib, $ch) = $self->_check_get_children ($node, $todo);  
         unshift @nodes, @$sib;  
         push @$new_todos, @$ch;  
       } elsif ($nt == 3 or $nt == 4) {  
         $s .= $node->data;  
         $todo->{flag}->{has_descendant}->{significant} = 1;  
       } elsif ($nt == 5) {  
         unshift @nodes, @{$node->child_nodes};  
       }  
     }  
277    
278      ## NOTE: There MUST NOT be any white space.      ## NOTE: There MUST NOT be any white space.
279      Whatpm::URIChecker->check_iri_reference ($s, sub {      Whatpm::URIChecker->check_iri_reference ($element_state->{value}, sub {
280        my %opt = @_;        my %opt = @_;
281        $self->{onerror}->(node => $todo->{node}, level => $opt{level},        $self->{onerror}->(node => $item->{node}, level => $opt{level},
282                           type => 'URI::'.$opt{type}.                           type => 'URI::'.$opt{type}.
283                           (defined $opt{position} ? ':'.$opt{position} : ''));                           (defined $opt{position} ? ':'.$opt{position} : ''));
284      });      });
285    
286      return ($new_todos);      $AtomChecker{check_end}->(@_);
287    },    },
288  };  };
289    
290  $Element->{$ATOM_NS}->{email} = {  $Element->{$ATOM_NS}->{email} = {
291      %AtomChecker,
292    
293    ## NOTE: Strictly speaking, structure and semantics for atom:email    ## NOTE: Strictly speaking, structure and semantics for atom:email
294    ## element outside of Person construct is not defined.    ## element outside of Person construct is not defined.
295    attrs_checker => $GetAtomAttrsChecker->({}),  
296    checker => sub {    ## NOTE: Elements are not explicitly disallowed.
297      my ($self, $todo) = @_;  
298      check_end => sub {
299      my @nodes = (@{$todo->{node}->child_nodes});      my ($self, $item, $element_state) = @_;
     my $new_todos = [];  
   
     my $s = '';  
     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;  
         unless ($self->{pluses}->{$node_ns}->{$node_ln}) {  
           ## NOTE: Not explicitly disallowed.  
           $self->{onerror}->(node => $node, type => 'element not allowed');  
         }  
         my ($sib, $ch) = $self->_check_get_children ($node, $todo);  
         unshift @nodes, @$sib;  
         push @$new_todos, @$ch;  
       } elsif ($nt == 3 or $nt == 4) {  
         $s .= $node->data;  
         $todo->{flag}->{has_descendant}->{significant} = 1;  
       } elsif ($nt == 5) {  
         unshift @nodes, @{$node->child_nodes};  
       }  
     }  
300    
301      ## TODO: addr-spec      ## TODO: addr-spec
302      $self->{onerror}->(node => $todo->{node}, type => 'addr-spec',      $self->{onerror}->(node => $item->{node},
303                         level => 'unsupported');                         type => 'addr-spec not supported',
304                           level => $self->{unsupported_level});
305    
306      return ($new_todos);      $AtomChecker{check_end}->(@_);
307    },    },
308  };  };
309    
310  ## MUST NOT be any white space  ## MUST NOT be any white space
311  my $AtomDateConstruct = {  my %AtomDateConstruct = (
312    attrs_checker => $GetAtomAttrsChecker->({}),    %AtomChecker,
313    checker => sub {  
314      my ($self, $todo) = @_;    ## NOTE: It does not explicitly say that there MUST NOT be any element.
315    
316      my @nodes = (@{$todo->{node}->child_nodes});    check_start => sub {
317      my $new_todos = [];      my ($self, $item, $element_state) = @_;
318        $element_state->{value} = '';
319      my $s = '';    },
320      while (@nodes) {    check_child_text => sub {
321        my $node = shift @nodes;      my ($self, $item, $child_node, $has_significant, $element_state) = @_;
322        $self->_remove_minuses ($node) and next if ref $node eq 'HASH';      $element_state->{value} .= $child_node->data;
323              },
324        my $nt = $node->node_type;    check_end => sub {
325        if ($nt == 1) {      my ($self, $item, $element_state) = @_;
         my $node_ns = $node->namespace_uri;  
         $node_ns = '' unless defined $node_ns;  
         my $node_ln = $node->manakai_local_name;  
         unless ($self->{pluses}->{$node_ns}->{$node_ln}) {  
           ## NOTE: It does not explicitly say that there MUST NOT be any element.  
           $self->{onerror}->(node => $node, type => 'element not allowed');  
         }  
         my ($sib, $ch) = $self->_check_get_children ($node, $todo);  
         unshift @nodes, @$sib;  
         push @$new_todos, @$ch;  
       } elsif ($nt == 3 or $nt == 4) {  
         $s .= $node->data;  
         $todo->{flag}->{has_descendant}->{significant} = 1;  
       } elsif ($nt == 5) {  
         unshift @nodes, @{$node->child_nodes};  
       }  
     }  
326    
327      ## MUST: RFC 3339 |date-time| with uppercase |T| and |Z|      ## MUST: RFC 3339 |date-time| with uppercase |T| and |Z|
328      if ($s =~ /\A([0-9]{4})-([0-9]{2})-([0-9]{2})T([0-9]{2}):([0-9]{2}):([0-9]{2})(?>\.[0-9]+)?(?>Z|[+-]([0-9]{2}):([0-9]{2}))\z/) {      if ($element_state->{value} =~ /\A([0-9]{4})-([0-9]{2})-([0-9]{2})T([0-9]{2}):([0-9]{2}):([0-9]{2})(?>\.[0-9]+)?(?>Z|[+-]([0-9]{2}):([0-9]{2}))\z/) {
329        my ($y, $M, $d, $h, $m, $s, $zh, $zm)        my ($y, $M, $d, $h, $m, $s, $zh, $zm)
330            = ($1, $2, $3, $4, $5, $6, $7, $8);            = ($1, $2, $3, $4, $5, $6, $7, $8);
331        my $node = $todo->{node};        my $node = $item->{node};
332    
333        ## Check additional constraints described or referenced in        ## Check additional constraints described or referenced in
334        ## comments of ABNF rules for |date-time|.        ## comments of ABNF rules for |date-time|.
# Line 429  my $AtomDateConstruct = { Line 358  my $AtomDateConstruct = {
358        $self->{onerror}->(node => $node, type => 'datetime:bad timezone minute',        $self->{onerror}->(node => $node, type => 'datetime:bad timezone minute',
359                           level => $level) if $zm > 59;                           level => $level) if $zm > 59;
360      } else {      } else {
361        $self->{onerror}->(node => $todo->{node},        $self->{onerror}->(node => $item->{node},
362                           type => 'datetime:syntax error',                           type => 'datetime:syntax error',
363                           level => $self->{must_level});                           level => $self->{must_level});
364      }      }
365      ## NOTE: SHOULD be accurate as possible (cannot be checked)      ## NOTE: SHOULD be accurate as possible (cannot be checked)
366    
367      return ($new_todos);      $AtomChecker{check_end}->(@_);
368    },    },
369  }; # $AtomDateConstruct  ); # %AtomDateConstruct
370    
371  $Element->{$ATOM_NS}->{entry} = {  $Element->{$ATOM_NS}->{entry} = {
372      %AtomChecker,
373    is_root => 1,    is_root => 1,
374    attrs_checker => $GetAtomAttrsChecker->({}),    ## TODO: MUST author+ unless (child::source/child::author)
375    checker => sub {    ## or (parent::feed/child::author)
376      my ($self, $todo) = @_;    check_child_element => sub {
377        my ($self, $item, $child_el, $child_nsuri, $child_ln,
378      my @nodes = (@{$todo->{node}->child_nodes});          $child_is_transparent, $element_state) = @_;
379      my $new_todos = [];  
380        ## NOTE: metadata elements, followed by atom:entry* (no explicit MAY)
381      ## TODO: MUST author+ unless (child::source/child::author)  
382      ## or (parent::feed/child::author)      if ($self->{minus_elements}->{$child_nsuri}->{$child_ln}) {
383          $self->{onerror}->(node => $child_el,
384      my $has_element = {};                           type => 'element not allowed:minus',
385      while (@nodes) {                           level => $self->{must_level});
386        my $node = shift @nodes;      } elsif ($self->{plus_elements}->{$child_nsuri}->{$child_ln}) {
387        $self->_remove_minuses ($node) and next if ref $node eq 'HASH';        #
388                } elsif ($child_nsuri eq $ATOM_NS) {
389        my $nt = $node->node_type;        my $not_allowed;
390        if ($nt == 1) {        if ({ # MUST (0, 1)
391          # MUST             content => 1,
392          my $nsuri = $node->namespace_uri;             id => 1,
393          $nsuri = '' unless defined $nsuri;             published => 1,
394          my $ln = $node->manakai_local_name;             rights => 1,
395          my $not_allowed;             source => 1,
396          if ($self->{pluses}->{$nsuri}->{$ln}) {             summary => 1,
397            #             ## TODO: MUST if child::content/@src | child::content/@type = IMT, !text/ !/xml !+xml
398          } elsif ($nsuri eq $ATOM_NS) {             title => 1,
399            if ({ # MUST (0, 1)             updated => 1,
400                 content => 1,            }->{$child_ln}) {
401                 id => 1,          unless ($element_state->{has_element}->{$child_ln}) {
402                 published => 1,            $element_state->{has_element}->{$child_ln} = 1;
403                 rights => 1,            $not_allowed = $element_state->{has_element}->{entry};
                source => 1,  
                summary => 1,  
                ## TODO: MUST if child::content/@src | child::content/@type = IMT, !text/ !/xml !+xml  
                title => 1,  
                updated => 1,  
               }->{$ln}) {  
             unless ($has_element->{$ln}) {  
               $has_element->{$ln} = 1;  
               $not_allowed = $has_element->{entry};  
             } else {  
               $not_allowed = 1;  
             }  
           } elsif ($ln eq 'link') { # MAY  
             if ($node->rel eq $LINK_REL . 'alternate') {  
               my $type = $node->get_attribute_ns (undef, 'type');  
               $type = '' unless defined $type;  
               my $hreflang = $node->get_attribute_ns (undef, 'hreflang');  
               $hreflang = '' unless defined $hreflang;  
               my $key = 'link:'.(defined $type ? ':'.$type : '').':'.  
                   (defined $hreflang ? ':'.$hreflang : '');  
               unless ($has_element->{$key}) {  
                 $has_element->{$key} = 1;  
                 $has_element->{'link.alternate'} = 1;  
               } else {  
                 $not_allowed = 1;  
               }  
             }  
               
             ## NOTE: MAY  
             $not_allowed ||= $has_element->{entry};  
           } elsif ({ # MAY  
                     author => 1,  
                     category => 1,  
                     contributor => 1,  
               }->{$ln}) {  
             $not_allowed = $has_element->{entry};  
           } else {  
             $not_allowed = 1;  
           }  
404          } else {          } else {
           ## TODO: extension element  
405            $not_allowed = 1;            $not_allowed = 1;
406          }          }
407          $self->{onerror}->(node => $node, type => 'element not allowed')        } elsif ($child_ln eq 'link') { # MAY
408              if $not_allowed;          if ($child_el->rel eq $LINK_REL . 'alternate') {
409          my ($sib, $ch) = $self->_check_get_children ($node, $todo);            my $type = $child_el->get_attribute_ns (undef, 'type');
410          unshift @nodes, @$sib;            $type = '' unless defined $type;
411          push @$new_todos, @$ch;            my $hreflang = $child_el->get_attribute_ns (undef, 'hreflang');
412        } elsif ($nt == 3 or $nt == 4) {            $hreflang = '' unless defined $hreflang;
413          ## TODO: Are white spaces allowed?            my $key = 'link:'.(defined $type ? ':'.$type : '').':'.
414          $self->{onerror}->(node => $node, type => 'character not allowed');                (defined $hreflang ? ':'.$hreflang : '');
415          if ($node->data =~ /[^\x09-\x0D\x20]/) {            unless ($element_state->{has_element}->{$key}) {
416            $todo->{flag}->{has_descendant}->{significant} = 1;              $element_state->{has_element}->{$key} = 1;
417                $element_state->{has_element}->{'link.alternate'} = 1;
418              } else {
419                $not_allowed = 1;
420              }
421          }          }
422        } elsif ($nt == 5) {          
423          unshift @nodes, @{$node->child_nodes};          ## NOTE: MAY
424            $not_allowed ||= $element_state->{has_element}->{entry};
425          } elsif ({ # MAY
426                    author => 1,
427                    category => 1,
428                    contributor => 1,
429                   }->{$child_ln}) {
430            $not_allowed = $element_state->{has_element}->{entry};
431          } else {
432            $not_allowed = 1;
433        }        }
434          if ($not_allowed) {
435            $self->{onerror}->(node => $child_el, type => 'element not allowed');
436          }
437        } else {
438          ## TODO: extension element
439          $self->{onerror}->(node => $child_el, type => 'element not allowed');
440      }      }
441      },
442      ## NOTE: metadata elements, followed by atom:entry* (no explicit MAY)    check_child_text => sub {
443        my ($self, $item, $child_node, $has_significant, $element_state) = @_;
444        if ($has_significant) {
445          $self->{onerror}->(node => $child_node, type => 'character not allowed',
446                             level => $self->{must_level});
447        }
448      },
449      check_end => sub {
450        my ($self, $item, $element_state) = @_;
451    
452      ## TODO: If entry's with same id, then updated SHOULD be different      ## TODO: If entry's with same id, then updated SHOULD be different
453    
454      unless ($has_element->{id}) { # MUST      unless ($element_state->{has_element}->{id}) { # MUST
455        $self->{onerror}->(node => $todo->{node},        $self->{onerror}->(node => $item->{node},
456                           type => 'element missing:atom.id');                           type => 'element missing:atom|id');
457      }      }
458      unless ($has_element->{title}) { # MUST      unless ($element_state->{has_element}->{title}) { # MUST
459        $self->{onerror}->(node => $todo->{node},        $self->{onerror}->(node => $item->{node},
460                           type => 'element missing:atom.title');                           type => 'element missing:atom|title');
461      }      }
462      unless ($has_element->{updated}) { # MUST      unless ($element_state->{has_element}->{updated}) { # MUST
463        $self->{onerror}->(node => $todo->{node},        $self->{onerror}->(node => $item->{node},
464                           type => 'element missing:atom.updated');                           type => 'element missing:atom|updated');
465        }
466        if (not $element_state->{has_element}->{content} and
467            not $element_state->{has_element}->{'link.alternate'}) {
468          $self->{onerror}->(node => $item->{node},
469                             type => 'element missing:atom|link|alternate');
470      }      }
     if (not $has_element->{content} and  
         not $has_element->{'link.alternate'}) {  
       $self->{onerror}->(node => $todo->{node},  
                          type => 'element missing:atom.link.alternate');  
     }  
   
     return ($new_todos);  
471    },    },
472  };  };
473    
474  $Element->{$ATOM_NS}->{feed} = {  $Element->{$ATOM_NS}->{feed} = {
475      %AtomChecker,
476    is_root => 1,    is_root => 1,
477    attrs_checker => $GetAtomAttrsChecker->({}),    check_child_element => sub {
478    checker => sub {      my ($self, $item, $child_el, $child_nsuri, $child_ln,
479      my ($self, $todo) = @_;          $child_is_transparent, $element_state) = @_;
480    
481      my @nodes = (@{$todo->{node}->child_nodes});      ## NOTE: metadata elements, followed by atom:entry* (no explicit MAY)
482      my $new_todos = [];  
483        if ($self->{minus_elements}->{$child_nsuri}->{$child_ln}) {
484      ## TODO: MUST author+ unless all entry child has author+.        $self->{onerror}->(node => $child_el,
485                             type => 'element not allowed:minus',
486      my $has_element = {};                           level => $self->{must_level});
487      while (@nodes) {      } elsif ($self->{plus_elements}->{$child_nsuri}->{$child_ln}) {
488        my $node = shift @nodes;        #
489        $self->_remove_minuses ($node) and next if ref $node eq 'HASH';      } elsif ($child_nsuri eq $ATOM_NS) {
490                  ## TODO: MUST author+ unless all entry child has author+.
491        my $nt = $node->node_type;        my $not_allowed;
492        if ($nt == 1) {        if ($child_ln eq 'entry') {
493          my $nsuri = $node->namespace_uri;          $element_state->{has_element}->{entry} = 1;
494          $nsuri = '' unless defined $nsuri;        } elsif ({ # MUST (0, 1)
495          my $ln = $node->manakai_local_name;                  generator => 1,
496          my $not_allowed;                  icon => 1,
497          if ($self->{pluses}->{$nsuri}->{$ln}) {                  id => 1,
498            #                  logo => 1,
499          } elsif ($nsuri eq $ATOM_NS) {                  rights => 1,
500            if ($ln eq 'entry') {                  subtitle => 1,
501              $has_element->{entry} = 1;                  title => 1,
502            } elsif ({ # MUST (0, 1)                  updated => 1,
503                 generator => 1,                 }->{$child_ln}) {
504                 icon => 1,          unless ($element_state->{has_element}->{$child_ln}) {
505                 id => 1,            $element_state->{has_element}->{$child_ln} = 1;
506                 logo => 1,            $not_allowed = $element_state->{has_element}->{entry};
                rights => 1,  
                subtitle => 1,  
                title => 1,  
                updated => 1,  
               }->{$ln}) {  
             unless ($has_element->{$ln}) {  
               $has_element->{$ln} = 1;  
               $not_allowed = $has_element->{entry};  
             } else {  
               $not_allowed = 1;  
             }  
           } elsif ($ln eq 'link') {  
             my $rel = $node->rel;  
             if ($rel eq $LINK_REL . 'alternate') {  
               my $type = $node->get_attribute_ns (undef, 'type');  
               $type = '' unless defined $type;  
               my $hreflang = $node->get_attribute_ns (undef, 'hreflang');  
               $hreflang = '' unless defined $hreflang;  
               my $key = 'link:'.(defined $type ? ':'.$type : '').':'.  
                   (defined $hreflang ? ':'.$hreflang : '');  
               unless ($has_element->{$key}) {  
                 $has_element->{$key} = 1;  
               } else {  
                 $not_allowed = 1;  
               }  
             } elsif ($rel eq $LINK_REL . 'self') {  
               $has_element->{'link.self'} = 1;  
             }  
               
             ## NOTE: MAY  
             $not_allowed = $has_element->{entry};  
           } elsif ({ # MAY  
                     author => 1,  
                     category => 1,  
                     contributor => 1,  
                    }->{$ln}) {  
             $not_allowed = $has_element->{entry};  
           } else {  
             $not_allowed = 1;  
           }  
507          } else {          } else {
           ## TODO: extension element  
508            $not_allowed = 1;            $not_allowed = 1;
509          }          }
510          $self->{onerror}->(node => $node, type => 'element not allowed')        } elsif ($child_ln eq 'link') {
511              if $not_allowed;          my $rel = $child_el->rel;
512          my ($sib, $ch) = $self->_check_get_children ($node, $todo);          if ($rel eq $LINK_REL . 'alternate') {
513          unshift @nodes, @$sib;            my $type = $child_el->get_attribute_ns (undef, 'type');
514          push @$new_todos, @$ch;            $type = '' unless defined $type;
515        } elsif ($nt == 3 or $nt == 4) {            my $hreflang = $child_el->get_attribute_ns (undef, 'hreflang');
516          ## TODO: Are white spaces allowed?            $hreflang = '' unless defined $hreflang;
517          $self->{onerror}->(node => $node, type => 'character not allowed');            my $key = 'link:'.(defined $type ? ':'.$type : '').':'.
518          if ($node->data =~ /[^\x09-\x0D\x20]/) {                (defined $hreflang ? ':'.$hreflang : '');
519            $todo->{flag}->{has_descendant}->{significant} = 1;            unless ($element_state->{has_element}->{$key}) {
520                $element_state->{has_element}->{$key} = 1;
521              } else {
522                $not_allowed = 1;
523              }
524            } elsif ($rel eq $LINK_REL . 'self') {
525              $element_state->{has_element}->{'link.self'} = 1;
526          }          }
527        } elsif ($nt == 5) {          
528          unshift @nodes, @{$node->child_nodes};          ## NOTE: MAY
529            $not_allowed = $element_state->{has_element}->{entry};
530          } elsif ({ # MAY
531                    author => 1,
532                    category => 1,
533                    contributor => 1,
534                   }->{$child_ln}) {
535            $not_allowed = $element_state->{has_element}->{entry};
536          } else {
537            $not_allowed = 1;
538        }        }
539          $self->{onerror}->(node => $child_el, type => 'element not allowed')
540              if $not_allowed;
541        } else {
542          ## TODO: extension element
543          $self->{onerror}->(node => $child_el, type => 'element not allowed');
544      }      }
545      },
546      ## NOTE: metadata elements, followed by atom:entry* (no explicit MAY)    check_child_text => sub {
547        my ($self, $item, $child_node, $has_significant, $element_state) = @_;
548        if ($has_significant) {
549          $self->{onerror}->(node => $child_node, type => 'character not allowed',
550                             level => $self->{must_level});
551        }
552      },
553      check_end => sub {
554        my ($self, $item, $element_state) = @_;
555    
556      ## TODO: If entry's with same id, then updated SHOULD be different      ## TODO: If entry's with same id, then updated SHOULD be different
557    
558      unless ($has_element->{id}) { # MUST      unless ($element_state->{has_element}->{id}) { # MUST
559        $self->{onerror}->(node => $todo->{node},        $self->{onerror}->(node => $item->{node},
560                           type => 'element missing:atom.id');                           type => 'element missing:atom|id');
561      }      }
562      unless ($has_element->{title}) { # MUST      unless ($element_state->{has_element}->{title}) { # MUST
563        $self->{onerror}->(node => $todo->{node},        $self->{onerror}->(node => $item->{node},
564                           type => 'element missing:atom.title');                           type => 'element missing:atom|title');
565      }      }
566      unless ($has_element->{updated}) { # MUST      unless ($element_state->{has_element}->{updated}) { # MUST
567        $self->{onerror}->(node => $todo->{node},        $self->{onerror}->(node => $item->{node},
568                           type => 'element missing:atom.updated');                           type => 'element missing:atom|updated');
569      }      }
570      unless ($has_element->{'link.self'}) {      unless ($element_state->{has_element}->{'link.self'}) {
571        $self->{onerror}->(node => $todo->{node}, level => 's',        $self->{onerror}->(node => $item->{node}, level => 's',
572                           type => 'child element missing:atom.link.self');                           type => 'element missing:atom|link|self');
573      }      }
574    
575      return ($new_todos);      $AtomChecker{check_end}->(@_);
576    },    },
577  };  };
578    
579  $Element->{$ATOM_NS}->{content} = {  $Element->{$ATOM_NS}->{content} = {
580    attrs_checker => $GetAtomAttrsChecker->({    %AtomChecker,
581      src => sub { 1 }, # checked in |checker|    check_start => sub {
582      type => sub { 1 }, # checked in |checker|      my ($self, $item, $element_state) = @_;
583    }),      $element_state->{type} = 'text';
584    checker => sub {    },
585      my ($self, $todo) = @_;    check_attrs => $GetAtomAttrsChecker->({
586        src => sub {
587          my ($self, $attr, $item, $element_state) = @_;
588    
589          $element_state->{has_src} = 1;
590    
591      my $attr = $todo->{node}->get_attribute_node_ns (undef, 'type');        ## NOTE: There MUST NOT be any white space.
592      my $src_attr = $todo->{node}->get_attribute_node_ns (undef, 'src');        Whatpm::URIChecker->check_iri_reference ($attr->value, sub {
593      my $value;          my %opt = @_;
594      if ($attr) {          $self->{onerror}->(node => $item->{node}, level => $opt{level},
595        $value = $attr->value;                             type => 'URI::'.$opt{type}.
596                               (defined $opt{position} ? ':'.$opt{position} : ''));
597          });
598        },
599        type => sub {
600          my ($self, $attr, $item, $element_state) = @_;
601    
602          $element_state->{has_type} = 1;
603    
604          my $value = $attr->value;
605        if ($value eq 'text' or $value eq 'html' or $value eq 'xhtml') {        if ($value eq 'text' or $value eq 'html' or $value eq 'xhtml') {
606          # MUST          # MUST
607        } else {        } else {
608          ## NOTE: MUST be a MIME media type.  What is "MIME media type"?          ## NOTE: MUST be a MIME media type.  What is "MIME media type"?
         my $value = $attr->value;  
609          my $lws0 = qr/(?>(?>\x0D\x0A)?[\x09\x20])*/;          my $lws0 = qr/(?>(?>\x0D\x0A)?[\x09\x20])*/;
610          my $token = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7E]+/;          my $token = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7E]+/;
611          my $qs = qr/"(?>[\x00-\x0C\x0E-\x21\x23-\x5B\x5D-\x7E]|\x0D\x0A[\x09\x20]|\x5C[\x00-\x7F])*"/;          my $qs = qr/"(?>[\x00-\x0C\x0E-\x21\x23-\x5B\x5D-\x7E]|\x0D\x0A[\x09\x20]|\x5C[\x00-\x7F])*"/;
# Line 714  $Element->{$ATOM_NS}->{content} = { Line 629  $Element->{$ATOM_NS}->{content} = {
629                                 type => 'IMT:'.$opt{type});                                 type => 'IMT:'.$opt{type});
630            }, @type);            }, @type);
631          } else {          } else {
632            $self->{onerror}->(node => $attr, type => 'IMT:syntax error');            $self->{onerror}->(node => $attr, type => 'IMT:syntax error',
633                                 level => $self->{must_level});
634          }          }
635        }        }
     } elsif ($src_attr) {  
       $value = '';  
       $self->{onerror}->(node => $todo->{node},  
                          type => 'attribute missing:type', level => 's');  
     } else {  
       $value = 'text';  
     }  
   
     ## TODO: This implementation is not optimal.  
636    
637      if ($src_attr) {        if ($value =~ m![+/][Xx][Mm][Ll]\z!) {
638        ## NOTE: There MUST NOT be any white space.          ## ISSUE: There is no definition for "XML media type" in RFC 3023.
639        Whatpm::URIChecker->check_iri_reference ($src_attr->value, sub {          ## Is |application/xml-dtd| an XML media type?
640          my %opt = @_;          $value = 'xml';
641          $self->{onerror}->(node => $todo->{node}, level => $opt{level},        } elsif ($value =~ m!^[Tt][Ee][Xx][Tt]/!) {
642                             type => 'URI::'.$opt{type}.          $value = 'mime_text';
643                             (defined $opt{position} ? ':'.$opt{position} : ''));        } elsif ($value =~ m!^(?>message|multipart)/!i) {
644        });          $self->{onerror}->(node => $attr, type => 'IMT:composite',
645                               level => $self->{must_level});
       ## NOTE: If @src, the element MUST be empty.  What is "empty"?  
       ## Is |<e><!----></e>| empty?  |<e>&e;</e>| where |&e;| has  
       ## empty replacement tree shuld be empty, since Atom is defined  
       ## in terms of XML Information Set where entities are expanded.  
       ## (but what if |&e;| is an unexpanded entity?)  
     }  
   
     if ($value eq 'text') {  
       $self->{onerror}->(node => $attr, type => 'not IMT') if $src_attr;  
   
       my @nodes = (@{$todo->{node}->child_nodes});  
       my $new_todos = [];  
         
       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->{pluses}->{$node_ns}->{$node_ln}) {  
             #  
           } else {  
             # MUST NOT  
             $self->{onerror}->(node => $node, type => 'element not allowed');  
           }  
           my ($sib, $ch) = $self->_check_get_children ($node, $todo);  
           unshift @nodes, @$sib;  
           push @$new_todos, @$ch;  
         } elsif ($nt == 3 or $nt == 4) {  
           $self->{onerror}->(node => $node, type => 'character not allowed')  
               if $src_attr;  
           if ($node->data =~ /[^\x09-\x0D\x20]/) {  
             $todo->{flag}->{has_descendant}->{significant} = 1;  
           }              
         } elsif ($nt == 5) {  
           unshift @nodes, @{$node->child_nodes};  
         }  
646        }        }
647    
648        return ($new_todos);        $element_state->{type} = $value;
649      } elsif ($value eq 'html') {      },
650        $self->{onerror}->(node => $attr, type => 'not IMT') if $src_attr;    }, {
651        src => FEATURE_RFC4287,
652        my @nodes = (@{$todo->{node}->child_nodes});      type => FEATURE_RFC4287,
653        my $new_todos = [];    }),
654            check_child_element => sub {
655        while (@nodes) {      my ($self, $item, $child_el, $child_nsuri, $child_ln,
656          my $node = shift @nodes;          $child_is_transparent, $element_state) = @_;
657          $self->_remove_minuses ($node) and next if ref $node eq 'HASH';  
658                if ($self->{minus_elements}->{$child_nsuri}->{$child_ln}) {
659          my $nt = $node->node_type;        $self->{onerror}->(node => $child_el,
660          if ($nt == 1) {                           type => 'element not allowed:minus',
661            my $node_ns = $node->namespace_uri;                           level => $self->{must_level});
662            $node_ns = '' unless defined $node_ns;      } elsif ($self->{plus_elements}->{$child_nsuri}->{$child_ln}) {
663            my $node_ln = $node->manakai_local_name;        #
664            if ($self->{pluses}->{$node_ns}->{$node_ln}) {      } else {
665              #        if ($element_state->{type} eq 'text' or
666            } else {            $element_state->{type} eq 'html' or
667              # MUST NOT            $element_state->{type} eq 'mime_text') {
668              $self->{onerror}->(node => $node, type => 'element not allowed');          # MUST NOT
669            }          $self->{onerror}->(node => $child_el,
670            my ($sib, $ch) = $self->_check_get_children ($node, $todo);                             type => 'element not allowed:atom|content',
671            unshift @nodes, @$sib;                             level => $self->{must_level});
672            push @$new_todos, @$ch;        } elsif ($element_state->{type} eq 'xhtml') {
673          } elsif ($nt == 3 or $nt == 4) {          if ($element_state->{has_div}) {
674            $self->{onerror}->(node => $node, type => 'character not allowed')            $self->{onerror}->(node => $child_el,
675                if $src_attr;                               type => 'element not allowed:atom|content',
676            if ($node->data =~ /[^\x09-\x0D\x20]/) {                               level => $self->{must_level});
677              $todo->{flag}->{has_descendant}->{significant} = 1;          } else {
678            }            ## TODO: SHOULD be suitable for handling as HTML [XHTML10]
679          } elsif ($nt == 5) {            $element_state->{has_div} = 1;
680            unshift @nodes, @{$node->child_nodes};          }
681          } elsif ($element_state->{type} eq 'xml') {
682            ## MAY contain elements
683            if ($element_state->{has_src}) {
684              $self->{onerror}->(node => $child_el,
685                                 type => 'element not allowed:atom|content',
686                                 level => $self->{must_level});
687          }          }
688          } else {
689            ## NOTE: Elements are not explicitly disallowed.
690        }        }
691        }
692      },
693      ## NOTE: If @src, the element MUST be empty.  What is "empty"?
694      ## Is |<e><!----></e>| empty?  |<e>&e;</e>| where |&e;| has
695      ## empty replacement tree shuld be empty, since Atom is defined
696      ## in terms of XML Information Set where entities are expanded.
697      ## (but what if |&e;| is an unexpanded entity?)
698      check_child_text => sub {
699        my ($self, $item, $child_node, $has_significant, $element_state) = @_;    
700        if ($has_significant) {
701          if ($element_state->{has_src}) {
702            $self->{onerror}->(node => $child_node,
703                               type => 'character not allowed',
704                               level => $self->{must_level});
705          } elsif ($element_state->{type} eq 'xhtml' or
706                   $element_state->{type} eq 'xml') {
707            $self->{onerror}->(node => $child_node,
708                               type => 'character not allowed:atom|content',
709                               level => $self->{must_level});
710          }
711        }
712    
713        ## type=html
714        ## TODO: SHOULD be suitable for handling as HTML [HTML4]        ## TODO: SHOULD be suitable for handling as HTML [HTML4]
715        # markup MUST be escaped        # markup MUST be escaped
716        ## TODO: HTML SHOULD be valid as if within <div>        ## TODO: HTML SHOULD be valid as if within <div>
717    
718        return ($new_todos);      ## NOTE: type=text/* has no further restriction (i.e. the content don't
719      } elsif ($value eq 'xhtml') {      ## have to conform to the definition of the type).
720        $self->{onerror}->(node => $attr, type => 'not IMT') if $src_attr;    },
721      check_end => sub {
722        my @nodes = (@{$todo->{node}->child_nodes});      my ($self, $item, $element_state) = @_;
       my $new_todos = [];  
         
       my $has_div;  
       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) {  
           # MUST  
           my $nsuri = $node->namespace_uri;  
           $nsuri = '' unless defined $nsuri;  
           my $node_ln = $node->manakai_local_name;  
           if ($self->{pluses}->{$nsuri}->{$node_ln}) {  
             #  
           } elsif ($nsuri eq q<http://www.w3.org/1999/xhtml> and  
                    $node_ln eq 'div' and not $has_div) {  
             ## TODO: SHOULD be suitable for handling as HTML [XHTML10]  
             $has_div = 1;  
             $self->{onerror}->(node => $node, type => 'element not allowed')  
                 if $src_attr;  
           } else {  
             $self->{onerror}->(node => $node, type => 'element not allowed');  
           }  
           my ($sib, $ch) = $self->_check_get_children ($node, $todo);  
           unshift @nodes, @$sib;  
           push @$new_todos, @$ch;  
         } elsif ($nt == 3 or $nt == 4) {  
           ## TODO: Are white spaces allowed?  
           $self->{onerror}->(node => $node, type => 'character not allowed');  
           if ($node->data =~ /[^\x09-\x0D\x20]/) {  
             $todo->{flag}->{has_descendant}->{significant} = 1;  
           }  
         } elsif ($nt == 5) {  
           unshift @nodes, @{$node->child_nodes};  
         }  
       }  
723    
724        unless ($has_div) {      if ($element_state->{has_src}) {
725          $self->{onerror}->(node => $todo->{node},        if (not $element_state->{has_type}) {
726                             type => 'element missing:div');          $self->{onerror}->(node => $item->{node},
727                               type => 'attribute missing:type',
728                               level => $self->{should_level});
729          }
730          if ($element_state->{type} eq 'text' or
731              $element_state->{type} eq 'html' or
732              $element_state->{type} eq 'xhtml') {
733            $self->{onerror}
734                ->(node => $item->{node}->get_attribute_node_ns (undef, 'type'),
735                   type => 'not IMT', level => $self->{must_level});
736        }        }
737        }
738    
739        return ($new_todos);      if ($element_state->{type} eq 'xhtml') {
740      } elsif ($value =~ m![+/][Xx][Mm][Ll]\z!) {        unless ($element_state->{has_div}) {
741        ## ISSUE: There is no definition for "XML media type" in RFC 3023.          $self->{onerror}->(node => $item->{node},
742        ## Is |application/xml-dtd| an XML media type?                             type => 'element missing:div',
743                               level => $self->{must_level});
       my @nodes = (@{$todo->{node}->child_nodes});  
       my $new_todos = [];  
         
       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) {  
           ## MAY contain elements  
           if ($src_attr) {  
             my $node_ns = $node->namespace_uri;  
             $node_ns = '' unless defined $node_ns;  
             my $node_ln = $node->manakai_local_name;  
             if ($self->{pluses}->{$node_ns}->{$node_ln}) {  
               #  
             } else {  
               $self->{onerror}->(node => $node, type => 'element not allowed');  
             }  
           }  
           my ($sib, $ch) = $self->_check_get_children ($node, $todo);  
           unshift @nodes, @$sib;  
           push @$new_todos, @$ch;  
         } elsif ($nt == 3 or $nt == 4) {  
           ## TODO: Are white spaces allowed?  
           $self->{onerror}->(node => $node, type => 'character not allowed');  
           if ($node->data =~ /[^\x09-\x0D\x20]/) {  
             $todo->{flag}->{has_descendant}->{significant} = 1;  
           }  
         } elsif ($nt == 5) {  
           unshift @nodes, @{$node->child_nodes};  
         }  
744        }        }
745        } elsif ($element_state->{type} eq 'xml') {
746        ## NOTE: SHOULD be suitable for handling as $value.        ## NOTE: SHOULD be suitable for handling as $value.
747        ## If no @src, this would normally mean it contains a        ## If no @src, this would normally mean it contains a
748        ## single child element that would serve as the root element.        ## single child element that would serve as the root element.
749        $self->{onerror}->(node => $todo->{node}, level => 'unsupported',        $self->{onerror}->(node => $item->{node},
750                           type => 'content:'.$value);                           level => $self->{unsupported_level},
751                             type => 'atom|content not supported',
752        return ($new_todos);                           value => $item->{node}->get_attribute_ns
753      } elsif ($value =~ m!^[Tt][Ee][Xx][Tt]/!) {                               (undef, 'type'));
754        my @nodes = (@{$todo->{node}->child_nodes});      } elsif ($element_state->{type} eq 'text' or
755        my $new_todos = [];               $element_state->{type} eq 'html' or
756                       $element_state->{type} eq 'mime-text') {
757        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->{pluses}->{$node_ns}->{$node_ln}) {  
             #  
           } else {  
             # MUST NOT  
             $self->{onerror}->(node => $node, type => 'element not allowed');  
           }  
           my ($sib, $ch) = $self->_check_get_children ($node, $todo);  
           unshift @nodes, @$sib;  
           push @$new_todos, @$ch;  
         } elsif ($nt == 3 or $nt == 4) {  
           $self->{onerror}->(node => $node, type => 'character not allowed')  
               if $src_attr;  
           if ($node->data =~ /[^\x09-\x0D\x20]/) {  
             $todo->{flag}->{has_descendant}->{significant} = 1;  
           }  
         } elsif ($nt == 5) {  
           unshift @nodes, @{$node->child_nodes};  
         }  
       }  
   
       ## NOTE: No further restriction (such as to conform to the type).  
   
       return ($new_todos);  
758      } else {      } else {
       my @nodes = (@{$todo->{node}->child_nodes});  
       my $new_todos = [];  
   
       if ($value =~ m!^(?>message|multipart)/!i) { # MUST NOT  
         $self->{onerror}->(node => $attr, type => 'IMT:composite');  
       }  
   
       my $s = '';  
       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) {  
           ## not explicitly disallowed  
           $self->{onerror}->(node => $node, type => 'element not allowed');  
           my ($sib, $ch) = $self->_check_get_children ($node, $todo);  
           unshift @nodes, @$sib;  
           push @$new_todos, @$ch;  
         } elsif ($nt == 3 or $nt == 4) {  
           $s .= $node->data;  
           $self->{onerror}->(node => $node, type => 'character not allowed')  
               if $src_attr;  
           if ($node->data =~ /[^\x09-\x0D\x20]/) {  
             $todo->{flag}->{has_descendant}->{significant} = 1;  
           }  
         } elsif ($nt == 5) {  
           unshift @nodes, @{$node->child_nodes};  
         }  
       }  
   
759        ## TODO: $s = valid Base64ed [RFC 3548] where        ## TODO: $s = valid Base64ed [RFC 3548] where
760        ## MAY leading and following "white space" (what?)        ## MAY leading and following "white space" (what?)
761        ## and lines separated by a single U+000A        ## and lines separated by a single U+000A
762    
763        ## NOTE: SHOULD be suitable for the indicated media type.        ## NOTE: SHOULD be suitable for the indicated media type.
764        $self->{onerror}->(node => $todo->{node}, level => 'unsupported',        $self->{onerror}->(node => $item->{node},
765                           type => 'content:'.$value);                           level => $self->{unsupported_level},
766                             type => 'atom|content not supported',
767        return ($new_todos);                           value => $item->{node}->get_attribute_ns
768                                 (undef, 'type'));
769      }      }
770    
771        $AtomChecker{check_end}->(@_);
772    },    },
773  };  };
774  ## TODO: Tests for <html:nest/> in <atom:content/>  ## TODO: Tests for <html:nest/> in <atom:content/>
775    
776  $Element->{$ATOM_NS}->{author} = $AtomPersonConstruct;  $Element->{$ATOM_NS}->{author} = \%AtomPersonConstruct;
777    
778  $Element->{$ATOM_NS}->{category} = {  $Element->{$ATOM_NS}->{category} = {
779    attrs_checker => $GetAtomAttrsChecker->({    %AtomChecker,
780      check_attrs => $GetAtomAttrsChecker->({
781      label => sub { 1 }, # no value constraint      label => sub { 1 }, # no value constraint
782      scheme => sub { # NOTE: No MUST.      scheme => sub { # NOTE: No MUST.
783        my ($self, $attr) = @_;        my ($self, $attr) = @_;
# Line 1009  $Element->{$ATOM_NS}->{category} = { Line 789  $Element->{$ATOM_NS}->{category} = {
789                             (defined $opt{position} ? ':'.$opt{position} : ''));                             (defined $opt{position} ? ':'.$opt{position} : ''));
790        });        });
791      },      },
792      term => sub { 1 }, # no value constraint      term => sub {
793          my ($self, $attr, $item, $element_state) = @_;
794          
795          ## NOTE: No value constraint.
796          
797          $element_state->{has_term} = 1;
798        },
799      }, {
800        label => FEATURE_RFC4287,
801        scheme => FEATURE_RFC4287,
802        term => FEATURE_RFC4287,
803    }),    }),
804    checker => sub {    check_end => sub {
805      my ($self, $todo) = @_;      my ($self, $item, $element_state) = @_;
806        unless ($element_state->{has_term}) {
807      unless ($todo->{node}->has_attribute_ns (undef, 'term')) {        $self->{onerror}->(node => $item->{node},
       $self->{onerror}->(node => $todo->{node},  
808                           type => 'attribute missing:term');                           type => 'attribute missing:term');
809      }      }
810    
811      my @nodes = (@{$todo->{node}->child_nodes});      $AtomChecker{check_end}->(@_);
     my $new_todos = [];  
       
     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 ($sib, $ch) = $self->_check_get_children ($node, $todo);  
         unshift @nodes, @$sib;  
         push @$new_todos, @$ch;  
       } elsif ($nt == 3 or $nt == 4) {  
         if ($node->data =~ /[^\x09-\x0D\x20]/) {  
           $todo->{flag}->{has_descendant}->{significant} = 1;  
         }  
       } elsif ($nt == 5) {  
         unshift @nodes, @{$node->child_nodes};  
       }  
     }  
   
     return ($new_todos);  
812    },    },
813      ## NOTE: Meaning of content is not defined.
814  };  };
815    
816  $Element->{$ATOM_NS}->{contributor} = $AtomPersonConstruct;  $Element->{$ATOM_NS}->{contributor} = \%AtomPersonConstruct;
817    
818  ## TODO: Anything below does not support <html:nest/> yet.  ## TODO: Anything below does not support <html:nest/> yet.
819    
820  $Element->{$ATOM_NS}->{generator} = {  $Element->{$ATOM_NS}->{generator} = {
821    attrs_checker => $GetAtomAttrsChecker->({    %AtomChecker,
822      check_attrs => $GetAtomAttrsChecker->({
823      uri => sub { # MUST      uri => sub { # MUST
824        my ($self, $attr) = @_;        my ($self, $attr) = @_;
825        ## NOTE: There MUST NOT be any white space.        ## NOTE: There MUST NOT be any white space.
# Line 1063  $Element->{$ATOM_NS}->{generator} = { Line 833  $Element->{$ATOM_NS}->{generator} = {
833        ## that is relevant to the agent.        ## that is relevant to the agent.
834      },      },
835      version => sub { 1 }, # no value constraint      version => sub { 1 }, # no value constraint
836      }, {
837        uri => FEATURE_RFC4287,
838        version => FEATURE_RFC4287,
839    }),    }),
   checker => sub {  
     my ($self, $todo) = @_;  
840    
841      my @nodes = (@{$todo->{node}->child_nodes});    ## NOTE: Elements are not explicitly disallowed.
     my $new_todos = [];  
       
     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) {  
         ## not explicitly disallowed  
         $self->{onerror}->(node => $node, type => 'element not allowed');  
         my ($sib, $ch) = $self->_check_get_children ($node, $todo);  
         unshift @nodes, @$sib;  
         push @$new_todos, @$ch;  
       } elsif ($nt == 3 or $nt == 4) {  
         ## MUST be a string that is a human-readable name for  
         ## the generating agent  
         if ($node->data =~ /[^\x09-\x0D\x20]/) {  
           $todo->{flag}->{has_descendant}->{significant} = 1;  
         }  
       } elsif ($nt == 5) {  
         unshift @nodes, @{$node->child_nodes};  
       }  
     }  
842    
843      return ($new_todos);    ## NOTE: Content MUST be a string that is a human-readable name for
844    },    ## the generating agent.
845  };  };
846    
847  $Element->{$ATOM_NS}->{icon} = {  $Element->{$ATOM_NS}->{icon} = {
848    attrs_checker => $GetAtomAttrsChecker->({}),    %AtomChecker,
849    checker => sub {    check_start =>  sub {
850      my ($self, $todo) = @_;      my ($self, $item, $element_state) = @_;
851        $element_state->{value} = '';
852      my @nodes = (@{$todo->{node}->child_nodes});    },
853      my $new_todos = [];    ## NOTE: Elements are not explicitly disallowed.
854          check_child_text => sub {
855      my $s = '';      my ($self, $item, $child_node, $has_significant, $element_state) = @_;
856      while (@nodes) {      $element_state->{value} .= $child_node->data;
857        my $node = shift @nodes;    },
858        $self->_remove_minuses ($node) and next if ref $node eq 'HASH';    check_end => sub {
859              my ($self, $item, $element_state) = @_;
       my $nt = $node->node_type;  
       if ($nt == 1) {  
         ## not explicitly disallowed  
         $self->{onerror}->(node => $node, type => 'element not allowed');  
         my ($sib, $ch) = $self->_check_get_children ($node, $todo);  
         unshift @nodes, @$sib;  
         push @$new_todos, @$ch;  
       } elsif ($nt == 3 or $nt == 4) {  
         $s .= $node->data;  
         if ($node->data =~ /[^\x09-\x0D\x20]/) {  
           $todo->{flag}->{has_descendant}->{significant} = 1;  
         }  
       } elsif ($nt == 5) {  
         unshift @nodes, @{$node->child_nodes};  
       }  
     }  
860    
861      ## NOTE: No MUST.      ## NOTE: No MUST.
862      ## NOTE: There MUST NOT be any white space.      ## NOTE: There MUST NOT be any white space.
863      Whatpm::URIChecker->check_iri_reference ($s, sub {      Whatpm::URIChecker->check_iri_reference ($element_state->{value}, sub {
864        my %opt = @_;        my %opt = @_;
865        $self->{onerror}->(node => $todo->{node}, level => $opt{level},        $self->{onerror}->(node => $item->{node}, level => $opt{level},
866                           type => 'URI::'.$opt{type}.                           type => 'URI::'.$opt{type}.
867                           (defined $opt{position} ? ':'.$opt{position} : ''));                           (defined $opt{position} ? ':'.$opt{position} : ''));
868      });      });
869    
870      ## NOTE: Image SHOULD be 1:1 and SHOULD be small      ## NOTE: Image SHOULD be 1:1 and SHOULD be small
871    
872      return ($new_todos);      $AtomChecker{check_end}->(@_);
873    },    },
874  };  };
875    
876  $Element->{$ATOM_NS}->{id} = {  $Element->{$ATOM_NS}->{id} = {
877    attrs_checker => $GetAtomAttrsChecker->({}),    %AtomChecker,
878    checker => sub {    check_start =>  sub {
879      my ($self, $todo) = @_;      my ($self, $item, $element_state) = @_;
880        $element_state->{value} = '';
881      my @nodes = (@{$todo->{node}->child_nodes});    },
882      my $new_todos = [];    ## NOTE: Elements are not explicitly disallowed.
883      check_child_text => sub {
884      my $s = '';      my ($self, $item, $child_node, $has_significant, $element_state) = @_;
885      while (@nodes) {      $element_state->{value} .= $child_node->data;
886        my $node = shift @nodes;    },
887        $self->_remove_minuses ($node) and next if ref $node eq 'HASH';    check_end => sub {
888              my ($self, $item, $element_state) = @_;
       my $nt = $node->node_type;  
       if ($nt == 1) {  
         ## not explicitly disallowed  
         $self->{onerror}->(node => $node, type => 'element not allowed');  
         my ($sib, $ch) = $self->_check_get_children ($node, $todo);  
         unshift @nodes, @$sib;  
         push @$new_todos, @$ch;  
       } elsif ($nt == 3 or $nt == 4) {  
         $s .= $node->data;  
         if ($node->data =~ /[^\x09-\x0D\x20]/) {  
           $todo->{flag}->{has_descendant}->{significant} = 1;  
         }  
       } elsif ($nt == 5) {  
         unshift @nodes, @{$node->child_nodes};  
       }  
     }  
889    
890      ## NOTE: There MUST NOT be any white space.      ## NOTE: There MUST NOT be any white space.
891      Whatpm::URIChecker->check_iri ($s, sub { # MUST      Whatpm::URIChecker->check_iri ($element_state->{value}, sub {
892        my %opt = @_;        my %opt = @_;
893        $self->{onerror}->(node => $todo->{node}, level => $opt{level},        $self->{onerror}->(node => $item->{node}, level => $opt{level},
894                           type => 'URI::'.$opt{type}.                           type => 'URI::'.$opt{type}.
895                           (defined $opt{position} ? ':'.$opt{position} : ''));                           (defined $opt{position} ? ':'.$opt{position} : ''));
896      });      });
897      ## TODO: SHOULD be normalized      ## TODO: SHOULD be normalized
898    
899      return ($new_todos);      $AtomChecker{check_end}->(@_);
900    },    },
901  };  };
902    
903  $Element->{$ATOM_NS}->{link} = {  $Element->{$ATOM_NS}->{link} = {
904    attrs_checker => $GetAtomAttrsChecker->({    %AtomChecker,
905      check_attrs => $GetAtomAttrsChecker->({
906      href => sub {      href => sub {
907        my ($self, $attr) = @_;        my ($self, $attr) = @_;
908        ## NOTE: There MUST NOT be any white space.        ## NOTE: There MUST NOT be any white space.
# Line 1246  $Element->{$ATOM_NS}->{link} = { Line 963  $Element->{$ATOM_NS}->{link} = {
963          $self->{onerror}->(node => $attr, type => 'IMT:syntax error');          $self->{onerror}->(node => $attr, type => 'IMT:syntax error');
964        }        }
965      },      },
966      }, {
967        href => FEATURE_RFC4287,
968        hreflang => FEATURE_RFC4287,
969        length => FEATURE_RFC4287,
970        rel => FEATURE_RFC4287,
971        title => FEATURE_RFC4287,
972        type => FEATURE_RFC4287,
973    }),    }),
974    checker => sub {    check_start =>  sub {
975      my ($self, $todo) = @_;      my ($self, $item, $element_state) = @_;
976    
977      unless ($todo->{node}->has_attribute_ns (undef, 'href')) { # MUST      unless ($item->{node}->has_attribute_ns (undef, 'href')) { # MUST
978        $self->{onerror}->(node => $todo->{node},        $self->{onerror}->(node => $item->{node},
979                           type => 'attribute missing:href');                           type => 'attribute missing:href');
980      }      }
981    
982      if ($todo->{node}->rel eq $LINK_REL . 'enclosure' and      if ($item->{node}->rel eq $LINK_REL . 'enclosure' and
983          not $todo->{node}->has_attribute_ns (undef, 'length')) {          not $item->{node}->has_attribute_ns (undef, 'length')) {
984        $self->{onerror}->(node => $todo->{node}, level => 's',        $self->{onerror}->(node => $item->{node}, level => 's',
985                           type => 'attribute missing:length');                           type => 'attribute missing:length');
986      }      }
   
     my @nodes = (@{$todo->{node}->child_nodes});  
     my $new_todos = [];  
       
     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 ($sib, $ch) = $self->_check_get_children ($node, $todo);  
         unshift @nodes, @$sib;  
         push @$new_todos, @$ch;  
       } elsif ($nt == 3 or $nt == 4) {  
         if ($node->data =~ /[^\x09-\x0D\x20]/) {  
           $todo->{flag}->{has_descendant}->{significant} = 1;  
         }  
       } elsif ($nt == 5) {  
         unshift @nodes, @{$node->child_nodes};  
       }  
     }  
   
     return ($new_todos);  
987    },    },
988  };  };
989    
990  $Element->{$ATOM_NS}->{logo} = {  $Element->{$ATOM_NS}->{logo} = {
991    attrs_checker => $GetAtomAttrsChecker->({}),    %AtomChecker,
992    checker => sub {    ## NOTE: Child elements are not explicitly disallowed
993      my ($self, $todo) = @_;    check_start =>  sub {
994        my ($self, $item, $element_state) = @_;
995      my @nodes = (@{$todo->{node}->child_nodes});      $element_state->{value} = '';
996      my $new_todos = [];    },
997      ## NOTE: Elements are not explicitly disallowed.
998      my $s = '';    check_child_text => sub {
999      while (@nodes) {      my ($self, $item, $child_node, $has_significant, $element_state) = @_;
1000        my $node = shift @nodes;      $element_state->{value} .= $child_node->data;
1001        $self->_remove_minuses ($node) and next if ref $node eq 'HASH';    },
1002            check_end => sub {
1003        my $nt = $node->node_type;      my ($self, $item, $element_state) = @_;  
       if ($nt == 1) {  
         ## not explicitly disallowed  
         $self->{onerror}->(node => $node, type => 'element not allowed');  
         my ($sib, $ch) = $self->_check_get_children ($node, $todo);  
         unshift @nodes, @$sib;  
         push @$new_todos, @$ch;  
       } elsif ($nt == 3 or $nt == 4) {  
         $s .= $node->data;  
         if ($node->data =~ /[^\x09-\x0D\x20]/) {  
           $todo->{flag}->{has_descendant}->{significant} = 1;  
         }  
       } elsif ($nt == 5) {  
         unshift @nodes, @{$node->child_nodes};  
       }  
     }  
1004    
1005      ## NOTE: There MUST NOT be any white space.      ## NOTE: There MUST NOT be any white space.
1006      Whatpm::URIChecker->check_iri_reference ($s, sub {      Whatpm::URIChecker->check_iri_reference ($element_state->{value}, sub {
1007        my %opt = @_;        my %opt = @_;
1008        $self->{onerror}->(node => $todo->{node}, level => $opt{level},        $self->{onerror}->(node => $item->{node}, level => $opt{level},
1009                           type => 'URI::'.$opt{type}.                           type => 'URI::'.$opt{type}.
1010                           (defined $opt{position} ? ':'.$opt{position} : ''));                           (defined $opt{position} ? ':'.$opt{position} : ''));
1011      });      });
1012            
1013      ## NOTE: Image SHOULD be 2:1      ## NOTE: Image SHOULD be 2:1
1014    
1015      return ($new_todos);      $AtomChecker{check_end}->(@_);
1016    },    },
1017  };  };
1018    
1019  $Element->{$ATOM_NS}->{published} = $AtomDateConstruct;  $Element->{$ATOM_NS}->{published} = \%AtomDateConstruct;
1020    
1021  $Element->{$ATOM_NS}->{rights} = $AtomDateConstruct;  $Element->{$ATOM_NS}->{rights} = \%AtomDateConstruct;
1022  ## NOTE: SHOULD NOT be used to convey machine-readable information.  ## NOTE: SHOULD NOT be used to convey machine-readable information.
1023    
1024  $Element->{$ATOM_NS}->{source} = {  $Element->{$ATOM_NS}->{source} = {
1025    attrs_checker => $GetAtomAttrsChecker->({}),    %AtomChecker,
1026    checker => sub {    check_child_element => sub {
1027      my ($self, $todo) = @_;      my ($self, $item, $child_el, $child_nsuri, $child_ln,
1028            $child_is_transparent, $element_state) = @_;
1029      my @nodes = (@{$todo->{node}->child_nodes});  
1030      my $new_todos = [];      if ($self->{minus_elements}->{$child_nsuri}->{$child_ln}) {
1031      my $has_element = {};        $self->{onerror}->(node => $child_el,
1032      while (@nodes) {                           type => 'element not allowed:minus',
1033        my $node = shift @nodes;                           level => $self->{must_level});
1034        $self->_remove_minuses ($node) and next if ref $node eq 'HASH';      } elsif ($self->{plus_elements}->{$child_nsuri}->{$child_ln}) {
1035                  #
1036        my $nt = $node->node_type;      } elsif ($child_nsuri eq $ATOM_NS) {
1037        if ($nt == 1) {        my $not_allowed;
1038          my $nsuri = $node->namespace_uri;        if ($child_ln eq 'entry') {
1039          $nsuri = '' unless defined $nsuri;          $element_state->{has_element}->{entry} = 1;
1040          my $not_allowed;        } elsif ({
1041          if ($nsuri eq $ATOM_NS) {                  generator => 1,
1042            my $ln = $node->manakai_local_name;                  icon => 1,
1043            if ($ln eq 'entry') {                  id => 1,
1044              $has_element->{entry} = 1;                  logo => 1,
1045            } elsif ({                  rights => 1,
1046                 generator => 1,                  subtitle => 1,
1047                 icon => 1,                  title => 1,
1048                 id => 1,                  updated => 1,
1049                 logo => 1,                 }->{$child_ln}) {
1050                 rights => 1,          unless ($element_state->{has_element}->{$child_ln}) {
1051                 subtitle => 1,            $element_state->{has_element}->{$child_ln} = 1;
1052                 title => 1,            $not_allowed = $element_state->{has_element}->{entry};
                updated => 1,  
               }->{$ln}) {  
             unless ($has_element->{$ln}) {  
               $has_element->{$ln} = 1;  
               $not_allowed = $has_element->{entry};  
             } else {  
               $not_allowed = 1;  
             }  
           } elsif ($ln eq 'link') {  
             if ($node->rel eq $LINK_REL . 'alternate') {  
               my $type = $node->get_attribute_ns (undef, 'type');  
               $type = '' unless defined $type;  
               my $hreflang = $node->get_attribute_ns (undef, 'hreflang');  
               $hreflang = '' unless defined $hreflang;  
               my $key = 'link:'.(defined $type ? ':'.$type : '').':'.  
                   (defined $hreflang ? ':'.$hreflang : '');  
               unless ($has_element->{$key}) {  
                 $has_element->{$key} = 1;  
               } else {  
                 $not_allowed = 1;  
               }  
             }  
             $not_allowed ||= $has_element->{entry};  
           } elsif ({  
                     author => 1,  
                     category => 1,  
                     contributor => 1,  
                    }->{$ln}) {  
             $not_allowed = $has_element->{entry};  
           } else {  
             $not_allowed = 1;  
           }  
1053          } else {          } else {
           ## TODO: extension element  
1054            $not_allowed = 1;            $not_allowed = 1;
1055          }          }
1056          $self->{onerror}->(node => $node, type => 'element not allowed')        } elsif ($child_ln eq 'link') {
1057              if $not_allowed;          if ($child_ln->rel eq $LINK_REL . 'alternate') {
1058          my ($sib, $ch) = $self->_check_get_children ($node, $todo);            my $type = $child_ln->get_attribute_ns (undef, 'type');
1059          unshift @nodes, @$sib;            $type = '' unless defined $type;
1060          push @$new_todos, @$ch;            my $hreflang = $child_ln->get_attribute_ns (undef, 'hreflang');
1061        } elsif ($nt == 3 or $nt == 4) {            $hreflang = '' unless defined $hreflang;
1062          ## TODO: Are white spaces allowed?            my $key = 'link:'.(defined $type ? ':'.$type : '').':'.
1063          $self->{onerror}->(node => $node, type => 'character not allowed');                (defined $hreflang ? ':'.$hreflang : '');
1064          if ($node->data =~ /[^\x09-\x0D\x20]/) {            unless ($element_state->{has_element}->{$key}) {
1065            $todo->{flag}->{has_descendant}->{significant} = 1;              $element_state->{has_element}->{$key} = 1;
1066              } else {
1067                $not_allowed = 1;
1068              }
1069          }          }
1070        } elsif ($nt == 5) {          $not_allowed ||= $element_state->{has_element}->{entry};
1071          unshift @nodes, @{$node->child_nodes};        } elsif ({
1072                    author => 1,
1073                    category => 1,
1074                    contributor => 1,
1075                   }->{$child_ln}) {
1076            $not_allowed = $element_state->{has_element}->{entry};
1077          } else {
1078            $not_allowed = 1;
1079        }        }
1080          if ($not_allowed) {
1081            $self->{onerror}->(node => $child_el, type => 'element not allowed');
1082          }
1083        } else {
1084          ## TODO: extension element
1085          $self->{onerror}->(node => $child_el, type => 'element not allowed');
1086        }
1087      },
1088      check_child_text => sub {
1089        my ($self, $item, $child_node, $has_significant, $element_state) = @_;
1090        if ($has_significant) {
1091          $self->{onerror}->(node => $child_node, type => 'character not allowed',
1092                             level => $self->{must_level});
1093      }      }
   
     return ($new_todos);  
1094    },    },
1095  };  };
1096    
1097  $Element->{$ATOM_NS}->{subtitle} = $AtomTextConstruct;  $Element->{$ATOM_NS}->{subtitle} = \%AtomTextConstruct;
1098    
1099  $Element->{$ATOM_NS}->{summary} = $AtomTextConstruct;  $Element->{$ATOM_NS}->{summary} = \%AtomTextConstruct;
1100    
1101  $Element->{$ATOM_NS}->{title} = $AtomTextConstruct;  $Element->{$ATOM_NS}->{title} = \%AtomTextConstruct;
1102    
1103  $Element->{$ATOM_NS}->{updated} = $AtomDateConstruct;  $Element->{$ATOM_NS}->{updated} = \%AtomDateConstruct;
1104    
1105  ## TODO: signature element  ## TODO: signature element
1106    
Legend:
Removed from v.1.7  
changed lines
  Added in v.1.8
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24