File Coverage

blib/lib/HTML/Encoding.pm

Criterion	Covered	Total	%
statement	60	221	27.1
branch	23	168	13.6
condition	11	61	18.0
subroutine	9	21	42.8
pod	9	9	100.0
total	112	480	23.3

package HTML::Encoding;
use strict;
use warnings;

use HTML::Parser        qw();
use HTTP::Headers::Util qw(split_header_words);
use Encode              qw();

use base qw(Exporter);

our $VERSION = '0.61';

our @EXPORT_OK =
qw/
    &encoding_from_meta_element
    &xml_declaration_from_octets
    &encoding_from_first_chars
    &encoding_from_xml_declaration
    &encoding_from_byte_order_mark
    &encoding_from_content_type
    &encoding_from_xml_document
    &encoding_from_html_document
    &encoding_from_http_message
/;

our $DEFAULT_ENCODINGS = [qw/
  ISO-8859-1
  UTF-16LE
  UTF-16BE
  UTF-32LE
  UTF-32BE
  UTF-8
/];

our %MAP =
(
    BM => "\x{FEFF}",
    CR => "\x{000D}",
    LF => "\x{000A}",
    SP => "\x{0020}",
    TB => "\x{0009}",
    QS => "\x{003F}",
    NL => "\x{0085}",
    LS => "\x{2028}",
    LT => "<", # fixme
    GT => ">", # fixme
);

sub _my_encode
{
    my $seq;

    eval
    {
        $seq = Encode::encode($_[0],
                              $_[1],
                              $_[2]);
    };

    return $seq unless $@;
    return;
}

sub _my_decode
{
    my $str;

    eval
    {
        $str = Encode::decode($_[0],
                              $_[1],
                              $_[2]);
    };

    return $str unless $@;
    return;
}

sub _make_character_map
{
    my $encoding = shift;
    my %data;

    foreach my $sym (keys %MAP)
    {
        my $seq = _my_encode($encoding, "$MAP{$sym}", Encode::FB_CROAK);
        $data{$sym} = $seq if defined $seq;
    }

    \%data;
}

# cache for U+XXXX octet sequences
our %CHARACTER_MAP_CACHE = ();

sub _get_character_map
{
    my $encoding = shift;

    # read from cache
    return $CHARACTER_MAP_CACHE{$encoding}
      if exists $CHARACTER_MAP_CACHE{$encoding};

    # new cache entry
    my $map = _make_character_map($encoding);
    $CHARACTER_MAP_CACHE{$encoding} = $map;

    # return new entry
    return $map;
}

sub encoding_from_meta_element
{
    my $text = shift;
    my $enco = shift;

    return unless defined $text;
    return unless length $text;

    return unless defined $enco;
    return unless length $enco;

    my $pars = HTML::Parser->new
    (
        api_version => 3,
        @_
    );

    my $meta = [];
    my $leng = length $text;
    my $size = 8192;
    my $data = '';
    my $utf8 = '';
    my $i = 0;

    # todo: should finish when  or logically body//*

    $pars->report_tags(qw/meta head/);
    $pars->handler(start => $meta, "tagname,attr");
    $pars->handler
    (
       end => sub { $_[0]->eof if $_[1] eq "head" },
       "self,tagname"
    );

    $pars->parse(sub
    {
        return if $i > $leng;
        $data .= substr $text, $i, $size;
        $i += $size;
        _my_decode($enco, $data, Encode::FB_QUIET);
    });

    my @resu;

    foreach (grep { $_->[0] eq "meta" } @$meta)
    {
        my %hash = %{$_->[1]};
        next unless defined $hash{'content'};
        next unless exists $hash{'http-equiv'};
        next unless lc $hash{'http-equiv'} eq "content-type";
        my $char = encoding_from_content_type($hash{'content'});
        push @resu, $char if defined $char and length $char;
    }

    return unless @resu;
    return wantarray ? @resu : $resu[0];
}

sub xml_declaration_from_octets
{
    my $text = shift;
    my %o = @_;
    my $encodings = $o{encodings} || $DEFAULT_ENCODINGS;
    my %resu;

    return unless defined $text;
    return unless length $text;

    foreach my $e (@$encodings)
    {
        my $map = _get_character_map($e);

        # search for >
        my $end = index $text, $map->{GT};

        # search for
        my $str = index $text, $map->{LT} . $map->{QS};

        # skip this encoding unless ...
        next unless $end > 0 and $str >= 0 and $end > $str;

        # extract tentative XML declaration
        my $decl = substr $text, $str, $end - $str + 1;

        # decode XML declaration
        my $deco = _my_decode($e, $decl, Encode::FB_CROAK);

        # skip encoding if decoding failed
        next unless defined $deco;

        $resu{$deco}++;
    }

    # No XML declarations found
    return unless keys %resu;

    # sort by number of matches, most match first
    my @sort = sort { $resu{$b} <=> $resu{$a} } keys %resu;

    # in array context return all encodings,
    # in scalar context return best match.
    return wantarray ? @sort : $sort[0];
}

sub encoding_from_first_chars
{
    my $text = shift;
    my %o = @_;
    my $encodings = $o{encodings} || $DEFAULT_ENCODINGS;
    my $whitespace = $o{whitespace} || [qw/CR LF TB SP/];

    return unless defined $text;
    return unless length $text;

    my %resu;
    foreach my $e (@$encodings)
    {
        my $m = _get_character_map($e);
        my $i = index $text, $m->{LT};
        next unless $i >= 0;
        my $t = substr $text, 0, $i;

        my @y;

        # construct \xXX\xXX string from octets, might make sense to
        # have this in the map construction process
        push@y,"(?:".join("",map{sprintf"\\x%02x",ord}split//,$m->{$_}).")"
          foreach grep defined, @$whitespace;

        my $x = join "|", @y;
        $t =~ s/^($x)+//g;

        $resu{$e} = $i + length $m->{LT} unless length $t;
    }

    # ...
    return unless keys %resu;

    # sort by match length, longest match first
    my @sort = sort { $resu{$b} <=> $resu{$a} } keys %resu;

    # in array context return all encodings,
    # in scalar context return best match.
    return wantarray ? @sort : $sort[0];
}

sub encoding_from_xml_declaration
{
    my $decl = shift;

    return unless defined $decl;
    return unless length $decl;

    # todo: move this to some better place...
    my $ws = qr/[\x09\x85\x20\x0d\x0a\x{2028}]*/;

    # skip if not an XML declaration
    return unless $decl =~ /^<\?xml$ws/i;

    # attempt to extract encoding pseudo attribute
    return unless $decl =~ /encoding$ws=$ws'([^']+)'/i or
                  $decl =~ /encoding$ws=$ws"([^"]+)"/i;

    # no encoding pseudo-attribute
    return unless defined $1;
    my $enco = $1;

    # strip leading/trailing whitespace/quotes
    $enco =~ s/^[\s'"]+|[\s'"]+$//g;

    # collapse white-space
    $enco =~ s/\s+/ /g;

    # treat empty charset as if it were unspecified
    return unless length $enco;

    return $enco;
}

sub encoding_from_byte_order_mark
{
    my $text = shift;
    my %o = @_;
    my $encodings = $o{encodings} || $DEFAULT_ENCODINGS;
    my %resu;

    return unless defined $text;
    return unless length $text;

    foreach my $e (@$encodings)
    {
        my $map = _get_character_map($e);
        my $bom = $map->{BM};

        # encoding cannot encode U+FEFF
        next unless defined $bom;

        # remember match length
        $resu{$e} = length $bom if $text =~ /^(\Q$bom\E)/;
    }

    # does not start with BOM
    return unless keys %resu;

    # sort by match length, longest match first
    my @sort = sort { $resu{$b} <=> $resu{$a} } keys %resu;

    # in array context return all encodings,
    # in scalar context return best match.
    return wantarray ? @sort : $sort[0];
}

sub encoding_from_content_type
{
    my $text = shift;

    # nothing to do...
    return unless defined $text and length $text;

    # downgrade Unicode strings
    $text = Encode::encode_utf8($text) if Encode::is_utf8($text);

    # split parameters, only look at the first set
    my %data = @{(split_header_words($text))[0]};

    # extract first charset parameter if any
    my $char;
    foreach my $param (keys %data) {
      $char = $data{$param} and last if 'charset' eq lc $param;
    }

    # no charset parameter
    return unless defined $char;

    # there are no special escapes so just remove \s
    $char =~ tr/\\//d;

    # strip leading/trailing whitespace/quotes
    $char =~ s/^[\s'"]+|[\s'"]+$//g;

    # collapse white-space
    $char =~ s/\s+/ /g;

    # treat empty charset as if it were unspecified
    return unless length $char;

    return $char
}

sub encoding_from_xml_document
{
    my $text = shift;
    my %o = @_;
    my $encodings = $o{encodings} || $DEFAULT_ENCODINGS;
    my %resu;

    return unless defined $text;
    return unless length $text;

    my @boms = encoding_from_byte_order_mark($text, encodings => $encodings);

    # BOM determines encoding
    return wantarray ? (bom => \@boms) : $boms[0] if @boms;

    # no BOM
    my @decls = xml_declaration_from_octets($text, encodings => $encodings);
    foreach my $decl (@decls)
    {
        my $enco = encoding_from_xml_declaration($decl);
        $resu{$enco}++ if defined $enco and length $enco;
    }

    return unless keys %resu;
    my @sort = sort { $resu{$b} <=> $resu{$a} } keys %resu;

    # in array context return all encodings,
    # in scalar context return best match.
    return wantarray ? (xml => \@sort) : $sort[0];
}

sub encoding_from_html_document
{
    my $text = shift;
    my %o = @_;
    my $encodings = $o{encodings} || $DEFAULT_ENCODINGS;
    my $popts = $o{parser_options} || {};
    my $xhtml = exists $o{xhtml} ? $o{xhtml} : 1;

    return unless defined $text;
    return unless length $text;

    if ($xhtml)
    {
        my @xml = wantarray
                    ? encoding_from_xml_document($text, encodings => $encodings)
                    : scalar encoding_from_xml_document($text, encodings => $encodings);

        return wantarray
          ? @xml
          : $xml[0]
            if @xml and defined $xml[0];
    }
    else
    {
        my @boms = encoding_from_byte_order_mark($text, encodings => $encodings);

        # BOM determines encoding
        return wantarray ? (bom => \@boms) : $boms[0] if @boms;
    }

    # no BOM
    my @resu;

    # sanity check to exclude e.g. UTF-32
    my @first = encoding_from_first_chars($text, encodings => $encodings);

    # fall back to provided encoding list
    @first = @$encodings unless @first;

    foreach my $try (@first)
    {
        push @resu, encoding_from_meta_element($text, $try, %$popts);
    }

    return unless @resu;
    return wantarray ? (meta => \@resu) : $resu[0];
}

sub encoding_from_http_message
{
    my $mess      = shift;
    my %o         = @_;

    my $encodings = $o{encodings}        || $DEFAULT_ENCODINGS;
    my $is_html   = $o{is_html}          || qr{^text/html$}i;
    my $is_xml    = $o{is_xml}           || qr{^.+/(?:.+\+)?xml$}i;
    my $is_t_xml  = $o{is_text_xml}      || qr{^text/(?:.+\+)?xml$}i;
    my $html_d    = $o{html_default}     || "ISO-8859-1";
    my $xml_d     = $o{xml_default}      || "UTF-8";
    my $txml      = $o{text_xml_default};

    my $xhtml     = exists $o{xhtml}   ? $o{xhtml}   : 1;
    my $default   = exists $o{default} ? $o{default} : 1;

    my $type      = $mess->header('Content-Type');
    my $charset   = encoding_from_content_type($type);

    if ($mess->content_type =~ $is_xml)
    {
        return wantarray ? (protocol => $charset) : $charset
          if defined $charset;

        # special case for text/xml at user option
        return wantarray ? (protocol_default => $txml) : $txml
          if defined $txml and $mess->content_type =~ $is_t_xml;

        if (wantarray)
        {
            my @xml = encoding_from_xml_document($mess->content, encodings => $encodings);
            return @xml if @xml;
        }
        else
        {
            my $xml = scalar encoding_from_xml_document($mess->content, encodings => $encodings);
            return $xml if defined $xml;
        }

        return wantarray ? (default => $xml_d) : $xml_d if defined $default;
    }

    if ($mess->content_type =~ $is_html)
    {
        return wantarray ? (protocol => $charset) : $charset
          if defined $charset;

        if (wantarray)
        {
            my @html = encoding_from_html_document($mess->content, encodings => $encodings, xhtml => $xhtml);
            return @html if @html;
        }
        else
        {
            my $html = scalar encoding_from_html_document($mess->content, encodings => $encodings, xhtml => $xhtml);
            return $html if defined $html;
        }

        return wantarray ? (default => $html_d) : $html_d if defined $default;
    }

    return
}

1;

__END__