File Coverage

blib/lib/Encode/JP/Mobile/AirHJIS.pm

Criterion	Covered	Total	%
statement	112	114	98.2
branch	38	46	82.6
condition	16	36	44.4
subroutine	20	20	100.0
pod	2	2	100.0
total	188	218	86.2

package Encode::JP::Mobile::AirHJIS;
use strict;
use warnings;
use base qw(Encode::Encoding);
use Encode::Alias;
use Encode::CJKConstants qw(:all);
use Encode qw(:fallbacks);
use Encode::JP::Mobile;
use POSIX 'ceil';
use Carp;

define_alias('x-iso-2022-jp-airedge' => 'x-iso-2022-jp-airh');
__PACKAGE__->Define(qw(x-iso-2022-jp-airh));

my $re_scan_sjis = qr{
    $RE{SJIS_KANA}|$RE{SJIS_C}
}x;

my $re_scan_jis = qr{
   (?:($RE{JIS_0212})|$RE{JIS_0208}|($RE{ISO_ASC})|($RE{JIS_KANA}))([^\e]*)
}x;

sub _encoding() { 'x-sjis-docomo-raw' }

sub decode($$;$) {
    my ($self, $str, $chk) = @_;

    my $residue = '';
    if ($chk) {
        $str =~ s/([^\x00-\x7f].*)$//so and $residue = $1;
    }
    $residue .= _jis_sjis( \$str );
    $_[1] = $residue if $chk;

    return Encode::decode( $self->_encoding, $str, FB_PERLQQ );
}

sub encode($$;$) {
    my ( $obj, $utf8, $chk ) = @_;
    my $octet = Encode::encode( $obj->_encoding, $utf8, $chk );
    return _sjis_jis( $octet );
}

sub ASC () { 1 }
sub JIS_0208 () { 2 }
sub KANA () { 3 }
sub _sjis_jis {
    my $octet = shift;

    use bytes;

    my @chars = split //, $octet;
    my $mode = ASC;
    my $res = '';

    for (my $i=0; $i<@chars; $i++) {
        my $x = ord $chars[$i];
        if ($x < 0x80) {
            if ($mode != ASC) {
                $res .= $ESC{ASC};
                $mode = ASC;
            }
            $res .= chr $x;
        } elsif (0xA1 <= $x && $x <= 0xDF) {
            if ($mode != KANA) {
                $res .= $ESC{KANA};
                $mode = KANA;
            }
            $mode = KANA;
            $res .= chr($x - 0x80);
        } else {
            if ($mode != JIS_0208) {
                $res .= $ESC{JIS_0208};
                $mode = JIS_0208;
            }
            $i++;
            last unless $i<@chars;
            my ($c1, $c2) = _sjis2jis_one($x, ord $chars[$i]);
            $res .= $c2 ? chr($c1).chr($c2) : $c1;
        }
    }

    if ($mode != ASC) {
        $res .= $ESC{ASC};
    }

    $res;
}
sub _sjis2jis_one {
    my ($c1, $c2) = @_;

    # 0xF89F - 0xF949
    # 0xF950 - 0xF952
    # 0xF955 - 0xF957
    # 0xF95B - 0xF95E
    # 0xF972 - 0xF9FC
    my $c = ($c1<<8) + $c2;
    if (0xF89F <= $c && $c <= 0xF949 ||
        0xF950 <= $c && $c <= 0xF952 ||
        0xF955 <= $c && $c <= 0xF957 ||
        0xF95B <= $c && $c <= 0xF95E ||
        0xF972 <= $c && $c <= 0xF9FC) {
        return pack('H*', sprintf('%X', $c));
    }

    $c1 -= ($c1 <= 0x9f) ? 0x71 : 0xB1;
    $c1 = $c1*2 + 1;

    if ($c2 > 0x7F) {
        $c2 -= 0x01;
    }

    if ($c2>=0x9E) {
        $c2  = $c2-0x7D;
        $c1++;
    } else {
        $c2 -= 0x1F;
    }

    return ($c1, $c2);
}

sub _jis_sjis {
    local ${^ENCODING};

    my $r_str = shift;
    $$r_str =~ s($re_scan_jis){
        my ($esc_0212, $esc_asc, $esc_kana, $chunk) = ($1, $2, $3, $4);

        if ($esc_kana) {
            $chunk =~ s{(.)}{
                pack "H*", sprintf "%X", (0x80 + (hex unpack "H*", $1));
            }geox;
            $chunk;
        } elsif ($esc_asc) {
            $chunk;
        } else {
            $chunk =~ s{(?:($re_scan_sjis)|(..))}{
                $1 ? $1 : pack "H*", sprintf "%X", _jis2sjis_one(hex(unpack "H*", $2))
            }geox;
            $chunk;
        }
    }geox;

    my ($residue) = ( $$r_str =~ s/(\e.*)$//so );

    return $residue;
}

sub _jis2sjis_one { my $x = shift; return ( _xy($x) << 8 ) + _zu($x) } # input is binary

sub _high { my $x = shift; $x >> 8 }
sub _low  { my $x = shift; $x & 0xff }

sub _xy {
    my $jis = shift;

    my $pq = _high($jis);
    my $t  = ceil( $pq / 2 ) + 0x70;
    my $ans = ($t <= 0x9F) ? $t : $t+0x40;

    # XXX !!!
    if (0xED == $ans || $ans == 0xEE) {
        return $ans + 0x06;
    } elsif (0xEB == $ans || $ans == 0xEC) {
        return $ans + 0x0b;
    } else {
        return $ans;
    }
}

sub _zu {
    my $jis = shift;
    my $pq  = _high($jis);
    my $rs  = _low($jis);

    if ( $pq % 2 ) {    # odd
        my $t = $rs + 0x20;
        return ( $t > 0x7f ) ? $t : $t - 1;
    }
    else {              # even
        return $rs + 0x7E;
    }
}

1;

__END__