File Coverage

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

Criterion	Covered	Total	%
statement	71	73	97.2
branch	21	24	87.5
condition	9	12	75.0
subroutine	19	19	100.0
pod	3	3	100.0
total	123	131	93.8

package Encode::JP::Mobile::Charnames;
use strict;
use warnings;
use bytes     ();
use File::ShareDir 'dist_file';
use Carp;
use Encode;
use Encode::JP::Mobile ':props';
use Encode::JP::Mobile::Character;

use base qw( Exporter );
our @EXPORT_OK = qw( unicode2name unicode2name_en vianame );

my $name2unicode;

{
    # re.pm clobbers $_ in 5.14.0 ~ 5.16.0
    # and charnames.pm requires re.pm
    # ref. https://github.com/mirrors/perl/commit/48895a0d
    BEGIN {
        local $_;
        require charnames;
        charnames->import(':full');
        *_def_translator = $^H{charnames}
    }
}


sub import {
    # for perl < 5.10
    if ($charnames::hint_bits) {
        $^H |= $charnames::hint_bits;
    }
    $^H{charnames} = \&_translator;
    __PACKAGE__->export_to_level(1, @_);
}

sub _translator {
    if ( $^H & $bytes::hint_bits ) {
        _bytes_translator(@_);
    }
    else {
        _unicode_translator(@_);
    }
}

sub _name2unicode () {
    return $name2unicode if $name2unicode;

    for my $carrier (qw/docomo kddi softbank/) {
        my $fname = dist_file( 'Encode-JP-Mobile', "${carrier}-table.pl" );
        my $dat = do $fname;

        for my $row (@$dat) {
            next unless exists $row->{name};
            $name2unicode->{$carrier}{$row->{name}} ||= hex $row->{unicode};
            if ( exists $row->{name_en} ) {
                $name2unicode->{$carrier}{$row->{name_en}} ||= hex $row->{unicode};
            }
        }
    }

    return $name2unicode;
}


my $re = qr/^(DoCoMo|KDDI|SoftBank) (.+)$/io;

sub _unicode_translator {
    my $name = shift;

    if ( my ( $carrier, $r_name ) = ( $name =~ $re ) ) {
        my $ret = _name2unicode->{lc($carrier)}{$r_name};
        if ( defined $ret ) {
            return pack "U*", $ret;
        }
        else {
            carp "unknown charnames: $r_name";
        }
    }
    else {
        return _def_translator($name);
    }
}

# pictograms are only in the above 0xFF area.
sub _bytes_translator {
    my $name = shift;
    return _def_translator($name);
}

sub vianame {
    my $name = shift;
    croak "missing name" unless $name;

    if ( my ( $carrier, $r_name ) = ( $name =~ $re ) ) {
        return _name2unicode->{lc($carrier)}{$r_name} || carp "unknown charnames: $r_name";
    }
    else {
        return charnames::vianame($name);
    }
}

# handling x-sjis-kddi-cp932-raw.see pod.
sub _kddi_cp932toauto {
    my $code = shift;

    my $c = pack('U', $code);
    if ($c !~ /^\p{InKDDISoftBankConflicts}$/ && $c =~ /^\p{InKDDICP932Pictograms}$/) {
        return unpack 'U*', decode('x-sjis-kddi-auto-raw', encode('x-sjis-kddi-cp932-raw', $c));
    } else {
        return $code;
    }
}

sub unicode2name {
    my $code = shift;
    croak "missing code" unless $code;

    return Encode::JP::Mobile::Character->from_unicode(_kddi_cp932toauto($code))->name;
}

sub unicode2name_en {
    my $code = shift;
    croak "missing code" unless $code;

    return Encode::JP::Mobile::Character->from_unicode(_kddi_cp932toauto($code))->name_en;
}

1;
__END__