/[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.1 by wakaba, Sun Aug 5 04:50:57 2007 UTC revision 1.2 by wakaba, Sun Aug 5 07:12:45 2007 UTC
# Line 2  package Whatpm::ContentChecker; Line 2  package Whatpm::ContentChecker;
2  use strict;  use strict;
3  require Whatpm::ContentChecker;  require Whatpm::ContentChecker;
4    
5    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    
9  ## 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)
# Line 177  my $AtomPersonConstruct = { Line 179  my $AtomPersonConstruct = {
179              }              }
180            } elsif ($ln eq 'uri') {            } elsif ($ln eq 'uri') {
181              unless ($has_uri) {              unless ($has_uri) {
               ## TODO: MUST be an IRI  
182                $has_uri = 1;                $has_uri = 1;
183              } else {              } else {
184                $not_allowed = 1; # MUST NOT                $not_allowed = 1; # MUST NOT
185              }              }
186            } elsif ($ln eq 'email') {            } elsif ($ln eq 'email') {
187              unless ($has_email) {              unless ($has_email) {
               ## TODO: MUST be an addr-spec  
188                $has_email = 1;                $has_email = 1;
189              } else {              } else {
190                $not_allowed = 1; # MUST NOT                $not_allowed = 1; # MUST NOT
# Line 218  my $AtomPersonConstruct = { Line 218  my $AtomPersonConstruct = {
218    },    },
219  }; # $AtomPersonConstruct  }; # $AtomPersonConstruct
220    
221  ## MUST NOT be any white space  our $Element;
222  my $AtomDateConstruct = {  
223    $Element->{$ATOM_NS}->{name} = {
224      ## NOTE: Strictly speaking, structure and semantics for atom:name
225      ## element outside of Person construct is not defined.
226      attrs_checker => $GetAtomAttrsChecker->({}),
227      checker => sub {
228        my ($self, $todo) = @_;
229    
230        my @nodes = (@{$todo->{node}->child_nodes});
231        my $new_todos = [];
232    
233        while (@nodes) {
234          my $node = shift @nodes;
235          $self->_remove_minuses ($node) and next if ref $node eq 'HASH';
236            
237          my $nt = $node->node_type;
238          if ($nt == 1) {
239            ## NOTE: No constraint.
240            my ($sib, $ch) = $self->_check_get_children ($node, $todo);
241            unshift @nodes, @$sib;
242            push @$new_todos, @$ch;
243          } elsif ($nt == 3 or $nt == 4) {
244            #
245          } elsif ($nt == 5) {
246            unshift @nodes, @{$node->child_nodes};
247          }
248        }
249    
250        return ($new_todos);
251      },
252    };
253    
254    $Element->{$ATOM_NS}->{uri} = {
255      ## NOTE: Strictly speaking, structure and semantics for atom:uri
256      ## element outside of Person construct is not defined.
257      attrs_checker => $GetAtomAttrsChecker->({}),
258      checker => sub {
259        my ($self, $todo) = @_;
260    
261        my @nodes = (@{$todo->{node}->child_nodes});
262        my $new_todos = [];
263    
264        my $s = '';
265        while (@nodes) {
266          my $node = shift @nodes;
267          $self->_remove_minuses ($node) and next if ref $node eq 'HASH';
268            
269          my $nt = $node->node_type;
270          if ($nt == 1) {
271            ## NOTE: Not explicitly disallowed.
272            $self->{onerror}->(node => $node, type => 'element not allowed');
273            my ($sib, $ch) = $self->_check_get_children ($node, $todo);
274            unshift @nodes, @$sib;
275            push @$new_todos, @$ch;
276          } elsif ($nt == 3 or $nt == 4) {
277            $s .= $node->data;
278          } elsif ($nt == 5) {
279            unshift @nodes, @{$node->child_nodes};
280          }
281        }
282    
283        ## NOTE: There MUST NOT be any white space.
284        Whatpm::URIChecker->check_iri_reference ($s, sub {
285          my %opt = @_;
286          $self->{onerror}->(node => $todo->{node}, level => $opt{level},
287                             type => 'URI::'.$opt{type}.
288                             (defined $opt{position} ? ':'.$opt{position} : ''));
289        });
290    
291        return ($new_todos);
292      },
293    };
294    
295    $Element->{$ATOM_NS}->{email} = {
296      ## NOTE: Strictly speaking, structure and semantics for atom:email
297      ## element outside of Person construct is not defined.
298    attrs_checker => $GetAtomAttrsChecker->({}),    attrs_checker => $GetAtomAttrsChecker->({}),
299    checker => sub {    checker => sub {
300      my ($self, $todo) = @_;      my ($self, $todo) = @_;
301    
302        my @nodes = (@{$todo->{node}->child_nodes});
303        my $new_todos = [];
304    
305        my $s = '';
306        while (@nodes) {
307          my $node = shift @nodes;
308          $self->_remove_minuses ($node) and next if ref $node eq 'HASH';
309            
310          my $nt = $node->node_type;
311          if ($nt == 1) {
312            ## NOTE: Not explicitly disallowed.
313            $self->{onerror}->(node => $node, type => 'element not allowed');
314            my ($sib, $ch) = $self->_check_get_children ($node, $todo);
315            unshift @nodes, @$sib;
316            push @$new_todos, @$ch;
317          } elsif ($nt == 3 or $nt == 4) {
318            $s .= $node->data;
319          } elsif ($nt == 5) {
320            unshift @nodes, @{$node->child_nodes};
321          }
322        }
323    
324        ## TODO: addr-spec
325        $self->{onerror}->(node => $todo->{node}, type => 'addr-spec',
326                           level => 'unsupported');
327    
328        return ($new_todos);
329      },
330    };
331    
332    ## MUST NOT be any white space
333    my $AtomDateConstruct = {
334      attrs_checker => $GetAtomAttrsChecker->({}),
335      checker => sub {
336      my ($self, $todo) = @_;      my ($self, $todo) = @_;
337    
338      my @nodes = (@{$todo->{node}->child_nodes});      my @nodes = (@{$todo->{node}->child_nodes});
# Line 255  my $AtomDateConstruct = { Line 364  my $AtomDateConstruct = {
364    },    },
365  }; # $AtomDateConstruct  }; # $AtomDateConstruct
366    
367  ## MUST NOT be any IRI  $Element->{$ATOM_NS}->{entry} = {
 my $AtomIRIChecker = sub {  
   
 }; # $AtomIRIChecker  
   
 our $Element;  
   
 $Element->{$ATOM_NS}->{entryXXX} = {  
368    is_root => 1,    is_root => 1,
369    attrs_checker => $GetAtomAttrsChecker->({}),    attrs_checker => $GetAtomAttrsChecker->({}),
370    checker => sub {    checker => sub {
# Line 375  $Element->{$ATOM_NS}->{feed} = { Line 477  $Element->{$ATOM_NS}->{feed} = {
477                    
478        my $nt = $node->node_type;        my $nt = $node->node_type;
479        if ($nt == 1) {        if ($nt == 1) {
         # MUST  
480          my $nsuri = $node->namespace_uri;          my $nsuri = $node->namespace_uri;
481          $nsuri = '' unless defined $nsuri;          $nsuri = '' unless defined $nsuri;
482          my $not_allowed;          my $not_allowed;
# Line 483  $Element->{$ATOM_NS}->{content} = { Line 584  $Element->{$ATOM_NS}->{content} = {
584      ## TODO: This implementation is not optimal.      ## TODO: This implementation is not optimal.
585    
586      if ($src_attr) {      if ($src_attr) {
587        ## TODO: MUST be an IRI reference        ## NOTE: There MUST NOT be any white space.
588          Whatpm::URIChecker->check_iri_reference ($src_attr->value, sub {
589            my %opt = @_;
590            $self->{onerror}->(node => $todo->{node}, level => $opt{level},
591                               type => 'URI::'.$opt{type}.
592                               (defined $opt{position} ? ':'.$opt{position} : ''));
593          });
594    
595        ## NOTE: If @src, the element MUST be empty.  What is "empty"?        ## NOTE: If @src, the element MUST be empty.  What is "empty"?
596        ## Is |<e><!----></e>| empty?  |<e>&e;</e>| where |&e;| has        ## Is |<e><!----></e>| empty?  |<e>&e;</e>| where |&e;| has
# Line 694  $Element->{$ATOM_NS}->{author} = $AtomPe Line 800  $Element->{$ATOM_NS}->{author} = $AtomPe
800  $Element->{$ATOM_NS}->{category} = {  $Element->{$ATOM_NS}->{category} = {
801    attrs_checker => $GetAtomAttrsChecker->({    attrs_checker => $GetAtomAttrsChecker->({
802      label => sub { 1 }, # no value constraint      label => sub { 1 }, # no value constraint
803      scheme => sub { }, ## TODO: IRI # No MUST      scheme => sub { # NOTE: No MUST.
804          my ($self, $attr) = @_;
805          ## NOTE: There MUST NOT be any white space.
806          Whatpm::URIChecker->check_iri ($attr->value, sub {
807            my %opt = @_;
808            $self->{onerror}->(node => $attr, level => $opt{level},
809                               type => 'URI::'.$opt{type}.
810                               (defined $opt{position} ? ':'.$opt{position} : ''));
811          });
812        },
813      term => sub { 1 }, # no value constraint      term => sub { 1 }, # no value constraint
814    }),    }),
815    checker => sub {    checker => sub {
# Line 732  $Element->{$ATOM_NS}->{contributor} = $A Line 847  $Element->{$ATOM_NS}->{contributor} = $A
847    
848  $Element->{$ATOM_NS}->{generator} = {  $Element->{$ATOM_NS}->{generator} = {
849    attrs_checker => $GetAtomAttrsChecker->({    attrs_checker => $GetAtomAttrsChecker->({
850      uri => sub { }, ## TODO: IRI reference # MUST # SHOULD produce a representation that is relevant to the agent      uri => sub { # MUST
851          my ($self, $attr) = @_;
852          ## NOTE: There MUST NOT be any white space.
853          Whatpm::URIChecker->check_iri_reference ($attr->value, sub {
854            my %opt = @_;
855            $self->{onerror}->(node => $attr, level => $opt{level},
856                               type => 'URI::'.$opt{type}.
857                               (defined $opt{position} ? ':'.$opt{position} : ''));
858          });
859          ## NOTE: Dereferencing SHOULD produce a representation
860          ## that is relevant to the agent.
861        },
862      version => sub { 1 }, # no value constraint      version => sub { 1 }, # no value constraint
863    }),    }),
864    checker => sub {    checker => sub {
# Line 772  $Element->{$ATOM_NS}->{icon} = { Line 898  $Element->{$ATOM_NS}->{icon} = {
898      my @nodes = (@{$todo->{node}->child_nodes});      my @nodes = (@{$todo->{node}->child_nodes});
899      my $new_todos = [];      my $new_todos = [];
900            
901        my $s = '';
902      while (@nodes) {      while (@nodes) {
903        my $node = shift @nodes;        my $node = shift @nodes;
904        $self->_remove_minuses ($node) and next if ref $node eq 'HASH';        $self->_remove_minuses ($node) and next if ref $node eq 'HASH';
# Line 784  $Element->{$ATOM_NS}->{icon} = { Line 911  $Element->{$ATOM_NS}->{icon} = {
911          unshift @nodes, @$sib;          unshift @nodes, @$sib;
912          push @$new_todos, @$ch;          push @$new_todos, @$ch;
913        } elsif ($nt == 3 or $nt == 4) {        } elsif ($nt == 3 or $nt == 4) {
914          #          $s .= $node->data;
915        } elsif ($nt == 5) {        } elsif ($nt == 5) {
916          unshift @nodes, @{$node->child_nodes};          unshift @nodes, @{$node->child_nodes};
917        }        }
918      }      }
919    
920      ## TODO: an IRI reference (no MUST)      ## NOTE: No MUST.
921        ## NOTE: There MUST NOT be any white space.
922        Whatpm::URIChecker->check_iri_reference ($s, sub {
923          my %opt = @_;
924          $self->{onerror}->(node => $todo->{node}, level => $opt{level},
925                             type => 'URI::'.$opt{type}.
926                             (defined $opt{position} ? ':'.$opt{position} : ''));
927        });
928    
929      ## NOTE: Image SHOULD be 1:1 and SHOULD be small      ## NOTE: Image SHOULD be 1:1 and SHOULD be small
930    
931      return ($new_todos);      return ($new_todos);
# Line 804  $Element->{$ATOM_NS}->{id} = { Line 939  $Element->{$ATOM_NS}->{id} = {
939    
940      my @nodes = (@{$todo->{node}->child_nodes});      my @nodes = (@{$todo->{node}->child_nodes});
941      my $new_todos = [];      my $new_todos = [];
942        
943        my $s = '';
944      while (@nodes) {      while (@nodes) {
945        my $node = shift @nodes;        my $node = shift @nodes;
946        $self->_remove_minuses ($node) and next if ref $node eq 'HASH';        $self->_remove_minuses ($node) and next if ref $node eq 'HASH';
# Line 817  $Element->{$ATOM_NS}->{id} = { Line 953  $Element->{$ATOM_NS}->{id} = {
953          unshift @nodes, @$sib;          unshift @nodes, @$sib;
954          push @$new_todos, @$ch;          push @$new_todos, @$ch;
955        } elsif ($nt == 3 or $nt == 4) {        } elsif ($nt == 3 or $nt == 4) {
956          #          $s .= $node->data;
957        } elsif ($nt == 5) {        } elsif ($nt == 5) {
958          unshift @nodes, @{$node->child_nodes};          unshift @nodes, @{$node->child_nodes};
959        }        }
960      }      }
961    
962      ## TODO: MUST be an IRI (absolute)      ## NOTE: There MUST NOT be any white space.
963        Whatpm::URIChecker->check_iri ($s, sub { # MUST
964          my %opt = @_;
965          $self->{onerror}->(node => $todo->{node}, level => $opt{level},
966                             type => 'URI::'.$opt{type}.
967                             (defined $opt{position} ? ':'.$opt{position} : ''));
968        });
969      ## TODO: SHOULD be normalized      ## TODO: SHOULD be normalized
970    
971      return ($new_todos);      return ($new_todos);
972    },    },
973  };  };
974    
975    $Element->{$ATOM_NS}->{link} = {
976      attrs_checker => $GetAtomAttrsChecker->({
977        href => sub {
978          my ($self, $attr) = @_;
979          ## NOTE: There MUST NOT be any white space.
980          Whatpm::URIChecker->check_iri_reference ($attr->value, sub {
981            my %opt = @_;
982            $self->{onerror}->(node => $attr, level => $opt{level},
983                               type => 'URI::'.$opt{type}.
984                               (defined $opt{position} ? ':'.$opt{position} : ''));
985          });
986        },
987        hreflang => sub { }, # TODO: MUST be an RFC 3066 language tag
988        length => sub { }, # No MUST; in octets.
989        rel => sub { # MUST
990          my ($self, $attr) = @_;
991          my $value = $attr->value;
992          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/) {
993            $value = q<http://www.iana.org/assignments/relation/> . $value;
994          }
995    
996          ## NOTE: There MUST NOT be any white space.
997          Whatpm::URIChecker->check_iri ($value, sub {
998            my %opt = @_;
999            $self->{onerror}->(node => $attr, level => $opt{level},
1000                               type => 'URI::'.$opt{type}.
1001                               (defined $opt{position} ? ':'.$opt{position} : ''));
1002          });
1003    
1004          ## TODO: Warn if unregistered
1005        },
1006        type => sub { }, # TODO: MUST be a MIME media type
1007      }),
1008      checker => sub {
1009        my ($self, $todo) = @_;
1010    
1011        unless ($todo->{node}->has_attribute_ns (undef, 'href')) { # MUST
1012          $self->{onerror}->(node => $todo->{node},
1013                             type => 'attribute missing:href');
1014        }
1015    
1016        if ($todo->{node}->rel eq
1017                q<http://www.iana.org/assignments/relation/enclosure> and
1018            not $todo->{node}->has_attribute_ns (undef, 'length')) {
1019          $self->{onerror}->(node => $todo->{node}, level => 's',
1020                             type => 'attribute missing:length');
1021        }
1022    
1023        my @nodes = (@{$todo->{node}->child_nodes});
1024        my $new_todos = [];
1025        
1026        while (@nodes) {
1027          my $node = shift @nodes;
1028          $self->_remove_minuses ($node) and next if ref $node eq 'HASH';
1029          
1030          my $nt = $node->node_type;
1031          if ($nt == 1) {
1032            my ($sib, $ch) = $self->_check_get_children ($node, $todo);
1033            unshift @nodes, @$sib;
1034            push @$new_todos, @$ch;
1035          } elsif ($nt == 3 or $nt == 4) {
1036            #
1037          } elsif ($nt == 5) {
1038            unshift @nodes, @{$node->child_nodes};
1039          }
1040        }
1041    
1042        return ($new_todos);
1043      },
1044    };
1045    
1046    $Element->{$ATOM_NS}->{logo} = {
1047      attrs_checker => $GetAtomAttrsChecker->({}),
1048      checker => sub {
1049        my ($self, $todo) = @_;
1050    
1051        my @nodes = (@{$todo->{node}->child_nodes});
1052        my $new_todos = [];
1053    
1054        my $s = '';
1055        while (@nodes) {
1056          my $node = shift @nodes;
1057          $self->_remove_minuses ($node) and next if ref $node eq 'HASH';
1058          
1059          my $nt = $node->node_type;
1060          if ($nt == 1) {
1061            ## not explicitly disallowed
1062            $self->{onerror}->(node => $node, type => 'element not allowed');
1063            my ($sib, $ch) = $self->_check_get_children ($node, $todo);
1064            unshift @nodes, @$sib;
1065            push @$new_todos, @$ch;
1066          } elsif ($nt == 3 or $nt == 4) {
1067            $s .= $node->data;
1068          } elsif ($nt == 5) {
1069            unshift @nodes, @{$node->child_nodes};
1070          }
1071        }
1072    
1073        ## NOTE: There MUST NOT be any white space.
1074        Whatpm::URIChecker->check_iri_reference ($s, sub {
1075          my %opt = @_;
1076          $self->{onerror}->(node => $todo->{node}, level => $opt{level},
1077                             type => 'URI::'.$opt{type}.
1078                             (defined $opt{position} ? ':'.$opt{position} : ''));
1079        });
1080        
1081        ## NOTE: Image SHOULD be 2:1
1082    
1083        return ($new_todos);
1084      },
1085    };
1086    
1087    $Element->{$ATOM_NS}->{published} = $AtomDateConstruct;
1088    
1089    $Element->{$ATOM_NS}->{rights} = $AtomDateConstruct;
1090    ## SHOULD NOT be used to convey machine-readable information.
1091    
1092    $Element->{$ATOM_NS}->{source} = {
1093      attrs_checker => $GetAtomAttrsChecker->({}),
1094      checker => sub {
1095        my ($self, $todo) = @_;
1096    
1097        my @nodes = (@{$todo->{node}->child_nodes});
1098        my $new_todos = [];
1099        my $has_element = {};
1100        while (@nodes) {
1101          my $node = shift @nodes;
1102          $self->_remove_minuses ($node) and next if ref $node eq 'HASH';
1103            
1104          my $nt = $node->node_type;
1105          if ($nt == 1) {
1106            my $nsuri = $node->namespace_uri;
1107            $nsuri = '' unless defined $nsuri;
1108            my $not_allowed;
1109            if ($nsuri eq $ATOM_NS) {
1110              my $ln = $node->manakai_local_name;
1111              if ($ln eq 'entry') {
1112                $has_element->{entry} = 1;
1113              } elsif ({
1114                   generator => 1,
1115                   icon => 1,
1116                   id => 1,
1117                   logo => 1,
1118                   rights => 1,
1119                   subtitle => 1,
1120                   title => 1,
1121                   updated => 1,
1122                  }->{$ln}) {
1123                unless ($has_element->{$ln}) {
1124                  $has_element->{$ln} = 1;
1125                  $not_allowed = $has_element->{entry};
1126                } else {
1127                  $not_allowed = 1;
1128                }
1129              } elsif ($ln eq 'link') {
1130                ## TODO: MUST NOT rel=alternate with same (type, hreflang)
1131                #
1132                $not_allowed = $has_element->{entry};
1133              } elsif ({
1134                        author => 1,
1135                        category => 1,
1136                        contributor => 1,
1137                       }->{$ln}) {
1138                $not_allowed = $has_element->{entry};
1139              } else {
1140                $not_allowed = 1;
1141              }
1142            } else {
1143              ## TODO: extension element
1144              $not_allowed = 1;
1145            }
1146            $self->{onerror}->(node => $node, type => 'element not allowed')
1147                if $not_allowed;
1148            my ($sib, $ch) = $self->_check_get_children ($node, $todo);
1149            unshift @nodes, @$sib;
1150            push @$new_todos, @$ch;
1151          } elsif ($nt == 3 or $nt == 4) {
1152            ## TODO: Are white spaces allowed?
1153            $self->{onerror}->(node => $node, type => 'character not allowed');
1154          } elsif ($nt == 5) {
1155            unshift @nodes, @{$node->child_nodes};
1156          }
1157        }
1158    
1159        return ($new_todos);
1160      },
1161    };
1162    
1163    $Element->{$ATOM_NS}->{subtitle} = $AtomTextConstruct;
1164    
1165    $Element->{$ATOM_NS}->{summary} = $AtomTextConstruct;
1166    
1167    $Element->{$ATOM_NS}->{title} = $AtomTextConstruct;
1168    
1169    $Element->{$ATOM_NS}->{updated} = $AtomDateConstruct;
1170    
1171    ## TODO: signature element
1172    
1173    ## TODO: simple extension element and structured extension element
1174    
1175  $Whatpm::ContentChecker::Namespace->{$ATOM_NS}->{loaded} = 1;  $Whatpm::ContentChecker::Namespace->{$ATOM_NS}->{loaded} = 1;
1176    
1177  1;  1;
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24