File Coverage

blib/lib/EBook/Ishmael/CharDet/EUCJP.pm

Criterion	Covered	Total	%
statement	53	73	72.6
branch	22	32	68.7
condition	6	15	40.0
subroutine	8	9	88.8
pod	0	5	0.0
total	89	134	66.4

package EBook::Ishmael::CharDet::EUCJP;
use 5.016;
our $VERSION = '2.03';
use strict;
use warnings;

use EBook::Ishmael::CharDet::Constants qw(:CONSTANTS);

# Generated from contrib/cjk2encodings.pl
my %EUCJP_FREQS = map { $_ => 1 } (
41428,41429,42190,42175,42148,42167,41378,42187,42186,42191,41379,42182,42184,
42155,42226,42150,42156,42219,42217,42183,42227,42210,42180,42179,42220,42159,
42163,42206,42176,42218,42146,42169,42157,42212,42165,42173,41430,41431,42216,
42223,42161,41404,42154,42177,42483,51424,42171,49101,42185,42209,42152,42425,
42207,42200,42221,45292,42168,42192,42194,42197,47275,48631,48592,51884,42189,
42203,48087,41382,45759,42441,42404,48118,42475,42224,42473,48362,48299,42440,
47296,42474,42463,45502,49895,46294,42170,48126,41397,47572,42162,42402,42208,
46575,50940,48869,50150,48082,50931,42195,48100,42164,45756,42431,42415,47779,
49076,42198,48340,51965,50126,45768,53460,53187,42438,49336,52444,49584,42435,
46500,42214,52905,42201,42158,42416,42453,42403,42424,51897,42406,42448,42181,
50942,52188,42178,42211,56806,42454,42160,42188,42436,42166,45744,49846,50123,
42477,42423,47333,42476,51882,47023,42462,50649,48573,42408,48360,48625,51119,
42204,48125,45269,47777,42215,50380,48814,42443,47591,51668,47357,49096,48048,
46262,52428,42467,52405,49587,50127,51700,42433,52416,52712,42427,48618,47565,
48876,46000,42174,48815,53725,52459,42411,49370,48848,50865,49893,42172,49384,
42410,49837,50624,49063,50602,48359,50149,52173,45755,48069,52387,42465,49316,
52149,49333,45809,49079,51186,50860,47815,49642,51926,52733,51896,46818,48096,
50361,45306,51671,48102,49065,47525,42412,50864,50875,56555,61690,41398,42439,
51948,51683,49070,52414,47358,42471,48880,48289,47083,47334,48051,42225,47810,
52452,51703,49340,45222,48355,52943,49876,48077,51669,50095,42413,48342,47614,
49094,46817,47351,52718,42419,50914,42455,50366,46313,52685,59105,47086,46837,
47326,49088,46511,52462,52442,52689,47586,49588,50678,49633,45258,50628,42432,
50134,50350,45996,51454,51105,47286,50424,52647,42193,45995,45793,49078,51916,
52693,42449,48581,48585,46770,42407,49863,46323,54748,42464,48322,47302,49896,
45776,42442,53154,46307,51151,46773,50893,50356,47854,48078,42421,50617,48095,
49325,42426,50347,49627,49339,50880,41432,47778,41433,42446,45283,50341,58051,
46558,45250,46828,51921,52412,47818,49125,48617,51390,61939,52212,42457,51413,
52695,48316,48072,49870,42484,52415,48373,53490,50889,51903,49854,50615,42469,
49084,56773,47080,52653,49830,48038,49855,52923,47340,47035,46045,45782,46536,
50122,48554,45810,51682,47783,49643,50663,50629,50682,46532,42414,45991,45764,
49145,53175,48314,48079,47833,52158,56539,42447,46546,45253,52404,47601,45763,
51679,45555,49087,47532,55464,51938,42461,51628,46296,48088,46787,50681,48370,
48081,45229,52420,47301,45811,45503,52964,51163,49648,50913,48545,52449,51414,
42417,54434,49390,46056,54761,46321,48835,51645,49360,49833,46509,42429,52154,
45815,57796,46762,45798,49326,51443,49872,52728,48872,53179,50401,45303,47352,
50102,42479,46832,49655,47285,46498,50639,51171,42460,50866,49573,46497,56014,
59834,49085,51444,52910,60925,48568,46030,49374,51922,48122,45774,50410,48338,
50427,49098,51650,46779,48298,46781,49366,42466,47041,51710,49140,46753,46042,
50157,49878,55544,48879,47090,50650,57514,45272,51964,46767,46792,49898,48068,
50147,51372,
);

# https://www-archive.mozilla.org/projects/intl/universalcharsetdetection
my $DIST_RATIO  = 0.93;

sub new {

    my ($class) = @_;

    my $self = {
        Code  => 0,
        Left  => 0,
        Set   => 0,
        Freqs => 0,
        MBs   => 0,
        Total => 0,
        Bad   => 0,
    };

    return bless $self, $class;

}

sub take {

    my ($self, $bytes) = @_;

    return TAKE_BAD if $self->{Bad};

    for my $i (0 .. length($bytes) - 1) {
        my $b = ord(substr $bytes, $i, 1) & 0xff;
        if ($self->{Set} == 3) {
            if ($b < 0xa1 or $b > 0xfe) {
                $self->{Bad} = 1;
                return TAKE_BAD;
            }
            $self->{Code} = ($self->{Code} << 8) | $b;
            $self->{Left}--;
            if ($self->{Left} == 0) {
                if (exists $EUCJP_FREQS{ $self->{Code} }) {
                    $self->{Freqs}++;
                }
                $self->{Total}++;
                $self->{MBs}++;
                $self->{Code} = 0;
                $self->{Set} = 0;
            }
        } elsif ($self->{Set} == 2) {
            if ($b < 0xa1 or $b > 0xdf) {
                $self->{Bad} = 1;
                return TAKE_BAD;
            }
            $self->{Code} = ($self->{Code} << 8) | $b;
            $self->{Left}--;
            if (exists $EUCJP_FREQS{ $self->{Code} }) {
                $self->{Freqs}++;
            }
            $self->{Total}++;
            $self->{MBs}++;
            $self->{Code} = 0;
            $self->{Set} = 0;
        } elsif ($self->{Set} == 1) {
            # The range is supposed to be 0xa1-0xfe, but HP-16 allows for
            # lower trailing bytes.
            if ($b < 0x21 or $b > 0xfe) {
                $self->{Bad} = 1;
                return TAKE_BAD;
            }
            $self->{Code} = ($self->{Code} << 8) | $b;
            if (exists $EUCJP_FREQS{ $self->{Code} }) {
                $self->{Freqs}++;
            }
            $self->{Left}--;
            $self->{MBs}++;
            $self->{Total}++;
            $self->{Code} = 0;
            $self->{Set} = 0;
        } elsif ($b == 0x8f) {
            $self->{Set} = 3;
            $self->{Left} = 2;
            $self->{Code} = $b;
        } elsif ($b == 0x8e) {
            $self->{Set} = 2;
            $self->{Left} = 1;
            $self->{Code} = $b;
        } elsif ($b >= 0xa1 && $b <= 0xfe) {
            $self->{Set} = 1;
            $self->{Left} = 1;
            $self->{Code} = $b;
        } elsif ($b & 0x80) {
            $self->{Bad} = 1;
            return TAKE_BAD;
        } else {
            $self->{Total}++;
        }
    }

    return TAKE_OK;

}

sub confidence {

    my ($self) = @_;

    if ($self->{Bad} or $self->{MBs} == 0) {
        return 0;
    }

    return $self->{Freqs} / $self->{MBs};

}

sub bad {

    my ($self) = @_;

    return $self->{Bad};

}

sub encoding { 'EUC-JP' }

1;