File Coverage

blib/lib/Text/Unidecode.pm

Criterion	Covered	Total	%
statement	52	65	80.0
branch	19	34	55.8
condition	1	2	50.0
subroutine	11	12	91.6
pod	1	5	20.0
total	84	118	71.1

;;;;# -*-coding:utf-8;-*-                                               µ ← col73

require 5;
use 5.8.0;
package Text::Unidecode;
$Last_Modified =' Time-stamp: "2015-10-21 06:43:24 MDT [e-mail]"';
use utf8;
use strict;
use integer; # vroom vroom!
use vars qw($VERSION @ISA @EXPORT @Char $UNKNOWN $NULLMAP $TABLE_SIZE $Last_Modified);
$VERSION = '1.27';
require Exporter;
@ISA = ('Exporter');
@EXPORT = ('unidecode');

BEGIN { *DEBUG = sub () {0} unless defined &DEBUG }
$UNKNOWN = '[?] ';
$TABLE_SIZE = 256;
$NULLMAP = [( $UNKNOWN ) x $TABLE_SIZE];  # for blocks we can't load

#--------------------------------------------------------------------------
{
  my $x = join '', "\x00" .. "\x7F";
  die "the 7-bit purity test fails!" unless $x eq unidecode($x);
}

#--------------------------------------------------------------------------

sub unidecode {
  # Destructive in void context -- in other contexts, nondestructive.

  unless(@_) {  # Sanity: Nothing coming in!
    return() if wantarray;
    return '';
  }

  if( defined wantarray ) {
    # We're in list or scalar context (i.e., just not void context.)
    #  So make @_'s items no longer be aliases.
    @_ = map $_, @_;
  } else {
    # Otherwise (if we're in void context), then just let @_ stay
    #  aliases, and alter their elements IN-PLACE!
  }

  foreach my $n (@_) {
    next unless defined $n;

    # Shut up potentially fatal warnings about UTF-16 surrogate
    # characters when running under perl -w
    # This is per https://rt.cpan.org/Ticket/Display.html?id=97456
    no warnings 'utf8';

    $n =~ s~([^\x00-\x7f])~${$Char[ord($1)>>8]||t($1)}[ord($1)&255]~egs;
  }
  # That means:
  #   Replace character 0xABCD with $Char[0xAB][0xCD], loading
  #    the table 0xAB as needed.
  #
  #======================================================================
  #
  # Yes, that's dense code.  It's the warp core!
  # Here is an expansion into pseudocode... as best as I can manage it...
  #
  #     $character = $1;
  #     $charnum = ord($character);
  #     $charnum_lowbits  = $charnum & 255;
  #     $charnum_highbits = $charnum >> 8;
  #
  #     $table_ref = $Char->[$charnum_highbits];
  #
  #     if($table_ref) {
  #       # As expected, we got the arrayref for this table.
  #     } else {
  #       # Uhoh, we couldn't find the arrayref for this table.
  #       # So we call t($character).
  #       #  It loads a table.  Namely, it does:
  #       Load_Table_For( $charnum_highbits );
  #        # ...which does magic, and puts something in
  #        #     $Char->[$charnum_highbits],
  #        #     so NOW we actually CAN do:
  #       $table_ref = $Char->[$charnum_highbits];
  #     }
  #
  #     $for_this_char
  #       = $table_ref->[ $charnum_lowbits ];
  #
  #     # Although the syntax we actually use is the odd
  #      but COMPLETE EQUIVALENT to this syntax:
  #
  #     $for_this_char
  #       = ${ $table_ref }[ $charnum_lowbits ];
  #
  #     and $for_this_char is the replacement text for this
  #      character, in:
  #      $n =~ s~(char)~replacement~egs
  #
  #  (And why did I use s~x~y~ instead of s/x/y/ ?
  #  It's all the same for Perl: perldoc perlretut says:
  #       As with the match "m//" operator, "s///" can
  #       use other delimiters, such as "s!!!" and "s{}{}",
  #  I didn't do it for sake of obscurity. I think it's just to
  #  keep my editor's syntax highlighter from crashing,
  #  which was a problem with s/// when the insides are as gory
  #  as we have here.

  return unless defined wantarray; # void context
  return @_ if wantarray;  # normal list context -- return the copies
  # Else normal scalar context:
  return $_[0] if @_ == 1;
  return join '', @_;      # rarer fallthru: a list in, but a scalar out.
}

#======================================================================

sub make_placeholder_map {
  return [( $UNKNOWN ) x $TABLE_SIZE ];
}
sub make_placeholder_map_nulls {
  return [( "" ) x $TABLE_SIZE ];
}

#======================================================================

sub t {   # "t" is for "t"able.
  # Load (and return) a char table for this character
  # this should get called only once per table per session.
  my $bank = ord($_[0]) >> 8;
  return $Char[$bank] if $Char[$bank];

  load_bank($bank);

  # Now see how that fared...

  if(ref($Char[$bank] || '') ne 'ARRAY') {
    DEBUG > 1 and print
      " Loading failed for bank $bank (err $@).  Using null map.\n";
    return $Char[$bank] = $NULLMAP;
  }


  DEBUG > 1 and print " Loading succeeded.\n";
  my $cb = $Char[$bank];

  # Sanity-check it:
  if(@$cb == $TABLE_SIZE) {
    # As expected.  Fallthru.

  } else {
    if(@$cb > $TABLE_SIZE) {
      DEBUG and print "Bank $bank is too large-- it has ", scalar @$cb,
        " entries in it.  Pruning.\n";
      splice @$cb, $TABLE_SIZE;
       # That two-argument form splices everything off into nowhere,
       #  starting with the first overage character.

    } elsif( @$cb < $TABLE_SIZE) {
      DEBUG and print "Bank $bank is too small-- it has ", scalar @$cb,
        " entries in it.  Now padding it.\n";
      if(@$cb == 0) {
        DEBUG and print "  (Yes, ZERO entries!)\n";
      }
      push @$cb,
	  ( $UNKNOWN )  x  ( $TABLE_SIZE - @$cb)
	  # i.e., however many items, times the deficit
      ;
      # And fallthru...

    } else {
      die "UNREACHABLE CODE HERE (INSANE)";
    }
  }

  # Check for undefness in block:

  for(my $i = 0; $i < $TABLE_SIZE; ++$i) {
    unless(defined $cb->[$i]) {
      DEBUG and printf "Undef at position %d in block x%02x\n",
        $i, $bank;
      $cb->[$i] = '';
    }
  }

  return $Char[$bank];
}

#-----------------------------------------------------------------------

our $eval_loaded_okay;

sub load_bank {

  # This is in its own sub, for sake of sweeping the scary thing
  #  (namely, a call to eval) under the rug.
  # I.e., to paraphrase what Larry Wall once said to me: if
  #  you're going to do something odd, maybe you should do it
  #  in private.

  my($banknum) = @_;  # just as an integer value

  DEBUG and printf
      "# Eval-loading %s::x%02x ...\n";

  $eval_loaded_okay = 0;
  my $code =
      sprintf( "require %s::x%02x; \$eval_loaded_okay = 1;\n",
               __PACKAGE__,
	       $banknum);

  {
    local $SIG{'__DIE__'};
    eval($code);
  }

  return 1 if $eval_loaded_okay;
  return 0;
}

#======================================================================

1;
__END__