File Coverage

blib/lib/Unicode/Decompose.pm

Criterion	Covered	Total	%
statement	16	18	88.8
branch			n/a
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	22	24	91.6

package Unicode::Decompose;

use lib "../../../lib";
use 5.006;
use strict;
use warnings;
use utf8;
use UnicodeCD qw(charinfo compexcl);

require Exporter;
require DynaLoader;

our @ISA = qw(Exporter DynaLoader);

our %EXPORT_TAGS = ( 'all' => [ qw(
	normalize normalize_d order decompose recompose
) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw();
our $VERSION = '0.02';

our %compat;
our %canon;

# First, load up the decomposition table
my @decomp = split /\n/, require "unicode/Decomposition.pl" or die $@;
my %decomp;
while ($_=pop @decomp) {
    chomp;
    my ($char,@line) = split;
    $decomp{$char} = [
        map { exists $decomp{$_} ? @{$decomp{$_}} : $_ } @line
    ];
}

# Then remove the recursion from it
my $changed;
do {
    $changed = 0;
    while (my($k,$v) = each %decomp) {
        $decomp{$k} = [ map { exists $decomp{$_} ? do { $changed++; @{$decomp{$_}} } : $_ } @$v ];
    }
} while $changed;

# Now split it into canon and compat
while (my($k,$v) = each %decomp) {
    $compat{pack("U*", hex $k)} = pack "U*", map { hex $_} grep !/
    next if "@$v" =~ /
    $canon{pack("U*", hex $k)} = pack "U*", map { hex $_} @$v;
}

my @ok_keys;
# Recomposition
for (keys %canon) {
    my $x = $_;
    next if (compexcl ord $x); # compexcl eats $_, bluh.
    push @ok_keys, $x;
}

my %recomp = map { $canon{$_} => $_ } @ok_keys;
my $recomppat = join "|", reverse sort keys %recomp;

bootstrap Unicode::Decompose $VERSION;

sub normalize {
    my $a = shift;
    _decompose($a, "canon");
    return recompose(order($a));
}
sub normalize_d {
    my $a = shift;
    _decompose($a, "canon");
    return order($a);
}

sub decompose {
    my $a = shift;
    decompose($a, "canon");
    return $a;
}

sub order {
    my $str = shift;
    my @chars = ($str =~ /(\X)*/);
    my $result;
    for (@chars) {
        # my ($head, @others) = /^(\PM)(\pM)*$/; Doesn't work, damn!
        s/^(\PM)// or die ;
        my $head = $1;
        my @others;
        push @others, $1 while s/^(\pM)//;
        $result .= $head;
        next unless @others;
        $result .= join '', sort { charinfo(ord $a)->{combining} <=> charinfo(ord($b))->{combining} } @others;
    }
    return $result;
}

sub recompose {
    my $a = shift;
    $a =~ s/($recomppat)/$recomp{$1}/g;
    return $a;
}

1;
__END__