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.3 $ =~ /\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 {
 966     eval { require Encode; };
 967     $@ and die "Unable to require Encode: $@\n";
 968     eval { require File::Spec; };
 969     # our used for variable expanstion
 970     my %in_core = map {$_=>1}('ascii','iso-8859-1','utf8');
 971     my %LocalMod = ();
 972     for my $d (@INC){
 973     my $inc = File::Spec->catfile($d, "Encode");
 974     -d $inc or next;
 975     opendir my $dh, $inc or die "$inc:$!";
 976     warn "Checking $inc...\n";
 977     for my $f (grep /\.pm$/o, readdir($dh)){
 978         -f File::Spec->catfile($inc, "$f") or next;
 979         $INC{"Encode/$f"} and next;
 980         warn "require Encode/$f;\n";
 981         eval { require "Encode/$f"; };
 982         $@ and die "Can't require Encode/$f: $@\n";
 983         for my $enc (Encode->encodings()){
 984         no warnings 'once';
 985         $in_core{$enc} and next;
 986         $Encode::Config::ExtModule{$enc} and next;
 987         my $mod = "Encode/$f";
 988         $mod =~ s/\.pm$//o; $mod =~ s,/,::,og;
 989         $LocalMod{$enc} ||= $mod;
 990         }
 991     }
 992     }
 993     $_ModLines = "";
 994     for my $enc (sort keys %LocalMod){
 995     $_ModLines .=
 996         qq(\$Encode::ExtModule{'$enc'} =\t"$LocalMod{$enc}";\n);
 997     }
 998     warn $_ModLines;
 999     $_LocalVer = _mkversion();
1000     $_E2X = find_e2x();
1001     $_Inc = $INC{"Encode.pm"}; $_Inc =~ s/\.pm$//o;
1002     _print_expand(File::Spec->catfile($_E2X,"ConfigLocal_PM.e2x"),
1003           File::Spec->catfile($_Inc,"ConfigLocal.pm"),
1004           1);
1005     exit;
1006 }
1007
1008 sub _mkversion{
1009     my ($ss,$mm,$hh,$dd,$mo,$yyyy) = localtime();
1010     $yyyy += 1900, $mo +=1;
1011     return sprintf("v%04d.%04d.%04d", $yyyy, $mo*100+$dd, $hh*100+$mm);
1012 }
1013
1014 sub _print_expand{
1015     eval { require File::Basename; };
1016     $@ and die "File::Basename needed.  Are you on miniperl?;\nerror: $@\n";
1017     File::Basename->import();
1018     my ($src, $dst, $clobber) = @_;
1019     if (!$clobber and -e $dst){
1020     warn "$dst exists. skipping\n";
1021     return;
1022     }
1023     warn "Generating $dst...\n";
1024     open my $in, $src or die "$src : $!";
1025     if ((my $d = dirname($dst)) ne '.'){
1026     -d $d or mkdir $d, 0755 or die  "mkdir $d : $!";
1027     }
1028     open my $out, ">$dst" or die "$!";
1029     my $asis = 0;
1030     while (<$in>){
1031     if (/^#### END_OF_HEADER/){
1032         $asis = 1; next;
1033     }
1034     s/(\$_[A-Z][A-Za-z0-9]+)_/$1/gee unless $asis;
1035     print $out $_;
1036     }
1037 }
1038 __END__
1039
1040 =head1 NAME
1041
1042 enc2xs -- Perl Encode Module Generator
1043
1044 =head1 SYNOPSIS
1045
1046   enc2xs -[options]
1047   enc2xs -M ModName mapfiles...
1048   enc2xs -C
1049
1050 =head1 DESCRIPTION
1051
1052 F<enc2xs> builds a Perl extension for use by Encode from either
1053 Unicode Character Mapping files (.ucm) or Tcl Encoding Files (.enc).
1054 Besides being used internally during the build process of the Encode
1055 module, you can use F<enc2xs> to add your own encoding to perl.
1056 No knowledge of XS is necessary.
1057
1058 =head1 Quick Guide
1059
1060 If you want to know as little about Perl as possible but need to
1061 add a new encoding, just read this chapter and forget the rest.
1062
1063 =over 4
1064
1065 =item 0.
1066
1067 Have a .ucm file ready.  You can get it from somewhere or you can write
1068 your own from scratch or you can grab one from the Encode distribution
1069 and customize it.  For the UCM format, see the next Chapter.  In the
1070 example below, I'll call my theoretical encoding myascii, defined
1071 in I<my.ucm>.  C<$> is a shell prompt.
1072
1073   $ ls -F
1074   my.ucm
1075
1076 =item 1.
1077
1078 Issue a command as follows;
1079
1080   $ enc2xs -M My my.ucm
1081   generating Makefile.PL
1082   generating My.pm
1083   generating README
1084   generating Changes
1085
1086 Now take a look at your current directory.  It should look like this.
1087
1088   $ ls -F
1089   Makefile.PL   My.pm         my.ucm        t/
1090
1091 The following files were created.
1092
1093   Makefile.PL - MakeMaker script
1094   My.pm       - Encode submodule
1095   t/My.t      - test file
1096
1097 =over 4
1098
1099 =item 1.1.
1100
1101 If you want *.ucm installed together with the modules, do as follows;
1102
1103   $ mkdir Encode
1104   $ mv *.ucm Encode
1105   $ enc2xs -M My Encode/*ucm
1106
1107 =back
1108
1109 =item 2.
1110
1111 Edit the files generated.  You don't have to if you have no time AND no
1112 intention to give it to someone else.  But it is a good idea to edit
1113 the pod and to add more tests.
1114
1115 =item 3.
1116
1117 Now issue a command all Perl Mongers love:
1118
1119   $ perl Makefile.PL
1120   Writing Makefile for Encode::My
1121
1122 =item 4.
1123
1124 Now all you have to do is make.
1125
1126   $ make
1127   cp My.pm blib/lib/Encode/My.pm
1128   /usr/local/bin/perl /usr/local/bin/enc2xs -Q -O \
1129     -o encode_t.c -f encode_t.fnm
1130   Reading myascii (myascii)
1131   Writing compiled form
1132   128 bytes in string tables
1133   384 bytes (75%) saved spotting duplicates
1134   1 bytes (0.775%) saved using substrings
1135   ....
1136   chmod 644 blib/arch/auto/Encode/My/My.bs
1137   $
1138
1139 The time it takes varies depending on how fast your machine is and
1140 how large your encoding is.  Unless you are working on something big
1141 like euc-tw, it won't take too long.
1142
1143 =item 5.
1144
1145 You can "make install" already but you should test first.
1146
1147   $ make test
1148   PERL_DL_NONLAZY=1 /usr/local/bin/perl -Iblib/arch -Iblib/lib \
1149     -e 'use Test::Harness  qw(&runtests $verbose); \
1150     $verbose=0; runtests @ARGV;' t/*.t
1151   t/My....ok
1152   All tests successful.
1153   Files=1, Tests=2,  0 wallclock secs
1154    ( 0.09 cusr + 0.01 csys = 0.09 CPU)
1155
1156 =item 6.
1157
1158 If you are content with the test result, just "make install"
1159
1160 =item 7.
1161
1162 If you want to add your encoding to Encode's demand-loading list
1163 (so you don't have to "use Encode::YourEncoding"), run
1164
1165   enc2xs -C
1166
1167 to update Encode::ConfigLocal, a module that controls local settings.
1168 After that, "use Encode;" is enough to load your encodings on demand.
1169
1170 =back
1171
1172 =head1 The Unicode Character Map
1173
1174 Encode uses the Unicode Character Map (UCM) format for source character
1175 mappings.  This format is used by IBM's ICU package and was adopted
1176 by Nick Ing-Simmons for use with the Encode module.  Since UCM is
1177 more flexible than Tcl's Encoding Map and far more user-friendly,
1178 this is the recommended formet for Encode now.
1179
1180 A UCM file looks like this.
1181
1182   #
1183   # Comments
1184   #
1185   <code_set_name> "US-ascii" # Required
1186   <code_set_alias> "ascii"   # Optional
1187   <mb_cur_min> 1             # Required; usually 1
1188   <mb_cur_max> 1             # Max. # of bytes/char
1189   <subchar> \x3F             # Substitution char
1190   #
1191   CHARMAP
1192   <U0000> \x00 |0 # <control>
1193   <U0001> \x01 |0 # <control>
1194   <U0002> \x02 |0 # <control>
1195   ....
1196   <U007C> \x7C |0 # VERTICAL LINE
1197   <U007D> \x7D |0 # RIGHT CURLY BRACKET
1198   <U007E> \x7E |0 # TILDE
1199   <U007F> \x7F |0 # <control>
1200   END CHARMAP
1201
1202 =over 4
1203
1204 =item *
1205
1206 Anything that follows C<#> is treated as a comment.
1207
1208 =item *
1209
1210 The header section continues until a line containing the word
1211 CHARMAP. This section has a form of I<E<lt>keywordE<gt> value>, one
1212 pair per line.  Strings used as values must be quoted. Barewords are
1213 treated as numbers.  I<\xXX> represents a byte.
1214
1215 Most of the keywords are self-explanatory. I<subchar> means
1216 substitution character, not subcharacter.  When you decode a Unicode
1217 sequence to this encoding but no matching character is found, the byte
1218 sequence defined here will be used.  For most cases, the value here is
1219 \x3F; in ASCII, this is a question mark.
1220
1221 =item *
1222
1223 CHARMAP starts the character map section.  Each line has a form as
1224 follows:
1225
1226   <UXXXX> \xXX.. |0 # comment
1227     ^     ^      ^
1228     |     |      +- Fallback flag
1229     |     +-------- Encoded byte sequence
1230     +-------------- Unicode Character ID in hex
1231
1232 The format is roughly the same as a header section except for the
1233 fallback flag: | followed by 0..3.   The meaning of the possible
1234 values is as follows:
1235
1236 =over 4
1237
1238 =item |0
1239
1240 Round trip safe.  A character decoded to Unicode encodes back to the
1241 same byte sequence.  Most characters have this flag.
1242
1243 =item |1
1244
1245 Fallback for unicode -> encoding.  When seen, enc2xs adds this
1246 character for the encode map only.
1247
1248 =item |2
1249
1250 Skip sub-char mapping should there be no code point.
1251
1252 =item |3
1253
1254 Fallback for encoding -> unicode.  When seen, enc2xs adds this
1255 character for the decode map only.
1256
1257 =back
1258
1259 =item *
1260
1261 And finally, END OF CHARMAP ends the section.
1262
1263 =back
1264
1265 When you are manually creating a UCM file, you should copy ascii.ucm
1266 or an existing encoding which is close to yours, rather than write
1267 your own from scratch.
1268
1269 When you do so, make sure you leave at least B<U0000> to B<U0020> as
1270 is, unless your environment is EBCDIC.
1271
1272 B<CAVEAT>: not all features in UCM are implemented.  For example,
1273 icu:state is not used.  Because of that, you need to write a perl
1274 module if you want to support algorithmical encodings, notably
1275 the ISO-2022 series.  Such modules include L<Encode::JP::2022_JP>,
1276 L<Encode::KR::2022_KR>, and L<Encode::TW::HZ>.
1277
1278 =head2 Coping with duplicate mappings
1279
1280 When you create a map, you SHOULD make your mappings round-trip safe.
1281 That is, C<encode('your-encoding', decode('your-encoding', $data)) eq
1282 $data> stands for all characters that are marked as C<|0>.  Here is
1283 how to make sure:
1284
1285 =over 4
1286
1287 =item *
1288
1289 Sort your map in Unicode order.
1290
1291 =item *
1292
1293 When you have a duplicate entry, mark either one with '|1' or '|3'.
1294
1295 =item *
1296
1297 And make sure the '|1' or '|3' entry FOLLOWS the '|0' entry.
1298
1299 =back
1300
1301 Here is an example from big5-eten.
1302
1303   <U2550> \xF9\xF9 |0
1304   <U2550> \xA2\xA4 |3
1305
1306 Internally Encoding -> Unicode and Unicode -> Encoding Map looks like
1307 this;
1308
1309   E to U               U to E
1310   --------------------------------------
1311   \xF9\xF9 => U2550    U2550 => \xF9\xF9
1312   \xA2\xA4 => U2550
1313
1314 So it is round-trip safe for \xF9\xF9.  But if the line above is upside
1315 down, here is what happens.
1316
1317   E to U               U to E
1318   --------------------------------------
1319   \xA2\xA4 => U2550    U2550 => \xF9\xF9
1320   (\xF9\xF9 => U2550 is now overwritten!)
1321
1322 The Encode package comes with F<ucmlint>, a crude but sufficient
1323 utility to check the integrity of a UCM file.  Check under the
1324 Encode/bin directory for this.
1325
1326 When in doubt, you can use F<ucmsort>, yet another utility under
1327 Encode/bin directory.
1328
1329 =head1 Bookmarks
1330
1331 =over 4
1332
1333 =item *
1334
1335 ICU Home Page
1336 L<http://oss.software.ibm.com/icu/>
1337
1338 =item *
1339
1340 ICU Character Mapping Tables
1341 L<http://oss.software.ibm.com/icu/charset/>
1342
1343 =item *
1344
1345 ICU:Conversion Data
1346 L<http://oss.software.ibm.com/icu/userguide/conversion-data.html>
1347
1348 =back
1349
1350 =head1 SEE ALSO
1351
1352 L<Encode>,
1353 L<perlmod>,
1354 L<perlpod>
1355
1356 =cut
1357
1358 # -Q to disable the duplicate codepoint test
1359 # -S make mapping errors fatal
1360 # -q to remove comments written to output files
1361 # -O to enable the (brute force) substring optimiser
1362 # -o <output> to specify the output file name (else it's the first arg)
1363 # -f <inlist> to give a file with a list of input files (else use the args)
1364 # -n <name> to name the encoding (else use the basename of the input file.
1365
1366 With %seen holding array refs:
1367
1368       865.66 real        28.80 user         8.79 sys
1369       7904  maximum resident set size
1370       1356  average shared memory size
1371      18566  average unshared data size
1372        229  average unshared stack size
1373      46080  page reclaims
1374      33373  page faults
1375
1376 With %seen holding simple scalars:
1377
1378       342.16 real        27.11 user         3.54 sys
1379       8388  maximum resident set size
1380       1394  average shared memory size
1381      14969  average unshared data size
1382        236  average unshared stack size
1383      28159  page reclaims
1384       9839  page faults
1385
1386 Yes, 5 minutes is faster than 15. Above is for CP936 in CN. Only difference is
1387 how %seen is storing things its seen. So it is pathalogically bad on a 16M
1388 RAM machine, but it's going to help even on modern machines.
1389 Swapping is bad, m'kay :-)