Unicode::Numeric

Perl で Unicode Character について触る - daily dayflower で書いたように文字の数値を調べるには Unicode::UCD を使えばよかったんですが，それを知らずに途中まで作りかけていた数値変換モジュールを一通りインプリメントしたので，さらしておきます。

利点は…… Perl 5.6 でも使えることくらい？

package Unicode::Numeric;

use strict;
use warnings;
use 5.006;

use base qw( Exporter );
our @EXPORT = qw( decimal digit numeric numeric_as_string );

our $VERSION = '0.01';

our $USE_UCD;
BEGIN {
    $USE_UCD = eval { require Unicode::UCD; 1; };
}

my $NumericMap;
my $BundledVersion;

sub decimal {
    return _retrieve_item(@_)->[0];
}

sub digit {
    return _retrieve_item(@_)->[1];
}

sub numeric_as_string {
    return _retrieve_item(@_)->[2];
}

sub numeric {
    my $v = numeric_as_string(@_);
    return if ! defined $v;
    return eval $v;
}

sub UnicodeVersion {
    if ($USE_UCD) {
        return Unicode::UCD::UnicodeVersion();
    }
    else {
        _init_map();
        return $BundledVersion;
    }
}

sub _retrieve_item {
    my ($c) = @_;
    return [] if ! defined $c;

    if ($USE_UCD) {
        my $ci = Unicode::UCD::charinfo(ord $c);
        return [] if ! $ci;

        for (qw( decimal digit numeric )) {
            $ci->{$_} = undef if $ci->{$_} eq q{};
        }
        return [ $ci->{decimal}, $ci->{digit}, $ci->{numeric} ];
    }

    $c = sprintf '%X', ord $c;

    _init_map();

    return [] if ! exists $NumericMap->{$c};

    return $NumericMap->{$c};
}

sub _init_map {
    return if ref $NumericMap eq 'HASH';

    $NumericMap = {};
    foreach my $line (split /[\r\n]+/, _map_data()) {
        next if $line =~ m'^###'o;

        if ($line =~ m' \A \# v ( \d+ \S+ ) 'xmso) {
            $BundledVersion = $1;
            next;
        }

        my @c = split /\t/, $line;

        my $code = shift @c;
        $code =~ s{ \A 0+ }{}xmso;

        @c = map { $_ eq q{} ? undef : $_ } @c;

        $NumericMap->{$code} = \@c;
    }
}

sub _map_data {
    return <<"END_MAP";
### BEGIN ###
#v5.1.0
0030\t0\t0\t0
0031\t1\t1\t1
0032\t2\t2\t2

### snip ###

1D7FD\t7\t7\t7
1D7FE\t8\t8\t8
1D7FF\t9\t9\t9
### END ###
END_MAP
}

1;
__END__

=head1 NAME

Unicode::Numeric - Unicode::Numeric

=cut

実際のテーブルが snip してあるんでこのままでは使えません。Makefile.PL で自動生成するようにしています。

ということで Makefile.PL の実装はこちら。Unicode::EastAsianWidth のをパクった参考にしました。

use strict;
use inc::Module::Install;

my $TargetModule    = 'lib/Unicode/Numeric.pm';
my $UnicodeDataFile = 'unicore/UnicodeData.txt';
my $UnicodeVerFile  = 'unicore/version';
my $BundledVersion  = '5.1.0';

_build_pm();

name 'Unicode-Numeric';
all_from 'lib/Unicode/Numeric.pm';

build_requires 'Test::More';
use_test_base;

auto_include;

WriteAll;

exit;

sub _build_pm {
    my ($path, $fname, $version);

    foreach ('.', @INC) {
        $path = $_;
        last if -e "$_/$UnicodeDataFile" && -e "$_/$UnicodeVerFile";
    }

    my $use_bundled = 1;

    TRY: {
        $fname = "$path/$UnicodeVerFile";
        if (! -e $fname) {
            print {*STDERR} "*** Cannot find $UnicodeVerFile.\n";
            last TRY;
        }

        if (! open my $UCV, '<', $fname) {
            print {*STDERR} "*** Cannot read $fname ($!).\n";
            last TRY;
        }
        else {
            $version = do { local $/; <$UCV> };
            close $UCV;
            chomp $version;

            if ($version <= $BundledVersion) {
                if (-e $TargetModule) {
                    print {*STDERR} "*** Installed table not newer than the bundled.\n";
                    last TRY;
                }
            }
        }

        $use_bundled = 0;
    }

    if ($use_bundled) {
        print {*STDERR} "*** Using bundled table.\n";
        return;
    }

    $fname = "$path/$UnicodeDataFile";

    print {*STDERR} "*** Using ${fname}.\n";

    my $table = q{};

    if (! open my $UCD, '<', $fname) {
        print {*STDERR} "*** Cannot read table ($!), falling back to default.\n";
        return;
    }
    else {
        while (<$UCD>) {
            chomp;
            my @c = split ';';
            next if join(q{}, @c[6..8]) eq q{};
            $table .= join('\t', @c[0, 6..8]) . "\n";
        }

        close $UCD;
    }

    $fname = (-e 'Numeric.pm.in') ? 'Numeric.pm.in'
           :                         $TargetModule;

    my $out = q{};

    if (! open my $PM, '<', $fname) {
        print {*STDERR} "*** Cannot read module ($!), falling back to default.\n";
        return;
    }
    else {
        while (<$PM>) { $out .= $_;    last if /^### BEGIN ###$/ }

        $out .= sprintf "#v%s\n", $version;

        $out .= $table;

        while (<$PM>) { $out .= $_ and last if /^### END ###$/ }

        while (<$PM>) { $out .= $_ }

        close $PM;
    }

    chmod 0644, $TargetModule if -e $TargetModule;

    if (! open my $PM, '>', $TargetModule) {
        print {*STDERR} "*** Cannot write to module ($!), falling back to default.\n";
        return;
    }
    else {
        print {$PM} $out;

        close $PM;
    }
}

実は Perl 5.8.x 付属の UnicodeData.txt だと Unicode Data のバージョンが 4.1.0 なので上記のような出力にはならないです。

いつの日か某所にあげときます。