ext/Encode/bin/enc2xs

   1 #!./perl
   2 BEGIN {
   3     # @INC poking  no longer needed w/ new MakeMaker and Makefile.PL's
   4     # with $ENV{PERL_CORE} set
   5     # In case we need it in future...
   6     require Config; import Config;
   7 }
   8 use strict;
   9 use warnings;
  10 use Getopt::Std;
  11 my @orig_ARGV = @ARGV;
  12 our $VERSION  = do { my @r = (q$Revision: 2.4 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
  13
  14 # These may get re-ordered.
  15 # RAW is a do_now as inserted by &enter
  16 # AGG is an aggreagated do_now, as built up by &process
  17
  18 use constant {
  19   RAW_NEXT => 0,
  20   RAW_IN_LEN => 1,
  21   RAW_OUT_BYTES => 2,
  22   RAW_FALLBACK => 3,
  23
  24   AGG_MIN_IN => 0,
  25   AGG_MAX_IN => 1,
  26   AGG_OUT_BYTES => 2,
  27   AGG_NEXT => 3,
  28   AGG_IN_LEN => 4,
  29   AGG_OUT_LEN => 5,
  30   AGG_FALLBACK => 6,
  31 };
  32
  33 # (See the algorithm in encengine.c - we're building structures for it)
  34
  35 # There are two sorts of structures.
  36 # "do_now" (an array, two variants of what needs storing) is whatever we need
  37 # to do now we've read an input byte.
  38 # It's housed in a "do_next" (which is how we got to it), and in turn points
  39 # to a "do_next" which contains all the "do_now"s for the next input byte.
  40
  41 # There will be a "do_next" which is the start state.
  42 # For a single byte encoding it's the only "do_next" - each "do_now" points
  43 # back to it, and each "do_now" will cause bytes. There is no state.
  44
  45 # For a multi-byte encoding where all characters in the input are the same
  46 # length, then there will be a tree of "do_now"->"do_next"->"do_now"
  47 # branching out from the start state, one step for each input byte.
  48 # The leaf "do_now"s will all be at the same distance from the start state,
  49 # only the leaf "do_now"s cause output bytes, and they in turn point back to
  50 # the start state.
  51
  52 # For an encoding where there are varaible length input byte sequences, you
  53 # will encounter a leaf "do_now" sooner for the shorter input sequences, but
  54 # as before the leaves will point back to the start state.
  55
  56 # The system will cope with escape encodings (imagine them as a mostly
  57 # self-contained tree for each escape state, and cross links between trees
  58 # at the state-switching characters) but so far no input format defines these.
  59
  60 # The system will also cope with having output "leaves" in the middle of
  61 # the bifurcating branches, not just at the extremities, but again no
  62 # input format does this yet.
  63
  64 # There are two variants of the "do_now" structure. The first, smaller variant
  65 # is generated by &enter as the input file is read. There is one structure
  66 # for each input byte. Say we are mapping a single byte encoding to a
  67 # single byte encoding, with  "ABCD" going "abcd". There will be
  68 # 4 "do_now"s, {"A" => [...,"a",...], "B" => [...,"b",...], "C"=>..., "D"=>...}
  69
  70 # &process then walks the tree, building aggregate "do_now" structres for
  71 # adjacent bytes where possible. The aggregate is for a contiguous range of
  72 # bytes which each produce the same length of output, each move to the
  73 # same next state, and each have the same fallback flag.
  74 # So our 4 RAW "do_now"s above become replaced by a single structure
  75 # containing:
  76 # ["A", "D", "abcd", 1, ...]
  77 # ie, for an input byte $_ in "A".."D", output 1 byte, found as
  78 # substr ("abcd", (ord $_ - ord "A") * 1, 1)
  79 # which maps very nicely into pointer arithmetic in C for encengine.c
  80
  81 sub encode_U
  82 {
  83  # UTF-8 encode long hand - only covers part of perl's range
  84  ## my $uv = shift;
  85  # chr() works in native space so convert value from table
  86  # into that space before using chr().
  87  my $ch = chr(utf8::unicode_to_native($_[0]));
  88  # Now get core perl to encode that the way it likes.
  89  utf8::encode($ch);
  90  return $ch;
  91 }
  92
  93 sub encode_S
  94 {
  95  # encode single byte
  96  ## my ($ch,$page) = @_; return chr($ch);
  97  return chr $_[0];
  98 }
  99
 100 sub encode_D
 101 {
 102  # encode double byte MS byte first
 103  ## my ($ch,$page) = @_; return chr($page).chr($ch);
 104  return chr ($_[1]) . chr $_[0];
 105 }
 106
 107 sub encode_M
 108 {
 109  # encode Multi-byte - single for 0..255 otherwise double
 110  ## my ($ch,$page) = @_;
 111  ## return &encode_D if $page;
 112  ## return &encode_S;
 113  return chr ($_[1]) . chr $_[0] if $_[1];
 114  return chr $_[0];
 115 }
 116
 117 my %encode_types = (U => \&encode_U,
 118                     S => \&encode_S,
 119                     D => \&encode_D,
 120                     M => \&encode_M,
 121                    );
 122
 123 # Win32 does not expand globs on command line
 124 eval "\@ARGV = map(glob(\$_),\@ARGV)" if ($^O eq 'MSWin32');
 125
 126 my %opt;
 127 # I think these are:
 128 # -Q to disable the duplicate codepoint test
 129 # -S make mapping errors fatal
 130 # -q to remove comments written to output files
 131 # -O to enable the (brute force) substring optimiser
 132 # -o <output> to specify the output file name (else it's the first arg)
 133 # -f <inlist> to give a file with a list of input files (else use the args)
 134 # -n <name> to name the encoding (else use the basename of the input file.
 135 getopts('CM:SQqOo:f:n:',\%opt);
 136
 137 $opt{M} and make_makefile_pl($opt{M}, @ARGV);
 138 $opt{C} and make_configlocal_pm($opt{C}, @ARGV);
 139
 140 # This really should go first, else the die here causes empty (non-erroneous)
 141 # output files to be written.
 142 my @encfiles;
 143 if (exists $opt{'f'}) {
 144     # -F is followed by name of file containing list of filenames
 145     my $flist = $opt{'f'};
 146     open(FLIST,$flist) || die "Cannot open $flist:$!";
 147     chomp(@encfiles = <FLIST>);
 148     close(FLIST);
 149 } else {
 150     @encfiles = @ARGV;
 151 }
 152
 153 my $cname = (exists $opt{'o'}) ? $opt{'o'} : shift(@ARGV);
 154 chmod(0666,$cname) if -f $cname && !-w $cname;
 155 open(C,">$cname") || die "Cannot open $cname:$!";
 156
 157 my $dname = $cname;
 158 my $hname = $cname;
 159
 160 my ($doC,$doEnc,$doUcm,$doPet);
 161
 162 if ($cname =~ /\.(c|xs)$/i) # VMS may have upcased filenames with DECC$ARGV_PARSE_STYLE defined
 163  {
 164   $doC = 1;
 165   $dname =~ s/(\.[^\.]*)?$/.exh/;
 166   chmod(0666,$dname) if -f $cname && !-w $dname;
 167   open(D,">$dname") || die "Cannot open $dname:$!";
 168   $hname =~ s/(\.[^\.]*)?$/.h/;
 169   chmod(0666,$hname) if -f $cname && !-w $hname;
 170   open(H,">$hname") || die "Cannot open $hname:$!";
 171
 172   foreach my $fh (\*C,\*D,\*H)
 173   {
 174    print $fh <<"END" unless $opt{'q'};
 175 /*
 176  !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
 177  This file was autogenerated by:
 178  $^X $0 @orig_ARGV
 179 */
 180 END
 181   }
 182
 183   if ($cname =~ /(\w+)\.xs$/)
 184    {
 185     print C "#include <EXTERN.h>\n";
 186     print C "#include <perl.h>\n";
 187     print C "#include <XSUB.h>\n";
 188     print C "#define U8 U8\n";
 189    }
 190   print C "#include \"encode.h\"\n\n";
 191
 192  }
 193 elsif ($cname =~ /\.enc$/)
 194  {
 195   $doEnc = 1;
 196  }
 197 elsif ($cname =~ /\.ucm$/)
 198  {
 199   $doUcm = 1;
 200  }
 201 elsif ($cname =~ /\.pet$/)
 202  {
 203   $doPet = 1;
 204  }
 205
 206 my %encoding;
 207 my %strings;
 208 my $string_acc;
 209 my %strings_in_acc;
 210
 211 my $saved = 0;
 212 my $subsave = 0;
 213 my $strings = 0;
 214
 215 sub cmp_name
 216 {
 217  if ($a =~ /^.*-(\d+)/)
 218   {
 219    my $an = $1;
 220    if ($b =~ /^.*-(\d+)/)
 221     {
 222      my $r = $an <=> $1;
 223      return $r if $r;
 224     }
 225   }
 226  return $a cmp $b;
 227 }
 228
 229
 230 foreach my $enc (sort cmp_name @encfiles)
 231  {
 232   my ($name,$sfx) = $enc =~ /^.*?([\w-]+)\.(enc|ucm)$/;
 233   $name = $opt{'n'} if exists $opt{'n'};
 234   if (open(E,$enc))
 235    {
 236     if ($sfx eq 'enc')
 237      {
 238       compile_enc(\*E,lc($name));
 239      }
 240     else
 241      {
 242       compile_ucm(\*E,lc($name));
 243      }
 244    }
 245   else
 246    {
 247     warn "Cannot open $enc for $name:$!";
 248    }
 249  }
 250
 251 if ($doC)
 252  {
 253   print STDERR "Writing compiled form\n";
 254   foreach my $name (sort cmp_name keys %encoding)
 255    {
 256     my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}};
 257     process($name.'_utf8',$e2u);
 258     addstrings(\*C,$e2u);
 259
 260     process('utf8_'.$name,$u2e);
 261     addstrings(\*C,$u2e);
 262    }
 263   outbigstring(\*C,"enctable");
 264   foreach my $name (sort cmp_name keys %encoding)
 265    {
 266     my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}};
 267     outtable(\*C,$e2u, "enctable");
 268     outtable(\*C,$u2e, "enctable");
 269
 270     # push(@{$encoding{$name}},outstring(\*C,$e2u->{Cname}.'_def',$erep));
 271    }
 272   foreach my $enc (sort cmp_name keys %encoding)
 273    {
 274     # my ($e2u,$u2e,$rep,$min_el,$max_el,$rsym) = @{$encoding{$enc}};
 275     my ($e2u,$u2e,$rep,$min_el,$max_el) = @{$encoding{$enc}};
 276     #my @info = ($e2u->{Cname},$u2e->{Cname},$rsym,length($rep),$min_el,$max_el);
 277     my $replen = 0;
 278     $replen++ while($rep =~ /\G\\x[0-9A-Fa-f]/g);
 279     my $sym = "${enc}_encoding";
 280     $sym =~ s/\W+/_/g;
 281     my @info = ($e2u->{Cname},$u2e->{Cname},"${sym}_rep_character",$replen,
 282         $min_el,$max_el);
 283     print C "static const U8 ${sym}_rep_character[] = \"$rep\";\n";
 284     print C "static const char ${sym}_enc_name[] = \"$enc\";\n\n";
 285     print C "const encode_t $sym = \n";
 286     # This is to make null encoding work -- dankogai
 287     for (my $i = (scalar @info) - 1;  $i >= 0; --$i){
 288     $info[$i] ||= 1;
 289     }
 290     # end of null tweak -- dankogai
 291     print C " {",join(',',@info,"{${sym}_enc_name,(const char *)0}"),"};\n\n";
 292    }
 293
 294   foreach my $enc (sort cmp_name keys %encoding)
 295    {
 296     my $sym = "${enc}_encoding";
 297     $sym =~ s/\W+/_/g;
 298     print H "extern encode_t $sym;\n";
 299     print D " Encode_XSEncoding(aTHX_ &$sym);\n";
 300    }
 301
 302   if ($cname =~ /(\w+)\.xs$/)
 303    {
 304     my $mod = $1;
 305     print C <<'END';
 306
 307 static void
 308 Encode_XSEncoding(pTHX_ encode_t *enc)
 309 {
 310  dSP;
 311  HV *stash = gv_stashpv("Encode::XS", TRUE);
 312  SV *sv    = sv_bless(newRV_noinc(newSViv(PTR2IV(enc))),stash);
 313  int i = 0;
 314  PUSHMARK(sp);
 315  XPUSHs(sv);
 316  while (enc->name[i])
 317   {
 318    const char *name = enc->name[i++];
 319    XPUSHs(sv_2mortal(newSVpvn(name,strlen(name))));
 320   }
 321  PUTBACK;
 322  call_pv("Encode::define_encoding",G_DISCARD);
 323  SvREFCNT_dec(sv);
 324 }
 325
 326 END
 327
 328     print C "\nMODULE = Encode::$mod\tPACKAGE = Encode::$mod\n\n";
 329     print C "BOOT:\n{\n";
 330     print C "#include \"$dname\"\n";
 331     print C "}\n";
 332    }
 333   # Close in void context is bad, m'kay
 334   close(D) or warn "Error closing '$dname': $!";
 335   close(H) or warn "Error closing '$hname': $!";
 336
 337   my $perc_saved    = $saved/($strings + $saved) * 100;
 338   my $perc_subsaved = $subsave/($strings + $subsave) * 100;
 339   printf STDERR "%d bytes in string tables\n",$strings;
 340   printf STDERR "%d bytes (%.3g%%) saved spotting duplicates\n",
 341     $saved, $perc_saved              if $saved;
 342   printf STDERR "%d bytes (%.3g%%) saved using substrings\n",
 343     $subsave, $perc_subsaved         if $subsave;
 344  }
 345 elsif ($doEnc)
 346  {
 347   foreach my $name (sort cmp_name keys %encoding)
 348    {
 349     my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}};
 350     output_enc(\*C,$name,$e2u);
 351    }
 352  }
 353 elsif ($doUcm)
 354  {
 355   foreach my $name (sort cmp_name keys %encoding)
 356    {
 357     my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}};
 358     output_ucm(\*C,$name,$u2e,$erep,$min_el,$max_el);
 359    }
 360  }
 361
 362 # writing half meg files and then not checking to see if you just filled the
 363 # disk is bad, m'kay
 364 close(C) or die "Error closing '$cname': $!";
 365
 366 # End of the main program.
 367
 368 sub compile_ucm
 369 {
 370  my ($fh,$name) = @_;
 371  my $e2u = {};
 372  my $u2e = {};
 373  my $cs;
 374  my %attr;
 375  while (<$fh>)
 376   {
 377    s/#.*$//;
 378    last if /^\s*CHARMAP\s*$/i;
 379    if (/^\s*<(\w+)>\s+"?([^"]*)"?\s*$/i) # " # Grrr
 380     {
 381      $attr{$1} = $2;
 382     }
 383   }
 384  if (!defined($cs =  $attr{'code_set_name'}))
 385   {
 386    warn "No <code_set_name> in $name\n";
 387   }
 388  else
 389   {
 390    $name = $cs unless exists $opt{'n'};
 391   }
 392  my $erep;
 393  my $urep;
 394  my $max_el;
 395  my $min_el;
 396  if (exists $attr{'subchar'})
 397   {
 398    #my @byte;
 399    #$attr{'subchar'} =~ /^\s*/cg;
 400    #push(@byte,$1) while $attr{'subchar'} =~ /\G\\x([0-9a-f]+)/icg;
 401    #$erep = join('',map(chr(hex($_)),@byte));
 402    $erep = $attr{'subchar'};
 403    $erep =~ s/^\s+//; $erep =~ s/\s+$//;
 404   }
 405  print "Reading $name ($cs)\n";
 406  my $nfb = 0;
 407  my $hfb = 0;
 408  while (<$fh>)
 409   {
 410    s/#.*$//;
 411    last if /^\s*END\s+CHARMAP\s*$/i;
 412    next if /^\s*$/;
 413    my (@uni, @byte) = ();
 414    my ($uni, $byte, $fb) = m/^(\S+)\s+(\S+)\s+(\S+)\s+/o
 415        or die "Bad line: $_";
 416    while ($uni =~  m/\G<([U0-9a-fA-F\+]+)>/g){
 417        push @uni, map { substr($_, 1) } split(/\+/, $1);
 418    }
 419    while ($byte =~ m/\G\\x([0-9a-fA-F]+)/g){
 420        push @byte, $1;
 421    }
 422    if (@uni)
 423     {
 424      my $uch =  join('', map { encode_U(hex($_)) } @uni );
 425      my $ech = join('',map(chr(hex($_)),@byte));
 426      my $el  = length($ech);
 427      $max_el = $el if (!defined($max_el) || $el > $max_el);
 428      $min_el = $el if (!defined($min_el) || $el < $min_el);
 429      if (length($fb))
 430       {
 431        $fb = substr($fb,1);
 432        $hfb++;
 433       }
 434      else
 435       {
 436        $nfb++;
 437        $fb = '0';
 438       }
 439      # $fb is fallback flag
 440      # 0 - round trip safe
 441      # 1 - fallback for unicode -> enc
 442      # 2 - skip sub-char mapping
 443      # 3 - fallback enc -> unicode
 444      enter($u2e,$uch,$ech,$u2e,$fb+0) if ($fb =~ /[01]/);
 445      enter($e2u,$ech,$uch,$e2u,$fb+0) if ($fb =~ /[03]/);
 446     }
 447    else
 448     {
 449      warn $_;
 450     }
 451   }
 452  if ($nfb && $hfb)
 453   {
 454    die "$nfb entries without fallback, $hfb entries with\n";
 455   }
 456  $encoding{$name} = [$e2u,$u2e,$erep,$min_el,$max_el];
 457 }
 458
 459
 460
 461 sub compile_enc
 462 {
 463  my ($fh,$name) = @_;
 464  my $e2u = {};
 465  my $u2e = {};
 466
 467  my $type;
 468  while ($type = <$fh>)
 469   {
 470    last if $type !~ /^\s*#/;
 471   }
 472  chomp($type);
 473  return if $type eq 'E';
 474  # Do the hash lookup once, rather than once per function call. 4% speedup.
 475  my $type_func = $encode_types{$type};
 476  my ($def,$sym,$pages) = split(/\s+/,scalar(<$fh>));
 477  warn "$type encoded $name\n";
 478  my $rep = '';
 479  # Save a defined test by setting these to defined values.
 480  my $min_el = ~0; # A very big integer
 481  my $max_el = 0;  # Anything must be longer than 0
 482  {
 483   my $v = hex($def);
 484   $rep = &$type_func($v & 0xFF, ($v >> 8) & 0xffe);
 485  }
 486  my $errors;
 487  my $seen;
 488  # use -Q to silence the seen test. Makefile.PL uses this by default.
 489  $seen = {} unless $opt{Q};
 490  do
 491   {
 492    my $line = <$fh>;
 493    chomp($line);
 494    my $page = hex($line);
 495    my $ch = 0;
 496    my $i = 16;
 497    do
 498     {
 499      # So why is it 1% faster to leave the my here?
 500      my $line = <$fh>;
 501      $line =~ s/\r\n$/\n/;
 502      die "$.:${line}Line should be exactly 65 characters long including
 503      newline (".length($line).")" unless length ($line) == 65;
 504      # Split line into groups of 4 hex digits, convert groups to ints
 505      # This takes 65.35
 506      # map {hex $_} $line =~ /(....)/g
 507      # This takes 63.75 (2.5% less time)
 508      # unpack "n*", pack "H*", $line
 509      # There's an implicit loop in map. Loops are bad, m'kay. Ops are bad, m'kay
 510      # Doing it as while ($line =~ /(....)/g) took 74.63
 511      foreach my $val (unpack "n*", pack "H*", $line)
 512       {
 513        next if $val == 0xFFFD;
 514        my $ech = &$type_func($ch,$page);
 515        if ($val || (!$ch && !$page))
 516         {
 517          my $el  = length($ech);
 518          $max_el = $el if $el > $max_el;
 519          $min_el = $el if $el < $min_el;
 520          my $uch = encode_U($val);
 521          if ($seen) {
 522            # We're doing the test.
 523            # We don't need to read this quickly, so storing it as a scalar,
 524            # rather than 3 (anon array, plus the 2 scalars it holds) saves
 525            # RAM and may make us faster on low RAM systems. [see __END__]
 526            if (exists $seen->{$uch})
 527              {
 528                warn sprintf("U%04X is %02X%02X and %04X\n",
 529                             $val,$page,$ch,$seen->{$uch});
 530                $errors++;
 531              }
 532            else
 533              {
 534                $seen->{$uch} = $page << 8 | $ch;
 535              }
 536          }
 537          # Passing 2 extra args each time is 3.6% slower!
 538          # Even with having to add $fallback ||= 0 later
 539          enter_fb0($e2u,$ech,$uch);
 540          enter_fb0($u2e,$uch,$ech);
 541         }
 542        else
 543         {
 544          # No character at this position
 545          # enter($e2u,$ech,undef,$e2u);
 546         }
 547        $ch++;
 548       }
 549     } while --$i;
 550   } while --$pages;
 551  die "\$min_el=$min_el, \$max_el=$max_el - seems we read no lines"
 552    if $min_el > $max_el;
 553  die "$errors mapping conflicts\n" if ($errors && $opt{'S'});
 554  $encoding{$name} = [$e2u,$u2e,$rep,$min_el,$max_el];
 555 }
 556
 557 # my ($a,$s,$d,$t,$fb) = @_;
 558 sub enter {
 559   my ($current,$inbytes,$outbytes,$next,$fallback) = @_;
 560   # state we shift to after this (multibyte) input character defaults to same
 561   # as current state.
 562   $next ||= $current;
 563   # Making sure it is defined seems to be faster than {no warnings;} in
 564   # &process, or passing it in as 0 explicity.
 565   # XXX $fallback ||= 0;
 566
 567   # Start at the beginning and work forwards through the string to zero.
 568   # effectively we are removing 1 character from the front each time
 569   # but we don't actually edit the string. [this alone seems to be 14% speedup]
 570   # Hence -$pos is the length of the remaining string.
 571   my $pos = -length $inbytes;
 572   while (1) {
 573     my $byte = substr $inbytes, $pos, 1;
 574     #  RAW_NEXT => 0,
 575     #  RAW_IN_LEN => 1,
 576     #  RAW_OUT_BYTES => 2,
 577     #  RAW_FALLBACK => 3,
 578     # to unicode an array would seem to be better, because the pages are dense.
 579     # from unicode can be very sparse, favouring a hash.
 580     # hash using the bytes (all length 1) as keys rather than ord value,
 581     # as it's easier to sort these in &process.
 582
 583     # It's faster to always add $fallback even if it's undef, rather than
 584     # choosing between 3 and 4 element array. (hence why we set it defined
 585     # above)
 586     my $do_now = $current->{Raw}{$byte} ||= [{},-$pos,'',$fallback];
 587     # When $pos was -1 we were at the last input character.
 588     unless (++$pos) {
 589       $do_now->[RAW_OUT_BYTES] = $outbytes;
 590       $do_now->[RAW_NEXT] = $next;
 591       return;
 592     }
 593     # Tail recursion. The intermdiate state may not have a name yet.
 594     $current = $do_now->[RAW_NEXT];
 595   }
 596 }
 597
 598 # This is purely for optimistation. It's just &enter hard coded for $fallback
 599 # of 0, using only a 3 entry array ref to save memory for every entry.
 600 sub enter_fb0 {
 601   my ($current,$inbytes,$outbytes,$next) = @_;
 602   $next ||= $current;
 603
 604   my $pos = -length $inbytes;
 605   while (1) {
 606     my $byte = substr $inbytes, $pos, 1;
 607     my $do_now = $current->{Raw}{$byte} ||= [{},-$pos,''];
 608     unless (++$pos) {
 609       $do_now->[RAW_OUT_BYTES] = $outbytes;
 610       $do_now->[RAW_NEXT] = $next;
 611       return;
 612     }
 613     $current = $do_now->[RAW_NEXT];
 614   }
 615 }
 616
 617 sub process
 618 {
 619   my ($name,$a) = @_;
 620   $name =~ s/\W+/_/g;
 621   $a->{Cname} = $name;
 622   my $raw = $a->{Raw};
 623   my ($l, $agg_max_in, $agg_next, $agg_in_len, $agg_out_len, $agg_fallback);
 624   my @ent;
 625   $agg_max_in = 0;
 626   foreach my $key (sort keys %$raw) {
 627     #  RAW_NEXT => 0,
 628     #  RAW_IN_LEN => 1,
 629     #  RAW_OUT_BYTES => 2,
 630     #  RAW_FALLBACK => 3,
 631     my ($next, $in_len, $out_bytes, $fallback) = @{$raw->{$key}};
 632     # Now we are converting from raw to aggregate, switch from 1 byte strings
 633     # to numbers
 634     my $b = ord $key;
 635     $fallback ||= 0;
 636     if ($l &&
 637         # If this == fails, we're going to reset $agg_max_in below anyway.
 638         $b == ++$agg_max_in &&
 639         # References in numeric context give the pointer as an int.
 640         $agg_next == $next &&
 641         $agg_in_len == $in_len &&
 642         $agg_out_len == length $out_bytes &&
 643         $agg_fallback == $fallback
 644         # && length($l->[AGG_OUT_BYTES]) < 16
 645        ) {
 646       #     my $i = ord($b)-ord($l->[AGG_MIN_IN]);
 647       # we can aggregate this byte onto the end.
 648       $l->[AGG_MAX_IN] = $b;
 649       $l->[AGG_OUT_BYTES] .= $out_bytes;
 650     } else {
 651       # AGG_MIN_IN => 0,
 652       # AGG_MAX_IN => 1,
 653       # AGG_OUT_BYTES => 2,
 654       # AGG_NEXT => 3,
 655       # AGG_IN_LEN => 4,
 656       # AGG_OUT_LEN => 5,
 657       # AGG_FALLBACK => 6,
 658       # Reset the last thing we saw, plus set 5 lexicals to save some derefs.
 659       # (only gains .6% on euc-jp  -- is it worth it?)
 660       push @ent, $l = [$b, $agg_max_in = $b, $out_bytes, $agg_next = $next,
 661                        $agg_in_len = $in_len, $agg_out_len = length $out_bytes,
 662                        $agg_fallback = $fallback];
 663     }
 664     if (exists $next->{Cname}) {
 665       $next->{'Forward'} = 1 if $next != $a;
 666     } else {
 667       process(sprintf("%s_%02x",$name,$b),$next);
 668     }
 669   }
 670   # encengine.c rules say that last entry must be for 255
 671   if ($agg_max_in < 255) {
 672     push @ent, [1+$agg_max_in, 255,undef,$a,0,0];
 673   }
 674   $a->{'Entries'} = \@ent;
 675 }
 676
 677
 678 sub addstrings
 679 {
 680  my ($fh,$a) = @_;
 681  my $name = $a->{'Cname'};
 682  # String tables
 683  foreach my $b (@{$a->{'Entries'}})
 684   {
 685    next unless $b->[AGG_OUT_LEN];
 686    $strings{$b->[AGG_OUT_BYTES]} = undef;
 687   }
 688  if ($a->{'Forward'})
 689   {
 690    my $var = $^O eq 'MacOS' ? 'extern' : 'static';
 691    print $fh "$var const encpage_t $name\[",scalar(@{$a->{'Entries'}}),"];\n";
 692   }
 693  $a->{'DoneStrings'} = 1;
 694  foreach my $b (@{$a->{'Entries'}})
 695   {
 696    my ($s,$e,$out,$t,$end,$l) = @$b;
 697    addstrings($fh,$t) unless $t->{'DoneStrings'};
 698   }
 699 }
 700
 701 sub outbigstring
 702 {
 703   my ($fh,$name) = @_;
 704
 705   $string_acc = '';
 706
 707   # Make the big string in the string accumulator. Longest first, on the hope
 708   # that this makes it more likely that we find the short strings later on.
 709   # Not sure if it helps sorting strings of the same length lexcically.
 710   foreach my $s (sort {length $b <=> length $a || $a cmp $b} keys %strings) {
 711     my $index = index $string_acc, $s;
 712     if ($index >= 0) {
 713       $saved += length($s);
 714       $strings_in_acc{$s} = $index;
 715     } else {
 716     OPTIMISER: {
 717     if ($opt{'O'}) {
 718       my $sublength = length $s;
 719       while (--$sublength > 0) {
 720         # progressively lop characters off the end, to see if the start of
 721         # the new string overlaps the end of the accumulator.
 722         if (substr ($string_acc, -$sublength)
 723         eq substr ($s, 0, $sublength)) {
 724           $subsave += $sublength;
 725           $strings_in_acc{$s} = length ($string_acc) - $sublength;
 726           # append the last bit on the end.
 727           $string_acc .= substr ($s, $sublength);
 728           last OPTIMISER;
 729         }
 730         # or if the end of the new string overlaps the start of the
 731         # accumulator
 732         next unless substr ($string_acc, 0, $sublength)
 733           eq substr ($s, -$sublength);
 734         # well, the last $sublength characters of the accumulator match.
 735         # so as we're prepending to the accumulator, need to shift all our
 736         # existing offsets forwards
 737         $_ += $sublength foreach values %strings_in_acc;
 738         $subsave += $sublength;
 739         $strings_in_acc{$s} = 0;
 740         # append the first bit on the start.
 741         $string_acc = substr ($s, 0, -$sublength) . $string_acc;
 742         last OPTIMISER;
 743       }
 744     }
 745     # Optimiser (if it ran) found nothing, so just going have to tack the
 746     # whole thing on the end.
 747     $strings_in_acc{$s} = length $string_acc;
 748     $string_acc .= $s;
 749       };
 750     }
 751   }
 752
 753   $strings = length $string_acc;
 754   my $definition = "\nstatic const U8 $name\[$strings] = { " .
 755     join(',',unpack "C*",$string_acc);
 756   # We have a single long line. Split it at convenient commas.
 757   print $fh $1, "\n" while $definition =~ /\G(.{74,77},)/gcs;
 758   print $fh substr ($definition, pos $definition), " };\n";
 759 }
 760
 761 sub findstring {
 762   my ($name,$s) = @_;
 763   my $offset = $strings_in_acc{$s};
 764   die "Can't find string " . join (',',unpack "C*",$s) . " in accumulator"
 765     unless defined $offset;
 766   "$name + $offset";
 767 }
 768
 769 sub outtable
 770 {
 771  my ($fh,$a,$bigname) = @_;
 772  my $name = $a->{'Cname'};
 773  $a->{'Done'} = 1;
 774  foreach my $b (@{$a->{'Entries'}})
 775   {
 776    my ($s,$e,$out,$t,$end,$l) = @$b;
 777    outtable($fh,$t,$bigname) unless $t->{'Done'};
 778   }
 779  print $fh "\nstatic const encpage_t $name\[",
 780    scalar(@{$a->{'Entries'}}), "] = {\n";
 781  foreach my $b (@{$a->{'Entries'}})
 782   {
 783    my ($sc,$ec,$out,$t,$end,$l,$fb) = @$b;
 784    # $end |= 0x80 if $fb; # what the heck was on your mind, Nick?  -- Dan
 785    print  $fh "{";
 786    if ($l)
 787     {
 788      printf $fh findstring($bigname,$out);
 789     }
 790    else
 791     {
 792      print  $fh "0";
 793     }
 794    print  $fh ",",$t->{Cname};
 795    printf $fh ",0x%02x,0x%02x,$l,$end},\n",$sc,$ec;
 796   }
 797  print $fh "};\n";
 798 }
 799
 800 sub output_enc
 801 {
 802  my ($fh,$name,$a) = @_;
 803  die "Changed - fix me for new structure";
 804  foreach my $b (sort keys %$a)
 805   {
 806    my ($s,$e,$out,$t,$end,$l,$fb) = @{$a->{$b}};
 807   }
 808 }
 809
 810 sub decode_U
 811 {
 812  my $s = shift;
 813 }
 814
 815 my @uname;
 816 sub char_names
 817 {
 818  my $s = do "unicore/Name.pl";
 819  die "char_names: unicore/Name.pl: $!\n" unless defined $s;
 820  pos($s) = 0;
 821  while ($s =~ /\G([0-9a-f]+)\t([0-9a-f]*)\t(.*?)\s*\n/igc)
 822   {
 823    my $name = $3;
 824    my $s = hex($1);
 825    last if $s >= 0x10000;
 826    my $e = length($2) ? hex($2) : $s;
 827    for (my $i = $s; $i <= $e; $i++)
 828     {
 829      $uname[$i] = $name;
 830 #    print sprintf("U%04X $name\n",$i);
 831     }
 832   }
 833 }
 834
 835 sub output_ucm_page
 836 {
 837   my ($cmap,$a,$t,$pre) = @_;
 838   # warn sprintf("Page %x\n",$pre);
 839   my $raw = $t->{Raw};
 840   foreach my $key (sort keys %$raw) {
 841     #  RAW_NEXT => 0,
 842     #  RAW_IN_LEN => 1,
 843     #  RAW_OUT_BYTES => 2,
 844     #  RAW_FALLBACK => 3,
 845     my ($next, $in_len, $out_bytes, $fallback) = @{$raw->{$key}};
 846     my $u = ord $key;
 847     $fallback ||= 0;
 848
 849     if ($next != $a && $next != $t) {
 850       output_ucm_page($cmap,$a,$next,(($pre|($u &0x3F)) << 6)&0xFFFF);
 851     } elsif (length $out_bytes) {
 852       if ($pre) {
 853         $u = $pre|($u &0x3f);
 854       }
 855       my $s = sprintf "<U%04X> ",$u;
 856       #foreach my $c (split(//,$out_bytes)) {
 857       #  $s .= sprintf "\\x%02X",ord($c);
 858       #}
 859       # 9.5% faster changing that loop to this:
 860       $s .= sprintf +("\\x%02X" x length $out_bytes), unpack "C*", $out_bytes;
 861       $s .= sprintf " |%d # %s\n",($fallback ? 1 : 0),$uname[$u];
 862       push(@$cmap,$s);
 863     } else {
 864       warn join(',',$u, @{$raw->{$key}},$a,$t);
 865     }
 866   }
 867 }
 868
 869 sub output_ucm
 870 {
 871  my ($fh,$name,$h,$rep,$min_el,$max_el) = @_;
 872  print $fh "# $0 @orig_ARGV\n" unless $opt{'q'};
 873  print $fh "<code_set_name> \"$name\"\n";
 874  char_names();
 875  if (defined $min_el)
 876   {
 877    print $fh "<mb_cur_min> $min_el\n";
 878   }
 879  if (defined $max_el)
 880   {
 881    print $fh "<mb_cur_max> $max_el\n";
 882   }
 883  if (defined $rep)
 884   {
 885    print $fh "<subchar> ";
 886    foreach my $c (split(//,$rep))
 887     {
 888      printf $fh "\\x%02X",ord($c);
 889     }
 890    print $fh "\n";
 891   }
 892  my @cmap;
 893  output_ucm_page(\@cmap,$h,$h,0);
 894  print $fh "#\nCHARMAP\n";
 895  foreach my $line (sort { substr($a,8) cmp substr($b,8) } @cmap)
 896   {
 897    print $fh $line;
 898   }
 899  print $fh "END CHARMAP\n";
 900 }
 901
 902 use vars qw(
 903     $_Enc2xs
 904     $_Version
 905     $_Inc
 906     $_E2X
 907     $_Name
 908     $_TableFiles
 909     $_Now
 910 );
 911
 912 sub find_e2x{
 913     eval { require File::Find; };
 914     my (@inc, %e2x_dir);
 915     for my $inc (@INC){
 916     push @inc, $inc unless $inc eq '.'; #skip current dir
 917     }
 918     File::Find::find(
 919          sub {
 920          my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
 921              $atime,$mtime,$ctime,$blksize,$blocks)
 922              = lstat($_) or return;
 923          -f _ or return;
 924          if (/^.*\.e2x$/o){
 925              no warnings 'once';
 926              $e2x_dir{$File::Find::dir} ||= $mtime;
 927          }
 928          return;
 929          }, @inc);
 930     warn join("\n", keys %e2x_dir), "\n";
 931     for my $d (sort {$e2x_dir{$a} <=> $e2x_dir{$b}} keys %e2x_dir){
 932     $_E2X = $d;
 933     # warn "$_E2X => ", scalar localtime($e2x_dir{$d});
 934     return $_E2X;
 935     }
 936 }
 937
 938 sub make_makefile_pl
 939 {
 940     eval { require Encode; };
 941     $@ and die "You need to install Encode to use enc2xs -M\nerror: $@\n";
 942     # our used for variable expanstion
 943     $_Enc2xs = $0;
 944     $_Version = $VERSION;
 945     $_E2X = find_e2x();
 946     $_Name = shift;
 947     $_TableFiles = join(",", map {qq('$_')} @_);
 948     $_Now = scalar localtime();
 949
 950     eval { require File::Spec; };
 951     _print_expand(File::Spec->catfile($_E2X,"Makefile_PL.e2x"),"Makefile.PL");
 952     _print_expand(File::Spec->catfile($_E2X,"_PM.e2x"),        "$_Name.pm");
 953     _print_expand(File::Spec->catfile($_E2X,"_T.e2x"),         "t/$_Name.t");
 954     _print_expand(File::Spec->catfile($_E2X,"README.e2x"),     "README");
 955     _print_expand(File::Spec->catfile($_E2X,"Changes.e2x"),    "Changes");
 956     exit;
 957 }
 958
 959 use vars qw(
 960         $_ModLines
 961         $_LocalVer
 962         );
 963
 964 sub make_configlocal_pm {
 965     eval { require Encode; };
 966     $@ and die "Unable to require Encode: $@\n";
 967     eval { require File::Spec; };
 968
 969     # our used for variable expanstion
 970     my %in_core = map { $_ => 1 } (
 971         'ascii',      'iso-8859-1', 'utf8',
 972         'ascii-ctrl', 'null',       'utf-8-strict'
 973     );
 974     my %LocalMod = ();
 975     # check @enc;
 976     use File::Find ();
 977     my $wanted = sub{
 978         -f $_ or return;
 979         $File::Find::name =~ /\A\./        and return;
 980         $File::Find::name =~ /\.pm\z/      or  return;
 981         $File::Find::name =~ m/\bEncode\b/ or  return;
 982         my $mod = $File::Find::name;
 983         $mod =~ s/.*\bEncode\b/Encode/o;
 984         $mod =~ s/\.pm\z//o;
 985         $mod =~ s,/,::,og;
 986         warn qq{ require $mod;\n};
 987         eval qq{ require $mod; };
 988         $@ and die "Can't require $mod: $@\n";
 989         for my $enc ( Encode->encodings() ) {
 990             no warnings;
 991             $in_core{$enc}                   and next;
 992             $Encode::Config::ExtModule{$enc} and next;
 993             $LocalMod{$enc} ||= $mod;
 994         }
 995     };
 996     File::Find::find({wanted => $wanted}, @INC);
 997     $_ModLines = "";
 998     for my $enc ( sort keys %LocalMod ) {
 999         $_ModLines .=
1000           qq(\$Encode::ExtModule{'$enc'} = "$LocalMod{$enc}";\n);
1001     }
1002     warn $_ModLines;
1003     $_LocalVer = _mkversion();
1004     $_E2X      = find_e2x();
1005     $_Inc      = $INC{"Encode.pm"};
1006     $_Inc =~ s/\.pm$//o;
1007     _print_expand( File::Spec->catfile( $_E2X, "ConfigLocal_PM.e2x" ),
1008         File::Spec->catfile( $_Inc, "ConfigLocal.pm" ), 1 );
1009     exit;
1010 }
1011
1012 sub _mkversion{
1013     # v-string is now depreciated; use time() instead;
1014     #my ($ss,$mm,$hh,$dd,$mo,$yyyy) = localtime();
1015     #$yyyy += 1900, $mo +=1;
1016     #return sprintf("v%04d.%04d.%04d", $yyyy, $mo*100+$dd, $hh*100+$mm);
1017     return time();
1018 }
1019
1020 sub _print_expand{
1021     eval { require File::Basename; };
1022     $@ and die "File::Basename needed.  Are you on miniperl?;\nerror: $@\n";
1023     File::Basename->import();
1024     my ($src, $dst, $clobber) = @_;
1025     if (!$clobber and -e $dst){
1026     warn "$dst exists. skipping\n";
1027     return;
1028     }
1029     warn "Generating $dst...\n";
1030     open my $in, $src or die "$src : $!";
1031     if ((my $d = dirname($dst)) ne '.'){
1032     -d $d or mkdir $d, 0755 or die  "mkdir $d : $!";
1033     }
1034     open my $out, ">$dst" or die "$!";
1035     my $asis = 0;
1036     while (<$in>){
1037     if (/^#### END_OF_HEADER/){
1038         $asis = 1; next;
1039     }
1040     s/(\$_[A-Z][A-Za-z0-9]+)_/$1/gee unless $asis;
1041     print $out $_;
1042     }
1043 }
1044 __END__
1045
1046 =head1 NAME
1047
1048 enc2xs -- Perl Encode Module Generator
1049
1050 =head1 SYNOPSIS
1051
1052   enc2xs -[options]
1053   enc2xs -M ModName mapfiles...
1054   enc2xs -C
1055
1056 =head1 DESCRIPTION
1057
1058 F<enc2xs> builds a Perl extension for use by Encode from either
1059 Unicode Character Mapping files (.ucm) or Tcl Encoding Files (.enc).
1060 Besides being used internally during the build process of the Encode
1061 module, you can use F<enc2xs> to add your own encoding to perl.
1062 No knowledge of XS is necessary.
1063
1064 =head1 Quick Guide
1065
1066 If you want to know as little about Perl as possible but need to
1067 add a new encoding, just read this chapter and forget the rest.
1068
1069 =over 4
1070
1071 =item 0.
1072
1073 Have a .ucm file ready.  You can get it from somewhere or you can write
1074 your own from scratch or you can grab one from the Encode distribution
1075 and customize it.  For the UCM format, see the next Chapter.  In the
1076 example below, I'll call my theoretical encoding myascii, defined
1077 in I<my.ucm>.  C<$> is a shell prompt.
1078
1079   $ ls -F
1080   my.ucm
1081
1082 =item 1.
1083
1084 Issue a command as follows;
1085
1086   $ enc2xs -M My my.ucm
1087   generating Makefile.PL
1088   generating My.pm
1089   generating README
1090   generating Changes
1091
1092 Now take a look at your current directory.  It should look like this.
1093
1094   $ ls -F
1095   Makefile.PL   My.pm         my.ucm        t/
1096
1097 The following files were created.
1098
1099   Makefile.PL - MakeMaker script
1100   My.pm       - Encode submodule
1101   t/My.t      - test file
1102
1103 =over 4
1104
1105 =item 1.1.
1106
1107 If you want *.ucm installed together with the modules, do as follows;
1108
1109   $ mkdir Encode
1110   $ mv *.ucm Encode
1111   $ enc2xs -M My Encode/*ucm
1112
1113 =back
1114
1115 =item 2.
1116
1117 Edit the files generated.  You don't have to if you have no time AND no
1118 intention to give it to someone else.  But it is a good idea to edit
1119 the pod and to add more tests.
1120
1121 =item 3.
1122
1123 Now issue a command all Perl Mongers love:
1124
1125   $ perl Makefile.PL
1126   Writing Makefile for Encode::My
1127
1128 =item 4.
1129
1130 Now all you have to do is make.
1131
1132   $ make
1133   cp My.pm blib/lib/Encode/My.pm
1134   /usr/local/bin/perl /usr/local/bin/enc2xs -Q -O \
1135     -o encode_t.c -f encode_t.fnm
1136   Reading myascii (myascii)
1137   Writing compiled form
1138   128 bytes in string tables
1139   384 bytes (75%) saved spotting duplicates
1140   1 bytes (0.775%) saved using substrings
1141   ....
1142   chmod 644 blib/arch/auto/Encode/My/My.bs
1143   $
1144
1145 The time it takes varies depending on how fast your machine is and
1146 how large your encoding is.  Unless you are working on something big
1147 like euc-tw, it won't take too long.
1148
1149 =item 5.
1150
1151 You can "make install" already but you should test first.
1152
1153   $ make test
1154   PERL_DL_NONLAZY=1 /usr/local/bin/perl -Iblib/arch -Iblib/lib \
1155     -e 'use Test::Harness  qw(&runtests $verbose); \
1156     $verbose=0; runtests @ARGV;' t/*.t
1157   t/My....ok
1158   All tests successful.
1159   Files=1, Tests=2,  0 wallclock secs
1160    ( 0.09 cusr + 0.01 csys = 0.09 CPU)
1161
1162 =item 6.
1163
1164 If you are content with the test result, just "make install"
1165
1166 =item 7.
1167
1168 If you want to add your encoding to Encode's demand-loading list
1169 (so you don't have to "use Encode::YourEncoding"), run
1170
1171   enc2xs -C
1172
1173 to update Encode::ConfigLocal, a module that controls local settings.
1174 After that, "use Encode;" is enough to load your encodings on demand.
1175
1176 =back
1177
1178 =head1 The Unicode Character Map
1179
1180 Encode uses the Unicode Character Map (UCM) format for source character
1181 mappings.  This format is used by IBM's ICU package and was adopted
1182 by Nick Ing-Simmons for use with the Encode module.  Since UCM is
1183 more flexible than Tcl's Encoding Map and far more user-friendly,
1184 this is the recommended formet for Encode now.
1185
1186 A UCM file looks like this.
1187
1188   #
1189   # Comments
1190   #
1191   <code_set_name> "US-ascii" # Required
1192   <code_set_alias> "ascii"   # Optional
1193   <mb_cur_min> 1             # Required; usually 1
1194   <mb_cur_max> 1             # Max. # of bytes/char
1195   <subchar> \x3F             # Substitution char
1196   #
1197   CHARMAP
1198   <U0000> \x00 |0 # <control>
1199   <U0001> \x01 |0 # <control>
1200   <U0002> \x02 |0 # <control>
1201   ....
1202   <U007C> \x7C |0 # VERTICAL LINE
1203   <U007D> \x7D |0 # RIGHT CURLY BRACKET
1204   <U007E> \x7E |0 # TILDE
1205   <U007F> \x7F |0 # <control>
1206   END CHARMAP
1207
1208 =over 4
1209
1210 =item *
1211
1212 Anything that follows C<#> is treated as a comment.
1213
1214 =item *
1215
1216 The header section continues until a line containing the word
1217 CHARMAP. This section has a form of I<E<lt>keywordE<gt> value>, one
1218 pair per line.  Strings used as values must be quoted. Barewords are
1219 treated as numbers.  I<\xXX> represents a byte.
1220
1221 Most of the keywords are self-explanatory. I<subchar> means
1222 substitution character, not subcharacter.  When you decode a Unicode
1223 sequence to this encoding but no matching character is found, the byte
1224 sequence defined here will be used.  For most cases, the value here is
1225 \x3F; in ASCII, this is a question mark.
1226
1227 =item *
1228
1229 CHARMAP starts the character map section.  Each line has a form as
1230 follows:
1231
1232   <UXXXX> \xXX.. |0 # comment
1233     ^     ^      ^
1234     |     |      +- Fallback flag
1235     |     +-------- Encoded byte sequence
1236     +-------------- Unicode Character ID in hex
1237
1238 The format is roughly the same as a header section except for the
1239 fallback flag: | followed by 0..3.   The meaning of the possible
1240 values is as follows:
1241
1242 =over 4
1243
1244 =item |0
1245
1246 Round trip safe.  A character decoded to Unicode encodes back to the
1247 same byte sequence.  Most characters have this flag.
1248
1249 =item |1
1250
1251 Fallback for unicode -> encoding.  When seen, enc2xs adds this
1252 character for the encode map only.
1253
1254 =item |2
1255
1256 Skip sub-char mapping should there be no code point.
1257
1258 =item |3
1259
1260 Fallback for encoding -> unicode.  When seen, enc2xs adds this
1261 character for the decode map only.
1262
1263 =back
1264
1265 =item *
1266
1267 And finally, END OF CHARMAP ends the section.
1268
1269 =back
1270
1271 When you are manually creating a UCM file, you should copy ascii.ucm
1272 or an existing encoding which is close to yours, rather than write
1273 your own from scratch.
1274
1275 When you do so, make sure you leave at least B<U0000> to B<U0020> as
1276 is, unless your environment is EBCDIC.
1277
1278 B<CAVEAT>: not all features in UCM are implemented.  For example,
1279 icu:state is not used.  Because of that, you need to write a perl
1280 module if you want to support algorithmical encodings, notably
1281 the ISO-2022 series.  Such modules include L<Encode::JP::2022_JP>,
1282 L<Encode::KR::2022_KR>, and L<Encode::TW::HZ>.
1283
1284 =head2 Coping with duplicate mappings
1285
1286 When you create a map, you SHOULD make your mappings round-trip safe.
1287 That is, C<encode('your-encoding', decode('your-encoding', $data)) eq
1288 $data> stands for all characters that are marked as C<|0>.  Here is
1289 how to make sure:
1290
1291 =over 4
1292
1293 =item *
1294
1295 Sort your map in Unicode order.
1296
1297 =item *
1298
1299 When you have a duplicate entry, mark either one with '|1' or '|3'.
1300
1301 =item *
1302
1303 And make sure the '|1' or '|3' entry FOLLOWS the '|0' entry.
1304
1305 =back
1306
1307 Here is an example from big5-eten.
1308
1309   <U2550> \xF9\xF9 |0
1310   <U2550> \xA2\xA4 |3
1311
1312 Internally Encoding -> Unicode and Unicode -> Encoding Map looks like
1313 this;
1314
1315   E to U               U to E
1316   --------------------------------------
1317   \xF9\xF9 => U2550    U2550 => \xF9\xF9
1318   \xA2\xA4 => U2550
1319
1320 So it is round-trip safe for \xF9\xF9.  But if the line above is upside
1321 down, here is what happens.
1322
1323   E to U               U to E
1324   --------------------------------------
1325   \xA2\xA4 => U2550    U2550 => \xF9\xF9
1326   (\xF9\xF9 => U2550 is now overwritten!)
1327
1328 The Encode package comes with F<ucmlint>, a crude but sufficient
1329 utility to check the integrity of a UCM file.  Check under the
1330 Encode/bin directory for this.
1331
1332 When in doubt, you can use F<ucmsort>, yet another utility under
1333 Encode/bin directory.
1334
1335 =head1 Bookmarks
1336
1337 =over 4
1338
1339 =item *
1340
1341 ICU Home Page
1342 L<http://oss.software.ibm.com/icu/>
1343
1344 =item *
1345
1346 ICU Character Mapping Tables
1347 L<http://oss.software.ibm.com/icu/charset/>
1348
1349 =item *
1350
1351 ICU:Conversion Data
1352 L<http://oss.software.ibm.com/icu/userguide/conversion-data.html>
1353
1354 =back
1355
1356 =head1 SEE ALSO
1357
1358 L<Encode>,
1359 L<perlmod>,
1360 L<perlpod>
1361
1362 =cut
1363
1364 # -Q to disable the duplicate codepoint test
1365 # -S make mapping errors fatal
1366 # -q to remove comments written to output files
1367 # -O to enable the (brute force) substring optimiser
1368 # -o <output> to specify the output file name (else it's the first arg)
1369 # -f <inlist> to give a file with a list of input files (else use the args)
1370 # -n <name> to name the encoding (else use the basename of the input file.
1371
1372 With %seen holding array refs:
1373
1374       865.66 real        28.80 user         8.79 sys
1375       7904  maximum resident set size
1376       1356  average shared memory size
1377      18566  average unshared data size
1378        229  average unshared stack size
1379      46080  page reclaims
1380      33373  page faults
1381
1382 With %seen holding simple scalars:
1383
1384       342.16 real        27.11 user         3.54 sys
1385       8388  maximum resident set size
1386       1394  average shared memory size
1387      14969  average unshared data size
1388        236  average unshared stack size
1389      28159  page reclaims
1390       9839  page faults
1391
1392 Yes, 5 minutes is faster than 15. Above is for CP936 in CN. Only difference is
1393 how %seen is storing things its seen. So it is pathalogically bad on a 16M
1394 RAM machine, but it's going to help even on modern machines.
1395 Swapping is bad, m'kay :-)