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.007'; =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/^)\ (.+)$/); 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__ ; "" ""; "" "" "" ""; ""; ; ""; "" "" "" "" ""; ""; ""; ""; ""; "" ""; ""; ""; ""; ""; ""; "" ""; ""; ""; ""; ""; ""; "" "" ""; ""; "";""; "";""; "" ""; ""; "" "" ""; ""; ; ; ; ; ; ; "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; "" "" ""; "" "" ""; "";"" "" "" "" "" ;""; "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" ; "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" ""; ""; ""; ""; ""; ""; ""; ""; ""; "" "" "" "" "" "" "" "" "" "" "" ""; ""; ""; ""; ""; ""; ""; ""; ""; "" "" "" "" "" "" "" "" "" "" "" ""; ""; ""; ""; ""; ""; ""; ""; ""; "" "" "" "" "" "" "" "" "" "" "" ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; ""; "" "" "" "" "" "" "" "" "" "" "" "" "";"" "" ""