File Coverage

blib/lib/Unicode/Diacritic/Strip.pm

Criterion	Covered	Total	%
statement	63	66	95.4
branch	15	18	83.3
condition	1	3	33.3
subroutine	9	9	100.0
pod	3	4	75.0
total	91	100	91.0

package Unicode::Diacritic::Strip;
use warnings;
use strict;
use utf8;
require Exporter;
use base qw(Exporter);
our @EXPORT_OK = qw/strip_diacritics strip_alphabet fast_strip/;
our %EXPORT_TAGS = (all => \@EXPORT_OK);
our $VERSION = '0.13';
use Unicode::UCD 'charinfo';

sub strip_diacritics
{
    my ($diacritics_text) = @_;
    if ($diacritics_text !~ /[^\x{01}-\x{80}]/) {
        # All the characters in this text are ASCII, and so there are
        # no diacritics.
        return $diacritics_text;
    }
    my @characters = split //, $diacritics_text;
    for my $character (@characters) {
        # Leave non-word characters unaltered.
	if ($character =~ /\W/) {
	    next;
	}
        my $decomposed = decompose ($character);
        if ($character ne $decomposed) {
            $character = $decomposed;
        }
    }
    my $stripped_text = join '', @characters;
    return $stripped_text;
}

sub decompose
{
    my ($character) = @_;
    # Get the Unicode::UCD decomposition.
    my $charinfo = charinfo (ord $character);
    my $decomposition = $charinfo->{decomposition};
    # Give up if there is no decomposition for $character
    if (! $decomposition) {
	return $character;
    }
    # Get the first character of the decomposition
    my @decomposition_chars = split /\s+/, $decomposition;
    $character = chr hex $decomposition_chars[0];
    # A character may have multiple decompositions, so repeat this
    # process until there are none left.
    return decompose ($character);
}

sub strip_alphabet
{
    my ($diacritics_text, %options) = @_;
    my %swaps;
    if (! defined $diacritics_text || length ($diacritics_text) == 0) {
	return ($diacritics_text, {});
    }
    my @characters = split //, $diacritics_text;
    my %alphabet;
    for my $c (@characters) {
	$alphabet{$c} = 1;
    }
    my @c = keys %alphabet;

    for my $character (@c) {
	# Reject non-word characters
	if ($character !~ /\w/) {
	    if ($options{verbose}) {
		print "Not altering non-word character '$character'.\n";
	    }
	    next;
	}
	my $decomposed = decompose ($character, %options);
	if ($character ne $decomposed) {
	    my $boo = "$decomposed baba";
	    $swaps{$character} = $boo;
	    $swaps{$character} =~ s/ baba$//;
	}
    }

    # Make the version of the text with all the diacritics removed.

    my $stripped_text = $diacritics_text;
    for my $k (keys %swaps) {
	if ($options{verbose}) {
	    printf "Swapping $k for $swaps{$k} (%X).\n", ord ($swaps{$k});
	}
	$stripped_text =~ s/$k/$swaps{$k}/g;
    }
    return ($stripped_text, \%swaps);
}

my %strip = (
'À' => 'A',
'Á' => 'A',
'Â' => 'A',
'Ã' => 'A',
'Ä' => 'A',
'Å' => 'A',
'Ç' => 'C',
'È' => 'E',
'É' => 'E',
'Ê' => 'E',
'Ë' => 'E',
'Ì' => 'I',
'Í' => 'I',
'Î' => 'I',
'Ï' => 'I',
'Ñ' => 'N',
'Ò' => 'O',
'Ó' => 'O',
'Ô' => 'O',
'Õ' => 'O',
'Ö' => 'O',
'Ø' => 'O',
'Ù' => 'U',
'Ú' => 'U',
'Û' => 'U',
'Ü' => 'U',
'Ý' => 'Y',
'à' => 'a',
'á' => 'a',
'â' => 'a',
'ã' => 'a',
'ä' => 'a',
'å' => 'a',
'ç' => 'c',
'è' => 'e',
'é' => 'e',
'ê' => 'e',
'ë' => 'e',
'ì' => 'i',
'í' => 'i',
'î' => 'i',
'ï' => 'i',
'ñ' => 'n',
'ò' => 'o',
'ó' => 'o',
'ô' => 'o',
'õ' => 'o',
'ö' => 'o',
'ø' => 'o',
'ù' => 'u',
'ú' => 'u',
'û' => 'u',
'ü' => 'u',
'ý' => 'y',
'ÿ' => 'y',
'Ā' => 'A',
'ā' => 'a',
'Ă' => 'A',
'ă' => 'a',
'Ą' => 'A',
'ą' => 'a',
'Ć' => 'C',
'ć' => 'c',
'Ĉ' => 'C',
'ĉ' => 'c',
'Ċ' => 'C',
'ċ' => 'c',
'Č' => 'C',
'č' => 'c',
'Ď' => 'D',
'ď' => 'd',
'Ē' => 'E',
'ē' => 'e',
'Ĕ' => 'E',
'ĕ' => 'e',
'Ė' => 'E',
'ė' => 'e',
'Ę' => 'E',
'ę' => 'e',
'Ě' => 'E',
'ě' => 'e',
'Ĝ' => 'G',
'ĝ' => 'g',
'Ğ' => 'G',
'ğ' => 'g',
'Ġ' => 'G',
'ġ' => 'g',
'Ģ' => 'G',
'ģ' => 'g',
'Ĥ' => 'H',
'ĥ' => 'h',
'Ĩ' => 'I',
'ĩ' => 'i',
'Ī' => 'I',
'ī' => 'i',
'Ĭ' => 'I',
'ĭ' => 'i',
'Į' => 'I',
'į' => 'i',
'İ' => 'I',
'Ĵ' => 'J',
'ĵ' => 'j',
'Ķ' => 'K',
'ķ' => 'k',
'Ĺ' => 'L',
'ĺ' => 'l',
'Ļ' => 'L',
'ļ' => 'l',
'Ľ' => 'L',
'ľ' => 'l',
'Ł' => 'L',
'ł' => 'l',
'Ń' => 'N',
'ń' => 'n',
'Ņ' => 'N',
'ņ' => 'n',
'Ň' => 'N',
'ň' => 'n',
'Ō' => 'O',
'ō' => 'o',
'Ŏ' => 'O',
'ŏ' => 'o',
'Ő' => 'O',
'ő' => 'o',
'Ŕ' => 'R',
'ŕ' => 'r',
'Ŗ' => 'R',
'ŗ' => 'r',
'Ř' => 'R',
'ř' => 'r',
'Ś' => 'S',
'ś' => 's',
'Ŝ' => 'S',
'ŝ' => 's',
'Ş' => 'S',
'ş' => 's',
'Š' => 'S',
'š' => 's',
'Ţ' => 'T',
'ţ' => 't',
'Ť' => 'T',
'ť' => 't',
'Ũ' => 'U',
'ũ' => 'u',
'Ū' => 'U',
'ū' => 'u',
'Ŭ' => 'U',
'ŭ' => 'u',
'Ů' => 'U',
'ů' => 'u',
'Ű' => 'U',
'ű' => 'u',
'Ų' => 'U',
'ų' => 'u',
'Ŵ' => 'W',
'ŵ' => 'w',
'Ŷ' => 'Y',
'ŷ' => 'y',
'Ÿ' => 'Y',
'Ź' => 'Z',
'ź' => 'z',
'Ż' => 'Z',
'ż' => 'z',
'Ž' => 'Z',
'ž' => 'z',
'Ơ' => 'O',
'ơ' => 'o',
'Ư' => 'U',
'ư' => 'u',
'Ǎ' => 'A',
'ǎ' => 'a',
'Ǐ' => 'I',
'ǐ' => 'i',
'Ǒ' => 'O',
'ǒ' => 'o',
'Ǔ' => 'U',
'ǔ' => 'u',
'Ǖ' => 'U',
'ǖ' => 'u',
'Ǘ' => 'U',
'ǘ' => 'u',
'Ǚ' => 'U',
'ǚ' => 'u',
'Ǜ' => 'U',
'ǜ' => 'u',
'Ǟ' => 'A',
'ǟ' => 'a',
'Ǡ' => 'A',
'ǡ' => 'a',
'Ǧ' => 'G',
'ǧ' => 'g',
'Ǩ' => 'K',
'ǩ' => 'k',
'Ǫ' => 'O',
'ǫ' => 'o',
'Ǭ' => 'O',
'ǭ' => 'o',
'ǰ' => 'j',
'Ǵ' => 'G',
'ǵ' => 'g',
'Ǹ' => 'N',
'ǹ' => 'n',
'Ǻ' => 'A',
'ǻ' => 'a',
'Ȁ' => 'A',
'ȁ' => 'a',
'Ȃ' => 'A',
'ȃ' => 'a',
'Ȅ' => 'E',
'ȅ' => 'e',
'Ȇ' => 'E',
'ȇ' => 'e',
'Ȉ' => 'I',
'ȉ' => 'i',
'Ȋ' => 'I',
'ȋ' => 'i',
'Ȍ' => 'O',
'ȍ' => 'o',
'Ȏ' => 'O',
'ȏ' => 'o',
'Ȑ' => 'R',
'ȑ' => 'r',
'Ȓ' => 'R',
'ȓ' => 'r',
'Ȕ' => 'U',
'ȕ' => 'u',
'Ȗ' => 'U',
'ȗ' => 'u',
'Ș' => 'S',
'ș' => 's',
'Ț' => 'T',
'ț' => 't',
'Ȟ' => 'H',
'ȟ' => 'h',
'Ȧ' => 'A',
'ȧ' => 'a',
'Ȩ' => 'E',
'ȩ' => 'e',
'Ȫ' => 'O',
'ȫ' => 'o',
'Ȭ' => 'O',
'ȭ' => 'o',
'Ȯ' => 'O',
'ȯ' => 'o',
'Ȱ' => 'O',
'ȱ' => 'o',
'Ȳ' => 'Y',
'ȳ' => 'y',
'Ḁ' => 'A',
'ḁ' => 'a',
'Ḃ' => 'B',
'ḃ' => 'b',
'Ḅ' => 'B',
'ḅ' => 'b',
'Ḇ' => 'B',
'ḇ' => 'b',
'Ḉ' => 'C',
'ḉ' => 'c',
'Ḋ' => 'D',
'ḋ' => 'd',
'Ḍ' => 'D',
'ḍ' => 'd',
'Ḏ' => 'D',
'ḏ' => 'd',
'Ḑ' => 'D',
'ḑ' => 'd',
'Ḓ' => 'D',
'ḓ' => 'd',
'Ḕ' => 'E',
'ḕ' => 'e',
'Ḗ' => 'E',
'ḗ' => 'e',
'Ḙ' => 'E',
'ḙ' => 'e',
'Ḛ' => 'E',
'ḛ' => 'e',
'Ḝ' => 'E',
'ḝ' => 'e',
'Ḟ' => 'F',
'ḟ' => 'f',
'Ḡ' => 'G',
'ḡ' => 'g',
'Ḣ' => 'H',
'ḣ' => 'h',
'Ḥ' => 'H',
'ḥ' => 'h',
'Ḧ' => 'H',
'ḧ' => 'h',
'Ḩ' => 'H',
'ḩ' => 'h',
'Ḫ' => 'H',
'ḫ' => 'h',
'Ḭ' => 'I',
'ḭ' => 'i',
'Ḯ' => 'I',
'ḯ' => 'i',
'Ḱ' => 'K',
'ḱ' => 'k',
'Ḳ' => 'K',
'ḳ' => 'k',
'Ḵ' => 'K',
'ḵ' => 'k',
'Ḷ' => 'L',
'ḷ' => 'l',
'Ḹ' => 'L',
'ḹ' => 'l',
'Ḻ' => 'L',
'ḻ' => 'l',
'Ḽ' => 'L',
'ḽ' => 'l',
'Ḿ' => 'M',
'ḿ' => 'm',
'Ṁ' => 'M',
'ṁ' => 'm',
'Ṃ' => 'M',
'ṃ' => 'm',
'Ṅ' => 'N',
'ṅ' => 'n',
'Ṇ' => 'N',
'ṇ' => 'n',
'Ṉ' => 'N',
'ṉ' => 'n',
'Ṋ' => 'N',
'ṋ' => 'n',
'Ṍ' => 'O',
'ṍ' => 'o',
'Ṏ' => 'O',
'ṏ' => 'o',
'Ṑ' => 'O',
'ṑ' => 'o',
'Ṓ' => 'O',
'ṓ' => 'o',
'Ṕ' => 'P',
'ṕ' => 'p',
'Ṗ' => 'P',
'ṗ' => 'p',
'Ṙ' => 'R',
'ṙ' => 'r',
'Ṛ' => 'R',
'ṛ' => 'r',
'Ṝ' => 'R',
'ṝ' => 'r',
'Ṟ' => 'R',
'ṟ' => 'r',
'Ṡ' => 'S',
'ṡ' => 's',
'Ṣ' => 'S',
'ṣ' => 's',
'Ṥ' => 'S',
'ṥ' => 's',
'Ṧ' => 'S',
'ṧ' => 's',
'Ṩ' => 'S',
'ṩ' => 's',
'Ṫ' => 'T',
'ṫ' => 't',
'Ṭ' => 'T',
'ṭ' => 't',
'Ṯ' => 'T',
'ṯ' => 't',
'Ṱ' => 'T',
'ṱ' => 't',
'Ṳ' => 'U',
'ṳ' => 'u',
'Ṵ' => 'U',
'ṵ' => 'u',
'Ṷ' => 'U',
'ṷ' => 'u',
'Ṹ' => 'U',
'ṹ' => 'u',
'Ṻ' => 'U',
'ṻ' => 'u',
'Ṽ' => 'V',
'ṽ' => 'v',
'Ṿ' => 'V',
'ṿ' => 'v',
'Ẁ' => 'W',
'ẁ' => 'w',
'Ẃ' => 'W',
'ẃ' => 'w',
'Ẅ' => 'W',
'ẅ' => 'w',
'Ẇ' => 'W',
'ẇ' => 'w',
'Ẉ' => 'W',
'ẉ' => 'w',
'Ẋ' => 'X',
'ẋ' => 'x',
'Ẍ' => 'X',
'ẍ' => 'x',
'Ẏ' => 'Y',
'ẏ' => 'y',
'Ẑ' => 'Z',
'ẑ' => 'z',
'Ẓ' => 'Z',
'ẓ' => 'z',
'Ẕ' => 'Z',
'ẕ' => 'z',
'ẖ' => 'h',
'ẗ' => 't',
'ẘ' => 'w',
'ẙ' => 'y',
'ẚ' => 'a',
'ẛ' => 'f',
'ẜ' => 'f',
'ẝ' => 'f',
'Ạ' => 'A',
'ạ' => 'a',
'Ả' => 'A',
'ả' => 'a',
'Ấ' => 'A',
'ấ' => 'a',
'Ầ' => 'A',
'ầ' => 'a',
'Ẩ' => 'A',
'ẩ' => 'a',
'Ẫ' => 'A',
'ẫ' => 'a',
'Ậ' => 'A',
'ậ' => 'a',
'Ắ' => 'A',
'ắ' => 'a',
'Ằ' => 'A',
'ằ' => 'a',
'Ẳ' => 'A',
'ẳ' => 'a',
'Ẵ' => 'A',
'ẵ' => 'a',
'Ặ' => 'A',
'ặ' => 'a',
'Ẹ' => 'E',
'ẹ' => 'e',
'Ẻ' => 'E',
'ẻ' => 'e',
'Ẽ' => 'E',
'ẽ' => 'e',
'Ế' => 'E',
'ế' => 'e',
'Ề' => 'E',
'ề' => 'e',
'Ể' => 'E',
'ể' => 'e',
'Ễ' => 'E',
'ễ' => 'e',
'Ệ' => 'E',
'ệ' => 'e',
'Ỉ' => 'I',
'ỉ' => 'i',
'Ị' => 'I',
'ị' => 'i',
'Ọ' => 'O',
'ọ' => 'o',
'Ỏ' => 'O',
'ỏ' => 'o',
'Ố' => 'O',
'ố' => 'o',
'Ồ' => 'O',
'ồ' => 'o',
'Ổ' => 'O',
'ổ' => 'o',
'Ỗ' => 'O',
'ỗ' => 'o',
'Ộ' => 'O',
'ộ' => 'o',
'Ớ' => 'O',
'ớ' => 'o',
'Ờ' => 'O',
'ờ' => 'o',
'Ở' => 'O',
'ở' => 'o',
'Ỡ' => 'O',
'ỡ' => 'o',
'Ợ' => 'O',
'ợ' => 'o',
'Ụ' => 'O',
'ụ' => 'o',
'Ủ' => 'U',
'ủ' => 'u',
'Ứ' => 'U',
'ứ' => 'u',
'Ừ' => 'U',
'ừ' => 'u',
'Ử' => 'U',
'ử' => 'u',
'Ữ' => 'U',
'ữ' => 'u',
'Ự' => 'U',
'ự' => 'u',
'Ỳ' => 'Y',
'ỳ' => 'y',
'Ỵ' => 'Y',
'ỵ' => 'y',
'Ỷ' => 'Y',
'ỷ' => 'y',
'Ỹ' => 'Y',
'ỹ' => 'y',
);

my $strip_keys = join '', keys %strip;

sub fast_strip
{
    my ($word) = @_;
    # Expand ligatures.
    $word =~ s/œ/oe/g;
    # Thorn is "th".
    $word =~ s/Þ|þ/th/g;
    # Remove all diacritics
    $word =~ s/([$strip_keys])/$strip{$1}/g;
    $word =~ s/\p{InCombiningDiacriticalMarks}//g;
    return $word;
}

1;