—

              
use 5.010;
use strict;
use warnings;
package HTML::HTML5::Sanity;
BEGIN {
        $HTML::HTML5::Sanity::AUTHORITY = 'cpan:TOBYINK';
        $HTML::HTML5::Sanity::VERSION   = '0.105';
}
require Exporter;
our @ISA = qw(Exporter);
our %EXPORT_TAGS = (
        'all'       => [ qw(fix_document) ],
        'standard'  => [ qw(fix_document) ],
);
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
our @EXPORT    = ( @{ $EXPORT_TAGS{'standard'} } );
our $FIX_LANG_ATTRIBUTES = 1;
use Locale::Country qw(country_code2code LOCALE_CODE_ALPHA_2 LOCALE_CODE_NUMERIC);
use XML::LibXML qw(:ns :libxml);
our $lang_3to2 = {
        'aar' => 'aa' ,
        'abk' => 'ab' ,
        'ave' => 'ae' ,
        'afr' => 'af' ,
        'aka' => 'ak' ,
        'amh' => 'am' ,
        'arg' => 'an' ,
        'ara' => 'ar' ,
        'asm' => 'as' ,
        'ava' => 'av' ,
        'aym' => 'ay' ,
        'aze' => 'az' ,
        'bak' => 'ba' ,
        'bel' => 'be' ,
        'bul' => 'bg' ,
        'bih' => 'bh' ,
        'bis' => 'bi' ,
        'bam' => 'bm' ,
        'ben' => 'bn' ,
        'tib' => 'bo' ,
        'bod' => 'bo' ,
        'bre' => 'br' ,
        'bos' => 'bs' ,
        'cat' => 'ca' ,
        'che' => 'ce' ,
        'cha' => 'ch' ,
        'cos' => 'co' ,
        'cre' => 'cr' ,
        'cze' => 'cs' ,
        'ces' => 'cs' ,
        'chu' => 'cu' ,
        'chv' => 'cv' ,
        'wel' => 'cy' ,
        'cym' => 'cy' ,
        'dan' => 'da' ,
        'ger' => 'de' ,
        'deu' => 'de' ,
        'div' => 'dv' ,
        'dzo' => 'dz' ,
        'ewe' => 'ee' ,
        'gre' => 'el' ,
        'ell' => 'el' ,
        'eng' => 'en' ,
        'epo' => 'eo' ,
        'spa' => 'es' ,
        'est' => 'et' ,
        'baq' => 'eu' ,
        'eus' => 'eu' ,
        'per' => 'fa' ,
        'fas' => 'fa' ,
        'ful' => 'ff' ,
        'fin' => 'fi' ,
        'fij' => 'fj' ,
        'fao' => 'fo' ,
        'fre' => 'fr' ,
        'fra' => 'fr' ,
        'fry' => 'fy' ,
        'gle' => 'ga' ,
        'gla' => 'gd' ,
        'glg' => 'gl' ,
        'grn' => 'gn' ,
        'guj' => 'gu' ,
        'glv' => 'gv' ,
        'hau' => 'ha' ,
        'heb' => 'he' ,
        'hin' => 'hi' ,
        'hmo' => 'ho' ,
        'hrv' => 'hr' ,
        'hat' => 'ht' ,
        'hat' => 'ht' ,
        'hun' => 'hu' ,
        'arm' => 'hy' ,
        'hye' => 'hy' ,
        'her' => 'hz' ,
        'ina' => 'ia' ,
        'ind' => 'id' ,
        'ile' => 'ie' ,
        'ibo' => 'ig' ,
        'iii' => 'ii' ,
        'ipk' => 'ik' ,
        'ido' => 'io' ,
        'ice' => 'is' ,
        'isl' => 'is' ,
        'ita' => 'it' ,
        'iku' => 'iu' ,
        'jpn' => 'ja' ,
        'jav' => 'jv' ,
        'geo' => 'ka' ,
        'kat' => 'ka' ,
        'kon' => 'kg' ,
        'kik' => 'ki' ,
        'kik' => 'ki' ,
        'kua' => 'kj' ,
        'kaz' => 'kk' ,
        'kal' => 'kl' ,
        'khm' => 'km' ,
        'kan' => 'kn' ,
        'kor' => 'ko' ,
        'kau' => 'kr' ,
        'kas' => 'ks' ,
        'kur' => 'ku' ,
        'kom' => 'kv' ,
        'cor' => 'kw' ,
        'kir' => 'ky' ,
        'lat' => 'la' ,
        'ltz' => 'lb' ,
        'ltz' => 'lb' ,
        'lug' => 'lg' ,
        'lim' => 'li' ,
        'lin' => 'ln' ,
        'lao' => 'lo' ,
        'lit' => 'lt' ,
        'lub' => 'lu' ,
        'lav' => 'lv' ,
        'mlg' => 'mg' ,
        'mah' => 'mh' ,
        'mao' => 'mi' ,
        'mri' => 'mi' ,
        'mac' => 'mk' ,
        'mkd' => 'mk' ,
        'mal' => 'ml' ,
        'mon' => 'mn' ,
        'mar' => 'mr' ,
        'may' => 'ms' ,
        'msa' => 'ms' ,
        'mlt' => 'mt' ,
        'bur' => 'my' ,
        'mya' => 'my' ,
        'nau' => 'na' ,
        'nob' => 'nb' ,
        'nde' => 'nd' ,
        'nep' => 'ne' ,
        'ndo' => 'ng' ,
        'dut' => 'nl' ,
        'nld' => 'nl' ,
        'nno' => 'nn' ,
        'nor' => 'no' ,
        'nbl' => 'nr' ,
        'nav' => 'nv' ,
        'nya' => 'ny' ,
        'oci' => 'oc' ,
        'oji' => 'oj' ,
        'orm' => 'om' ,
        'ori' => 'or' ,
        'oss' => 'os' ,
        'pan' => 'pa' ,
        'pli' => 'pi' ,
        'pol' => 'pl' ,
        'pus' => 'ps' ,
        'por' => 'pt' ,
        'que' => 'qu' ,
        'roh' => 'rm' ,
        'run' => 'rn' ,
        'rum' => 'ro' ,
        'ron' => 'ro' ,
        'rus' => 'ru' ,
        'kin' => 'rw' ,
        'san' => 'sa' ,
        'srd' => 'sc' ,
        'snd' => 'sd' ,
        'sme' => 'se' ,
        'sag' => 'sg' ,
        'sin' => 'si' ,
        'slo' => 'sk' ,
        'slk' => 'sk' ,
        'slv' => 'sl' ,
        'smo' => 'sm' ,
        'sna' => 'sn' ,
        'som' => 'so' ,
        'alb' => 'sq' ,
        'sqi' => 'sq' ,
        'srp' => 'sr' ,
        'ssw' => 'ss' ,
        'sot' => 'st' ,
        'sun' => 'su' ,
        'swe' => 'sv' ,
        'swa' => 'sw' ,
        'tam' => 'ta' ,
        'tel' => 'te' ,
        'tgk' => 'tg' ,
        'tha' => 'th' ,
        'tir' => 'ti' ,
        'tuk' => 'tk' ,
        'tgl' => 'tl' ,
        'tsn' => 'tn' ,
        'ton' => 'to' ,
        'tur' => 'tr' ,
        'tso' => 'ts' ,
        'tat' => 'tt' ,
        'twi' => 'tw' ,
        'tah' => 'ty' ,
        'uig' => 'ug' ,
        'ukr' => 'uk' ,
        'urd' => 'ur' ,
        'uzb' => 'uz' ,
        'ven' => 've' ,
        'vie' => 'vi' ,
        'vol' => 'vo' ,
        'wln' => 'wa' ,
        'wol' => 'wo' ,
        'xho' => 'xh' ,
        'yid' => 'yi' ,
        'yor' => 'yo' ,
        'zha' => 'za' ,
        'chi' => 'zh' ,
        'zho' => 'zh' ,
        'zul' => 'zu' ,
};
our $lang_grandfather = {
        'art-lojban'       => 'jbo',
        'i-ami'            => 'ami',
        'i-bnn'            => 'bnn',
        'i-hak'            => 'hak',
        'i-klingon'        => 'tlh',
        'i-lux'            => 'lb',
        'i-navajo'         => 'nv',
        'i-pwn'            => 'pwn', #haha
        'i-tao'            => 'tao',
        'i-tay'            => 'tay',
        'i-tsu'            => 'tsu',
        'no-bok'           => 'nb',
        'no-nyn'           => 'nn',
        'sgn-be-fr'        => 'sfb',
        'sgn-be-nl'        => 'vgt',
        'sgn-ch-de'        => 'sgg',
        'zh-guoyu'         => 'cmn',
        'zh-hakka'         => 'hak',
        'zh-min-nan'       => 'nan',
        'zh-xiang'         => 'hsn',
        };
our $obsolete_iso3166 = {
        'UK' => 'GB',   # Exceptionally reserved
        'FX' => 'FR',   # Exceptionally reserved
        'ZR' => 'CD',   # Zaire => Congo
        'HV' => 'BF',   # Upper Volta => Burkina Faso
        'DY' => 'BJ',   # Dahomey => Benin
        'BU' => 'MM',   # Burma => Myanmar
        'TP' => 'TL',   # East Timor => Timor-Leste
        'NH' => 'VU',   # New Hebrides => Vanuatu
        'RH' => 'ZW',   # Rhodesia => Zimbabwe
};
our $canon_lang = {};
sub fix_document
{
        my $old_document        = shift;
        my $attribute_behaviour = shift || 0;
         
        my $new_document        = XML::LibXML::Document->new;
         
        my $new_root = fix_element(
                $old_document->documentElement,
                $new_document,
                { ':' => 'http://www.w3.org/1999/xhtml', 'xml' => XML_XML_NS }
                );
                 
        $new_document->setDocumentElement($new_root);
         
        return $new_document;
}
sub fix_element
{
        my $old_element         = shift;
        my $new_document        = shift;
        my $parent_declarations = shift;
         
        my $declared_namespaces = {};
        foreach my $k (keys %{$parent_declarations})
        {
                $declared_namespaces->{$k} = $parent_declarations->{$k};
        }
         
        # Process namespace declarations on this element.
        foreach my $attr ($old_element->attributes)
        {
                next if $attr->nodeType == XML_NAMESPACE_DECL;
                 
                if ($attr->nodeName =~ /^xmlns:(.*)$/)
                {
                        my $prefix = $1;
                         
                        if ($prefix eq 'xml' && $attr->getData eq XML_XML_NS)
                        {
                                # that's OK.
                        }
                        elsif ($prefix eq 'xml' || $attr->getData eq XML_XML_NS)
                        {
                                next;
                        }
                        elsif ($prefix eq 'xmlns' || $attr->getData eq XML_XMLNS_NS)
                        {
                                next;
                        }
                         
                        $declared_namespaces->{ $prefix } = $attr->getData;
                }
        }
         
        # Process any default XML Namespace
        my $hasExplicit = 0;
        if ($old_element->hasAttributeNS(undef, 'xmlns'))
        {
                $hasExplicit = 1;
                $declared_namespaces->{ ':' } = $old_element->getAttributeNS(undef, 'xmlns');
        }
         
        # Create a new element.
        my $new_element;
        if ($hasExplicit)
        {
                $new_element = $new_document->createElementNS(
                        $declared_namespaces->{ ':' },
                        $old_element->nodeName,
                        );
        }
        else
        {
                my $tag = $old_element->nodeName;
                if ($tag =~ /^([^:]+)\:([^:]+)$/)
                {
                        my $ns_prefix = $1;
                        my $localname = $2;
                         
                        if (defined $declared_namespaces->{$ns_prefix})
                        {
                                $new_element = $new_document->createElementNS(
                                        $declared_namespaces->{$ns_prefix},  $tag);
                        }
                }
                unless ($new_element)
                {
                        $new_element = $new_document->createElementNS(
                                $declared_namespaces->{ ':' }, $tag);
                }
        }
         
        # Add attributes to new element.
        foreach my $old_attr ($old_element->attributes)
        {
                next if $old_attr->nodeType == XML_NAMESPACE_DECL;
                # next if $old_attr->nodeName =~ /^xmlns(:.*)?$/;
                 
                fix_attribute($old_attr, $new_element, $declared_namespaces);
        }
         
        # Process child nodes.
        foreach my $old_kid ($old_element->childNodes)
        {
                if ($old_kid->nodeType == XML_TEXT_NODE
                ||  $old_kid->nodeType == XML_CDATA_SECTION_NODE)
                {
                        $new_element->appendTextNode($old_kid->nodeValue);
                }
                elsif ($old_kid->nodeType == XML_COMMENT_NODE)
                {
                        $new_element->appendChild(
                                $new_document->createComment($old_kid->nodeValue)
                                );
                }
                elsif ($old_kid->nodeType == XML_ELEMENT_NODE)
                {
                        $new_element->appendChild(
                                fix_element($old_kid, $new_document, $declared_namespaces)
                                );
                }
        }
         
        return $new_element;
}
sub fix_attribute
{
        my $old_attribute       = shift;
        my $new_element         = shift;
        my $declared_namespaces = shift;
         
        my $name = $old_attribute->nodeName;
        my @new_attribute;
         
        if ($name =~ /^([^:]+)\:([^:]+)$/)
        {
                my $ns_prefix = $1;
                my $localname = $2;
                 
                if (defined $declared_namespaces->{$ns_prefix})
                {
                        @new_attribute = (
                                $declared_namespaces->{$ns_prefix},
                                sprintf("%s:%s", $ns_prefix, $localname),
                                );
                }
        }
         
        my $node_value = $old_attribute->nodeValue;
         
        if ($FIX_LANG_ATTRIBUTES && $name =~ /^(xml:)?lang$/i)
        {
                return undef
                        unless _valid_lang($node_value);
                 
                if ($FIX_LANG_ATTRIBUTES == 2)
                {
                        $node_value = _canon_lang($node_value);
                }
        }
         
        if (@new_attribute)
        {
                $new_element->setAttributeNS(@new_attribute, $node_value);
        }
        else
        {
                $new_element->setAttribute($name, $node_value);
        }
         
        return undef;
}
sub _valid_lang
{
        my $value_to_test = shift;
        return 1 if (defined $value_to_test) && ($value_to_test eq '');
        return 0 unless defined $value_to_test;
         
        # Regex for recognizing RFC 4646 well-formed tags
        # http://www.rfc-editor.org/rfc/rfc4646.txt
        # http://tools.ietf.org/html/draft-ietf-ltru-4646bis-21
        # The structure requires no forward references, so it reverses the order.
        # It uses Java/Perl syntax instead of the old ABNF
        # The uppercase comments are fragments copied from RFC 4646
        # Note: the tool requires that any real "=" or "#" or ";" in the regex be escaped.
        my $alpha      = '[a-z]';      # ALPHA
        my $digit      = '[0-9]';      # DIGIT
        my $alphanum   = '[a-z0-9]';   # ALPHA / DIGIT
        my $x          = 'x';          # private use singleton
        my $singleton  = '[a-wyz]';    # other singleton
        my $s          = '[_-]';       # separator -- lenient parsers will use [_-] -- strict will use [-]
        # Now do the components. The structure is slightly different to allow for capturing the right components.
        # The notation (?:....) is a non-capturing version of (...): so the "?:" can be deleted if someone doesn't care about capturing.
        my $language   = '([a-z]{2,8}) | ([a-z]{2,3} [_-] [a-z]{3})';
         
        # ABNF (2*3ALPHA) / 4ALPHA / 5*8ALPHA  --- note: because of how | works in regex, don't use $alpha{2,3} | $alpha{4,8} 
        # We don't have to have the general case of extlang, because there can be only one extlang (except for zh-min-nan).
        # Note: extlang invalid in Unicode language tags
        my $script = '[a-z]{4}' ;   # 4ALPHA 
        my $region = '(?: [a-z]{2}|[0-9]{3})' ;    # 2ALPHA / 3DIGIT
        my $variant    = '(?: [a-z0-9]{5,8} | [0-9] [a-z0-9]{3} )' ;  # 5*8alphanum / (DIGIT 3alphanum)
        my $extension  = '(?: [a-wyz] (?: [_-] [a-z0-9]{2,8} )+ )' ; # singleton 1*("-" (2*8alphanum))
        my $privateUse = '(?: x (?: [_-] [a-z0-9]{1,8} )+ )' ; # "x" 1*("-" (1*8alphanum))
        # Define certain grandfathered codes, since otherwise the regex is pretty useless.
        # Since these are limited, this is safe even later changes to the registry --
        # the only oddity is that it might change the type of the tag, and thus
        # the results from the capturing groups.
        # http://www.iana.org/assignments/language-subtag-registry
        # Note that these have to be compared case insensitively, requiring (?i) below.
        my $grandfathered  = '(?:
                          (en [_-] GB [_-] oed)
                        | (i [_-] (?: ami | bnn | default | enochian | hak | klingon | lux | mingo | navajo | pwn | tao | tay | tsu ))
                        | (no [_-] (?: bok | nyn ))
                        | (sgn [_-] (?: BE [_-] (?: fr | nl) | CH [_-] de ))
                        | (zh [_-] min [_-] nan)
                        )';
        # old:         | zh $s (?: cmn (?: $s Hans | $s Hant )? | gan | min (?: $s nan)? | wuu | yue );
        # For well-formedness, we don't need the ones that would otherwise pass.
        # For validity, they need to be checked.
        # $grandfatheredWellFormed = (?:
        #         art $s lojban
        #     | cel $s gaulish
        #     | zh $s (?: guoyu | hakka | xiang )
        # );
        # Unicode locales: but we are shifting to a compatible form
        # $keyvalue = (?: $alphanum+ \= $alphanum+);
        # $keywords = ($keyvalue (?: \; $keyvalue)*);
        # We separate items that we want to capture as a single group
        my $variantList   = $variant . '(?:' . $s . $variant . ')*' ;     # special for multiples
        my $extensionList = $extension . '(?:' . $s . $extension . ')*' ; # special for multiples
        my $langtag = "
                        ($language)
                        ($s ( $script ) )?
                        ($s ( $region ) )?
                        ($s ( $variantList ) )?
                        ($s ( $extensionList ) )?
                        ($s ( $privateUse ) )?
                        ";
        # Here is the final breakdown, with capturing groups for each of these components
        # The variants, extensions, grandfathered, and private-use may have interior '-'
         
        my $r = ($value_to_test =~ 
                /^(
                        ($langtag)
                 | ($privateUse)
                 | ($grandfathered)
                 )$/xi);
        return $r;
}
# If people use a non-canon lang once, they're likely to do it twice, so a little caching.
sub _canon_lang
{
        my $lang = shift;
        unless (defined $canon_lang->{$lang})
        {
                $canon_lang->{$lang} = __canon_lang($lang);
        }
        return $canon_lang->{$lang};
}
sub __canon_lang
{
        # Use lower case only
        my $lang = lc shift;
        # If there's a 2 letter code where a three letter code has been used, replace it.
        if ($lang =~ /^([a-z]{3})/)
        {
                substr($lang, 0, 3) = $lang_3to2->{$1}
                        if defined $lang_3to2->{$1};
        }
         
        return $lang_grandfather->{$lang}
                if defined $lang_grandfather->{$lang};
        # Simple case.
        return $lang if length $lang < 4;
        # Replace '_' with '-'.
        $lang =~ s/_/-/g;
         
        # upper case the country component of lang-country pairs.
        return sprintf('%s-%s', $1, _canon_country($2))
                if $lang =~ /^([a-z]{2,3})-([a-z]{2}|\d{3})$/;
        # title case the script component of lang-script pairs.
        return sprintf('%s-%s', $1, _canon_script($2))
                if $lang =~ /^([a-z]{2,3})-([a-z]{4})$/;
        # title case the script component, upper case country componet of lang-script-country triplets.
        return sprintf('%s-%s-%s', $1, _canon_script($2), _canon_country($3))
                if $lang =~ /^([a-z]{2,3})-([a-z]{4})-([a-z]{2}|\d{3})$/;
        # Too complicated - give up and return lower case.
        return $lang;
}
sub _canon_country
{
        my $c = uc shift;
        if ($c =~ /^\d\d\d$/)
        {
                my $c1 = country_code2code($c, LOCALE_CODE_NUMERIC, LOCALE_CODE_ALPHA_2);
                $c = uc $c1
                        if defined $c1 && length $c1;
        }
        return $obsolete_iso3166->{$c}
                if defined $obsolete_iso3166->{$c};
         
        return $c;
}
sub _canon_script
{
        my $s = ucfirst lc shift;
        return $s;
}
1;
__END__
HideShow 85 lines of Pod
=head1 NAME
HTML::HTML5::Sanity - make HTML5 DOM trees less insane
=head1 SYNOPSIS
  use HTML::HTML5::Parser;
  use HTML::HTML5::Sanity;
   
  my $parser    = HTML::HTML5::Parser->new;
  my $html5_dom = $parser->parse_file('http://example.com/');
  my $sane_dom  = fix_document($html5_dom);
=head1 DESCRIPTION
The Document Object Model (DOM) generated by HTML::HTML5::Parser meets
the requirements of the HTML5 spec, but will probably catch a lot of
people by surprise.
The main oddity is that elements and attributes which appear to be
namespaced are not really. For example, the following element:
  <div xml:lang="fr">...</div>
Looks like it should be parsed so that it has an attribute "lang" in
the XML namespace. Not so. It will really be parsed as having the
attribute "xml:lang" in the null namespace.
=over 4
=item C<< fix_document($document) >>
  $sane_dom = fix_document($html5_dom);
Returns a modified copy of the DOM and leaving the original DOM
unmodified.
=item C<< fix_element($element_node, $new_document_node, \%namespaces) >>
Don't use this. Not exported.
=item C<< fix_attribute($attribute_node, $new_element_node, \%namespaces) >>
Don't use this. Not exported.
=item C<$HTML::HTML5::Sanity::FIX_LANG_ATTRIBUTES>
  $HTML::HTML5::Sanity::FIX_LANG_ATTRIBUTES = 2;
  $sane_dom = fix_document($html5_dom);
If set to 1 (the default), the package will detect invalid values in
@lang and @xml:lang, and remove the attribute if it is invalid. If set
to 2, it will also attempt to canonicalise the value (e.g. 'EN_GB' will
be converted to to 'en-GB'). If set to 0, then the value of language
attributes is not checked.
=back
=head1 BUGS
Please report any bugs to L<http://rt.cpan.org/>.
=head1 SEE ALSO
L<HTML::HTML5::Parser>, L<XML::LibXML>, L<Task::HTML5>.
=head1 AUTHOR
Toby Inkster E<lt>tobyink@cpan.orgE<gt>.
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2009-2014 by Toby Inkster
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=head1 DISCLAIMER OF WARRANTIES
THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
=cut