File Coverage

blib/lib/Search/Tools/Transliterate.pm

Criterion	Covered	Total	%
statement	67	71	94.3
branch	25	38	65.7
condition			n/a
subroutine	11	11	100.0
pod	3	3	100.0
total	106	123	86.1

package Search::Tools::Transliterate;
use Moo;
extends 'Search::Tools::Object';
use Search::Tools::UTF8;
use Carp;
use Encode;
use Encoding::FixLatin qw( fix_latin );
use Data::Dump qw( dump );

has 'ebit' => ( is => 'rw', default => sub {1} );
has 'map' => ( is => 'ro' );

our $VERSION = '1.004';

=pod

=head1 NAME

Search::Tools::Transliterate - transliterations of UTF-8 chars

=head1 SYNOPSIS

 my $tr = Search::Tools::Transliterate->new();
 print $tr->convert( 'some string of utf8 chars' );

=head1 DESCRIPTION

Search::Tools::Transliterate transliterates UTF-8 characters
to single-byte equivalents. It is based on the transmap project
by Markus Kuhn http://www.cl.cam.ac.uk/~mgk25/.

B All the I encoding check methods that existed in this class prior
to version 0.05 were moved to Search::Tools::UTF8 and refactored as functions,
many using XS for speed improvements.


=head1 METHODS

=head2 new

Create new instance. Takes the following optional parameters:

=over

=item map

Customize the character mapping. Should be a hashref. See map() method.

=item ebit

Allow convert() to use full native 8bit characters for transliterating,
rather than only 7bit ASCII. The default is true (1). Set to 0 to disable.
B This must be set in new(). Changing via the accessor
after new() will have no effect on map().

=back

=head2 BUILD

Called internally by new().

=head2 map

Access the transliteration character map. Example:

 use Search::Tools::Transliterate;
 my $tr = Search::Tools::Transliterate->new;
 $tr->map->{mychar} = 'my transliteration';
 print $tr->convert('mychar');  # prints 'my transliteration'

NOTE: The map() method is an accessor only. You can not pass in a new map.


=head2 convert( I )

Returns UTF-8 I converted with all single bytes, transliterated according
to %Map. Will croak if I is not valid UTF-8, so if in doubt, check first with
is_valid_utf8() in Search::Tools::UTF8.

=head2 convert1252( I )

Returns UTF-8 I converted to all single byte characters,
transliterated with convert() and the Windows 1252 characters in the range
B<0x80> and B<0x9f> inclusive.

The 1252 codepoints are converted first to
their UTF-8 counterparts per
http://www.unicode.org/Public/MAPPINGS/VENDORS/MICSFT/WINDOWS/CP1252.TXT
using Encoding::FixLatin::fix_latin() and then
I is run through convert().

Note that I is checked with the looks_like_cp1252() function from
Search::Tools::UTF8 before calling fix_latin().

=head1 BUGS

You might consider the whole attempt as a bug. It's really an attempt to
accomodate applications that don't support Unicode. Perhaps we shouldn't even
try. But for things like curly quotes and other 'smart' punctuation, it's often
helpful to render the UTF-8 character as B rather than just letting
a character without a direct translation slip into the ether.

That said, if a character has no mapping (and there are plenty that do not)
a single space will be used.

=head1 AUTHOR

Peter Karman C<<  >>

Originally based on the HTML::HiLiter regular expression building code,
by the same author, copyright 2004 by Cray Inc.

Thanks to Atomic Learning C
for sponsoring the development of some of these modules.

=head1 BUGS

Please report any bugs or feature requests to C, or through
the web interface at L.
I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Search::Tools


You can also look for information at:

=over 4

=item * RT: CPAN's request tracker

L

=item * AnnoCPAN: Annotated CPAN documentation

L

=item * CPAN Ratings

L

=item * Search CPAN

L

=back

=head1 COPYRIGHT

Copyright 2006-2010 by Peter Karman.

This package is free software; you can redistribute it and/or modify it under the
same terms as Perl itself.

=head1 SEE ALSO

Search::Tools::UTF8, Unicode::Map, Encode, Test::utf8, Encoding::FixLatin

=cut

# must memoize  the first time since if we call new()
# more than once,  has already been iterated over
# and _init_map() will end up returning empty hash.
my %MAP;

sub _init_map {
    my $self = shift;

    return {%MAP} if %MAP;

    while () {
        chomp;
        next unless m/^
        my ( $from, $to ) = (m/^()\ (.+)$/);
        if ( !defined $to ) {
            warn "Undefined mapping for $_\n";
            next;
        }
        my @o = split( /;/, $to );
        $MAP{ _Utag_to_chr($from) } = _Utag_to_chr( $o[0] );
    }

    return {%MAP};
}

sub _Utag_to_chr {
    my $t = shift;

    # cruft
    $t =~ s/[<>"]+//g;

    $t =~ s,U([0-9A-F]+),chr( hex($1) ),oge;
    return $t;
}

sub BUILD {
    my $self = shift;

    my $map = $self->_init_map;

    # add/override 8bit chars
    if ( $self->ebit ) {
        $self->debug and warn "ebit on\n";
        for ( 128 .. 255 ) {
            my $c = chr($_);
            $self->debug and warn "chr $_ -> $c\n";
            $map->{$c} = $c;
        }
    }

    if ( $self->{map} ) {
        $map->{$_} = $self->{map}->{$_} for keys %{ $self->{map} };
    }
    $self->{map} = $map;
}

# benchmark shows this is 244% faster than previous version.
sub convert {
    my ( $self, $buf ) = @_;
    my $newbuf = '';

    # don't bother unless we have non-ascii bytes
    return $buf if is_ascii($buf);

    # make sure we've got valid UTF-8 to start with
    unless ( is_valid_utf8($buf) ) {
        my $badbyte = find_bad_utf8($buf);
        croak "bad UTF-8 byte(s) at $badbyte [ " . dump($buf) . " ]";
    }

    # an alternate algorithm. no idea if it is faster.
    # it depends on Perl's utf8 char matching (.)
    # which should work if locale is correct, afaik.
    my $map = $self->map;

    $self->debug and warn "converting $buf\n";
    while ( $buf =~ m/(.)/gso ) {
        my $char = $1;
        $self->debug and warn "$char\n";
        if ( is_ascii($char) ) {
            $self->debug and warn "$char is_ascii\n";
            $newbuf .= $char;
        }
        elsif ( !exists $map->{$char} ) {
            $self->debug and warn "$char not in map\n";
            $newbuf .= ' ';
        }
        else {
            $self->debug and warn "transliterate $char => $map->{$char}\n";
            $newbuf .= $map->{$char};
        }

    }

    return $newbuf;
}

sub convert1252 {
    my ( $self, $buf ) = @_;

    # don't bother unless we have non-ascii bytes
    return $buf if is_ascii($buf);

    $self->debug and warn "converting $buf\n";
    my $newbuf = looks_like_cp1252($buf) ? fix_latin($buf) : $buf;
    return $self->convert($newbuf);
}

1;

# map taken directly from
# http://www.cl.cam.ac.uk/~mgk25/download/transtab.tar.gz
# by Markus Kuhn

__DATA__