ext/Encode/compile

   1 #!../../perl -w
   2 BEGIN {
   3     unshift @INC, qw(../../lib ../../../lib);
   4     $ENV{PATH} .= ';../..;../../..' if $^O eq 'MSWin32';
   5 }
   6 use strict;
   7 use Getopt::Std;
   8 my @orig_ARGV = @ARGV;
   9 our $VERSION  = '0.30';
  10
  11 # These may get re-ordered.
  12 # RAW is a do_now as inserted by &enter
  13 # AGG is an aggreagated do_now, as built up by &process
  14 use constant {
  15   RAW_NEXT => 0,
  16   RAW_IN_LEN => 1,
  17   RAW_OUT_BYTES => 2,
  18   RAW_FALLBACK => 3,
  19
  20   AGG_MIN_IN => 0,
  21   AGG_MAX_IN => 1,
  22   AGG_OUT_BYTES => 2,
  23   AGG_NEXT => 3,
  24   AGG_IN_LEN => 4,
  25   AGG_OUT_LEN => 5,
  26   AGG_FALLBACK => 6,
  27 };
  28 # (See the algorithm in encengine.c - we're building structures for it)
  29
  30 # There are two sorts of structures.
  31 # "do_now" (an array, two variants of what needs storing) is whatever we need
  32 # to do now we've read an input byte.
  33 # It's housed in a "do_next" (which is how we got to it), and in turn points
  34 # to a "do_next" which contains all the "do_now"s for the next input byte.
  35
  36 # There will be a "do_next" which is the start state.
  37 # For a single byte encoding it's the only "do_next" - each "do_now" points
  38 # back to it, and each "do_now" will cause bytes. There is no state.
  39
  40 # For a multi-byte encoding where all characters in the input are the same
  41 # length, then there will be a tree of "do_now"->"do_next"->"do_now"
  42 # branching out from the start state, one step for each input byte.
  43 # The leaf "do_now"s will all be at the same distance from the start state,
  44 # only the leaf "do_now"s cause output bytes, and they in turn point back to
  45 # the start state.
  46
  47 # For an encoding where there are varaible length input byte sequences, you
  48 # will encounter a leaf "do_now" sooner for the shorter input sequences, but
  49 # as before the leaves will point back to the start state.
  50
  51 # The system will cope with escape encodings (imagine them as a mostly
  52 # self-contained tree for each escape state, and cross links between trees
  53 # at the state-switching characters) but so far no input format defines these.
  54
  55 # The system will also cope with having output "leaves" in the middle of
  56 # the bifurcating branches, not just at the extremities, but again no
  57 # input format does this yet.
  58
  59 # There are two variants of the "do_now" structure. The first, smaller variant
  60 # is generated by &enter as the input file is read. There is one structure
  61 # for each input byte. Say we are mapping a single byte encoding to a
  62 # single byte encoding, with  "ABCD" going "abcd". There will be
  63 # 4 "do_now"s, {"A" => [...,"a",...], "B" => [...,"b",...], "C"=>..., "D"=>...}
  64
  65 # &process then walks the tree, building aggregate "do_now" structres for
  66 # adjacent bytes where possible. The aggregate is for a contiguous range of
  67 # bytes which each produce the same length of output, each move to the
  68 # same next state, and each have the same fallback flag.
  69 # So our 4 RAW "do_now"s above become replaced by a single structure
  70 # containing:
  71 # ["A", "D", "abcd", 1, ...]
  72 # ie, for an input byte $_ in "A".."D", output 1 byte, found as
  73 # substr ("abcd", (ord $_ - ord "A") * 1, 1)
  74 # which maps very nicely into pointer arithmetic in C for encengine.c
  75
  76 sub encode_U
  77 {
  78  # UTF-8 encode long hand - only covers part of perl's range
  79  ## my $uv = shift;
  80  # chr() works in native space so convert value from table
  81  # into that space before using chr().
  82  my $ch = chr(utf8::unicode_to_native($_[0]));
  83  # Now get core perl to encode that the way it likes.
  84  utf8::encode($ch);
  85  return $ch;
  86 }
  87
  88 sub encode_S
  89 {
  90  # encode single byte
  91  ## my ($ch,$page) = @_; return chr($ch);
  92  return chr $_[0];
  93 }
  94
  95 sub encode_D
  96 {
  97  # encode double byte MS byte first
  98  ## my ($ch,$page) = @_; return chr($page).chr($ch);
  99  return chr ($_[1]) . chr $_[0];
 100 }
 101
 102 sub encode_M
 103 {
 104  # encode Multi-byte - single for 0..255 otherwise double
 105  ## my ($ch,$page) = @_;
 106  ## return &encode_D if $page;
 107  ## return &encode_S;
 108  return chr ($_[1]) . chr $_[0] if $_[1];
 109  return chr $_[0];
 110 }
 111
 112 my %encode_types = (U => \&encode_U,
 113                     S => \&encode_S,
 114                     D => \&encode_D,
 115                     M => \&encode_M,
 116                    );
 117
 118 # Win32 does not expand globs on command line
 119 eval "\@ARGV = map(glob(\$_),\@ARGV)" if ($^O eq 'MSWin32');
 120
 121 my %opt;
 122 # I think these are:
 123 # -Q to disable the duplicate codepoint test
 124 # -S make mapping errors fatal
 125 # -q to remove comments written to output files
 126 # -O to enable the (brute force) substring optimiser
 127 # -o <output> to specify the output file name (else it's the first arg)
 128 # -f <inlist> to give a file with a list of input files (else use the args)
 129 # -n <name> to name the encoding (else use the basename of the input file.
 130 getopts('SQqOo:f:n:',\%opt);
 131
 132 # This really should go first, else the die here causes empty (non-erroneous)
 133 # output files to be written.
 134 my @encfiles;
 135 if (exists $opt{'f'}) {
 136     # -F is followed by name of file containing list of filenames
 137     my $flist = $opt{'f'};
 138     open(FLIST,$flist) || die "Cannot open $flist:$!";
 139     chomp(@encfiles = <FLIST>);
 140     close(FLIST);
 141 } else {
 142     @encfiles = @ARGV;
 143 }
 144
 145 my $cname = (exists $opt{'o'}) ? $opt{'o'} : shift(@ARGV);
 146 chmod(0666,$cname) if -f $cname && !-w $cname;
 147 open(C,">$cname") || die "Cannot open $cname:$!";
 148
 149 my $dname = $cname;
 150 my $hname = $cname;
 151
 152 my ($doC,$doEnc,$doUcm,$doPet);
 153
 154 if ($cname =~ /\.(c|xs)$/)
 155  {
 156   $doC = 1;
 157   $dname =~ s/(\.[^\.]*)?$/_def.h/;
 158   chmod(0666,$dname) if -f $cname && !-w $dname;
 159   open(D,">$dname") || die "Cannot open $dname:$!";
 160   $hname =~ s/(\.[^\.]*)?$/.h/;
 161   chmod(0666,$hname) if -f $cname && !-w $hname;
 162   open(H,">$hname") || die "Cannot open $hname:$!";
 163
 164   foreach my $fh (\*C,\*D,\*H)
 165   {
 166    print $fh <<"END" unless $opt{'q'};
 167 /*
 168  !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
 169  This file was autogenerated by:
 170  $^X $0 @orig_ARGV
 171 */
 172 END
 173   }
 174
 175   if ($cname =~ /(\w+)\.xs$/)
 176    {
 177     print C "#include <EXTERN.h>\n";
 178     print C "#include <perl.h>\n";
 179     print C "#include <XSUB.h>\n";
 180     print C "#define U8 U8\n";
 181    }
 182   print C "#include \"encode.h\"\n";
 183
 184  }
 185 elsif ($cname =~ /\.enc$/)
 186  {
 187   $doEnc = 1;
 188  }
 189 elsif ($cname =~ /\.ucm$/)
 190  {
 191   $doUcm = 1;
 192  }
 193 elsif ($cname =~ /\.pet$/)
 194  {
 195   $doPet = 1;
 196  }
 197
 198 my %encoding;
 199 my %strings;
 200 my $saved = 0;
 201 my $subsave = 0;
 202 my $strings = 0;
 203
 204 sub cmp_name
 205 {
 206  if ($a =~ /^.*-(\d+)/)
 207   {
 208    my $an = $1;
 209    if ($b =~ /^.*-(\d+)/)
 210     {
 211      my $r = $an <=> $1;
 212      return $r if $r;
 213     }
 214   }
 215  return $a cmp $b;
 216 }
 217
 218
 219 foreach my $enc (sort cmp_name @encfiles)
 220  {
 221   my ($name,$sfx) = $enc =~ /^.*?([\w-]+)\.(enc|ucm)$/;
 222   $name = $opt{'n'} if exists $opt{'n'};
 223   if (open(E,$enc))
 224    {
 225     if ($sfx eq 'enc')
 226      {
 227       compile_enc(\*E,lc($name));
 228      }
 229     else
 230      {
 231       compile_ucm(\*E,lc($name));
 232      }
 233    }
 234   else
 235    {
 236     warn "Cannot open $enc for $name:$!";
 237    }
 238  }
 239
 240 if ($doC)
 241  {
 242   print STDERR "Writing compiled form\n";
 243   foreach my $name (sort cmp_name keys %encoding)
 244    {
 245     my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}};
 246     output(\*C,$name.'_utf8',$e2u);
 247     output(\*C,'utf8_'.$name,$u2e);
 248     push(@{$encoding{$name}},outstring(\*C,$e2u->{Cname}.'_def',$erep));
 249    }
 250   foreach my $enc (sort cmp_name keys %encoding)
 251    {
 252     my ($e2u,$u2e,$rep,$min_el,$max_el,$rsym) = @{$encoding{$enc}};
 253     my @info = ($e2u->{Cname},$u2e->{Cname},$rsym,length($rep),$min_el,$max_el);
 254     my $sym = "${enc}_encoding";
 255     $sym =~ s/\W+/_/g;
 256     print C "encode_t $sym = \n";
 257     print C " {",join(',',@info,"{\"$enc\",(const char *)0}"),"};\n\n";
 258    }
 259
 260   foreach my $enc (sort cmp_name keys %encoding)
 261    {
 262     my $sym = "${enc}_encoding";
 263     $sym =~ s/\W+/_/g;
 264     print H "extern encode_t $sym;\n";
 265     print D " Encode_XSEncoding(aTHX_ &$sym);\n";
 266    }
 267
 268   if ($cname =~ /(\w+)\.xs$/)
 269    {
 270     my $mod = $1;
 271     print C <<'END';
 272
 273 static void
 274 Encode_XSEncoding(pTHX_ encode_t *enc)
 275 {
 276  dSP;
 277  HV *stash = gv_stashpv("Encode::XS", TRUE);
 278  SV *sv    = sv_bless(newRV_noinc(newSViv(PTR2IV(enc))),stash);
 279  int i = 0;
 280  PUSHMARK(sp);
 281  XPUSHs(sv);
 282  while (enc->name[i])
 283   {
 284    const char *name = enc->name[i++];
 285    XPUSHs(sv_2mortal(newSVpvn(name,strlen(name))));
 286   }
 287  PUTBACK;
 288  call_pv("Encode::define_encoding",G_DISCARD);
 289  SvREFCNT_dec(sv);
 290 }
 291
 292 END
 293
 294     print C "\nMODULE = Encode::$mod\tPACKAGE = Encode::$mod\n\n";
 295     print C "BOOT:\n{\n";
 296     print C "#include \"$dname\"\n";
 297     print C "}\n";
 298    }
 299   # Close in void context is bad, m'kay
 300   close(D) or warn "Error closing '$dname': $!";
 301   close(H) or warn "Error closing '$hname': $!";
 302
 303   my $perc_saved    = $strings/($strings + $saved) * 100;
 304   my $perc_subsaved = $strings/($strings + $subsave) * 100;
 305   printf STDERR "%d bytes in string tables\n",$strings;
 306   printf STDERR "%d bytes (%.3g%%) saved spotting duplicates\n",
 307     $saved, $perc_saved              if $saved;
 308   printf STDERR "%d bytes (%.3g%%) saved using substrings\n",
 309     $subsave, $perc_subsaved         if $subsave;
 310  }
 311 elsif ($doEnc)
 312  {
 313   foreach my $name (sort cmp_name keys %encoding)
 314    {
 315     my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}};
 316     output_enc(\*C,$name,$e2u);
 317    }
 318  }
 319 elsif ($doUcm)
 320  {
 321   foreach my $name (sort cmp_name keys %encoding)
 322    {
 323     my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}};
 324     output_ucm(\*C,$name,$u2e,$erep,$min_el,$max_el);
 325    }
 326  }
 327
 328 # writing half meg files and then not checking to see if you just filled the
 329 # disk is bad, m'kay
 330 close(C) or die "Error closing '$cname': $!";
 331
 332 # End of the main program.
 333
 334 sub compile_ucm
 335 {
 336  my ($fh,$name) = @_;
 337  my $e2u = {};
 338  my $u2e = {};
 339  my $cs;
 340  my %attr;
 341  while (<$fh>)
 342   {
 343    s/#.*$//;
 344    last if /^\s*CHARMAP\s*$/i;
 345    if (/^\s*<(\w+)>\s+"?([^"]*)"?\s*$/i) # " # Grrr
 346     {
 347      $attr{$1} = $2;
 348     }
 349   }
 350  if (!defined($cs =  $attr{'code_set_name'}))
 351   {
 352    warn "No <code_set_name> in $name\n";
 353   }
 354  else
 355   {
 356    $name = $cs unless exists $opt{'n'};
 357   }
 358  my $erep;
 359  my $urep;
 360  my $max_el;
 361  my $min_el;
 362  if (exists $attr{'subchar'})
 363   {
 364    my @byte;
 365    $attr{'subchar'} =~ /^\s*/cg;
 366    push(@byte,$1) while $attr{'subchar'} =~ /\G\\x([0-9a-f]+)/icg;
 367    $erep = join('',map(chr(hex($_)),@byte));
 368   }
 369  print "Reading $name ($cs)\n";
 370  my $nfb = 0;
 371  my $hfb = 0;
 372  while (<$fh>)
 373   {
 374    s/#.*$//;
 375    last if /^\s*END\s+CHARMAP\s*$/i;
 376    next if /^\s*$/;
 377    my ($u,@byte);
 378    my $fb = '';
 379    $u = $1 if (/^<U([0-9a-f]+)>\s+/igc);
 380    push(@byte,$1) while /\G\\x([0-9a-f]+)/igc;
 381    $fb = $1 if /\G\s*(\|[0-3])/gc;
 382    # warn "$_: $u @byte | $fb\n";
 383    die "Bad line:$_" unless /\G\s*(#.*)?$/gc;
 384    if (defined($u))
 385     {
 386      my $uch = encode_U(hex($u));
 387      my $ech = join('',map(chr(hex($_)),@byte));
 388      my $el  = length($ech);
 389      $max_el = $el if (!defined($max_el) || $el > $max_el);
 390      $min_el = $el if (!defined($min_el) || $el < $min_el);
 391      if (length($fb))
 392       {
 393        $fb = substr($fb,1);
 394        $hfb++;
 395       }
 396      else
 397       {
 398        $nfb++;
 399        $fb = '0';
 400       }
 401      # $fb is fallback flag
 402      # 0 - round trip safe
 403      # 1 - fallback for unicode -> enc
 404      # 2 - skip sub-char mapping
 405      # 3 - fallback enc -> unicode
 406      enter($u2e,$uch,$ech,$u2e,$fb+0) if ($fb =~ /[01]/);
 407      enter($e2u,$ech,$uch,$e2u,$fb+0) if ($fb =~ /[03]/);
 408     }
 409    else
 410     {
 411      warn $_;
 412     }
 413   }
 414  if ($nfb && $hfb)
 415   {
 416    die "$nfb entries without fallback, $hfb entries with\n";
 417   }
 418  $encoding{$name} = [$e2u,$u2e,$erep,$min_el,$max_el];
 419 }
 420
 421
 422
 423 sub compile_enc
 424 {
 425  my ($fh,$name) = @_;
 426  my $e2u = {};
 427  my $u2e = {};
 428
 429  my $type;
 430  while ($type = <$fh>)
 431   {
 432    last if $type !~ /^\s*#/;
 433   }
 434  chomp($type);
 435  return if $type eq 'E';
 436  # Do the hash lookup once, rather than once per function call. 4% speedup.
 437  my $type_func = $encode_types{$type};
 438  my ($def,$sym,$pages) = split(/\s+/,scalar(<$fh>));
 439  warn "$type encoded $name\n";
 440  my $rep = '';
 441  # Save a defined test by setting these to defined values.
 442  my $min_el = ~0; # A very big integer
 443  my $max_el = 0;  # Anything must be longer than 0
 444  {
 445   my $v = hex($def);
 446   $rep = &$type_func($v & 0xFF, ($v >> 8) & 0xffe);
 447  }
 448  my $errors;
 449  my $seen;
 450  # use -Q to silence the seen test. Makefile.PL uses this by default.
 451  $seen = {} unless $opt{Q};
 452  do
 453   {
 454    my $line = <$fh>;
 455    chomp($line);
 456    my $page = hex($line);
 457    my $ch = 0;
 458    my $i = 16;
 459    do
 460     {
 461      # So why is it 1% faster to leave the my here?
 462      my $line = <$fh>;
 463      $line =~ s/\r\n$/\n/;
 464      die "$.:${line}Line should be exactly 65 characters long including
 465      newline (".length($line).")" unless length ($line) == 65;
 466      # Split line into groups of 4 hex digits, convert groups to ints
 467      # This takes 65.35
 468      # map {hex $_} $line =~ /(....)/g
 469      # This takes 63.75 (2.5% less time)
 470      # unpack "n*", pack "H*", $line
 471      # There's an implicit loop in map. Loops are bad, m'kay. Ops are bad, m'kay
 472      # Doing it as while ($line =~ /(....)/g) took 74.63
 473      foreach my $val (unpack "n*", pack "H*", $line)
 474       {
 475        next if $val == 0xFFFD;
 476        my $ech = &$type_func($ch,$page);
 477        if ($val || (!$ch && !$page))
 478         {
 479          my $el  = length($ech);
 480          $max_el = $el if $el > $max_el;
 481          $min_el = $el if $el < $min_el;
 482          my $uch = encode_U($val);
 483          if ($seen) {
 484            # We're doing the test.
 485            # We don't need to read this quickly, so storing it as a scalar,
 486            # rather than 3 (anon array, plus the 2 scalars it holds) saves
 487            # RAM and may make us faster on low RAM systems. [see __END__]
 488            if (exists $seen->{$uch})
 489              {
 490                warn sprintf("U%04X is %02X%02X and %04X\n",
 491                             $val,$page,$ch,$seen->{$uch});
 492                $errors++;
 493              }
 494            else
 495              {
 496                $seen->{$uch} = $page << 8 | $ch;
 497              }
 498          }
 499          # Passing 2 extra args each time is 3.6% slower!
 500          # Even with having to add $fallback ||= 0 later
 501          enter_fb0($e2u,$ech,$uch);
 502          enter_fb0($u2e,$uch,$ech);
 503         }
 504        else
 505         {
 506          # No character at this position
 507          # enter($e2u,$ech,undef,$e2u);
 508         }
 509        $ch++;
 510       }
 511     } while --$i;
 512   } while --$pages;
 513  die "\$min_el=$min_el, \$max_el=$max_el - seems we read no lines"
 514    if $min_el > $max_el;
 515  die "$errors mapping conflicts\n" if ($errors && $opt{'S'});
 516  $encoding{$name} = [$e2u,$u2e,$rep,$min_el,$max_el];
 517 }
 518
 519 # my ($a,$s,$d,$t,$fb) = @_;
 520 sub enter {
 521   my ($current,$inbytes,$outbytes,$next,$fallback) = @_;
 522   # state we shift to after this (multibyte) input character defaults to same
 523   # as current state.
 524   $next ||= $current;
 525   # Making sure it is defined seems to be faster than {no warnings;} in
 526   # &process, or passing it in as 0 explicity.
 527   # XXX $fallback ||= 0;
 528
 529   # Start at the beginning and work forwards through the string to zero.
 530   # effectively we are removing 1 character from the front each time
 531   # but we don't actually edit the string. [this alone seems to be 14% speedup]
 532   # Hence -$pos is the length of the remaining string.
 533   my $pos = -length $inbytes;
 534   while (1) {
 535     my $byte = substr $inbytes, $pos, 1;
 536     #  RAW_NEXT => 0,
 537     #  RAW_IN_LEN => 1,
 538     #  RAW_OUT_BYTES => 2,
 539     #  RAW_FALLBACK => 3,
 540     # to unicode an array would seem to be better, because the pages are dense.
 541     # from unicode can be very sparse, favouring a hash.
 542     # hash using the bytes (all length 1) as keys rather than ord value,
 543     # as it's easier to sort these in &process.
 544
 545     # It's faster to always add $fallback even if it's undef, rather than
 546     # choosing between 3 and 4 element array. (hence why we set it defined
 547     # above)
 548     my $do_now = $current->{Raw}{$byte} ||= [{},-$pos,'',$fallback];
 549     # When $pos was -1 we were at the last input character.
 550     unless (++$pos) {
 551       $do_now->[RAW_OUT_BYTES] = $outbytes;
 552       $do_now->[RAW_NEXT] = $next;
 553       return;
 554     }
 555     # Tail recursion. The intermdiate state may not have a name yet.
 556     $current = $do_now->[RAW_NEXT];
 557   }
 558 }
 559
 560 # This is purely for optimistation. It's just &enter hard coded for $fallback
 561 # of 0, using only a 3 entry array ref to save memory for every entry.
 562 sub enter_fb0 {
 563   my ($current,$inbytes,$outbytes,$next) = @_;
 564   $next ||= $current;
 565
 566   my $pos = -length $inbytes;
 567   while (1) {
 568     my $byte = substr $inbytes, $pos, 1;
 569     my $do_now = $current->{Raw}{$byte} ||= [{},-$pos,''];
 570     unless (++$pos) {
 571       $do_now->[RAW_OUT_BYTES] = $outbytes;
 572       $do_now->[RAW_NEXT] = $next;
 573       return;
 574     }
 575     $current = $do_now->[RAW_NEXT];
 576   }
 577 }
 578
 579
 580 sub outstring
 581 {
 582  my ($fh,$name,$s) = @_;
 583  my $sym = $strings{$s};
 584  if ($sym)
 585   {
 586    $saved += length($s);
 587   }
 588  else
 589   {
 590    if ($opt{'O'}) {
 591        foreach my $o (keys %strings)
 592         {
 593          next unless (my $i = index($o,$s)) >= 0;
 594          $sym = $strings{$o};
 595          # gcc things that 0x0e+0x10 (anything with e+) starts to look like
 596          # a hexadecimal floating point constant. Silly gcc. Only p
 597          # introduces a floating point constant. Put the space in to stop it
 598          # getting confused.
 599          $sym .= sprintf(" +0x%02x",$i) if ($i);
 600          $subsave += length($s);
 601          return $strings{$s} = $sym;
 602        }
 603    }
 604    $strings{$s} = $sym = $name;
 605    $strings += length($s);
 606    my $definition = sprintf "static const U8 %s[%d] = { ",$name,length($s);
 607    # Maybe we should assert that these are all <256.
 608    $definition .= join(',',unpack "C*",$s);
 609    # We have a single long line. Split it at convenient commas.
 610    $definition =~ s/(.{74,77},)/$1\n/g;
 611    print $fh "$definition };\n\n";
 612   }
 613  return $sym;
 614 }
 615
 616 sub process
 617 {
 618   my ($name,$a) = @_;
 619   $name =~ s/\W+/_/g;
 620   $a->{Cname} = $name;
 621   my $raw = $a->{Raw};
 622   my ($l, $agg_max_in, $agg_next, $agg_in_len, $agg_out_len, $agg_fallback);
 623   my @ent;
 624   $agg_max_in = 0;
 625   foreach my $key (sort keys %$raw) {
 626     #  RAW_NEXT => 0,
 627     #  RAW_IN_LEN => 1,
 628     #  RAW_OUT_BYTES => 2,
 629     #  RAW_FALLBACK => 3,
 630     my ($next, $in_len, $out_bytes, $fallback) = @{$raw->{$key}};
 631     # Now we are converting from raw to aggregate, switch from 1 byte strings
 632     # to numbers
 633     my $b = ord $key;
 634     $fallback ||= 0;
 635     if ($l &&
 636         # If this == fails, we're going to reset $agg_max_in below anyway.
 637         $b == ++$agg_max_in &&
 638         # References in numeric context give the pointer as an int.
 639         $agg_next == $next &&
 640         $agg_in_len == $in_len &&
 641         $agg_out_len == length $out_bytes &&
 642         $agg_fallback == $fallback
 643         # && length($l->[AGG_OUT_BYTES]) < 16
 644        ) {
 645       #     my $i = ord($b)-ord($l->[AGG_MIN_IN]);
 646       # we can aggregate this byte onto the end.
 647       $l->[AGG_MAX_IN] = $b;
 648       $l->[AGG_OUT_BYTES] .= $out_bytes;
 649     } else {
 650       # AGG_MIN_IN => 0,
 651       # AGG_MAX_IN => 1,
 652       # AGG_OUT_BYTES => 2,
 653       # AGG_NEXT => 3,
 654       # AGG_IN_LEN => 4,
 655       # AGG_OUT_LEN => 5,
 656       # AGG_FALLBACK => 6,
 657       # Reset the last thing we saw, plus set 5 lexicals to save some derefs.
 658       # (only gains .6% on euc-jp  -- is it worth it?)
 659       push @ent, $l = [$b, $agg_max_in = $b, $out_bytes, $agg_next = $next,
 660                        $agg_in_len = $in_len, $agg_out_len = length $out_bytes,
 661                        $agg_fallback = $fallback];
 662     }
 663     if (exists $next->{Cname}) {
 664       $next->{'Forward'} = 1 if $next != $a;
 665     } else {
 666       process(sprintf("%s_%02x",$name,$b),$next);
 667     }
 668   }
 669   # encengine.c rules say that last entry must be for 255
 670   if ($agg_max_in < 255) {
 671     push @ent, [1+$agg_max_in, 255,undef,$a,0,0];
 672   }
 673   $a->{'Entries'} = \@ent;
 674 }
 675
 676 sub outtable
 677 {
 678  my ($fh,$a) = @_;
 679  my $name = $a->{'Cname'};
 680  # String tables
 681  foreach my $b (@{$a->{'Entries'}})
 682   {
 683    next unless $b->[AGG_OUT_LEN];
 684    my $s = $b->[AGG_MIN_IN];
 685    my $e = $b->[AGG_MAX_IN];
 686    outstring($fh,sprintf("%s__%02x_%02x",$name,$s,$e),$b->[AGG_OUT_BYTES]);
 687   }
 688  if ($a->{'Forward'})
 689   {
 690    print $fh "\nstatic encpage_t $name\[",scalar(@{$a->{'Entries'}}),"];\n";
 691   }
 692  $a->{'Done'} = 1;
 693  foreach my $b (@{$a->{'Entries'}})
 694   {
 695    my ($s,$e,$out,$t,$end,$l) = @$b;
 696    outtable($fh,$t) unless $t->{'Done'};
 697   }
 698  print $fh "\nstatic encpage_t $name\[",scalar(@{$a->{'Entries'}}),"] = {\n";
 699  foreach my $b (@{$a->{'Entries'}})
 700   {
 701    my ($sc,$ec,$out,$t,$end,$l,$fb) = @$b;
 702    $end |= 0x80 if $fb;
 703    print  $fh "{";
 704    if ($l)
 705     {
 706      printf $fh outstring($fh,'',$out);
 707     }
 708    else
 709     {
 710      print  $fh "0";
 711     }
 712    print  $fh ",",$t->{Cname};
 713    printf $fh ",0x%02x,0x%02x,$l,$end},\n",$sc,$ec;
 714   }
 715  print $fh "};\n";
 716 }
 717
 718 sub output
 719 {
 720  my ($fh,$name,$a) = @_;
 721  process($name,$a);
 722  # Sub-tables
 723  outtable($fh,$a);
 724 }
 725
 726 sub output_enc
 727 {
 728  my ($fh,$name,$a) = @_;
 729  die "Changed - fix me for new structure";
 730  foreach my $b (sort keys %$a)
 731   {
 732    my ($s,$e,$out,$t,$end,$l,$fb) = @{$a->{$b}};
 733   }
 734 }
 735
 736 sub decode_U
 737 {
 738  my $s = shift;
 739 }
 740
 741 my @uname;
 742 sub char_names
 743 {
 744  my $s = do "unicore/Name.pl";
 745  die "char_names: unicore/Name.pl: $!\n" unless defined $s;
 746  pos($s) = 0;
 747  while ($s =~ /\G([0-9a-f]+)\t([0-9a-f]*)\t(.*?)\s*\n/igc)
 748   {
 749    my $name = $3;
 750    my $s = hex($1);
 751    last if $s >= 0x10000;
 752    my $e = length($2) ? hex($2) : $s;
 753    for (my $i = $s; $i <= $e; $i++)
 754     {
 755      $uname[$i] = $name;
 756 #    print sprintf("U%04X $name\n",$i);
 757     }
 758   }
 759 }
 760
 761 sub output_ucm_page
 762 {
 763   my ($cmap,$a,$t,$pre) = @_;
 764   # warn sprintf("Page %x\n",$pre);
 765   my $raw = $t->{Raw};
 766   foreach my $key (sort keys %$raw) {
 767     #  RAW_NEXT => 0,
 768     #  RAW_IN_LEN => 1,
 769     #  RAW_OUT_BYTES => 2,
 770     #  RAW_FALLBACK => 3,
 771     my ($next, $in_len, $out_bytes, $fallback) = @{$raw->{$key}};
 772     my $u = ord $key;
 773     $fallback ||= 0;
 774
 775     if ($next != $a && $next != $t) {
 776       output_ucm_page($cmap,$a,$next,(($pre|($u &0x3F)) << 6)&0xFFFF);
 777     } elsif (length $out_bytes) {
 778       if ($pre) {
 779         $u = $pre|($u &0x3f);
 780       }
 781       my $s = sprintf "<U%04X> ",$u;
 782       #foreach my $c (split(//,$out_bytes)) {
 783       #  $s .= sprintf "\\x%02X",ord($c);
 784       #}
 785       # 9.5% faster changing that loop to this:
 786       $s .= sprintf +("\\x%02X" x length $out_bytes), unpack "C*", $out_bytes;
 787       $s .= sprintf " |%d # %s\n",($fallback ? 1 : 0),$uname[$u];
 788       push(@$cmap,$s);
 789     } else {
 790       warn join(',',$u, @{$raw->{$key}},$a,$t);
 791     }
 792   }
 793 }
 794
 795 sub output_ucm
 796 {
 797  my ($fh,$name,$h,$rep,$min_el,$max_el) = @_;
 798  print $fh "# $0 @orig_ARGV\n" unless $opt{'q'};
 799  print $fh "<code_set_name> \"$name\"\n";
 800  char_names();
 801  if (defined $min_el)
 802   {
 803    print $fh "<mb_cur_min> $min_el\n";
 804   }
 805  if (defined $max_el)
 806   {
 807    print $fh "<mb_cur_max> $max_el\n";
 808   }
 809  if (defined $rep)
 810   {
 811    print $fh "<subchar> ";
 812    foreach my $c (split(//,$rep))
 813     {
 814      printf $fh "\\x%02X",ord($c);
 815     }
 816    print $fh "\n";
 817   }
 818  my @cmap;
 819  output_ucm_page(\@cmap,$h,$h,0);
 820  print $fh "#\nCHARMAP\n";
 821  foreach my $line (sort { substr($a,8) cmp substr($b,8) } @cmap)
 822   {
 823    print $fh $line;
 824   }
 825  print $fh "END CHARMAP\n";
 826 }
 827
 828
 829 __END__
 830 With %seen holding array refs:
 831
 832       865.66 real        28.80 user         8.79 sys
 833       7904  maximum resident set size
 834       1356  average shared memory size
 835      18566  average unshared data size
 836        229  average unshared stack size
 837      46080  page reclaims
 838      33373  page faults
 839
 840 With %seen holding simple scalars:
 841
 842       342.16 real        27.11 user         3.54 sys
 843       8388  maximum resident set size
 844       1394  average shared memory size
 845      14969  average unshared data size
 846        236  average unshared stack size
 847      28159  page reclaims
 848       9839  page faults
 849
 850 Yes, 5 minutes is faster than 15. Above is for CP936 in CN. Only difference is
 851 how %seen is storing things its seen. So it is pathalogically bad on a 16M
 852 RAM machine, but it's going to help even on modern machines.
 853 Swapping is bad, m'kay :-)