File Coverage

blib/lib/Encode/ZapCP1252.pm

Criterion	Covered	Total	%
statement	51	52	98.0
branch	14	16	87.5
condition	3	3	100.0
subroutine	9	9	100.0
pod	0	2	0.0
total	77	82	93.9

package Encode::ZapCP1252;

use strict;
require Exporter;
use vars qw($VERSION @ISA @EXPORT);
use 5.006_002;

$VERSION = '0.40';
@ISA     = qw(Exporter);
@EXPORT  = qw(zap_cp1252 fix_cp1252);
use constant PERL588 => $] >= 5.008_008;
use Encode ();

our %ascii_for = (
    # https://en.wikipedia.org/wiki/Windows-1252
    "\x80" => 'e',    # EURO SIGN
    "\x82" => ',',    # SINGLE LOW-9 QUOTATION MARK
    "\x83" => 'f',    # LATIN SMALL LETTER F WITH HOOK
    "\x84" => ',,',   # DOUBLE LOW-9 QUOTATION MARK
    "\x85" => '...',  # HORIZONTAL ELLIPSIS
    "\x86" => '+',    # DAGGER
    "\x87" => '++',   # DOUBLE DAGGER
    "\x88" => '^',    # MODIFIER LETTER CIRCUMFLEX ACCENT
    "\x89" => '%',    # PER MILLE SIGN
    "\x8a" => 'S',    # LATIN CAPITAL LETTER S WITH CARON
    "\x8b" => '<',    # SINGLE LEFT-POINTING ANGLE QUOTATION MARK
    "\x8c" => 'OE',   # LATIN CAPITAL LIGATURE OE
    "\x8e" => 'Z',    # LATIN CAPITAL LETTER Z WITH CARON
    "\x91" => "'",    # LEFT SINGLE QUOTATION MARK
    "\x92" => "'",    # RIGHT SINGLE QUOTATION MARK
    "\x93" => '"',    # LEFT DOUBLE QUOTATION MARK
    "\x94" => '"',    # RIGHT DOUBLE QUOTATION MARK
    "\x95" => '*',    # BULLET
    "\x96" => '-',    # EN DASH
    "\x97" => '--',   # EM DASH
    "\x98" => '~',    # SMALL TILDE
    "\x99" => '(tm)', # TRADE MARK SIGN
    "\x9a" => 's',    # LATIN SMALL LETTER S WITH CARON
    "\x9b" => '>',    # SINGLE RIGHT-POINTING ANGLE QUOTATION MARK
    "\x9c" => 'oe',   # LATIN SMALL LIGATURE OE
    "\x9e" => 'z',    # LATIN SMALL LETTER Z WITH CARON
    "\x9f" => 'Y',    # LATIN CAPITAL LETTER Y WITH DIAERESIS
);

our %utf8_for = (
    # https://en.wikipedia.org/wiki/Windows-1252
    "\x80" => '€',    # EURO SIGN
    "\x82" => ',',    # SINGLE LOW-9 QUOTATION MARK
    "\x83" => 'ƒ',    # LATIN SMALL LETTER F WITH HOOK
    "\x84" => '„',    # DOUBLE LOW-9 QUOTATION MARK
    "\x85" => '…',    # HORIZONTAL ELLIPSIS
    "\x86" => '†',    # DAGGER
    "\x87" => '‡',    # DOUBLE DAGGER
    "\x88" => 'ˆ',    # MODIFIER LETTER CIRCUMFLEX ACCENT
    "\x89" => '‰',    # PER MILLE SIGN
    "\x8a" => 'Š',    # LATIN CAPITAL LETTER S WITH CARON
    "\x8b" => '‹',    # SINGLE LEFT-POINTING ANGLE QUOTATION MARK
    "\x8c" => 'Œ',    # LATIN CAPITAL LIGATURE OE
    "\x8e" => 'Ž',    # LATIN CAPITAL LETTER Z WITH CARON
    "\x91" => '‘',    # LEFT SINGLE QUOTATION MARK
    "\x92" => '’',    # RIGHT SINGLE QUOTATION MARK
    "\x93" => '“',    # LEFT DOUBLE QUOTATION MARK
    "\x94" => '”',    # RIGHT DOUBLE QUOTATION MARK
    "\x95" => '•',    # BULLET
    "\x96" => '–',    # EN DASH
    "\x97" => '—',    # EM DASH
    "\x98" => '˜',    # SMALL TILDE
    "\x99" => '™',    # TRADE MARK SIGN
    "\x9a" => 'š',    # LATIN SMALL LETTER S WITH CARON
    "\x9b" => '›',    # SINGLE RIGHT-POINTING ANGLE QUOTATION MARK
    "\x9c" => 'œ',    # LATIN SMALL LIGATURE OE
    "\x9e" => 'ž',    # LATIN SMALL LETTER Z WITH CARON
    "\x9f" => 'Ÿ',    # LATIN CAPITAL LETTER Y WITH DIAERESIS
);

my @utf8_skip = (
# This translates a utf-8-encoded byte into how many bytes the full utf8
# character occupies.  Illegal start bytes have a negative count.

# UTF-8 is a variable-length encoding.  The 128 ASCII characters were very
# deliberately set to be themselves, so UTF-8 would be backwards compatible
# with 7-bit applications.  Every other character has 2 - 13 bytes comprising
# it.
#
# If the first bit of the first byte in a character is 0, it is one of those
# 128 ASCII characters with length 1.

# Otherwise, the first bit is 1, and if the second bit is also one, this byte
# starts the sequence of bytes that represent the character.  The bytes C0-FF
# have the characteristic that the first two bits are both one.  The number of
# bytes that form a character corresponds to the number of consecutive leading
# bits that are all one in the start byte.  In the case of FE, the first 7
# bits are one, so the number of bytes in the character it represents is 7.
# FF is a special case, and Perl has arbitrarily set it to 13 instead of the
# expected 8.
#
# The remaining bytes begin with '10', from 80..9F.  They are called
# continuation bytes, and a UTF-8 character is comprised of a start byte
# indicating 'n' bytes total in it, then 'n-1' of these continuation bytes.
# What the character is that each sequence represents is derived by shifting
# and adding the other bits in the bytes.  (C0 and C1 aren't actually legal
# start bytes for security reasons that need not concern us here, hence are
# marked as negative in the table below.)

  # 0  1  2  3  4  5  6  7  8  9  A  B  C  D  E  F
    1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,  # 0
    1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,  # 1
    1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,  # 2
    1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,  # 3
    1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,  # 4
    1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,  # 5
    1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,  # 6
    1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,  # 7
   -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,  # 8
   -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,  # 9
   -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,  # A
   -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,  # B
   -1,-1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,  # C
    2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,  # D
    3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,  # E
    4, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 6, 6, 7,13,  # F
);

BEGIN {
    my $proto = $] >= 5.010000 ? '_' : '$';
    eval "sub zap_cp1252($proto) { unshift \@_, \\%ascii_for; &_tweakit; }";
    eval "sub fix_cp1252($proto) { unshift \@_, \\%utf8_for;  &_tweakit; }";
}

# These are the bytes that CP1252 redefines
my $cp1252_re = qr/[\x80\x82-\x8c\x8e\x91-\x9c\x9e\x9f]/;

sub _tweakit {
    my $table = shift;
    return unless defined $_[0];
    local $_[0] = $_[0] if defined wantarray;
    my $is_utf8 = PERL588 && Encode::is_utf8($_[0]);
    my $valid_utf8 = $is_utf8 && utf8::valid($_[0]);
    if (!$is_utf8) {

        # Here is non-UTF-8. Change the 1252 characters to their UTF-8
        # counterparts. These bytes are very rarely used in real world
        # applications, so their presence likely indicates that CP1252 was
        # meant.
        $_[0] =~ s/($cp1252_re)/$table->{$1}/gems;
    } elsif ($valid_utf8) {

        # Here is well-formed Perl extended UTF-8 and has the UTF-8 flag on
        # and the string is held as bytes. Change the 1252 characters to their
        # Unicode counterparts.
        $_[0] =~ s/($cp1252_re)/Encode::decode_utf8($table->{$1})/gems;
    } else {    # Invalid UTF-8.  Look for single-byte CP1252 gremlins

        # Turn off the UTF-8 flag so that we can go through the string
        # byte-by-byte.
        Encode::_utf8_off($_[0]);

        my $i = 0;
        my $length = length $_[0];
        my $fixed = "";     # The input after being fixed up by this loop
        while ($i < $length) {

            # Each time through the loop, we should here be ready to look at a
            # new character, and it's 0th byte is called a 'start byte'
            my $start_byte = substr($_[0], $i, 1);
            my $skip = $utf8_skip[ord $start_byte];

            # The table is set up so that legal UTF-8 start bytes have a
            # positive byte length.  Simply add all the bytes in the character
            # to the output, and go on to handle the next character in the
            # next loop iteration.
            if ($skip > 0) {
                $fixed .= substr($_[0], $i, $skip);
                $i += $skip;
                next;
            }

            # Here we have a byte that isn't a start byte in a position that
            # should oughta be a start byte.  The whole point of this loop is
            # to find such bytes that are CP1252 ones and which were
            # incorrectly inserted by the upstream process into an otherwise
            # valid UTF-8 string.  So, if we have such a one, change it into
            # its corresponding correct character.
            if ($start_byte =~ s/($cp1252_re)/$table->{$1}/ems) {

                # The correct character may be UTF-8 bytes.  We treat them as
                # just a sequence of non-UTF-8 bytes, because that's what
                # $fixed has in it so far.  After everything is consistently
                # added, we turn the UTF-8 flag back on before returning at
                # the end.
                Encode::_utf8_off($start_byte);
                $fixed .= $start_byte;
                $i++;
                next;
            }

            # Here the byte isn't a CP1252 one.
            die "Unexpected continuation byte: %02x", ord $start_byte;
        }

        # $fixed now has everything properly in it, but set to return it in
        # $_[0], marked as UTF-8.
        $_[0] = $fixed;
        Encode::_utf8_on($_[0]);
    }
    return $_[0] if defined wantarray;
}

1;
__END__