File Coverage

blib/lib/Text/Transliterator/Unaccent.pm

Criterion	Covered	Total	%
statement	38	57	66.6
branch	6	18	33.3
condition	6	12	50.0
subroutine	7	14	50.0
pod	3	3	100.0
total	60	104	57.6

package Text::Transliterator::Unaccent;

use warnings;
use strict;

use Text::Transliterator; our $VERSION = $Text::Transliterator::VERSION;

use Unicode::UCD        qw(charinfo charscript charblock);
use Unicode::Normalize  qw();

sub char_map {
  my $class = shift;

  my @all_ranges;
  my $ignore_wide  = 0;
  my $ignore_upper = 0;
  my $ignore_lower = 0;

  # decode arguments to get character ranges and boolean flags
  while (my ($kind, $arg) = splice(@_, 0, 2)) {
    my $ranges;

    my $todo = {
      script   => sub { $ranges = charscript($arg)
                          or die "$arg is not a valid Unicode script" },
      block    => sub { $ranges = charblock($arg)
                          or die "$arg is not a valid Unicode block"  },
      ranges   => sub { $ranges = $arg },
      wide     => sub { $ignore_wide  = !$arg                         },
      upper    => sub { $ignore_upper = !$arg                         },
      lower    => sub { $ignore_lower = !$arg                         },
     };
    my $coderef = $todo->{$kind}
      or die "invalid argument: $kind";
    $coderef->();
    push @all_ranges, @$ranges if $ranges;
  }

  # default
  @all_ranges = @{charscript('Latin')} if !@all_ranges;

  # build the map
  my %map;
  foreach my $range (@all_ranges) {
    my ($start, $end) = @$range;

    # iterate over characters in range
  CHAR:
    for my $c ($start .. $end) {

      # maybe drop that char under some conditions
      last CHAR if $ignore_wide and $c > 255;
      next CHAR if $ignore_upper and chr($c) =~ /\p{Uppercase_Letter}/;
      next CHAR if $ignore_lower and chr($c) =~ /\p{Lowercase_Letter}/;

      # get canonical decomposition (if any)
      my $canon  = Unicode::Normalize::getCanon($c);

      # store into map
      if ($canon && length($canon) > 1) {
        # the unaccented char is the the base (first char) of the decomposition
        my $base = substr $canon, 0, 1;
        $map{chr($c)} = $base,
      }
    }
  }

  return \%map;
}

sub char_map_descr {
  my $class = shift;

  my $map = $class->char_map(@_);

  my $txt = "";
  while (my ($k, $v) = each %$map) {
    my $accented = ord($k);
    my $base     = ord($v);
    $txt .= sprintf "U+%04x %-40s => U+%04x %s\n",
               $accented,
               charinfo($accented)->{name},
               $base,
               charinfo($base)->{name};
  }
  return $txt;
}

sub new {
  my $class = shift;
  my $map = $class->char_map(@_);
  return Text::Transliterator->new($map)
}

1; # End of Text::Transliterator::Unaccent


__END__