File Coverage

blib/lib/Search/Tools/UTF8.pm

Criterion	Covered	Total	%
statement	68	86	79.0
branch	21	36	58.3
condition	12	16	75.0
subroutine	15	15	100.0
pod	7	7	100.0
total	123	160	76.8

package Search::Tools::UTF8;
use strict;
use warnings;
use Carp;
use Search::Tools;    # XS stuff
use Encode;
use charnames ':full';
use Data::Dump qw( dump );
use base qw( Exporter );
our @EXPORT = qw(
    to_utf8
    is_valid_utf8
    is_flagged_utf8
    is_perl_utf8_string
    is_ascii
    is_latin1
    is_sane_utf8
    find_bad_utf8
    find_bad_ascii
    find_bad_latin1
    find_bad_latin1_report
    byte_length
    looks_like_cp1252
    fix_cp1252_codepoints_in_utf8
    debug_bytes
);

our $Debug = ( $ENV{PERL_DEBUG} && $ENV{PERL_DEBUG} > 2 ) ? 1 : 0;

our $VERSION = '1.004';

sub to_utf8 {
    my $str = shift;
    Carp::cluck("\$str is undefined") unless defined $str;

    my $charset = shift || 'iso-8859-1';

    # checks first
    if ( is_flagged_utf8($str) ) {
        $Debug and carp "string '$str' is flagged utf8 already";
        return $str;
    }
    if ( is_ascii($str) ) {
        Encode::_utf8_on($str);
        $Debug and carp "string '$str' is ascii; utf8 flag turned on";
        return $str;
    }
    if ( is_valid_utf8($str) ) {

        # we got here only because the flag was off and it wasn't ascii.
        # however, is_valid_utf8() claims that it is valid internal UTF8,
        # so just turn the flag on.
        Encode::_utf8_on($str);
        $Debug and carp "string '$str' is valid utf8; utf8 flag turned on";
        return $str;
    }

    $Debug
        and carp "converting $str from $charset -> utf8";
    my $c = Encode::decode( $charset, $str );
    $Debug and carp "converted $c";

    unless ( is_sane_utf8( $c, 1 ) ) {
        carp "not sane: $c";
    }

    return $c;
}

sub is_flagged_utf8 {
    return Encode::is_utf8( $_[0] );
}

my $re_bit = join "|",
    map { Encode::encode( "utf8", chr($_) ) } ( 127 .. 255 );

#binmode STDERR, ":utf8";
#print STDERR $re_bit;

sub is_sane_utf8 {
    my $string = shift;
    my $warnings = shift || $Debug || 0;

    my $is_insane = 0;
    while ( $string =~ /($re_bit)/go ) {

        # work out what the double encoded string was
        my $bytes = $1;

        my $index = $+[0] - length($bytes);
        my $codes = join '', map { sprintf '<%00x>', ord($_) } split //,
            $bytes;

        # what character does that represent?
        my $char = Encode::decode( "utf8", $bytes );
        my $ord  = ord($char);
        my $hex  = sprintf '%00x', $ord;
        $char = charnames::viacode($ord);

        # print out diagnostic messages
        if ($warnings) {

            warn(qq{Found dodgy chars "$codes" at char $index\n});
            if ( Encode::is_utf8($string) ) {
                warn("Chars in utf8 string look like utf8 byte sequence.");
            }
            else {
                warn("String not flagged as utf8...was it meant to be?\n");
            }
            warn(
                "Probably originally a $char char - codepoint $ord (dec), $hex (hex)\n"
            );

        }
        $is_insane++;
    }

    return $is_insane ? 0 : 1;
}

sub is_valid_utf8 {
    if (   is_latin1( $_[0] )
        && !is_ascii( $_[0] )
        && !is_perl_utf8_string( $_[0] ) )
    {
        return 0;
    }
    return is_perl_utf8_string( $_[0] );
}

sub find_bad_latin1_report {
    my $bad = find_bad_latin1(@_);
    if ($bad) {

        # explain why we failed
        my $char = substr( $_[0], $bad, 1 );
        my $dec  = ord($char);
        my $hex  = sprintf '%x', $dec;
        carp("byte $bad ($char) is not Latin1 (it's $dec dec / $hex hex)");
    }
    return $bad;
}

sub looks_like_cp1252 {
    if (   !is_latin1( $_[0] )
        && !is_ascii( $_[0] )
        && $_[0] =~ m/[\x80-\x9f]/ )
    {
        return 1;
    }
    return 0;
}

my %win1252 = (
    "\x80" => "\x{20AC}",    #EURO SIGN
    "\x81" => '',            #UNDEFINED
    "\x82" => "\x{201A}",    #SINGLE LOW-9 QUOTATION MARK
    "\x83" => "\x{0192}",    #LATIN SMALL LETTER F WITH HOOK
    "\x84" => "\x{201E}",    #DOUBLE LOW-9 QUOTATION MARK
    "\x85" => "\x{2026}",    #HORIZONTAL ELLIPSIS
    "\x86" => "\x{2020}",    #DAGGER
    "\x87" => "\x{2021}",    #DOUBLE DAGGER
    "\x88" => "\x{02C6}",    #MODIFIER LETTER CIRCUMFLEX ACCENT
    "\x89" => "\x{2030}",    #PER MILLE SIGN
    "\x8A" => "\x{0160}",    #LATIN CAPITAL LETTER S WITH CARON
    "\x8B" => "\x{2039}",    #SINGLE LEFT-POINTING ANGLE QUOTATION MARK
    "\x8C" => "\x{0152}",    #LATIN CAPITAL LIGATURE OE
    "\x8D" => '',            #UNDEFINED
    "\x8E" => "\x{017D}",    #LATIN CAPITAL LETTER Z WITH CARON
    "\x8F" => '',            #UNDEFINED
    "\x90" => '',            #UNDEFINED
    "\x91" => "\x{2018}",    #LEFT SINGLE QUOTATION MARK
    "\x92" => "\x{2019}",    #RIGHT SINGLE QUOTATION MARK
    "\x93" => "\x{201C}",    #LEFT DOUBLE QUOTATION MARK
    "\x94" => "\x{201D}",    #RIGHT DOUBLE QUOTATION MARK
    "\x95" => "\x{2022}",    #BULLET
    "\x96" => "\x{2013}",    #EN DASH
    "\x97" => "\x{2014}",    #EM DASH
    "\x98" => "\x{02DC}",    #SMALL TILDE
    "\x99" => "\x{2122}",    #TRADE MARK SIGN
    "\x9A" => "\x{0161}",    #LATIN SMALL LETTER S WITH CARON
    "\x9B" => "\x{203A}",    #SINGLE RIGHT-POINTING ANGLE QUOTATION MARK
    "\x9C" => "\x{0153}",    #LATIN SMALL LIGATURE OE
    "\x9D" => '',            #UNDEFINED
    "\x9E" => "\x{017E}",    #LATIN SMALL LETTER Z WITH CARON
    "\x9F" => "\x{0178}",    #LATIN CAPITAL LETTER Y WITH DIAERESIS

);

# fix_latin (used in Transliterate) lacks the check for the
# prefixed \xc2 byte, but the UTF-8 encoding for these
# Windows codepoints has the leading \xc2 byte.
sub fix_cp1252_codepoints_in_utf8 {
    my $buf = shift;
    unless ( is_valid_utf8($buf) ) {
        my $badbyte = find_bad_utf8($buf);
        croak "bad UTF-8 byte(s) at $badbyte [ " . dump($buf) . " ]";
    }
    $Debug and warn "converting $buf\n";
    my $bytes = Encode::encode_utf8( to_utf8($buf) );
    $bytes =~ s/\xc2([\x80-\x9f])/$win1252{$1}/g;
    return to_utf8($bytes);
}

1;

__END__