File Coverage

blib/lib/Encoding/FixLatin.pm

Criterion	Covered	Total	%
statement	87	91	95.6
branch	37	44	84.0
condition	10	15	66.6
subroutine	11	11	100.0
pod	1	1	100.0
total	146	162	90.1

package Encoding::FixLatin;
{
  $Encoding::FixLatin::VERSION = '1.04';
}

use warnings;
use strict;

require 5.008;

use Carp     qw(croak);
use Exporter qw(import);
use Encode   qw(is_utf8 encode_utf8);

our @EXPORT_OK = qw(fix_latin);


my $xs_loaded  = undef; # no attempt to load yet

my $byte_map;

my $ascii_str = qr{\A([\x00-\x7F]+)(.*)\z}s;

my $cont_byte = '[\x80-\xBF]';
my $utf8_2    = qr{\A([\xC0-\xDF])($cont_byte)(.*)\z}s;
my $utf8_3    = qr{\A([\xE0-\xEF])($cont_byte)($cont_byte)(.*)\z}s;
my $utf8_4    = qr{\A([\xF0-\xF7])($cont_byte)($cont_byte)($cont_byte)(.*)\z}s;
my $utf8_5    = qr{\A([\xF8-\xFB])($cont_byte)($cont_byte)($cont_byte)($cont_byte)(.*)\z}s;

my %known_opt = map { $_ => 1 } qw(bytes_only ascii_hex overlong_fatal use_xs);

my %non_1252  = (
    "\x81" => '%81',
    "\x8D" => '%8D',
    "\x8F" => '%8F',
    "\x90" => '%90',
    "\x9D" => '%9D',
);

sub fix_latin {
    my $input = shift;
    my %opt   = (
        ascii_hex      => 1,
        bytes_only     => 0,
        overlong_fatal => 0,
        use_xs         => 'auto',
        @_
    );

    foreach (keys %opt) {
        croak "Unknown option '$_'" unless $known_opt{$_};
    }

    return unless defined($input);
    _init_byte_map(\%opt) unless $byte_map;
    _init_xs($opt{use_xs});

    if(is_utf8($input)) {       # input string already has utf8 flag set
        if($opt{bytes_only}) {
            return encode_utf8($input);
        }
        else {
            return $input;
        }
    }

    if($xs_loaded and $opt{use_xs} ne 'never') {
        my $olf = $opt{overlong_fatal} ? 1 : 0;
        my $asx = $opt{ascii_hex}      ? 1 : 0;
        local($@);
        $input = eval {   # assign back to $input to avoid copying if all ASCII
            Encoding::FixLatin::XS::_fix_latin_xs($input, $olf, $asx);
        };
        if(my $msg = $@) {
            chomp($msg);
            croak $msg;
        };
        if($opt{bytes_only}) {
            return encode_utf8($input);
        }
        else {
            return $input;
        }
    }
    return _fix_latin_pp($input, \%opt);
}


sub _fix_latin_pp {
    my($input, $opt) = @_;

    my $output = '';
    my $char   = '';
    my $rest   = '';
    my $olf    = $opt->{overlong_fatal};
    while(length($input) > 0) {
        if($input =~ $ascii_str) {
            $output .= $1;
            $rest = $2;
        }
        elsif($input =~ $utf8_2) {
            $output .= _decode_utf8($olf, ord($1) & 0x1F, $1, $2);
            $rest = $3;
        }
        elsif($input =~ $utf8_3) {
            $output .= _decode_utf8($olf, ord($1) & 0x0F, $1, $2, $3);
            $rest = $4;
        }
        elsif($input =~ $utf8_4) {
            $output .= _decode_utf8($olf, ord($1) & 0x07, $1, $2, $3, $4);
            $rest = $5;
        }
        elsif($input =~ $utf8_5) {
            $output .= _decode_utf8($olf, ord($1) & 0x03, $1, $2, $3, $4, $5);
            $rest = $6;
        }
        else {
            ($char, $rest) = $input =~ /^(.)(.*)$/s;
            if($opt->{ascii_hex} && exists $non_1252{$char}) {
                $output .= $non_1252{$char};
            }
            else {
                $output .= $byte_map->{$char};
            }
        }
        $input = $rest;
    }
    utf8::decode($output) unless $opt->{bytes_only};
    return $output;
}


sub _decode_utf8 {
    my $overlong_fatal = shift;
    my $c              = shift;
    my $byte_count     = @_;
    foreach my $i (1..$#_) {
        $c = ($c << 6) + (ord($_[$i]) & 0x3F);
    }
    my $bytes = encode_utf8(chr($c));
    if($overlong_fatal and $byte_count > length($bytes)) {
        my $hex_bytes= join ' ', map { sprintf('%02X', ord($_)) } @_;
        croak "Over-long UTF-8 byte sequence: $hex_bytes";
    }
    return $bytes;
}


sub _init_byte_map {
    foreach my $i (0x80..0xFF) {
        my $utf_char = chr($i);
        utf8::encode($utf_char);
        $byte_map->{pack('C', $i)} = $utf_char;
    }
    _add_cp1252_mappings();
}


sub _init_xs {
    my($use_xs) = @_;

    if($use_xs eq 'never' or $xs_loaded) {
        return;
    }
    if(!defined($xs_loaded)) {
        local($@);
        $xs_loaded = eval { require 'Encoding/FixLatin/XS.pm' } ? 1 : 0;
    }
    if(!$xs_loaded and $use_xs eq 'always') {
        croak "Failed to load Encoding::FixLatin::XS";
    }
}


sub _add_cp1252_mappings {
    # From http://unicode.org/Public/MAPPINGS/VENDORS/MICSFT/WINDOWS/CP1252.TXT
    my %ms_map = (
        "\x80" => "\xE2\x82\xAC",  # EURO SIGN
        "\x82" => "\xE2\x80\x9A",  # SINGLE LOW-9 QUOTATION MARK
        "\x83" => "\xC6\x92",      # LATIN SMALL LETTER F WITH HOOK
        "\x84" => "\xE2\x80\x9E",  # DOUBLE LOW-9 QUOTATION MARK
        "\x85" => "\xE2\x80\xA6",  # HORIZONTAL ELLIPSIS
        "\x86" => "\xE2\x80\xA0",  # DAGGER
        "\x87" => "\xE2\x80\xA1",  # DOUBLE DAGGER
        "\x88" => "\xCB\x86",      # MODIFIER LETTER CIRCUMFLEX ACCENT
        "\x89" => "\xE2\x80\xB0",  # PER MILLE SIGN
        "\x8A" => "\xC5\xA0",      # LATIN CAPITAL LETTER S WITH CARON
        "\x8B" => "\xE2\x80\xB9",  # SINGLE LEFT-POINTING ANGLE QUOTATION MARK
        "\x8C" => "\xC5\x92",      # LATIN CAPITAL LIGATURE OE
        "\x8E" => "\xC5\xBD",      # LATIN CAPITAL LETTER Z WITH CARON
        "\x91" => "\xE2\x80\x98",  # LEFT SINGLE QUOTATION MARK
        "\x92" => "\xE2\x80\x99",  # RIGHT SINGLE QUOTATION MARK
        "\x93" => "\xE2\x80\x9C",  # LEFT DOUBLE QUOTATION MARK
        "\x94" => "\xE2\x80\x9D",  # RIGHT DOUBLE QUOTATION MARK
        "\x95" => "\xE2\x80\xA2",  # BULLET
        "\x96" => "\xE2\x80\x93",  # EN DASH
        "\x97" => "\xE2\x80\x94",  # EM DASH
        "\x98" => "\xCB\x9C",      # SMALL TILDE
        "\x99" => "\xE2\x84\xA2",  # TRADE MARK SIGN
        "\x9A" => "\xC5\xA1",      # LATIN SMALL LETTER S WITH CARON
        "\x9B" => "\xE2\x80\xBA",  # SINGLE RIGHT-POINTING ANGLE QUOTATION MARK
        "\x9C" => "\xC5\x93",      # LATIN SMALL LIGATURE OE
        "\x9E" => "\xC5\xBE",      # LATIN SMALL LETTER Z WITH CARON
        "\x9F" => "\xC5\xB8",      # LATIN CAPITAL LETTER Y WITH DIAERESIS
    );
    while(my($k, $v) = each %ms_map) {
        $byte_map->{$k} = $v;
    }
}


1;

__END__