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

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

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

revision 1.68 by wakaba, Sun Feb 24 07:51:19 2008 UTC revision 1.97 by wakaba, Sun Sep 21 09:45:02 2008 UTC
# Line 9  require Whatpm::URIChecker; Line 9  require Whatpm::URIChecker;
9    
10  ## TODO: Conformance of an HTML document with non-html root element.  ## TODO: Conformance of an HTML document with non-html root element.
11    
12    ## Stability
13  sub FEATURE_STATUS_REC () { 0b1 } ## Interoperable standard  sub FEATURE_STATUS_REC () { 0b1 } ## Interoperable standard
14  sub FEATURE_STATUS_CR () { 0b10 } ## Call for implementation  sub FEATURE_STATUS_CR () { 0b10 } ## Call for implementation
15  sub FEATURE_STATUS_LC () { 0b100 } ## Last call for comments  sub FEATURE_STATUS_LC () { 0b100 } ## Last call for comments
16  sub FEATURE_STATUS_WD () { 0b1000 } ## Working or editor's draft  sub FEATURE_STATUS_WD () { 0b1000 } ## Working or editor's draft
17    
18    ## Deprecated
19    sub FEATURE_DEPRECATED_SHOULD () { 0b100000 } ## SHOULD-level
20    sub FEATURE_DEPRECATED_INFO () { 0b1000000 } ## Does not affect conformance
21    
22    ## Conformance
23    sub FEATURE_ALLOWED () { 0b10000 }
24    
25  my $HTML_NS = q<http://www.w3.org/1999/xhtml>;  my $HTML_NS = q<http://www.w3.org/1999/xhtml>;
26  my $XML_NS = q<http://www.w3.org/XML/1998/namespace>;  my $XML_NS = q<http://www.w3.org/XML/1998/namespace>;
27  my $XMLNS_NS = q<http://www.w3.org/2000/xmlns/>;  my $XMLNS_NS = q<http://www.w3.org/2000/xmlns/>;
28    
29  my $Namespace = {  my $Namespace = {
30      '' => {loaded => 1},
31    q<http://www.w3.org/2005/Atom> => {module => 'Whatpm::ContentChecker::Atom'},    q<http://www.w3.org/2005/Atom> => {module => 'Whatpm::ContentChecker::Atom'},
32      q<http://purl.org/syndication/history/1.0>
33          => {module => 'Whatpm::ContentChecker::Atom'},
34      q<http://purl.org/syndication/threading/1.0>
35          => {module => 'Whatpm::ContentChecker::Atom'},
36    $HTML_NS => {module => 'Whatpm::ContentChecker::HTML'},    $HTML_NS => {module => 'Whatpm::ContentChecker::HTML'},
37    $XML_NS => {loaded => 1},    $XML_NS => {loaded => 1},
38    $XMLNS_NS => {loaded => 1},    $XMLNS_NS => {loaded => 1},
39      q<http://www.w3.org/1999/02/22-rdf-syntax-ns#> => {loaded => 1},
40  };  };
41    
42    sub load_ns_module ($) {
43      my $nsuri = shift; # namespace URI or ''
44      unless ($Namespace->{$nsuri}->{loaded}) {
45        if ($Namespace->{$nsuri}->{module}) {
46          eval qq{ require $Namespace->{$nsuri}->{module} } or die $@;
47        } else {
48          $Namespace->{$nsuri}->{loaded} = 1;
49        }
50      }
51    } # load_ns_module
52    
53  our $AttrChecker = {  our $AttrChecker = {
54    $XML_NS => {    $XML_NS => {
55      space => sub {      space => sub {
# Line 34  our $AttrChecker = { Line 59  our $AttrChecker = {
59          #          #
60        } else {        } else {
61          ## NOTE: An XML "error"          ## NOTE: An XML "error"
62          $self->{onerror}->(node => $attr, level => 'error',          $self->{onerror}->(node => $attr, level => $self->{level}->{xml_error},
63                             type => 'invalid attribute value');                             type => 'invalid attribute value');
64        }        }
65      },      },
# Line 46  our $AttrChecker = { Line 71  our $AttrChecker = {
71        } else {        } else {
72          require Whatpm::LangTag;          require Whatpm::LangTag;
73          Whatpm::LangTag->check_rfc3066_language_tag ($value, sub {          Whatpm::LangTag->check_rfc3066_language_tag ($value, sub {
74            my %opt = @_;            $self->{onerror}->(@_, node => $attr);
75            my $type = 'LangTag:'.$opt{type};          }, $self->{level});
           $type .= ':' . $opt{subtag} if defined $opt{subtag};  
           $self->{onerror}->(node => $attr, type => $type,  
                              value => $opt{value}, level => $opt{level});  
         });  
76        }        }
77    
78        ## NOTE: "The values of the attribute are language identifiers        ## NOTE: "The values of the attribute are language identifiers
79        ## as defined by [IETF RFC 3066], Tags for the Identification        ## as defined by [IETF RFC 3066], Tags for the Identification
80        ## of Languages, or its successor; in addition, the empty string        ## of Languages, or its successor; in addition, the empty string
81        ## may be specified." ("may" in lower case)        ## may be specified." ("may" in lower case)
82        ## NOTE: Is an RFC 3066-valid (but RFC 4647-invalid) language tag        ## NOTE: Is an RFC 3066-valid (but RFC 4646-invalid) language tag
83        ## allowed today?        ## allowed today?
84    
85        ## TODO: test data        ## TODO: test data
86    
87          my $nsuri = $attr->owner_element->namespace_uri;
88          if (defined $nsuri and $nsuri eq $HTML_NS) {
89            my $lang_attr = $attr->owner_element->get_attribute_node_ns
90                (undef, 'lang');
91            if ($lang_attr) {
92              my $lang_attr_value = $lang_attr->value;
93              $lang_attr_value =~ tr/A-Z/a-z/; ## ASCII case-insensitive
94              my $value = $value;
95              $value =~ tr/A-Z/a-z/; ## ASCII case-insensitive
96              if ($lang_attr_value ne $value) {
97                ## NOTE: HTML5 Section "The |lang| and |xml:lang| attributes"
98                $self->{onerror}->(node => $attr,
99                                   type => 'xml:lang ne lang',
100                                   level => $self->{level}->{must});
101              }
102            }
103          }
104    
105        if ($attr->owner_document->manakai_is_html) { # MUST NOT        if ($attr->owner_document->manakai_is_html) { # MUST NOT
106          $self->{onerror}->(node => $attr, type => 'in HTML:xml:lang');          $self->{onerror}->(node => $attr, type => 'in HTML:xml:lang',
107                               level => $self->{level}->{must});
108  ## TODO: Test data...  ## TODO: Test data...
109        }        }
110      },      },
# Line 73  our $AttrChecker = { Line 113  our $AttrChecker = {
113        my $value = $attr->value;        my $value = $attr->value;
114        if ($value =~ /[^\x{0000}-\x{10FFFF}]/) { ## ISSUE: Should we disallow noncharacters?        if ($value =~ /[^\x{0000}-\x{10FFFF}]/) { ## ISSUE: Should we disallow noncharacters?
115          $self->{onerror}->(node => $attr,          $self->{onerror}->(node => $attr,
116                             type => 'invalid attribute value');                             type => 'invalid attribute value',
117                               level => $self->{level}->{fact}, ## TODO: correct?
118                              );
119        }        }
120        ## NOTE: Conformance to URI standard is not checked since there is        ## NOTE: Conformance to URI standard is not checked since there is
121        ## no author requirement on conformance in the XML Base specification.        ## no author requirement on conformance in the XML Base specification.
# Line 86  our $AttrChecker = { Line 128  our $AttrChecker = {
128        $value =~ s/\x20$//;        $value =~ s/\x20$//;
129        ## TODO: NCName in XML 1.0 or 1.1        ## TODO: NCName in XML 1.0 or 1.1
130        ## TODO: declared type is ID?        ## TODO: declared type is ID?
131        if ($self->{id}->{$value}) { ## NOTE: An xml:id error        if ($self->{id}->{$value}) {
132          $self->{onerror}->(node => $attr, level => 'error',          $self->{onerror}->(node => $attr,
133                             type => 'duplicate ID');                             type => 'duplicate ID',
134                               level => $self->{level}->{xml_id_error});
135          push @{$self->{id}->{$value}}, $attr;          push @{$self->{id}->{$value}}, $attr;
136        } else {        } else {
137          $self->{id}->{$value} = [$attr];          $self->{id}->{$value} = [$attr];
# Line 102  our $AttrChecker = { Line 145  our $AttrChecker = {
145        my $value = $attr->value;        my $value = $attr->value;
146        if ($value eq $XML_NS and $ln ne 'xml') {        if ($value eq $XML_NS and $ln ne 'xml') {
147          $self->{onerror}          $self->{onerror}
148            ->(node => $attr, level => 'NC',            ->(node => $attr,
149               type => 'Reserved Prefixes and Namespace Names:=xml');               type => 'Reserved Prefixes and Namespace Names:Name',
150                 text => $value,
151                 level => $self->{level}->{nc});
152        } elsif ($value eq $XMLNS_NS) {        } elsif ($value eq $XMLNS_NS) {
153          $self->{onerror}          $self->{onerror}
154            ->(node => $attr, level => 'NC',            ->(node => $attr,
155               type => 'Reserved Prefixes and Namespace Names:=xmlns');               type => 'Reserved Prefixes and Namespace Names:Name',
156                 text => $value,
157                 level => $self->{level}->{nc});
158        }        }
159        if ($ln eq 'xml' and $value ne $XML_NS) {        if ($ln eq 'xml' and $value ne $XML_NS) {
160          $self->{onerror}          $self->{onerror}
161            ->(node => $attr, level => 'NC',            ->(node => $attr,
162               type => 'Reserved Prefixes and Namespace Names:xmlns:xml=');               type => 'Reserved Prefixes and Namespace Names:Prefix',
163                 text => $ln,
164                 level => $self->{level}->{nc});
165        } elsif ($ln eq 'xmlns') {        } elsif ($ln eq 'xmlns') {
166          $self->{onerror}          $self->{onerror}
167            ->(node => $attr, level => 'NC',            ->(node => $attr,
168               type => 'Reserved Prefixes and Namespace Names:xmlns:xmlns=');               type => 'Reserved Prefixes and Namespace Names:Prefix',
169                 text => $ln,
170                 level => $self->{level}->{nc});
171        }        }
172        ## TODO: If XML 1.0 and empty        ## TODO: If XML 1.0 and empty
173      },      },
# Line 128  our $AttrChecker = { Line 179  our $AttrChecker = {
179        my $value = $attr->value;        my $value = $attr->value;
180        if ($value eq $XML_NS) {        if ($value eq $XML_NS) {
181          $self->{onerror}          $self->{onerror}
182            ->(node => $attr, level => 'NC',            ->(node => $attr,
183               type => 'Reserved Prefixes and Namespace Names:=xml');               type => 'Reserved Prefixes and Namespace Names:Name',
184                 text => $value,
185                 level => $self->{level}->{nc});
186        } elsif ($value eq $XMLNS_NS) {        } elsif ($value eq $XMLNS_NS) {
187          $self->{onerror}          $self->{onerror}
188            ->(node => $attr, level => 'NC',            ->(node => $attr,
189               type => 'Reserved Prefixes and Namespace Names:=xmlns');               type => 'Reserved Prefixes and Namespace Names:Name',
190                 text => $value,
191                 level => $self->{level}->{nc});
192        }        }
193      },      },
194    },    },
# Line 142  our $AttrChecker = { Line 197  our $AttrChecker = {
197  ## ISSUE: Should we really allow these attributes?  ## ISSUE: Should we really allow these attributes?
198  $AttrChecker->{''}->{'xml:space'} = $AttrChecker->{$XML_NS}->{space};  $AttrChecker->{''}->{'xml:space'} = $AttrChecker->{$XML_NS}->{space};
199  $AttrChecker->{''}->{'xml:lang'} = $AttrChecker->{$XML_NS}->{lang};  $AttrChecker->{''}->{'xml:lang'} = $AttrChecker->{$XML_NS}->{lang};
200        ## NOTE: Checker for (null, "xml:lang") attribute is shadowed for
201        ## HTML elements in Whatpm::ContentChecker::HTML.
202  $AttrChecker->{''}->{'xml:base'} = $AttrChecker->{$XML_NS}->{base};  $AttrChecker->{''}->{'xml:base'} = $AttrChecker->{$XML_NS}->{base};
203  $AttrChecker->{''}->{'xml:id'} = $AttrChecker->{$XML_NS}->{id};  $AttrChecker->{''}->{'xml:id'} = $AttrChecker->{$XML_NS}->{id};
204    
205    our $AttrStatus;
206    
207    for (qw/space lang base id/) {
208      $AttrStatus->{$XML_NS}->{$_} = FEATURE_STATUS_REC | FEATURE_ALLOWED;
209      $AttrStatus->{''}->{"xml:$_"} = FEATURE_STATUS_REC | FEATURE_ALLOWED;
210      ## XML 1.0: FEATURE_STATUS_CR
211      ## XML 1.1: FEATURE_STATUS_REC
212      ## XML Namespaces 1.0: FEATURE_STATUS_CR
213      ## XML Namespaces 1.1: FEATURE_STATUS_REC
214      ## XML Base: FEATURE_STATUS_REC
215      ## xml:id: FEATURE_STATUS_REC
216    }
217    
218    $AttrStatus->{$XMLNS_NS}->{''} = FEATURE_STATUS_REC | FEATURE_ALLOWED;
219    
220    ## TODO: xsi:schemaLocation for XHTML2 support (very, very low priority)
221    
222  our %AnyChecker = (  our %AnyChecker = (
223    check_start => sub { },    check_start => sub { },
224    check_attrs => sub {    check_attrs => sub {
225      my ($self, $item, $element_state) = @_;      my ($self, $item, $element_state) = @_;
226      for my $attr (@{$item->{node}->attributes}) {      for my $attr (@{$item->{node}->attributes}) {
227        my $attr_ns = $attr->namespace_uri;        my $attr_ns = $attr->namespace_uri;
228        $attr_ns = '' unless defined $attr_ns;        if (defined $attr_ns) {
229            load_ns_module ($attr_ns);
230          } else {
231            $attr_ns = '';
232          }
233        my $attr_ln = $attr->manakai_local_name;        my $attr_ln = $attr->manakai_local_name;
234          
235        my $checker = $AttrChecker->{$attr_ns}->{$attr_ln}        my $checker = $AttrChecker->{$attr_ns}->{$attr_ln}
236            || $AttrChecker->{$attr_ns}->{''};            || $AttrChecker->{$attr_ns}->{''};
237          my $status = $AttrStatus->{$attr_ns}->{$attr_ln}
238              || $AttrStatus->{$attr_ns}->{''};
239          if (not defined $status) {
240            $status = FEATURE_ALLOWED;
241            ## NOTE: FEATURE_ALLOWED for all attributes, since the element
242            ## is not supported and therefore "attribute not defined" error
243            ## should not raised (too verbose) and global attributes should be
244            ## allowed anyway (if a global attribute has its specified creteria
245            ## for where it may be specified, then it should be checked in it's
246            ## checker function).
247          }
248        if ($checker) {        if ($checker) {
249          $checker->($self, $attr);          $checker->($self, $attr);
250        } else {        } else {
251          $self->{onerror}->(node => $attr, level => 'unsupported',          $self->{onerror}->(node => $attr,
252                             type => 'attribute');                             type => 'unknown attribute',
253                               level => $self->{level}->{uncertain});
254        }        }
255          $self->_attr_status_info ($attr, $status);
256      }      }
257    },    },
258    check_child_element => sub {    check_child_element => sub {
# Line 169  our %AnyChecker = ( Line 261  our %AnyChecker = (
261      if ($self->{minus_elements}->{$child_nsuri}->{$child_ln}) {      if ($self->{minus_elements}->{$child_nsuri}->{$child_ln}) {
262        $self->{onerror}->(node => $child_el,        $self->{onerror}->(node => $child_el,
263                           type => 'element not allowed:minus',                           type => 'element not allowed:minus',
264                           level => $self->{must_level});                           level => $self->{level}->{must});
265      } elsif ($self->{plus_elements}->{$child_nsuri}->{$child_ln}) {      } elsif ($self->{plus_elements}->{$child_nsuri}->{$child_ln}) {
266        #        #
267      } else {      } else {
# Line 179  our %AnyChecker = ( Line 271  our %AnyChecker = (
271    check_child_text => sub { },    check_child_text => sub { },
272    check_end => sub {    check_end => sub {
273      my ($self, $item, $element_state) = @_;      my ($self, $item, $element_state) = @_;
274        ## NOTE: There is a modified copy of the code below for |html:ruby|.
275      if ($element_state->{has_significant}) {      if ($element_state->{has_significant}) {
276        $item->{real_parent_state}->{has_significant} = 1;        $item->{real_parent_state}->{has_significant} = 1;
277      }          }    
# Line 187  our %AnyChecker = ( Line 280  our %AnyChecker = (
280    
281  our $ElementDefault = {  our $ElementDefault = {
282    %AnyChecker,    %AnyChecker,
283      status => FEATURE_ALLOWED,
284          ## NOTE: No "element not defined" error - it is not supported anyway.
285    check_start => sub {    check_start => sub {
286      my ($self, $item, $element_state) = @_;      my ($self, $item, $element_state) = @_;
287      $self->{onerror}->(node => $item->{node}, level => 'unsupported',      $self->{onerror}->(node => $item->{node},
288                         type => 'element');                         type => 'unknown element',
289                           level => $self->{level}->{uncertain});
290    },    },
291  };  };
292    
# Line 200  our $HTMLEmbeddedContent = { Line 296  our $HTMLEmbeddedContent = {
296      img => 1, iframe => 1, embed => 1, object => 1, video => 1, audio => 1,      img => 1, iframe => 1, embed => 1, object => 1, video => 1, audio => 1,
297      canvas => 1,      canvas => 1,
298    },    },
   ## NOTE: MathML is mentioned in the HTML5 spec.  
299    q<http://www.w3.org/1998/Math/MathML> => {math => 1},    q<http://www.w3.org/1998/Math/MathML> => {math => 1},
   ## NOTE: SVG is mentioned in the HTML5 spec.  
300    q<http://www.w3.org/2000/svg> => {svg => 1},    q<http://www.w3.org/2000/svg> => {svg => 1},
301    ## NOTE: Foreign elements with content (but no metadata) are    ## NOTE: Foreign elements with content (but no metadata) are
302    ## embedded content.    ## embedded content.
303  };    };  
304    
305    our $IsInHTMLInteractiveContent = sub {
306      my ($el, $nsuri, $ln) = @_;
307    
308      ## NOTE: This CODE returns whether an element that is conditionally
309      ## categorizzed as an interactive content is currently in that
310      ## condition or not.  See $HTMLInteractiveContent list defined in
311      ## Whatpm::ContentChecler::HTML for the list of all (conditionally
312      ## or permanently) interactive content.
313    
314      if ($nsuri eq $HTML_NS and ($ln eq 'video' or $ln eq 'audio')) {
315        return $el->has_attribute ('controls');
316      } elsif ($nsuri eq $HTML_NS and $ln eq 'menu') {
317        my $value = $el->get_attribute ('type');
318        $value =~ tr/A-Z/a-z/; # ASCII case-insensitive
319        return ($value eq 'toolbar');
320      } else {
321        return 1;
322      }
323    }; # $IsInHTMLInteractiveContent
324    
325  my $HTMLTransparentElements = {  my $HTMLTransparentElements = {
326    $HTML_NS => {qw/ins 1 del 1 font 1 noscript 1 canvas 1/},    $HTML_NS => {qw/ins 1 del 1 font 1 noscript 1 canvas 1 a 1/},
327    ## NOTE: |html:noscript| is transparent if scripting is disabled    ## NOTE: |html:noscript| is transparent if scripting is disabled
328    ## and not in |head|.    ## and not in |head|.
329  };  };
# Line 220  my $HTMLSemiTransparentElements = { Line 334  my $HTMLSemiTransparentElements = {
334    
335  our $Element = {};  our $Element = {};
336    
337    $Element->{q<http://www.w3.org/1999/02/22-rdf-syntax-ns#>}->{RDF} = {
338      %AnyChecker,
339      status => FEATURE_STATUS_REC | FEATURE_ALLOWED,
340      is_root => 1, ## ISSUE: Not explicitly allowed for non application/rdf+xml
341      check_start => sub {
342        my ($self, $item, $element_state) = @_;
343        my $triple = [];
344        push @{$self->{return}->{rdf}}, [$item->{node}, $triple];
345        require Whatpm::RDFXML;
346        my $rdf = Whatpm::RDFXML->new;
347        ## TODO: Should we make bnodeid unique in a document?
348        $rdf->{onerror} = $self->{onerror};
349        $rdf->{level} = $self->{level};
350        $rdf->{ontriple} = sub {
351          my %opt = @_;
352          push @$triple,
353              [$opt{node}, $opt{subject}, $opt{predicate}, $opt{object}];
354          if (defined $opt{id}) {
355            push @$triple,
356                [$opt{node},
357                 $opt{id},
358                 {uri => q<http://www.w3.org/1999/02/22-rdf-syntax-ns#subject>},
359                 $opt{subject}];
360            push @$triple,
361                [$opt{node},
362                 $opt{id},
363                 {uri => q<http://www.w3.org/1999/02/22-rdf-syntax-ns#predicate>},
364                 $opt{predicate}];
365            push @$triple,
366                [$opt{node},
367                 $opt{id},
368                 {uri => q<http://www.w3.org/1999/02/22-rdf-syntax-ns#object>},
369                 $opt{object}];
370            push @$triple,
371                [$opt{node},
372                 $opt{id},
373                 {uri => q<http://www.w3.org/1999/02/22-rdf-syntax-ns#type>},
374                 {uri => q<http://www.w3.org/1999/02/22-rdf-syntax-ns#Statement>}];
375          }
376        };
377        $rdf->convert_rdf_element ($item->{node});
378      },
379    };
380    
381    my $default_error_level = {
382      must => 'm',
383      should => 's',
384      warn => 'w',
385      good => 'w',
386      undefined => 'w',
387      info => 'i',
388    
389      uncertain => 'u',
390    
391      html4_fact => 'm',
392      html5_no_may => 'm',
393    
394      xml_error => 'm', ## TODO: correct?
395      xml_id_error => 'm', ## TODO: ?
396      nc => 'm', ## XML Namespace Constraints ## TODO: correct?
397    
398      ## |Whatpm::URIChecker|
399      uri_syntax => 'm',
400      uri_fact => 'm',
401      uri_lc_must => 'm',
402      uri_lc_should => 'w',
403    
404      ## |Whatpm::IMTChecker|
405      mime_must => 'm', # lowercase "must"
406      mime_fact => 'm',
407      mime_strongly_discouraged => 'w',
408      mime_discouraged => 'w',
409    
410      ## |Whatpm::LangTag|
411      langtag_fact => 'm',
412    
413      ## |Whatpm::RDFXML|
414      rdf_fact => 'm',
415      rdf_grammer => 'm',
416      rdf_lc_must => 'm',
417    
418      ## |Message::Charset::Info| and |Whatpm::Charset::DecodeHandle|
419      charset_variant => 'm',
420        ## An error caused by use of a variant charset that is not conforming
421        ## to the original charset (e.g. use of 0x80 in an ISO-8859-1 document
422        ## which is interpreted as a Windows-1252 document instead).
423      charset_fact => 'm',
424      iso_shall => 'm',
425    };
426    
427  sub check_document ($$$;$) {  sub check_document ($$$;$) {
428    my ($self, $doc, $onerror, $onsubdoc) = @_;    my ($self, $doc, $onerror, $onsubdoc) = @_;
429    $self = bless {}, $self unless ref $self;    $self = bless {}, $self unless ref $self;
# Line 228  sub check_document ($$$;$) { Line 432  sub check_document ($$$;$) {
432      warn "A subdocument is not conformance-checked";      warn "A subdocument is not conformance-checked";
433    };    };
434    
435    $self->{must_level} = 'm';    $self->{level} ||= $default_error_level;
436    $self->{fact_level} = 'f';  
437    $self->{should_level} = 's';    ## TODO: If application/rdf+xml, RDF/XML mode should be invoked.
   $self->{good_level} = 'w';  
   $self->{info_level} = 'i';  
   $self->{unsupported_lavel} = 'u';  
438    
439    my $docel = $doc->document_element;    my $docel = $doc->document_element;
440    unless (defined $docel) {    unless (defined $docel) {
441      ## ISSUE: Should we check content of Document node?      ## ISSUE: Should we check content of Document node?
442      $onerror->(node => $doc, type => 'no document element');      $onerror->(node => $doc, type => 'no document element',
443                   level => $self->{level}->{must});
444      ## ISSUE: Is this non-conforming (to what spec)?  Or just a warning?      ## ISSUE: Is this non-conforming (to what spec)?  Or just a warning?
445      return {      return {
446              class => {},              class => {},
# Line 249  sub check_document ($$$;$) { Line 451  sub check_document ($$$;$) {
451    ## ISSUE: Unexpanded entity references and HTML5 conformance    ## ISSUE: Unexpanded entity references and HTML5 conformance
452        
453    my $docel_nsuri = $docel->namespace_uri;    my $docel_nsuri = $docel->namespace_uri;
454    $docel_nsuri = '' unless defined $docel_nsuri;    if (defined $docel_nsuri) {
455    unless ($Namespace->{$docel_nsuri}->{loaded}) {      load_ns_module ($docel_nsuri);
456      if ($Namespace->{$docel_nsuri}->{module}) {    } else {
457        eval qq{ require $Namespace->{$docel_nsuri}->{module} } or die $@;      $docel_nsuri = '';
     } else {  
       $Namespace->{$docel_nsuri}->{loaded} = 1;  
     }  
458    }    }
459    my $docel_def = $Element->{$docel_nsuri}->{$docel->manakai_local_name} ||    my $docel_def = $Element->{$docel_nsuri}->{$docel->manakai_local_name} ||
460      $Element->{$docel_nsuri}->{''} ||      $Element->{$docel_nsuri}->{''} ||
# Line 266  sub check_document ($$$;$) { Line 465  sub check_document ($$$;$) {
465      unless ($doc->manakai_is_html) {      unless ($doc->manakai_is_html) {
466        #        #
467      } else {      } else {
468        $onerror->(node => $docel, type => 'element not allowed:root:xml');        $onerror->(node => $docel, type => 'element not allowed:root:xml',
469                     level => $self->{level}->{must});
470      }      }
471    } else {    } else {
472      $onerror->(node => $docel, type => 'element not allowed:root');      $onerror->(node => $docel, type => 'element not allowed:root',
473                   level => $self->{level}->{must});
474    }    }
475    
476    ## TODO: Check for other items other than document element    ## TODO: Check for other items other than document element
# Line 283  sub check_document ($$$;$) { Line 484  sub check_document ($$$;$) {
484      require Message::Charset::Info;      require Message::Charset::Info;
485      my $charset = $Message::Charset::Info::IANACharset->{$charset_name};      my $charset = $Message::Charset::Info::IANACharset->{$charset_name};
486    
487      if ($doc->manakai_is_html and      if ($doc->manakai_is_html) {
488          not $doc->manakai_has_bom and        if (not $doc->manakai_has_bom and
489          not defined $doc->manakai_charset) {            not defined $doc->manakai_charset) {
490        unless ($charset->{is_html_ascii_superset}) {          unless ($charset->{is_html_ascii_superset}) {
491          $onerror->(node => $doc, level => $self->{must_level},            $onerror->(node => $doc,
492                     type => 'non ascii superset:'.$charset_name);                       level => $self->{level}->{must},
493        }                       type => 'non ascii superset',
494                               text => $charset_name);
495        if (not $self->{has_charset} and          }
496            not $charset->{iana_names}->{'us-ascii'}) {          
497          $onerror->(node => $doc, level => $self->{must_level},          if (not $self->{has_charset} and ## TODO: This does not work now.
498                     type => 'no character encoding declaration:'.$charset_name);              not $charset->{iana_names}->{'us-ascii'}) {
499              $onerror->(node => $doc,
500                         level => $self->{level}->{must},
501                         type => 'no character encoding declaration',
502                         text => $charset_name);
503            }
504        }        }
     }  
505    
506      if ($charset->{iana_names}->{'utf-8'}) {        if ($charset->{iana_names}->{'utf-8'}) {
507        #          #
508      } elsif ($charset->{iana_names}->{'jis_x0212-1990'} or        } elsif ($charset->{iana_names}->{'jis_x0212-1990'} or
509               $charset->{iana_names}->{'x-jis0208'} or                 $charset->{iana_names}->{'x-jis0208'} or
510               $charset->{iana_names}->{'utf-32'} or ## ISSUE: UTF-32BE? UTF-32LE?                 $charset->{iana_names}->{'utf-32'} or ## ISSUE: UTF-32BE? UTF-32LE?
511               $charset->{is_ebcdic_based}) {                 ($charset->{category} & Message::Charset::Info::CHARSET_CATEGORY_EBCDIC ())) {
512        $onerror->(node => $doc,          $onerror->(node => $doc,
513                   type => 'character encoding:'.$charset_name,                     type => 'bad character encoding',
514                   level => $self->{should_level});                     text => $charset_name,
515      } elsif ($charset->{iana_names}->{'cesu-8'} or                     level => $self->{level}->{should},
516               $charset->{iana_names}->{'utf-8'} or ## ISSUE: UNICODE-1-1-UTF-7?                     layer => 'encode');
517               $charset->{iana_names}->{'bocu-1'} or        } elsif ($charset->{iana_names}->{'cesu-8'} or
518               $charset->{iana_names}->{'scsu'}) {                 $charset->{iana_names}->{'utf-8'} or ## ISSUE: UNICODE-1-1-UTF-7?
519        $onerror->(node => $doc,                 $charset->{iana_names}->{'bocu-1'} or
520                   type => 'character encoding:'.$charset_name,                 $charset->{iana_names}->{'scsu'}) {
521                   level => $self->{must_level});          $onerror->(node => $doc,
522      } else {                     type => 'disallowed character encoding',
523        $onerror->(node => $doc,                     text => $charset_name,
524                   type => 'character encoding:'.$charset_name,                     level => $self->{level}->{must},
525                   level => $self->{good_level});                     layer => 'encode');
526          } else {
527            $onerror->(node => $doc,
528                       type => 'non-utf-8 character encoding',
529                       text => $charset_name,
530                       level => $self->{level}->{good},
531                       layer => 'encode');
532          }
533      }      }
534    } elsif ($doc->manakai_is_html) {    } elsif ($doc->manakai_is_html) {
535      ## NOTE: MUST and SHOULD requirements above cannot be tested,      ## NOTE: MUST and SHOULD requirements above cannot be tested,
536      ## since the document has no input charset encoding information.      ## since the document has no input charset encoding information.
537      $onerror->(node => $doc,      $onerror->(node => $doc,
538                 type => 'character encoding:',                 type => 'character encoding unchecked',
539                 level => 'unsupported');                 level => $self->{level}->{info},
540                   layer => 'encode');
541    }    }
542    
543    return $return;    return $return;
544  } # check_document  } # check_document
545    
546    ## Check an element.  The element is checked as if it is an orphan node (i.e.
547    ## an element without a parent node).
548  sub check_element ($$$;$) {  sub check_element ($$$;$) {
549    my ($self, $el, $onerror, $onsubdoc) = @_;    my ($self, $el, $onerror, $onsubdoc) = @_;
550    $self = bless {}, $self unless ref $self;    $self = bless {}, $self unless ref $self;
# Line 338  sub check_element ($$$;$) { Line 553  sub check_element ($$$;$) {
553      warn "A subdocument is not conformance-checked";      warn "A subdocument is not conformance-checked";
554    };    };
555    
556    $self->{must_level} = 'm';    $self->{level} ||= $default_error_level;
   $self->{fact_level} = 'f';  
   $self->{should_level} = 's';  
   $self->{good_level} = 'w';  
   $self->{info_level} = 'i';  
   $self->{unsupported_lavel} = 'u';  
557    
558    $self->{plus_elements} = {};    $self->{plus_elements} = {};
559    $self->{minus_elements} = {};    $self->{minus_elements} = {};
560    $self->{id} = {};    $self->{id} = {};
561      $self->{form} = {};
562    $self->{term} = {};    $self->{term} = {};
563    $self->{usemap} = [];    $self->{usemap} = [];
564      $self->{ref} = []; # datetemplate data references
565      $self->{template} = []; # datatemplate template references
566    $self->{contextmenu} = [];    $self->{contextmenu} = [];
567    $self->{map} = {};    $self->{map} = {};
568    $self->{menu} = {};    $self->{menu} = {};
# Line 361  sub check_element ($$$;$) { Line 574  sub check_element ($$$;$) {
574    #$self->{has_base};    #$self->{has_base};
575    $self->{return} = {    $self->{return} = {
576      class => {},      class => {},
577      id => $self->{id}, table => [], term => $self->{term},      id => $self->{id},
578        table => [], # table objects returned by Whatpm::HTMLTable
579        term => $self->{term},
580        uri => {}, # URIs other than those in RDF triples
581                         ## TODO: xmlns="", SYSTEM "", atom:* src="", xml:base=""
582        rdf => [],
583    };    };
584    
585    my @item = ({type => 'element', node => $el, parent_state => {}});    my @item = ({type => 'element', node => $el, parent_state => {}});
# Line 374  next unless $code;## TODO: temp. Line 592  next unless $code;## TODO: temp.
592        $code->(@$item);        $code->(@$item);
593      } elsif ($item->{type} eq 'element') {      } elsif ($item->{type} eq 'element') {
594        my $el_nsuri = $item->{node}->namespace_uri;        my $el_nsuri = $item->{node}->namespace_uri;
595        $el_nsuri = '' unless defined $el_nsuri;        if (defined $el_nsuri) {
596            load_ns_module ($el_nsuri);
597          } else {
598            $el_nsuri = '';
599          }
600        my $el_ln = $item->{node}->manakai_local_name;        my $el_ln = $item->{node}->manakai_local_name;
601                
       unless ($Namespace->{$el_nsuri}->{loaded}) {  
         if ($Namespace->{$el_nsuri}->{module}) {  
           eval qq{ require $Namespace->{$el_nsuri}->{module} } or die $@;  
         } else {  
           $Namespace->{$el_nsuri}->{loaded} = 1;  
         }  
       }  
   
602        my $element_state = {};        my $element_state = {};
603        my $eldef = $Element->{$el_nsuri}->{$el_ln} ||        my $eldef = $Element->{$el_nsuri}->{$el_ln} ||
604            $Element->{$el_nsuri}->{''} ||            $Element->{$el_nsuri}->{''} ||
# Line 402  next unless $code;## TODO: temp. Line 616  next unless $code;## TODO: temp.
616              $eldef->{status} & FEATURE_STATUS_WD ? 'wd' : 'non-standard';              $eldef->{status} & FEATURE_STATUS_WD ? 'wd' : 'non-standard';
617          $self->{onerror}->(node => $item->{node},          $self->{onerror}->(node => $item->{node},
618                             type => 'status:'.$status.':element',                             type => 'status:'.$status.':element',
619                             level => $self->{info_level});                             level => $self->{level}->{info});
620          }
621          if (not ($eldef->{status} & FEATURE_ALLOWED)) {
622            $self->{onerror}->(node => $item->{node},
623                               type => 'element not defined',
624                               level => $self->{level}->{must});
625          } elsif ($eldef->{status} & FEATURE_DEPRECATED_SHOULD) {
626            $self->{onerror}->(node => $item->{node},
627                               type => 'deprecated:element',
628                               level => $self->{level}->{should});
629          } elsif ($eldef->{status} & FEATURE_DEPRECATED_INFO) {
630            $self->{onerror}->(node => $item->{node},
631                               type => 'deprecated:element',
632                               level => $self->{level}->{info});
633        }        }
634    
635        my @new_item;        my @new_item;
# Line 471  next unless $code;## TODO: temp. Line 698  next unless $code;## TODO: temp.
698            }            }
699          } elsif ($child_nt == 3 or # TEXT_NODE          } elsif ($child_nt == 3 or # TEXT_NODE
700                   $child_nt == 4) { # CDATA_SECTION_NODE                   $child_nt == 4) { # CDATA_SECTION_NODE
701            my $has_significant = ($child->data =~ /[^\x09-\x0D\x20]/);            my $has_significant = ($child->data =~ /[^\x09\x0A\x0C\x0D\x20]/);
702            push @new_item, [$content_def->{check_child_text},            push @new_item, [$content_def->{check_child_text},
703                             $self, $item, $child, $has_significant,                             $self, $item, $child, $has_significant,
704                             $content_state, $element_state];                             $content_state, $element_state];
# Line 495  next unless $code;## TODO: temp. Line 722  next unless $code;## TODO: temp.
722      }      }
723    }    }
724    
725      for (@{$self->{template}}) {
726        ## TODO: If the document is an XML document, ...
727        ## NOTE: If the document is an HTML document:
728        ## ISSUE: We need to percent-decode?
729        F: {
730          if ($self->{id}->{$_->[0]}) {
731            my $el = $self->{id}->{$_->[0]}->[0]->owner_element;
732            if ($el->node_type == 1 and # ELEMENT_NODE
733                $el->manakai_local_name eq 'datatemplate') {
734              my $nsuri = $el->namespace_uri;
735              if (defined $nsuri and $nsuri eq $HTML_NS) {
736                if ($el eq $_->[1]->owner_element) {
737                  $self->{onerror}->(node => $_->[1],
738                                     type => 'fragment points itself',
739                                     level => $self->{level}->{must});
740                }
741                
742                last F;
743              }
744            }
745          }
746          ## TODO: Should we raise a "fragment points nothing" error instead
747          ## if the fragment identifier identifies no element?
748    
749          $self->{onerror}->(node => $_->[1], type => 'template:not template',
750                             level => $self->{level}->{must});
751        } # F
752      }
753      
754      for (@{$self->{ref}}) {
755        ## TOOD: If XML
756        ## NOTE: If it is an HTML document:
757        if ($_->[0] eq '') {
758          ## NOTE: It points the top of the document.
759        } elsif ($self->{id}->{$_->[0]}) {
760          if ($self->{id}->{$_->[0]}->[0]->owner_element
761                  eq $_->[1]->owner_element) {
762            $self->{onerror}->(node => $_->[1], type => 'fragment points itself',
763                               level => $self->{level}->{must});
764          }
765        } else {
766          $self->{onerror}->(node => $_->[1], type => 'fragment points nothing',
767                             level => $self->{level}->{must});
768        }
769      }
770    
771      ## TODO: Maybe we should have $document->manakai_get_by_fragment or something
772    
773    for (@{$self->{usemap}}) {    for (@{$self->{usemap}}) {
774      unless ($self->{map}->{$_->[0]}) {      unless ($self->{map}->{$_->[0]}) {
775        $self->{onerror}->(node => $_->[1], type => 'no referenced map');        $self->{onerror}->(node => $_->[1], type => 'no referenced map',
776                             level => $self->{level}->{must});
777      }      }
778    }    }
779    
780    for (@{$self->{contextmenu}}) {    for (@{$self->{contextmenu}}) {
781      unless ($self->{menu}->{$_->[0]}) {      unless ($self->{menu}->{$_->[0]}) {
782        $self->{onerror}->(node => $_->[1], type => 'no referenced menu');        $self->{onerror}->(node => $_->[1], type => 'no referenced menu',
783                             level => $self->{level}->{must});
784      }      }
785    }    }
786    
# Line 511  next unless $code;## TODO: temp. Line 788  next unless $code;## TODO: temp.
788    delete $self->{minus_elements};    delete $self->{minus_elements};
789    delete $self->{onerror};    delete $self->{onerror};
790    delete $self->{id};    delete $self->{id};
791      delete $self->{form};
792    delete $self->{usemap};    delete $self->{usemap};
793      delete $self->{ref};
794      delete $self->{template};
795    delete $self->{map};    delete $self->{map};
796    return $self->{return};    return $self->{return};
797  } # check_element  } # check_element
# Line 568  sub _remove_plus_elements ($$) { Line 848  sub _remove_plus_elements ($$) {
848    
849  sub _attr_status_info ($$$) {  sub _attr_status_info ($$$) {
850    my ($self, $attr, $status_code) = @_;    my ($self, $attr, $status_code) = @_;
851    
852      if (not ($status_code & FEATURE_ALLOWED)) {
853        $self->{onerror}->(node => $attr,
854                           type => 'attribute not defined',
855                           level => $self->{level}->{must});
856      } elsif ($status_code & FEATURE_DEPRECATED_SHOULD) {
857        $self->{onerror}->(node => $attr,
858                           type => 'deprecated:attr',
859                           level => $self->{level}->{should});
860      } elsif ($status_code & FEATURE_DEPRECATED_INFO) {
861        $self->{onerror}->(node => $attr,
862                           type => 'deprecated:attr',
863                           level => $self->{level}->{info});
864      }
865    
866    my $status;    my $status;
867    if ($status_code & FEATURE_STATUS_REC) {    if ($status_code & FEATURE_STATUS_REC) {
868      return;      return;
# Line 582  sub _attr_status_info ($$$) { Line 877  sub _attr_status_info ($$$) {
877    }    }
878    $self->{onerror}->(node => $attr,    $self->{onerror}->(node => $attr,
879                       type => 'status:'.$status.':attr',                       type => 'status:'.$status.':attr',
880                       level => $self->{info_level});                       level => $self->{level}->{info});
881  } # _attr_status_info  } # _attr_status_info
882    
883  sub _add_minuses ($@) {  sub _add_minuses ($@) {
# Line 697  sub _check_get_children ($$$) { Line 992  sub _check_get_children ($$$) {
992                last CN;                last CN;
993              }              }
994            } elsif ($cnt == 3 or $cnt == 4) {            } elsif ($cnt == 3 or $cnt == 4) {
995              if ($cn->data =~ /[^\x09-\x0D\x20]/) {              if ($cn->data =~ /[^\x09\x0A\x0C\x0D\x20]/) {
996                last CN;                last CN;
997              }              }
998            }            }
# Line 718  sub _check_get_children ($$$) { Line 1013  sub _check_get_children ($$$) {
1013              last CN;              last CN;
1014            }            }
1015          } elsif ($cnt == 3 or $cnt == 4) {          } elsif ($cnt == 3 or $cnt == 4) {
1016            if ($cn->data =~ /[^\x09-\x0D\x20]/) {            if ($cn->data =~ /[^\x09\x0A\x0C\x0D\x20]/) {
1017              last CN;              last CN;
1018            }            }
1019          }          }
Legend:
Removed from v.1.68  
changed lines
  Added in v.1.97
[email protected]
 ViewVC Help
Powered by ViewVC 1.1.24