/[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.17 by wakaba, Thu Mar 20 10:58:17 2008 UTC
# Line 5  require Whatpm::ContentChecker; Line 5  require Whatpm::ContentChecker;
5  require Whatpm::URIChecker;  require Whatpm::URIChecker;
6    
7  my $ATOM_NS = q<http://www.w3.org/2005/Atom>;  my $ATOM_NS = q<http://www.w3.org/2005/Atom>;
8    my $THR_NS = q<http://purl.org/syndication/thread/1.0>;
9    my $FH_NS = q<http://purl.org/syndication/history/1.0>;
10  my $LINK_REL = q<http://www.iana.org/assignments/relation/>;  my $LINK_REL = q<http://www.iana.org/assignments/relation/>;
11    
12    sub FEATURE_RFC4287 () {
13      Whatpm::ContentChecker::FEATURE_STATUS_CR |
14      Whatpm::ContentChecker::FEATURE_ALLOWED
15    }
16    
17    sub FEATURE_RFC4685 () {
18      Whatpm::ContentChecker::FEATURE_STATUS_CR |
19      Whatpm::ContentChecker::FEATURE_ALLOWED
20    }
21    
22  ## 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)
23    
24  ## NOTE: Commants and PIs are not explicitly allowed.  ## NOTE: Commants and PIs are not explicitly allowed.
# Line 16  our $AttrChecker; Line 28  our $AttrChecker;
28  ## Any element MAY have xml:base, xml:lang  ## Any element MAY have xml:base, xml:lang
29  my $GetAtomAttrsChecker = sub {  my $GetAtomAttrsChecker = sub {
30    my $element_specific_checker = shift;    my $element_specific_checker = shift;
31      my $element_specific_status = shift;
32    return sub {    return sub {
33      my ($self, $todo) = @_;      my ($self, $todo, $element_state) = @_;
34      for my $attr (@{$todo->{node}->attributes}) {      for my $attr (@{$todo->{node}->attributes}) {
35        my $attr_ns = $attr->namespace_uri;        my $attr_ns = $attr->namespace_uri;
36        $attr_ns = '' unless defined $attr_ns;        $attr_ns = '' unless defined $attr_ns;
# Line 30  my $GetAtomAttrsChecker = sub { Line 43  my $GetAtomAttrsChecker = sub {
43              || $AttrChecker->{$attr_ns}->{''};              || $AttrChecker->{$attr_ns}->{''};
44        }        }
45        if ($checker) {        if ($checker) {
46          $checker->($self, $attr, $todo);          $checker->($self, $attr, $todo, $element_state);
47          } elsif ($attr_ln eq '') {
48            #
49        } else {        } else {
50          $self->{onerror}->(node => $attr, level => 'unsupported',          $self->{onerror}->(node => $attr, level => 'unsupported',
51                             type => 'attribute');                             type => 'attribute');
52          ## ISSUE: No comformance createria for unknown attributes in the spec          ## ISSUE: No comformance createria for unknown attributes in the spec
53        }        }
54    
55          if ($attr_ns eq '') {
56            $self->_attr_status_info ($attr, $element_specific_status->{$attr_ln});
57          }
58          ## TODO: global attribute
59      }      }
60    };    };
61  }; # $GetAtomAttrsChecker  }; # $GetAtomAttrsChecker
# Line 56  my $AtomLanguageTagAttrChecker = sub { Line 76  my $AtomLanguageTagAttrChecker = sub {
76    ## ISSUE: RFC 4646 (3066bis)?    ## ISSUE: RFC 4646 (3066bis)?
77  }; # $AtomLanguageTagAttrChecker  }; # $AtomLanguageTagAttrChecker
78    
79  my $AtomTextConstruct = {  my %AtomChecker = (
80    attrs_checker => $GetAtomAttrsChecker->({    %Whatpm::ContentChecker::AnyChecker,
81      type => sub { 1 }, # checked in |checker|    status => FEATURE_RFC4287,
82    }),    check_attrs => $GetAtomAttrsChecker->({}, {}),
83    checker => sub {  );
84      my ($self, $todo) = @_;  
85    my %AtomTextConstruct = (
86      my $attr = $todo->{node}->get_attribute_node_ns (undef, 'type');    %AtomChecker,
87      my $value = 'text';    check_start => sub {
88      if ($attr) {      my ($self, $item, $element_state) = @_;
89        $value = $attr->value;      $element_state->{type} = 'text';
90        if ($value eq 'text' or $value eq 'html' or $value eq 'xhtml') {      $element_state->{value} = '';
91          # MUST    },
92      check_attrs => $GetAtomAttrsChecker->({
93        type => sub {
94          my ($self, $attr, $item, $element_state) = @_;
95          my $value = $attr->value;
96          if ($value eq 'text' or $value eq 'html' or $value eq 'xhtml') { # MUST
97            $element_state->{type} = $value;
98        } else {        } else {
99            ## NOTE: IMT MUST NOT be used here.
100          $self->{onerror}->(node => $attr, type => 'keyword:invalid');          $self->{onerror}->(node => $attr, type => 'keyword:invalid');
101        }        }
102        # IMT MUST NOT be used      }, # checked in |checker|
103      }    }, {
104        type => FEATURE_RFC4287,
105      if ($value eq 'text') {    }),
106        my @nodes = (@{$todo->{node}->child_nodes});    check_child_element => sub {
107        my $new_todos = [];      my ($self, $item, $child_el, $child_nsuri, $child_ln,
108                  $child_is_transparent, $element_state) = @_;
109        while (@nodes) {      if ($self->{minus_elements}->{$child_nsuri}->{$child_ln}) {
110          my $node = shift @nodes;        $self->{onerror}->(node => $child_el,
111          $self->_remove_minuses ($node) and next if ref $node eq 'HASH';                           type => 'element not allowed:minus',
112                                     level => $self->{must_level});
113          my $nt = $node->node_type;      } elsif ($self->{plus_elements}->{$child_nsuri}->{$child_ln}) {
114          if ($nt == 1) {        #
115            # MUST NOT      } else {
116            $self->{onerror}->(node => $node, type => 'element not allowed');        if ($element_state->{type} eq 'text' or
117            my ($sib, $ch) = $self->_check_get_children ($node, $todo);            $element_state->{type} eq 'html') { # MUST NOT
118            unshift @nodes, @$sib;          $self->{onerror}->(node => $child_el,
119            push @$new_todos, @$ch;                             type => 'element not allowed:atom|TextConstruct',
120          } elsif ($nt == 5) {                             level => $self->{must_level});
121            unshift @nodes, @{$node->child_nodes};        } elsif ($element_state->{type} eq 'xhtml') {
122          }          if ($child_nsuri eq q<http://www.w3.org/1999/xhtml> and
123        }              $child_ln eq 'div') { # MUST
124              if ($element_state->{has_div}) {
125        return ($new_todos);              $self->{onerror}
126      } elsif ($value eq 'html') {                  ->(node => $child_el,
127        my @nodes = (@{$todo->{node}->child_nodes});                     type => 'element not allowed:atom|TextConstruct',
128        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;  
129            } else {            } else {
130              $self->{onerror}->(node => $node, type => 'element not allowed');              $element_state->{has_div} = 1;
131                ## TODO: SHOULD be suitable for handling as HTML [XHTML10]
132            }            }
133            my ($sib, $ch) = $self->_check_get_children ($node, $todo);          } else {
134            unshift @nodes, @$sib;            $self->{onerror}->(node => $child_el,
135            push @$new_todos, @$ch;                               type => 'element not allowed:atom|TextConstruct',
136          } 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};  
137          }          }
138          } else {
139            die "atom:TextConstruct type error: $element_state->{type}";
140        }        }
141        }
142        unless ($has_div) {    },
143          $self->{onerror}->(node => $todo->{node},    check_child_text => sub {
144                             type => 'element missing:div');      my ($self, $item, $child_node, $has_significant, $element_state) = @_;
145        if ($element_state->{type} eq 'text') {
146          #
147        } elsif ($element_state->{type} eq 'html') {
148          $element_state->{value} .= $child_node->text_content;
149          ## NOTE: Markup MUST be escaped.
150        } elsif ($element_state->{type} eq 'xhtml') {
151          if ($has_significant) {
152            $self->{onerror}->(node => $child_node,
153                               type => 'character not allowed:atom|TextConstruct',
154                               level => $self->{must_level});
155        }        }
156        } else {
157        return ($new_todos);        die "atom:TextConstruct type error: $element_state->{type}";
158      }      }
       
159    },    },
160  }; # $AtomTextConstruct    check_end => sub {
161        my ($self, $item, $element_state) = @_;
162        if ($element_state->{type} eq 'xhtml') {
163          unless ($element_state->{has_div}) {
164            $self->{onerror}->(node => $item->{node},
165                               type => 'element missing:div',
166                               level => $self->{must_level});
167          }
168        } elsif ($element_state->{type} eq 'html') {
169          ## TODO: SHOULD be suitable for handling as HTML [HTML4]
170          # markup MUST be escaped
171          $self->{onsubdoc}->({s => $element_state->{value},
172                               container_node => $item->{node},
173                               media_type => 'text/html',
174                               inner_html_element => 'div',
175                               is_char_string => 1});
176        }
177    
178  my $AtomPersonConstruct = {      $AtomChecker{check_end}->(@_);
179    attrs_checker => $GetAtomAttrsChecker->({}),    },
180    checker => sub {  ); # %AtomTextConstruct
     my ($self, $todo) = @_;  
181    
182      my @nodes = (@{$todo->{node}->child_nodes});  my %AtomPersonConstruct = (
183      my $new_todos = [];    %AtomChecker,
184            check_child_element => sub {
185      my $has_name;      my ($self, $item, $child_el, $child_nsuri, $child_ln,
186      my $has_uri;          $child_is_transparent, $element_state) = @_;
187      my $has_email;      if ($self->{minus_elements}->{$child_nsuri}->{$child_ln}) {
188      while (@nodes) {        $self->{onerror}->(node => $child_el,
189        my $node = shift @nodes;                           type => 'element not allowed:minus',
190        $self->_remove_minuses ($node) and next if ref $node eq 'HASH';                           level => $self->{must_level});
191                } elsif ($self->{plus_elements}->{$child_nsuri}->{$child_ln}) {
192        my $nt = $node->node_type;        #
193        if ($nt == 1) {      } elsif ($child_nsuri eq $ATOM_NS) {
194          # MUST        if ($child_ln eq 'name') {
195          my $nsuri = $node->namespace_uri;          if ($element_state->{has_name}) {
196          $nsuri = '' unless defined $nsuri;            $self->{onerror}
197          my $not_allowed;                ->(node => $child_el,
198          if ($nsuri eq $ATOM_NS) {                   type => 'element not allowed:atom|PersonConstruct',
199            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;  
           }  
200          } else {          } else {
201            ## TODO: extension element            $element_state->{has_name} = 1;
202            $not_allowed = 1;          }
203          } elsif ($child_ln eq 'uri') {
204            if ($element_state->{has_uri}) {
205              $self->{onerror}
206                  ->(node => $child_el,
207                     type => 'element not allowed:atom|PersonConstruct',
208                     level => $self->{must_level});
209            } else {
210              $element_state->{has_uri} = 1;
211          }          }
212          $self->{onerror}->(node => $node, type => 'element not allowed')        } elsif ($child_ln eq 'email') {
213              if $not_allowed;          if ($element_state->{has_email}) {
214          my ($sib, $ch) = $self->_check_get_children ($node, $todo);            $self->{onerror}
215          unshift @nodes, @$sib;                ->(node => $child_el,
216          push @$new_todos, @$ch;                   type => 'element not allowed:atom|PersonConstruct',
217        } elsif ($nt == 3 or $nt == 4) {                   level => $self->{must_level});
218          ## TODO: Are white spaces allowed?          } else {
219          $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;  
220          }          }
221        } elsif ($nt == 5) {        } else {
222          unshift @nodes, @{$node->child_nodes};          $self->{onerror}
223                ->(node => $child_el,
224                   type => 'element not allowed:atom|PersonConstruct',
225                   level => $self->{must_level});
226        }        }
227        } else {
228          $self->{onerror}
229              ->(node => $child_el,
230                 type => 'element not allowed:atom|PersonConstruct',
231                 level => $self->{must_level});
232      }      }
233        ## TODO: extension element
234      },
235      check_child_text => sub {
236        my ($self, $item, $child_node, $has_significant, $element_state) = @_;
237        if ($has_significant) {
238          $self->{onerror}->(node => $child_node,
239                             type => 'character not allowed:atom|PersonConstruct',
240                             level => $self->{must_level});
241        }
242      },
243      check_end => sub {
244        my ($self, $item, $element_state) = @_;
245    
246      unless ($has_name) { # MUST      unless ($element_state->{has_name}) {
247        $self->{onerror}->(node => $todo->{node},        $self->{onerror}->(node => $item->{node},
248                           type => 'element missing:atom.name');                           type => 'element missing:atom|name',
249                             level => $self->{must_level});
250      }      }
251    
252      return ($new_todos);      $AtomChecker{check_end}->(@_);
253    },    },
254  }; # $AtomPersonConstruct  ); # %AtomPersonConstruct
255    
256  our $Element;  our $Element;
257    
258    $Element->{$ATOM_NS}->{''} = {
259      %AtomChecker,
260      status => 0,
261    };
262    
263  $Element->{$ATOM_NS}->{name} = {  $Element->{$ATOM_NS}->{name} = {
264      %AtomChecker,
265    
266    ## NOTE: Strictly speaking, structure and semantics for atom:name    ## NOTE: Strictly speaking, structure and semantics for atom:name
267    ## 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};  
       }  
     }  
268    
269      return ($new_todos);    ## NOTE: No constraint.
   },  
270  };  };
271    
272  $Element->{$ATOM_NS}->{uri} = {  $Element->{$ATOM_NS}->{uri} = {
273      %AtomChecker,
274    
275    ## NOTE: Strictly speaking, structure and semantics for atom:uri    ## NOTE: Strictly speaking, structure and semantics for atom:uri
276    ## element outside of Person construct is not defined.    ## element outside of Person construct is not defined.
277    attrs_checker => $GetAtomAttrsChecker->({}),  
278    checker => sub {    ## NOTE: Elements are not explicitly disallowed.
279      my ($self, $todo) = @_;  
280      check_start => sub {
281      my @nodes = (@{$todo->{node}->child_nodes});      my ($self, $item, $element_state) = @_;
282      my $new_todos = [];      $element_state->{value} = '';
283      },
284      my $s = '';    check_child_text => sub {
285      while (@nodes) {      my ($self, $item, $child_node, $has_significant, $element_state) = @_;
286        my $node = shift @nodes;      $element_state->{value} .= $child_node->data;
287        $self->_remove_minuses ($node) and next if ref $node eq 'HASH';    },
288              check_end => sub {
289        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};  
       }  
     }  
290    
291      ## NOTE: There MUST NOT be any white space.      ## NOTE: There MUST NOT be any white space.
292      Whatpm::URIChecker->check_iri_reference ($s, sub {      Whatpm::URIChecker->check_iri_reference ($element_state->{value}, sub {
293        my %opt = @_;        my %opt = @_;
294        $self->{onerror}->(node => $todo->{node}, level => $opt{level},        $self->{onerror}->(node => $item->{node}, level => $opt{level},
295                           type => 'URI::'.$opt{type}.                           type => 'URI::'.$opt{type}.
296                           (defined $opt{position} ? ':'.$opt{position} : ''));                           (defined $opt{position} ? ':'.$opt{position} : ''));
297      });      });
298    
299      return ($new_todos);      $AtomChecker{check_end}->(@_);
300    },    },
301  };  };
302    
303  $Element->{$ATOM_NS}->{email} = {  $Element->{$ATOM_NS}->{email} = {
304      %AtomChecker,
305    
306    ## NOTE: Strictly speaking, structure and semantics for atom:email    ## NOTE: Strictly speaking, structure and semantics for atom:email
307    ## element outside of Person construct is not defined.    ## element outside of Person construct is not defined.
308    attrs_checker => $GetAtomAttrsChecker->({}),  
309    checker => sub {    ## NOTE: Elements are not explicitly disallowed.
310      my ($self, $todo) = @_;  
311      check_end => sub {
312      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};  
       }  
     }  
313    
314      ## TODO: addr-spec      ## TODO: addr-spec
315      $self->{onerror}->(node => $todo->{node}, type => 'addr-spec',      $self->{onerror}->(node => $item->{node},
316                         level => 'unsupported');                         type => 'addr-spec not supported',
317                           level => $self->{unsupported_level});
318    
319      return ($new_todos);      $AtomChecker{check_end}->(@_);
320    },    },
321  };  };
322    
323  ## MUST NOT be any white space  ## MUST NOT be any white space
324  my $AtomDateConstruct = {  my %AtomDateConstruct = (
325    attrs_checker => $GetAtomAttrsChecker->({}),    %AtomChecker,
326    checker => sub {  
327      my ($self, $todo) = @_;    ## NOTE: It does not explicitly say that there MUST NOT be any element.
328    
329      my @nodes = (@{$todo->{node}->child_nodes});    check_start => sub {
330      my $new_todos = [];      my ($self, $item, $element_state) = @_;
331        $element_state->{value} = '';
332      my $s = '';    },
333      while (@nodes) {    check_child_text => sub {
334        my $node = shift @nodes;      my ($self, $item, $child_node, $has_significant, $element_state) = @_;
335        $self->_remove_minuses ($node) and next if ref $node eq 'HASH';      $element_state->{value} .= $child_node->data;
336              },
337        my $nt = $node->node_type;    check_end => sub {
338        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};  
       }  
     }  
339    
340      ## MUST: RFC 3339 |date-time| with uppercase |T| and |Z|      ## MUST: RFC 3339 |date-time| with uppercase |T| and |Z|
341      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/) {
342        my ($y, $M, $d, $h, $m, $s, $zh, $zm)        my ($y, $M, $d, $h, $m, $s, $zh, $zm)
343            = ($1, $2, $3, $4, $5, $6, $7, $8);            = ($1, $2, $3, $4, $5, $6, $7, $8);
344        my $node = $todo->{node};        my $node = $item->{node};
345    
346        ## Check additional constraints described or referenced in        ## Check additional constraints described or referenced in
347        ## comments of ABNF rules for |date-time|.        ## comments of ABNF rules for |date-time|.
# Line 429  my $AtomDateConstruct = { Line 371  my $AtomDateConstruct = {
371        $self->{onerror}->(node => $node, type => 'datetime:bad timezone minute',        $self->{onerror}->(node => $node, type => 'datetime:bad timezone minute',
372                           level => $level) if $zm > 59;                           level => $level) if $zm > 59;
373      } else {      } else {
374        $self->{onerror}->(node => $todo->{node},        $self->{onerror}->(node => $item->{node},
375                           type => 'datetime:syntax error',                           type => 'datetime:syntax error',
376                           level => $self->{must_level});                           level => $self->{must_level});
377      }      }
378      ## NOTE: SHOULD be accurate as possible (cannot be checked)      ## NOTE: SHOULD be accurate as possible (cannot be checked)
379    
380      return ($new_todos);      $AtomChecker{check_end}->(@_);
381    },    },
382  }; # $AtomDateConstruct  ); # %AtomDateConstruct
383    
384  $Element->{$ATOM_NS}->{entry} = {  $Element->{$ATOM_NS}->{entry} = {
385      %AtomChecker,
386    is_root => 1,    is_root => 1,
387    attrs_checker => $GetAtomAttrsChecker->({}),    check_child_element => sub {
388    checker => sub {      my ($self, $item, $child_el, $child_nsuri, $child_ln,
389      my ($self, $todo) = @_;          $child_is_transparent, $element_state) = @_;
390    
391      my @nodes = (@{$todo->{node}->child_nodes});      ## NOTE: metadata elements, followed by atom:entry* (no explicit MAY)
392      my $new_todos = [];  
393        if ($self->{minus_elements}->{$child_nsuri}->{$child_ln}) {
394      ## TODO: MUST author+ unless (child::source/child::author)        $self->{onerror}->(node => $child_el,
395      ## or (parent::feed/child::author)                           type => 'element not allowed:minus',
396                             level => $self->{must_level});
397      my $has_element = {};      } elsif ($self->{plus_elements}->{$child_nsuri}->{$child_ln}) {
398      while (@nodes) {        #
399        my $node = shift @nodes;      } elsif ($child_nsuri eq $ATOM_NS) {
400        $self->_remove_minuses ($node) and next if ref $node eq 'HASH';        my $not_allowed;
401                  if ({ # MUST (0, 1)
402        my $nt = $node->node_type;             content => 1,
403        if ($nt == 1) {             id => 1,
404          # MUST             published => 1,
405          my $nsuri = $node->namespace_uri;             rights => 1,
406          $nsuri = '' unless defined $nsuri;             source => 1,
407          my $ln = $node->manakai_local_name;             summary => 1,
408          my $not_allowed;             title => 1,
409          if ($self->{pluses}->{$nsuri}->{$ln}) {             updated => 1,
410            #            }->{$child_ln}) {
411          } elsif ($nsuri eq $ATOM_NS) {          unless ($element_state->{has_element}->{$child_ln}) {
412            if ({ # MUST (0, 1)            $element_state->{has_element}->{$child_ln} = 1;
413                 content => 1,            $not_allowed = $element_state->{has_element}->{entry};
                id => 1,  
                published => 1,  
                rights => 1,  
                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;  
           }  
414          } else {          } else {
           ## TODO: extension element  
415            $not_allowed = 1;            $not_allowed = 1;
416          }          }
417          $self->{onerror}->(node => $node, type => 'element not allowed')        } elsif ($child_ln eq 'link') { # MAY
418              if $not_allowed;          if ($child_el->rel eq $LINK_REL . 'alternate') {
419          my ($sib, $ch) = $self->_check_get_children ($node, $todo);            my $type = $child_el->get_attribute_ns (undef, 'type');
420          unshift @nodes, @$sib;            $type = '' unless defined $type;
421          push @$new_todos, @$ch;            my $hreflang = $child_el->get_attribute_ns (undef, 'hreflang');
422        } elsif ($nt == 3 or $nt == 4) {            $hreflang = '' unless defined $hreflang;
423          ## TODO: Are white spaces allowed?            my $key = 'link:'.(defined $type ? ':'.$type : '').':'.
424          $self->{onerror}->(node => $node, type => 'character not allowed');                (defined $hreflang ? ':'.$hreflang : '');
425          if ($node->data =~ /[^\x09-\x0D\x20]/) {            unless ($element_state->{has_element}->{$key}) {
426            $todo->{flag}->{has_descendant}->{significant} = 1;              $element_state->{has_element}->{$key} = 1;
427                $element_state->{has_element}->{'link.alternate'} = 1;
428              } else {
429                $not_allowed = 1;
430              }
431          }          }
432        } elsif ($nt == 5) {          
433          unshift @nodes, @{$node->child_nodes};          ## NOTE: MAY
434            $not_allowed ||= $element_state->{has_element}->{entry};
435          } elsif ({ # MAY
436                    category => 1,
437                    contributor => 1,
438                   }->{$child_ln}) {
439            $not_allowed = $element_state->{has_element}->{entry};
440          } elsif ($child_ln eq 'author') { # MAY
441            $not_allowed = $element_state->{has_element}->{entry};
442            $element_state->{has_author} = 1; # ./author | ./source/author
443            $element_state->{has_element}->{$child_ln} = 1; # ./author
444          } else {
445            $not_allowed = 1;
446          }
447          if ($not_allowed) {
448            $self->{onerror}->(node => $child_el, type => 'element not allowed');
449        }        }
450        } elsif ($child_nsuri eq $THR_NS and $child_ln eq 'in-reply-to') {
451          ## ISSUE: Where |thr:in-reply-to| is allowed is not explicit;y
452          ## defined in RFC 4685.
453          #
454        } elsif ($child_nsuri eq $THR_NS and $child_ln eq 'total') {
455          #
456        } else {
457          ## TODO: extension element
458          $self->{onerror}->(node => $child_el, type => 'element not allowed');
459      }      }
460      },
461      check_child_text => sub {
462        my ($self, $item, $child_node, $has_significant, $element_state) = @_;
463        if ($has_significant) {
464          $self->{onerror}->(node => $child_node, type => 'character not allowed',
465                             level => $self->{must_level});
466        }
467      },
468      check_end => sub {
469        my ($self, $item, $element_state) = @_;
470    
471      ## NOTE: metadata elements, followed by atom:entry* (no explicit MAY)      if ($element_state->{has_author}) {
472          ## NOTE: There is either a child atom:author element
473          ## or a child atom:source element which contains an atom:author
474          ## child element.
475          #
476        } else {
477          A: {
478            my $root = $item->{node}->owner_document->document_element;
479            if ($root and $root->manakai_local_name eq 'feed') {
480              my $nsuri = $root->namespace_uri;
481              if (defined $nsuri and $nsuri eq $ATOM_NS) {
482                ## NOTE: An Atom Feed Document.
483                for my $root_child (@{$root->child_nodes}) {
484                  ## NOTE: Entity references are not supported.
485                  next unless $root_child->node_type == 1; # ELEMENT_NODE
486                  next unless $root_child->manakai_local_name eq 'author';
487                  my $root_child_nsuri = $root_child->namespace_uri;
488                  next unless defined $root_child_nsuri;
489                  next unless $root_child_nsuri eq $ATOM_NS;
490                  last A;
491                }
492              }
493            }
494            
495            $self->{onerror}->(node => $item->{node},
496                               type => 'element missing:atom|author',
497                               level => $self->{must_level});
498          } # A
499        }
500    
501        unless ($element_state->{has_element}->{author}) {
502          $item->{parent_state}->{has_no_author_entry} = 1; # for atom:feed's check
503        }
504    
505      ## TODO: If entry's with same id, then updated SHOULD be different      ## TODO: If entry's with same id, then updated SHOULD be different
506    
507      unless ($has_element->{id}) { # MUST      unless ($element_state->{has_element}->{id}) { # MUST
508        $self->{onerror}->(node => $todo->{node},        $self->{onerror}->(node => $item->{node},
509                           type => 'element missing:atom.id');                           type => 'element missing:atom|id');
510      }      }
511      unless ($has_element->{title}) { # MUST      unless ($element_state->{has_element}->{title}) { # MUST
512        $self->{onerror}->(node => $todo->{node},        $self->{onerror}->(node => $item->{node},
513                           type => 'element missing:atom.title');                           type => 'element missing:atom|title');
514      }      }
515      unless ($has_element->{updated}) { # MUST      unless ($element_state->{has_element}->{updated}) { # MUST
516        $self->{onerror}->(node => $todo->{node},        $self->{onerror}->(node => $item->{node},
517                           type => 'element missing:atom.updated');                           type => 'element missing:atom|updated');
518      }      }
519      if (not $has_element->{content} and      if (not $element_state->{has_element}->{content} and
520          not $has_element->{'link.alternate'}) {          not $element_state->{has_element}->{'link.alternate'}) {
521        $self->{onerror}->(node => $todo->{node},        $self->{onerror}->(node => $item->{node},
522                           type => 'element missing:atom.link.alternate');                           type => 'element missing:atom|link|alternate');
523        }
524    
525        if ($element_state->{require_summary} and
526            not $element_state->{has_element}->{summary}) {
527          $self->{onerror}->(node => $item->{node},
528                             type => 'element missing:atom|summary',
529                             level => $self->{must_level});
530      }      }
   
     return ($new_todos);  
531    },    },
532  };  };
533    
534  $Element->{$ATOM_NS}->{feed} = {  $Element->{$ATOM_NS}->{feed} = {
535      %AtomChecker,
536    is_root => 1,    is_root => 1,
537    attrs_checker => $GetAtomAttrsChecker->({}),    check_child_element => sub {
538    checker => sub {      my ($self, $item, $child_el, $child_nsuri, $child_ln,
539      my ($self, $todo) = @_;          $child_is_transparent, $element_state) = @_;
540    
541      my @nodes = (@{$todo->{node}->child_nodes});      ## NOTE: metadata elements, followed by atom:entry* (no explicit MAY)
542      my $new_todos = [];  
543        if ($self->{minus_elements}->{$child_nsuri}->{$child_ln}) {
544      ## TODO: MUST author+ unless all entry child has author+.        $self->{onerror}->(node => $child_el,
545                             type => 'element not allowed:minus',
546      my $has_element = {};                           level => $self->{must_level});
547      while (@nodes) {      } elsif ($self->{plus_elements}->{$child_nsuri}->{$child_ln}) {
548        my $node = shift @nodes;        #
549        $self->_remove_minuses ($node) and next if ref $node eq 'HASH';      } elsif ($child_nsuri eq $ATOM_NS) {
550                  my $not_allowed;
551        my $nt = $node->node_type;        if ($child_ln eq 'entry') {
552        if ($nt == 1) {          $element_state->{has_element}->{entry} = 1;
553          my $nsuri = $node->namespace_uri;        } elsif ({ # MUST (0, 1)
554          $nsuri = '' unless defined $nsuri;                  generator => 1,
555          my $ln = $node->manakai_local_name;                  icon => 1,
556          my $not_allowed;                  id => 1,
557          if ($self->{pluses}->{$nsuri}->{$ln}) {                  logo => 1,
558            #                  rights => 1,
559          } elsif ($nsuri eq $ATOM_NS) {                  subtitle => 1,
560            if ($ln eq 'entry') {                  title => 1,
561              $has_element->{entry} = 1;                  updated => 1,
562            } elsif ({ # MUST (0, 1)                 }->{$child_ln}) {
563                 generator => 1,          unless ($element_state->{has_element}->{$child_ln}) {
564                 icon => 1,            $element_state->{has_element}->{$child_ln} = 1;
565                 id => 1,            $not_allowed = $element_state->{has_element}->{entry};
                logo => 1,  
                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;  
           }  
566          } else {          } else {
           ## TODO: extension element  
567            $not_allowed = 1;            $not_allowed = 1;
568          }          }
569          $self->{onerror}->(node => $node, type => 'element not allowed')        } elsif ($child_ln eq 'link') {
570              if $not_allowed;          my $rel = $child_el->rel;
571          my ($sib, $ch) = $self->_check_get_children ($node, $todo);          if ($rel eq $LINK_REL . 'alternate') {
572          unshift @nodes, @$sib;            my $type = $child_el->get_attribute_ns (undef, 'type');
573          push @$new_todos, @$ch;            $type = '' unless defined $type;
574        } elsif ($nt == 3 or $nt == 4) {            my $hreflang = $child_el->get_attribute_ns (undef, 'hreflang');
575          ## TODO: Are white spaces allowed?            $hreflang = '' unless defined $hreflang;
576          $self->{onerror}->(node => $node, type => 'character not allowed');            my $key = 'link:'.(defined $type ? ':'.$type : '').':'.
577          if ($node->data =~ /[^\x09-\x0D\x20]/) {                (defined $hreflang ? ':'.$hreflang : '');
578            $todo->{flag}->{has_descendant}->{significant} = 1;            unless ($element_state->{has_element}->{$key}) {
579                $element_state->{has_element}->{$key} = 1;
580              } else {
581                $not_allowed = 1;
582              }
583            } elsif ($rel eq $LINK_REL . 'self') {
584              $element_state->{has_element}->{'link.self'} = 1;
585          }          }
586        } elsif ($nt == 5) {          
587          unshift @nodes, @{$node->child_nodes};          ## NOTE: MAY
588            $not_allowed = $element_state->{has_element}->{entry};
589          } elsif ({ # MAY
590                    category => 1,
591                    contributor => 1,
592                   }->{$child_ln}) {
593            $not_allowed = $element_state->{has_element}->{entry};
594          } elsif ($child_ln eq 'author') { # MAY
595            $not_allowed = $element_state->{has_element}->{entry};
596            $element_state->{has_element}->{author} = 1;
597          } else {
598            $not_allowed = 1;
599        }        }
600          $self->{onerror}->(node => $child_el, type => 'element not allowed')
601              if $not_allowed;
602        } else {
603          ## TODO: extension element
604          $self->{onerror}->(node => $child_el, type => 'element not allowed');
605      }      }
606      },
607      check_child_text => sub {
608        my ($self, $item, $child_node, $has_significant, $element_state) = @_;
609        if ($has_significant) {
610          $self->{onerror}->(node => $child_node, type => 'character not allowed',
611                             level => $self->{must_level});
612        }
613      },
614      check_end => sub {
615        my ($self, $item, $element_state) = @_;
616    
617      ## NOTE: metadata elements, followed by atom:entry* (no explicit MAY)      if ($element_state->{has_no_author_entry} and
618            not $element_state->{has_element}->{author}) {
619          $self->{onerror}->(node => $item->{node},
620                             type => 'element missing:atom|author',
621                             level => $self->{must_level});
622          ## ISSUE: If there is no |atom:entry| element,
623          ## there should be an |atom:author| element?
624        }
625    
626      ## TODO: If entry's with same id, then updated SHOULD be different      ## TODO: If entry's with same id, then updated SHOULD be different
627    
628      unless ($has_element->{id}) { # MUST      unless ($element_state->{has_element}->{id}) { # MUST
629        $self->{onerror}->(node => $todo->{node},        $self->{onerror}->(node => $item->{node},
630                           type => 'element missing:atom.id');                           type => 'element missing:atom|id');
631      }      }
632      unless ($has_element->{title}) { # MUST      unless ($element_state->{has_element}->{title}) { # MUST
633        $self->{onerror}->(node => $todo->{node},        $self->{onerror}->(node => $item->{node},
634                           type => 'element missing:atom.title');                           type => 'element missing:atom|title');
635      }      }
636      unless ($has_element->{updated}) { # MUST      unless ($element_state->{has_element}->{updated}) { # MUST
637        $self->{onerror}->(node => $todo->{node},        $self->{onerror}->(node => $item->{node},
638                           type => 'element missing:atom.updated');                           type => 'element missing:atom|updated');
639      }      }
640      unless ($has_element->{'link.self'}) {      unless ($element_state->{has_element}->{'link.self'}) {
641        $self->{onerror}->(node => $todo->{node}, level => 's',        $self->{onerror}->(node => $item->{node}, level => 's',
642                           type => 'child element missing:atom.link.self');                           type => 'element missing:atom|link|self');
643      }      }
644    
645      return ($new_todos);      $AtomChecker{check_end}->(@_);
646    },    },
647  };  };
648    
649  $Element->{$ATOM_NS}->{content} = {  $Element->{$ATOM_NS}->{content} = {
650    attrs_checker => $GetAtomAttrsChecker->({    %AtomChecker,
651      src => sub { 1 }, # checked in |checker|    check_start => sub {
652      type => sub { 1 }, # checked in |checker|      my ($self, $item, $element_state) = @_;
653    }),      $element_state->{type} = 'text';
654    checker => sub {      $element_state->{value} = '';
655      my ($self, $todo) = @_;    },
656      check_attrs => $GetAtomAttrsChecker->({
657        src => sub {
658          my ($self, $attr, $item, $element_state) = @_;
659    
660          $element_state->{has_src} = 1;
661          $item->{parent_state}->{require_summary} = 1;
662    
663          ## NOTE: There MUST NOT be any white space.
664          Whatpm::URIChecker->check_iri_reference ($attr->value, sub {
665            my %opt = @_;
666            $self->{onerror}->(node => $item->{node}, level => $opt{level},
667                               type => 'URI::'.$opt{type}.
668                               (defined $opt{position} ? ':'.$opt{position} : ''));
669          });
670        },
671        type => sub {
672          my ($self, $attr, $item, $element_state) = @_;
673    
674          $element_state->{has_type} = 1;
675    
676      my $attr = $todo->{node}->get_attribute_node_ns (undef, 'type');        my $value = $attr->value;
     my $src_attr = $todo->{node}->get_attribute_node_ns (undef, 'src');  
     my $value;  
     if ($attr) {  
       $value = $attr->value;  
677        if ($value eq 'text' or $value eq 'html' or $value eq 'xhtml') {        if ($value eq 'text' or $value eq 'html' or $value eq 'xhtml') {
678          # MUST          # MUST
679        } else {        } else {
680          ## 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;  
681          my $lws0 = qr/(?>(?>\x0D\x0A)?[\x09\x20])*/;          my $lws0 = qr/(?>(?>\x0D\x0A)?[\x09\x20])*/;
682          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]+/;
683          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 701  $Element->{$ATOM_NS}->{content} = {
701                                 type => 'IMT:'.$opt{type});                                 type => 'IMT:'.$opt{type});
702            }, @type);            }, @type);
703          } else {          } else {
704            $self->{onerror}->(node => $attr, type => 'IMT:syntax error');            $self->{onerror}->(node => $attr, type => 'IMT:syntax error',
705                                 level => $self->{must_level});
706          }          }
707        }        }
     } elsif ($src_attr) {  
       $value = '';  
       $self->{onerror}->(node => $todo->{node},  
                          type => 'attribute missing:type', level => 's');  
     } else {  
       $value = 'text';  
     }  
   
     ## TODO: This implementation is not optimal.  
708    
709      if ($src_attr) {        if ({text => 1, html => 1, xhtml => 1}->{$value}) {
710        ## NOTE: There MUST NOT be any white space.          #
711        Whatpm::URIChecker->check_iri_reference ($src_attr->value, sub {        } elsif ($value =~ m![+/][Xx][Mm][Ll]\z!) {
712          my %opt = @_;          ## ISSUE: There is no definition for "XML media type" in RFC 3023.
713          $self->{onerror}->(node => $todo->{node}, level => $opt{level},          ## Is |application/xml-dtd| an XML media type?
714                             type => 'URI::'.$opt{type}.          $value = 'xml';
715                             (defined $opt{position} ? ':'.$opt{position} : ''));        } elsif ($value =~ m!^[Tt][Ee][Xx][Tt]/!) {
716        });          $value = 'mime_text';
717          } elsif ($value =~ m!^(?>message|multipart)/!i) {
718        ## NOTE: If @src, the element MUST be empty.  What is "empty"?          $self->{onerror}->(node => $attr, type => 'IMT:composite',
719        ## Is |<e><!----></e>| empty?  |<e>&e;</e>| where |&e;| has                             level => $self->{must_level});
720        ## empty replacement tree shuld be empty, since Atom is defined          $item->{parent_state}->{require_summary} = 1;
721        ## in terms of XML Information Set where entities are expanded.        } else {
722        ## (but what if |&e;| is an unexpanded entity?)          $item->{parent_state}->{require_summary} = 1;
     }  
   
     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};  
         }  
723        }        }
724    
725        return ($new_todos);        $element_state->{type} = $value;
726      } elsif ($value eq 'html') {      },
727        $self->{onerror}->(node => $attr, type => 'not IMT') if $src_attr;    }, {
728        src => FEATURE_RFC4287,
729        my @nodes = (@{$todo->{node}->child_nodes});      type => FEATURE_RFC4287,
730        my $new_todos = [];    }),
731            check_child_element => sub {
732        while (@nodes) {      my ($self, $item, $child_el, $child_nsuri, $child_ln,
733          my $node = shift @nodes;          $child_is_transparent, $element_state) = @_;
734          $self->_remove_minuses ($node) and next if ref $node eq 'HASH';  
735                if ($self->{minus_elements}->{$child_nsuri}->{$child_ln}) {
736          my $nt = $node->node_type;        $self->{onerror}->(node => $child_el,
737          if ($nt == 1) {                           type => 'element not allowed:minus',
738            my $node_ns = $node->namespace_uri;                           level => $self->{must_level});
739            $node_ns = '' unless defined $node_ns;      } elsif ($self->{plus_elements}->{$child_nsuri}->{$child_ln}) {
740            my $node_ln = $node->manakai_local_name;        #
741            if ($self->{pluses}->{$node_ns}->{$node_ln}) {      } else {
742              #        if ($element_state->{type} eq 'text' or
743            } else {            $element_state->{type} eq 'html' or
744              # MUST NOT            $element_state->{type} eq 'mime_text') {
745              $self->{onerror}->(node => $node, type => 'element not allowed');          # MUST NOT
746            }          $self->{onerror}->(node => $child_el,
747            my ($sib, $ch) = $self->_check_get_children ($node, $todo);                             type => 'element not allowed:atom|content',
748            unshift @nodes, @$sib;                             level => $self->{must_level});
749            push @$new_todos, @$ch;        } elsif ($element_state->{type} eq 'xhtml') {
750          } elsif ($nt == 3 or $nt == 4) {          if ($element_state->{has_div}) {
751            $self->{onerror}->(node => $node, type => 'character not allowed')            $self->{onerror}->(node => $child_el,
752                if $src_attr;                               type => 'element not allowed:atom|content',
753            if ($node->data =~ /[^\x09-\x0D\x20]/) {                               level => $self->{must_level});
754              $todo->{flag}->{has_descendant}->{significant} = 1;          } else {
755            }            ## TODO: SHOULD be suitable for handling as HTML [XHTML10]
756          } elsif ($nt == 5) {            $element_state->{has_div} = 1;
           unshift @nodes, @{$node->child_nodes};  
757          }          }
758        }        } elsif ($element_state->{type} eq 'xml') {
759            ## MAY contain elements
760        ## TODO: SHOULD be suitable for handling as HTML [HTML4]          if ($element_state->{has_src}) {
761        # markup MUST be escaped            $self->{onerror}->(node => $child_el,
762        ## TODO: HTML SHOULD be valid as if within <div>                               type => 'element not allowed:atom|content',
763                                 level => $self->{must_level});
       return ($new_todos);  
     } elsif ($value eq 'xhtml') {  
       $self->{onerror}->(node => $attr, type => 'not IMT') if $src_attr;  
   
       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;  
           $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};  
764          }          }
765          } else {
766            ## NOTE: Elements are not explicitly disallowed.
767        }        }
768        }
769        unless ($has_div) {    },
770          $self->{onerror}->(node => $todo->{node},    ## NOTE: If @src, the element MUST be empty.  What is "empty"?
771                             type => 'element missing:div');    ## Is |<e><!----></e>| empty?  |<e>&e;</e>| where |&e;| has
772      ## empty replacement tree shuld be empty, since Atom is defined
773      ## in terms of XML Information Set where entities are expanded.
774      ## (but what if |&e;| is an unexpanded entity?)
775      check_child_text => sub {
776        my ($self, $item, $child_node, $has_significant, $element_state) = @_;    
777        if ($has_significant) {
778          if ($element_state->{has_src}) {
779            $self->{onerror}->(node => $child_node,
780                               type => 'character not allowed',
781                               level => $self->{must_level});
782          } elsif ($element_state->{type} eq 'xhtml' or
783                   $element_state->{type} eq 'xml') {
784            $self->{onerror}->(node => $child_node,
785                               type => 'character not allowed:atom|content',
786                               level => $self->{must_level});
787        }        }
788        }
789    
790        return ($new_todos);      $element_state->{value} .= $child_node->data;
     } elsif ($value =~ m![+/][Xx][Mm][Ll]\z!) {  
       ## ISSUE: There is no definition for "XML media type" in RFC 3023.  
       ## Is |application/xml-dtd| an XML media type?  
791    
792        my @nodes = (@{$todo->{node}->child_nodes});      ## NOTE: type=text/* has no further restriction (i.e. the content don't
793        my $new_todos = [];      ## have to conform to the definition of the type).
794            },
795        while (@nodes) {    check_end => sub {
796          my $node = shift @nodes;      my ($self, $item, $element_state) = @_;
797          $self->_remove_minuses ($node) and next if ref $node eq 'HASH';  
798                if ($element_state->{has_src}) {
799          my $nt = $node->node_type;        if (not $element_state->{has_type}) {
800          if ($nt == 1) {          $self->{onerror}->(node => $item->{node},
801            ## MAY contain elements                             type => 'attribute missing:type',
802            if ($src_attr) {                             level => $self->{should_level});
803              my $node_ns = $node->namespace_uri;        } elsif ($element_state->{type} eq 'text' or
804              $node_ns = '' unless defined $node_ns;                 $element_state->{type} eq 'html' or
805              my $node_ln = $node->manakai_local_name;                 $element_state->{type} eq 'xhtml') {
806              if ($self->{pluses}->{$node_ns}->{$node_ln}) {          $self->{onerror}
807                #              ->(node => $item->{node}->get_attribute_node_ns (undef, 'type'),
808              } else {                 type => 'not IMT', level => $self->{must_level});
               $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};  
         }  
809        }        }
810        }
811    
812        if ($element_state->{type} eq 'xhtml') {
813          unless ($element_state->{has_div}) {
814            $self->{onerror}->(node => $item->{node},
815                               type => 'element missing:div',
816                               level => $self->{must_level});
817          }
818        } elsif ($element_state->{type} eq 'html') {
819          ## TODO: SHOULD be suitable for handling as HTML [HTML4]
820          # markup MUST be escaped
821          $self->{onsubdoc}->({s => $element_state->{value},
822                               container_node => $item->{node},
823                               media_type => 'text/html',
824                               inner_html_element => 'div',
825                               is_char_string => 1});
826        } elsif ($element_state->{type} eq 'xml') {
827        ## NOTE: SHOULD be suitable for handling as $value.        ## NOTE: SHOULD be suitable for handling as $value.
828        ## If no @src, this would normally mean it contains a        ## If no @src, this would normally mean it contains a
829        ## single child element that would serve as the root element.        ## single child element that would serve as the root element.
830        $self->{onerror}->(node => $todo->{node}, level => 'unsupported',        $self->{onerror}->(node => $item->{node},
831                           type => 'content:'.$value);                           level => $self->{unsupported_level},
832                             type => 'atom|content not supported',
833        return ($new_todos);                           value => $item->{node}->get_attribute_ns
834      } elsif ($value =~ m!^[Tt][Ee][Xx][Tt]/!) {                               (undef, 'type'));
835        my @nodes = (@{$todo->{node}->child_nodes});      } elsif ($element_state->{type} eq 'text' or
836        my $new_todos = [];               $element_state->{type} eq 'mime-text') {
837                #
       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);  
838      } 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};  
         }  
       }  
   
839        ## TODO: $s = valid Base64ed [RFC 3548] where        ## TODO: $s = valid Base64ed [RFC 3548] where
840        ## MAY leading and following "white space" (what?)        ## MAY leading and following "white space" (what?)
841        ## and lines separated by a single U+000A        ## and lines separated by a single U+000A
842    
843        ## NOTE: SHOULD be suitable for the indicated media type.        ## NOTE: SHOULD be suitable for the indicated media type.
844        $self->{onerror}->(node => $todo->{node}, level => 'unsupported',        $self->{onerror}->(node => $item->{node},
845                           type => 'content:'.$value);                           level => $self->{unsupported_level},
846                             type => 'atom|content not supported',
847        return ($new_todos);                           value => $item->{node}->get_attribute_ns
848                                 (undef, 'type'));
849      }      }
850    
851        $AtomChecker{check_end}->(@_);
852    },    },
853  };  };
854  ## TODO: Tests for <html:nest/> in <atom:content/>  ## TODO: Tests for <html:nest/> in <atom:content/>
855    
856  $Element->{$ATOM_NS}->{author} = $AtomPersonConstruct;  $Element->{$ATOM_NS}->{author} = \%AtomPersonConstruct;
857    
858  $Element->{$ATOM_NS}->{category} = {  $Element->{$ATOM_NS}->{category} = {
859    attrs_checker => $GetAtomAttrsChecker->({    %AtomChecker,
860      check_attrs => $GetAtomAttrsChecker->({
861      label => sub { 1 }, # no value constraint      label => sub { 1 }, # no value constraint
862      scheme => sub { # NOTE: No MUST.      scheme => sub { # NOTE: No MUST.
863        my ($self, $attr) = @_;        my ($self, $attr) = @_;
# Line 1009  $Element->{$ATOM_NS}->{category} = { Line 869  $Element->{$ATOM_NS}->{category} = {
869                             (defined $opt{position} ? ':'.$opt{position} : ''));                             (defined $opt{position} ? ':'.$opt{position} : ''));
870        });        });
871      },      },
872      term => sub { 1 }, # no value constraint      term => sub {
873          my ($self, $attr, $item, $element_state) = @_;
874          
875          ## NOTE: No value constraint.
876          
877          $element_state->{has_term} = 1;
878        },
879      }, {
880        label => FEATURE_RFC4287,
881        scheme => FEATURE_RFC4287,
882        term => FEATURE_RFC4287,
883    }),    }),
884    checker => sub {    check_end => sub {
885      my ($self, $todo) = @_;      my ($self, $item, $element_state) = @_;
886        unless ($element_state->{has_term}) {
887      unless ($todo->{node}->has_attribute_ns (undef, 'term')) {        $self->{onerror}->(node => $item->{node},
       $self->{onerror}->(node => $todo->{node},  
888                           type => 'attribute missing:term');                           type => 'attribute missing:term');
889      }      }
890    
891      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);  
892    },    },
893      ## NOTE: Meaning of content is not defined.
894  };  };
895    
896  $Element->{$ATOM_NS}->{contributor} = $AtomPersonConstruct;  $Element->{$ATOM_NS}->{contributor} = \%AtomPersonConstruct;
897    
898  ## TODO: Anything below does not support <html:nest/> yet.  ## TODO: Anything below does not support <html:nest/> yet.
899    
900  $Element->{$ATOM_NS}->{generator} = {  $Element->{$ATOM_NS}->{generator} = {
901    attrs_checker => $GetAtomAttrsChecker->({    %AtomChecker,
902      check_attrs => $GetAtomAttrsChecker->({
903      uri => sub { # MUST      uri => sub { # MUST
904        my ($self, $attr) = @_;        my ($self, $attr) = @_;
905        ## NOTE: There MUST NOT be any white space.        ## NOTE: There MUST NOT be any white space.
# Line 1063  $Element->{$ATOM_NS}->{generator} = { Line 913  $Element->{$ATOM_NS}->{generator} = {
913        ## that is relevant to the agent.        ## that is relevant to the agent.
914      },      },
915      version => sub { 1 }, # no value constraint      version => sub { 1 }, # no value constraint
916      }, {
917        uri => FEATURE_RFC4287,
918        version => FEATURE_RFC4287,
919    }),    }),
   checker => sub {  
     my ($self, $todo) = @_;  
920    
921      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};  
       }  
     }  
922    
923      return ($new_todos);    ## NOTE: Content MUST be a string that is a human-readable name for
924    },    ## the generating agent.
925  };  };
926    
927  $Element->{$ATOM_NS}->{icon} = {  $Element->{$ATOM_NS}->{icon} = {
928    attrs_checker => $GetAtomAttrsChecker->({}),    %AtomChecker,
929    checker => sub {    check_start =>  sub {
930      my ($self, $todo) = @_;      my ($self, $item, $element_state) = @_;
931        $element_state->{value} = '';
932      my @nodes = (@{$todo->{node}->child_nodes});    },
933      my $new_todos = [];    ## NOTE: Elements are not explicitly disallowed.
934          check_child_text => sub {
935      my $s = '';      my ($self, $item, $child_node, $has_significant, $element_state) = @_;
936      while (@nodes) {      $element_state->{value} .= $child_node->data;
937        my $node = shift @nodes;    },
938        $self->_remove_minuses ($node) and next if ref $node eq 'HASH';    check_end => sub {
939              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};  
       }  
     }  
940    
941      ## NOTE: No MUST.      ## NOTE: No MUST.
942      ## NOTE: There MUST NOT be any white space.      ## NOTE: There MUST NOT be any white space.
943      Whatpm::URIChecker->check_iri_reference ($s, sub {      Whatpm::URIChecker->check_iri_reference ($element_state->{value}, sub {
944        my %opt = @_;        my %opt = @_;
945        $self->{onerror}->(node => $todo->{node}, level => $opt{level},        $self->{onerror}->(node => $item->{node}, level => $opt{level},
946                           type => 'URI::'.$opt{type}.                           type => 'URI::'.$opt{type}.
947                           (defined $opt{position} ? ':'.$opt{position} : ''));                           (defined $opt{position} ? ':'.$opt{position} : ''));
948      });      });
949    
950      ## NOTE: Image SHOULD be 1:1 and SHOULD be small      ## NOTE: Image SHOULD be 1:1 and SHOULD be small
951    
952      return ($new_todos);      $AtomChecker{check_end}->(@_);
953    },    },
954  };  };
955    
956  $Element->{$ATOM_NS}->{id} = {  $Element->{$ATOM_NS}->{id} = {
957    attrs_checker => $GetAtomAttrsChecker->({}),    %AtomChecker,
958    checker => sub {    check_start =>  sub {
959      my ($self, $todo) = @_;      my ($self, $item, $element_state) = @_;
960        $element_state->{value} = '';
961      my @nodes = (@{$todo->{node}->child_nodes});    },
962      my $new_todos = [];    ## NOTE: Elements are not explicitly disallowed.
963      check_child_text => sub {
964      my $s = '';      my ($self, $item, $child_node, $has_significant, $element_state) = @_;
965      while (@nodes) {      $element_state->{value} .= $child_node->data;
966        my $node = shift @nodes;    },
967        $self->_remove_minuses ($node) and next if ref $node eq 'HASH';    check_end => sub {
968              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};  
       }  
     }  
969    
970      ## NOTE: There MUST NOT be any white space.      ## NOTE: There MUST NOT be any white space.
971      Whatpm::URIChecker->check_iri ($s, sub { # MUST      Whatpm::URIChecker->check_iri ($element_state->{value}, sub {
972        my %opt = @_;        my %opt = @_;
973        $self->{onerror}->(node => $todo->{node}, level => $opt{level},        $self->{onerror}->(node => $item->{node}, level => $opt{level},
974                           type => 'URI::'.$opt{type}.                           type => 'URI::'.$opt{type}.
975                           (defined $opt{position} ? ':'.$opt{position} : ''));                           (defined $opt{position} ? ':'.$opt{position} : ''));
976      });      });
977      ## TODO: SHOULD be normalized      ## TODO: SHOULD be normalized
978    
979      return ($new_todos);      $AtomChecker{check_end}->(@_);
980    },    },
981  };  };
982    
983  $Element->{$ATOM_NS}->{link} = {  my $AtomIMTAttrChecker = sub {
   attrs_checker => $GetAtomAttrsChecker->({  
     href => sub {  
       my ($self, $attr) = @_;  
       ## NOTE: There MUST NOT be any white space.  
       Whatpm::URIChecker->check_iri_reference ($attr->value, sub {  
         my %opt = @_;  
         $self->{onerror}->(node => $attr, level => $opt{level},  
                            type => 'URI::'.$opt{type}.  
                            (defined $opt{position} ? ':'.$opt{position} : ''));  
       });  
     },  
     hreflang => $AtomLanguageTagAttrChecker,  
     length => sub { }, # No MUST; in octets.  
     rel => sub { # MUST  
       my ($self, $attr) = @_;  
       my $value = $attr->value;  
       if ($value =~ /\A(?>[0-9A-Za-z._~!\$&'()*+,;=\x{A0}-\x{D7FF}\x{F900}-\x{FDCF}\x{FDF0}-\x{FFEF}\x{10000}-\x{1FFFD}\x{20000}-\x{2FFFD}\x{30000}-\x{3FFFD}\x{40000}-\x{4FFFD}\x{50000}-\x{5FFFD}\x{60000}-\x{6FFFD}\x{70000}-\x{7FFFD}\x{80000}-\x{8FFFD}\x{90000}-\x{9FFFD}\x{A0000}-\x{AFFFD}\x{B0000}-\x{BFFFD}\x{C0000}-\x{CFFFD}\x{D0000}-\x{DFFFD}\x{E1000}-\x{EFFFD}-]|%[0-9A-Fa-f][0-9A-Fa-f]|\@)+\z/) {  
         $value = $LINK_REL . $value;  
       }  
   
       ## NOTE: There MUST NOT be any white space.  
       Whatpm::URIChecker->check_iri ($value, sub {  
         my %opt = @_;  
         $self->{onerror}->(node => $attr, level => $opt{level},  
                            type => 'URI::'.$opt{type}.  
                            (defined $opt{position} ? ':'.$opt{position} : ''));  
       });  
   
       ## TODO: Warn if unregistered  
     },  
     title => sub { }, # No MUST  
     type => sub {  
       ## NOTE: MUST be a MIME media type.  What is "MIME media type"?  
984        my ($self, $attr) = @_;        my ($self, $attr) = @_;
985        my $value = $attr->value;        my $value = $attr->value;
986        my $lws0 = qr/(?>(?>\x0D\x0A)?[\x09\x20])*/;        my $lws0 = qr/(?>(?>\x0D\x0A)?[\x09\x20])*/;
# Line 1245  $Element->{$ATOM_NS}->{link} = { Line 1008  $Element->{$ATOM_NS}->{link} = {
1008        } else {        } else {
1009          $self->{onerror}->(node => $attr, type => 'IMT:syntax error');          $self->{onerror}->(node => $attr, type => 'IMT:syntax error');
1010        }        }
1011    }; # $AtomIMTAttrChecker
1012    
1013    my $AtomIRIReferenceAttrChecker = sub {
1014      my ($self, $attr) = @_;
1015      ## NOTE: There MUST NOT be any white space.
1016      Whatpm::URIChecker->check_iri_reference ($attr->value, sub {
1017        my %opt = @_;
1018        $self->{onerror}->(node => $attr, level => $opt{level},
1019                           type => 'URI::'.$opt{type}.
1020                           (defined $opt{position} ? ':'.$opt{position} : ''));
1021      });
1022    }; # $AtomIRIReferenceAttrChecker
1023    
1024    $Element->{$ATOM_NS}->{link} = {
1025      %AtomChecker,
1026      check_attrs => $GetAtomAttrsChecker->({
1027        href => $AtomIRIReferenceAttrChecker,
1028        hreflang => $AtomLanguageTagAttrChecker,
1029        length => sub { }, # No MUST; in octets.
1030        rel => sub { # MUST
1031          my ($self, $attr) = @_;
1032          my $value = $attr->value;
1033          if ($value =~ /\A(?>[0-9A-Za-z._~!\$&'()*+,;=\x{A0}-\x{D7FF}\x{F900}-\x{FDCF}\x{FDF0}-\x{FFEF}\x{10000}-\x{1FFFD}\x{20000}-\x{2FFFD}\x{30000}-\x{3FFFD}\x{40000}-\x{4FFFD}\x{50000}-\x{5FFFD}\x{60000}-\x{6FFFD}\x{70000}-\x{7FFFD}\x{80000}-\x{8FFFD}\x{90000}-\x{9FFFD}\x{A0000}-\x{AFFFD}\x{B0000}-\x{BFFFD}\x{C0000}-\x{CFFFD}\x{D0000}-\x{DFFFD}\x{E1000}-\x{EFFFD}-]|%[0-9A-Fa-f][0-9A-Fa-f]|\@)+\z/) {
1034            $value = $LINK_REL . $value;
1035          }
1036    
1037          ## NOTE: There MUST NOT be any white space.
1038          Whatpm::URIChecker->check_iri ($value, sub {
1039            my %opt = @_;
1040            $self->{onerror}->(node => $attr, level => $opt{level},
1041                               type => 'URI::'.$opt{type}.
1042                               (defined $opt{position} ? ':'.$opt{position} : ''));
1043          });
1044    
1045          ## TODO: Warn if unregistered
1046    
1047          ## TODO: rel=license [RFC 4946]
1048          ## MUST NOT multiple rel=license with same href="",type="" pairs
1049          ## href="" SHOULD be dereferencable
1050          ## title="" SHOULD be there if multiple rel=license
1051          ## MUST NOT "unspecified" and other rel=license
1052      },      },
1053        title => sub { }, # No MUST
1054        type => $AtomIMTAttrChecker,
1055        ## NOTE: MUST be a MIME media type.  What is "MIME media type"?
1056      }, {
1057        href => FEATURE_RFC4287,
1058        hreflang => FEATURE_RFC4287,
1059        length => FEATURE_RFC4287,
1060        rel => FEATURE_RFC4287,
1061        title => FEATURE_RFC4287,
1062        type => FEATURE_RFC4287,
1063    
1064        ## TODO: thr:count
1065        ## TODO: thr:updated
1066    }),    }),
1067    checker => sub {    check_start =>  sub {
1068      my ($self, $todo) = @_;      my ($self, $item, $element_state) = @_;
1069    
1070      unless ($todo->{node}->has_attribute_ns (undef, 'href')) { # MUST      unless ($item->{node}->has_attribute_ns (undef, 'href')) { # MUST
1071        $self->{onerror}->(node => $todo->{node},        $self->{onerror}->(node => $item->{node},
1072                           type => 'attribute missing:href');                           type => 'attribute missing:href');
1073      }      }
1074    
1075      if ($todo->{node}->rel eq $LINK_REL . 'enclosure' and      if ($item->{node}->rel eq $LINK_REL . 'enclosure' and
1076          not $todo->{node}->has_attribute_ns (undef, 'length')) {          not $item->{node}->has_attribute_ns (undef, 'length')) {
1077        $self->{onerror}->(node => $todo->{node}, level => 's',        $self->{onerror}->(node => $item->{node}, level => 's',
1078                           type => 'attribute missing:length');                           type => 'attribute missing:length');
1079      }      }
   
     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);  
1080    },    },
1081  };  };
1082    
1083  $Element->{$ATOM_NS}->{logo} = {  $Element->{$ATOM_NS}->{logo} = {
1084    attrs_checker => $GetAtomAttrsChecker->({}),    %AtomChecker,
1085    checker => sub {    ## NOTE: Child elements are not explicitly disallowed
1086      my ($self, $todo) = @_;    check_start =>  sub {
1087        my ($self, $item, $element_state) = @_;
1088      my @nodes = (@{$todo->{node}->child_nodes});      $element_state->{value} = '';
1089      my $new_todos = [];    },
1090      ## NOTE: Elements are not explicitly disallowed.
1091      my $s = '';    check_child_text => sub {
1092      while (@nodes) {      my ($self, $item, $child_node, $has_significant, $element_state) = @_;
1093        my $node = shift @nodes;      $element_state->{value} .= $child_node->data;
1094        $self->_remove_minuses ($node) and next if ref $node eq 'HASH';    },
1095            check_end => sub {
1096        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};  
       }  
     }  
1097    
1098      ## NOTE: There MUST NOT be any white space.      ## NOTE: There MUST NOT be any white space.
1099      Whatpm::URIChecker->check_iri_reference ($s, sub {      Whatpm::URIChecker->check_iri_reference ($element_state->{value}, sub {
1100        my %opt = @_;        my %opt = @_;
1101        $self->{onerror}->(node => $todo->{node}, level => $opt{level},        $self->{onerror}->(node => $item->{node}, level => $opt{level},
1102                           type => 'URI::'.$opt{type}.                           type => 'URI::'.$opt{type}.
1103                           (defined $opt{position} ? ':'.$opt{position} : ''));                           (defined $opt{position} ? ':'.$opt{position} : ''));
1104      });      });
1105            
1106      ## NOTE: Image SHOULD be 2:1      ## NOTE: Image SHOULD be 2:1
1107    
1108      return ($new_todos);      $AtomChecker{check_end}->(@_);
1109    },    },
1110  };  };
1111    
1112  $Element->{$ATOM_NS}->{published} = $AtomDateConstruct;  $Element->{$ATOM_NS}->{published} = \%AtomDateConstruct;
1113    
1114  $Element->{$ATOM_NS}->{rights} = $AtomDateConstruct;  $Element->{$ATOM_NS}->{rights} = \%AtomTextConstruct;
1115  ## NOTE: SHOULD NOT be used to convey machine-readable information.  ## NOTE: SHOULD NOT be used to convey machine-readable information.
1116    
1117  $Element->{$ATOM_NS}->{source} = {  $Element->{$ATOM_NS}->{source} = {
1118    attrs_checker => $GetAtomAttrsChecker->({}),    %AtomChecker,
1119    checker => sub {    check_child_element => sub {
1120      my ($self, $todo) = @_;      my ($self, $item, $child_el, $child_nsuri, $child_ln,
1121            $child_is_transparent, $element_state) = @_;
1122      my @nodes = (@{$todo->{node}->child_nodes});  
1123      my $new_todos = [];      if ($self->{minus_elements}->{$child_nsuri}->{$child_ln}) {
1124      my $has_element = {};        $self->{onerror}->(node => $child_el,
1125      while (@nodes) {                           type => 'element not allowed:minus',
1126        my $node = shift @nodes;                           level => $self->{must_level});
1127        $self->_remove_minuses ($node) and next if ref $node eq 'HASH';      } elsif ($self->{plus_elements}->{$child_nsuri}->{$child_ln}) {
1128                  #
1129        my $nt = $node->node_type;      } elsif ($child_nsuri eq $ATOM_NS) {
1130        if ($nt == 1) {        my $not_allowed;
1131          my $nsuri = $node->namespace_uri;        if ($child_ln eq 'entry') {
1132          $nsuri = '' unless defined $nsuri;          $element_state->{has_element}->{entry} = 1;
1133          my $not_allowed;        } elsif ({
1134          if ($nsuri eq $ATOM_NS) {                  generator => 1,
1135            my $ln = $node->manakai_local_name;                  icon => 1,
1136            if ($ln eq 'entry') {                  id => 1,
1137              $has_element->{entry} = 1;                  logo => 1,
1138            } elsif ({                  rights => 1,
1139                 generator => 1,                  subtitle => 1,
1140                 icon => 1,                  title => 1,
1141                 id => 1,                  updated => 1,
1142                 logo => 1,                 }->{$child_ln}) {
1143                 rights => 1,          unless ($element_state->{has_element}->{$child_ln}) {
1144                 subtitle => 1,            $element_state->{has_element}->{$child_ln} = 1;
1145                 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;  
           }  
1146          } else {          } else {
           ## TODO: extension element  
1147            $not_allowed = 1;            $not_allowed = 1;
1148          }          }
1149          $self->{onerror}->(node => $node, type => 'element not allowed')        } elsif ($child_ln eq 'link') {
1150              if $not_allowed;          if ($child_el->rel eq $LINK_REL . 'alternate') {
1151          my ($sib, $ch) = $self->_check_get_children ($node, $todo);            my $type = $child_el->get_attribute_ns (undef, 'type');
1152          unshift @nodes, @$sib;            $type = '' unless defined $type;
1153          push @$new_todos, @$ch;            my $hreflang = $child_el->get_attribute_ns (undef, 'hreflang');
1154        } elsif ($nt == 3 or $nt == 4) {            $hreflang = '' unless defined $hreflang;
1155          ## TODO: Are white spaces allowed?            my $key = 'link:'.(defined $type ? ':'.$type : '').':'.
1156          $self->{onerror}->(node => $node, type => 'character not allowed');                (defined $hreflang ? ':'.$hreflang : '');
1157          if ($node->data =~ /[^\x09-\x0D\x20]/) {            unless ($element_state->{has_element}->{$key}) {
1158            $todo->{flag}->{has_descendant}->{significant} = 1;              $element_state->{has_element}->{$key} = 1;
1159              } else {
1160                $not_allowed = 1;
1161              }
1162          }          }
1163        } elsif ($nt == 5) {          $not_allowed ||= $element_state->{has_element}->{entry};
1164          unshift @nodes, @{$node->child_nodes};        } elsif ({
1165                    category => 1,
1166                    contributor => 1,
1167                   }->{$child_ln}) {
1168            $not_allowed = $element_state->{has_element}->{entry};
1169          } elsif ($child_ln eq 'author') {
1170            $not_allowed = $element_state->{has_element}->{entry};
1171            $item->{parent_state}->{has_author} = 1; # parent::atom:entry's flag
1172          } else {
1173            $not_allowed = 1;
1174          }
1175          if ($not_allowed) {
1176            $self->{onerror}->(node => $child_el, type => 'element not allowed');
1177        }        }
1178        } else {
1179          ## TODO: extension element
1180          $self->{onerror}->(node => $child_el, type => 'element not allowed');
1181        }
1182      },
1183      check_child_text => sub {
1184        my ($self, $item, $child_node, $has_significant, $element_state) = @_;
1185        if ($has_significant) {
1186          $self->{onerror}->(node => $child_node, type => 'character not allowed',
1187                             level => $self->{must_level});
1188      }      }
   
     return ($new_todos);  
1189    },    },
1190  };  };
1191    
1192  $Element->{$ATOM_NS}->{subtitle} = $AtomTextConstruct;  $Element->{$ATOM_NS}->{subtitle} = \%AtomTextConstruct;
1193    
1194  $Element->{$ATOM_NS}->{summary} = $AtomTextConstruct;  $Element->{$ATOM_NS}->{summary} = \%AtomTextConstruct;
1195    
1196  $Element->{$ATOM_NS}->{title} = $AtomTextConstruct;  $Element->{$ATOM_NS}->{title} = \%AtomTextConstruct;
1197    
1198  $Element->{$ATOM_NS}->{updated} = $AtomDateConstruct;  $Element->{$ATOM_NS}->{updated} = \%AtomDateConstruct;
1199    
1200  ## TODO: signature element  ## TODO: signature element
1201    
1202  ## TODO: simple extension element and structured extension element  ## TODO: simple extension element and structured extension element
1203    
1204    ## -- Atom Threading 1.0 [RFC 4685]
1205    
1206    $Element->{$THR_NS}->{''} = {
1207      %AtomChecker,
1208      status => 0,
1209    };
1210    
1211    ## ISSUE: Strictly speaking, thr:* element/attribute,
1212    ## where * is an undefined local name, is not disallowed.
1213    
1214    $Element->{$THR_NS}->{'in-reply-to'} = {
1215      %AtomChecker,
1216      status => FEATURE_RFC4685,
1217      check_attrs => $GetAtomAttrsChecker->({
1218        href => $AtomIRIReferenceAttrChecker,
1219            ## TODO: fact-level.
1220            ## TODO: MUST be dereferencable.
1221        ref => sub {
1222          my ($self, $attr, $item, $element_state) = @_;
1223          $element_state->{has_ref} = 1;
1224    
1225          ## NOTE: Same as |atom:id|.
1226          ## NOTE: There MUST NOT be any white space.
1227          Whatpm::URIChecker->check_iri ($attr->value, sub {
1228            my %opt = @_;
1229            $self->{onerror}->(node => $attr, level => $opt{level},
1230                               type => 'URI::'.$opt{type}.
1231                               (defined $opt{position} ? ':'.$opt{position} : ''));
1232          });
1233    
1234          ## TODO: Check against ID guideline...
1235        },
1236        source => $AtomIRIReferenceAttrChecker,
1237            ## TODO: fact-level.
1238            ## TODO: MUST be dereferencable.
1239        type => $AtomIMTAttrChecker,
1240            ## TODO: fact-level.
1241      }, {
1242        href => FEATURE_RFC4685,
1243        source => FEATURE_RFC4685,
1244        ref => FEATURE_RFC4685,
1245        type => FEATURE_RFC4685,
1246      }),
1247      check_end => sub {
1248        my ($self, $item, $element_state) = @_;
1249      
1250        unless ($element_state->{has_ref}) {
1251          $self->{onerror}->(node => $item->{node},
1252                             type => 'attribute missing:ref',
1253                             level => $self->{must_level});
1254        }
1255    
1256        $AtomChecker{check_end}->(@_);
1257      },
1258      ## NOTE: Content model has no constraint.
1259    };
1260    
1261    $Element->{$THR_NS}->{total} = {
1262      %AtomChecker,
1263      check_start =>  sub {
1264        my ($self, $item, $element_state) = @_;
1265        $element_state->{value} = '';
1266      },
1267      check_child_element => sub {
1268        my ($self, $item, $child_el, $child_nsuri, $child_ln,
1269            $child_is_transparent, $element_state) = @_;
1270    
1271        if ($self->{minus_elements}->{$child_nsuri}->{$child_ln}) {
1272          $self->{onerror}->(node => $child_el,
1273                             type => 'element not allowed:minus',
1274                             level => $self->{must_level});
1275        } elsif ($self->{plus_elements}->{$child_nsuri}->{$child_ln}) {
1276          #
1277        } else {
1278          $self->{onerror}->(node => $child_el,
1279                             type => 'element not allowed',
1280                             level => $self->{must_level});
1281        }
1282      },
1283      check_child_text => sub {
1284        my ($self, $item, $child_node, $has_significant, $element_state) = @_;
1285        $element_state->{value} .= $child_node->data;
1286      },
1287      check_end => sub {
1288        my ($self, $item, $element_state) = @_;
1289    
1290        ## NOTE: xsd:nonNegativeInteger
1291        unless ($element_state->{value} =~ /\A(?>[0-9]+|-0+)\z/) {
1292          $self->{onerror}->(node => $item->{node},
1293                             type => 'syntax error', ## TODO:
1294                             level => $self->{must_level});
1295        }
1296    
1297        $AtomChecker{check_end}->(@_);
1298      },
1299    };
1300    
1301    ## TODO: fh:complete
1302    
1303    ## TODO: fh:archive
1304    
1305    ## TODO: Check as archive document, page feed document, ...
1306    
1307    ## TODO: APP [RFC 5023]
1308    
1309  $Whatpm::ContentChecker::Namespace->{$ATOM_NS}->{loaded} = 1;  $Whatpm::ContentChecker::Namespace->{$ATOM_NS}->{loaded} = 1;
1310    $Whatpm::ContentChecker::Namespace->{$THR_NS}->{loaded} = 1;
1311    
1312  1;  1;
Legend:
Removed from v.1.7  
changed lines
  Added in v.1.17
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24