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          $sym .= sprintf("+0x%02x",$i) if ($i);
 596          $subsave += length($s);
 597          return $strings{$s} = $sym;
 598        }
 599    }
 600    $strings{$s} = $sym = $name;
 601    $strings += length($s);
 602    my $definition = sprintf "static const U8 %s[%d] = { ",$name,length($s);
 603    # Maybe we should assert that these are all <256.
 604    $definition .= join(',',unpack "C*",$s);
 605    # We have a single long line. Split it at convenient commas.
 606    $definition =~ s/(.{74,77},)/$1\n/g;
 607    print $fh "$definition };\n\n";
 608   }
 609  return $sym;
 610 }
 611
 612 sub process
 613 {
 614   my ($name,$a) = @_;
 615   $name =~ s/\W+/_/g;
 616   $a->{Cname} = $name;
 617   my $raw = $a->{Raw};
 618   my ($l, $agg_max_in, $agg_next, $agg_in_len, $agg_out_len, $agg_fallback);
 619   my @ent;
 620   $agg_max_in = 0;
 621   foreach my $key (sort keys %$raw) {
 622     #  RAW_NEXT => 0,
 623     #  RAW_IN_LEN => 1,
 624     #  RAW_OUT_BYTES => 2,
 625     #  RAW_FALLBACK => 3,
 626     my ($next, $in_len, $out_bytes, $fallback) = @{$raw->{$key}};
 627     # Now we are converting from raw to aggregate, switch from 1 byte strings
 628     # to numbers
 629     my $b = ord $key;
 630     $fallback ||= 0;
 631     if ($l &&
 632         # If this == fails, we're going to reset $agg_max_in below anyway.
 633         $b == ++$agg_max_in &&
 634         # References in numeric context give the pointer as an int.
 635         $agg_next == $next &&
 636         $agg_in_len == $in_len &&
 637         $agg_out_len == length $out_bytes &&
 638         $agg_fallback == $fallback
 639         # && length($l->[AGG_OUT_BYTES]) < 16
 640        ) {
 641       #     my $i = ord($b)-ord($l->[AGG_MIN_IN]);
 642       # we can aggregate this byte onto the end.
 643       $l->[AGG_MAX_IN] = $b;
 644       $l->[AGG_OUT_BYTES] .= $out_bytes;
 645     } else {
 646       # AGG_MIN_IN => 0,
 647       # AGG_MAX_IN => 1,
 648       # AGG_OUT_BYTES => 2,
 649       # AGG_NEXT => 3,
 650       # AGG_IN_LEN => 4,
 651       # AGG_OUT_LEN => 5,
 652       # AGG_FALLBACK => 6,
 653       # Reset the last thing we saw, plus set 5 lexicals to save some derefs.
 654       # (only gains .6% on euc-jp  -- is it worth it?)
 655       push @ent, $l = [$b, $agg_max_in = $b, $out_bytes, $agg_next = $next,
 656                        $agg_in_len = $in_len, $agg_out_len = length $out_bytes,
 657                        $agg_fallback = $fallback];
 658     }
 659     if (exists $next->{Cname}) {
 660       $next->{'Forward'} = 1 if $next != $a;
 661     } else {
 662       process(sprintf("%s_%02x",$name,$b),$next);
 663     }
 664   }
 665   # encengine.c rules say that last entry must be for 255
 666   if ($agg_max_in < 255) {
 667     push @ent, [1+$agg_max_in, 255,undef,$a,0,0];
 668   }
 669   $a->{'Entries'} = \@ent;
 670 }
 671
 672 sub outtable
 673 {
 674  my ($fh,$a) = @_;
 675  my $name = $a->{'Cname'};
 676  # String tables
 677  foreach my $b (@{$a->{'Entries'}})
 678   {
 679    next unless $b->[AGG_OUT_LEN];
 680    my $s = $b->[AGG_MIN_IN];
 681    my $e = $b->[AGG_MAX_IN];
 682    outstring($fh,sprintf("%s__%02x_%02x",$name,$s,$e),$b->[AGG_OUT_BYTES]);
 683   }
 684  if ($a->{'Forward'})
 685   {
 686    print $fh "\nstatic encpage_t $name\[",scalar(@{$a->{'Entries'}}),"];\n";
 687   }
 688  $a->{'Done'} = 1;
 689  foreach my $b (@{$a->{'Entries'}})
 690   {
 691    my ($s,$e,$out,$t,$end,$l) = @$b;
 692    outtable($fh,$t) unless $t->{'Done'};
 693   }
 694  print $fh "\nstatic encpage_t $name\[",scalar(@{$a->{'Entries'}}),"] = {\n";
 695  foreach my $b (@{$a->{'Entries'}})
 696   {
 697    my ($sc,$ec,$out,$t,$end,$l,$fb) = @$b;
 698    $end |= 0x80 if $fb;
 699    print  $fh "{";
 700    if ($l)
 701     {
 702      printf $fh outstring($fh,'',$out);
 703     }
 704    else
 705     {
 706      print  $fh "0";
 707     }
 708    print  $fh ",",$t->{Cname};
 709    printf $fh ",0x%02x,0x%02x,$l,$end},\n",$sc,$ec;
 710   }
 711  print $fh "};\n";
 712 }
 713
 714 sub output
 715 {
 716  my ($fh,$name,$a) = @_;
 717  process($name,$a);
 718  # Sub-tables
 719  outtable($fh,$a);
 720 }
 721
 722 sub output_enc
 723 {
 724  my ($fh,$name,$a) = @_;
 725  die "Changed - fix me for new structure";
 726  foreach my $b (sort keys %$a)
 727   {
 728    my ($s,$e,$out,$t,$end,$l,$fb) = @{$a->{$b}};
 729   }
 730 }
 731
 732 sub decode_U
 733 {
 734  my $s = shift;
 735 }
 736
 737 my @uname;
 738 sub char_names
 739 {
 740  my $s = do "unicore/Name.pl";
 741  die "char_names: unicore/Name.pl: $!\n" unless defined $s;
 742  pos($s) = 0;
 743  while ($s =~ /\G([0-9a-f]+)\t([0-9a-f]*)\t(.*?)\s*\n/igc)
 744   {
 745    my $name = $3;
 746    my $s = hex($1);
 747    last if $s >= 0x10000;
 748    my $e = length($2) ? hex($2) : $s;
 749    for (my $i = $s; $i <= $e; $i++)
 750     {
 751      $uname[$i] = $name;
 752 #    print sprintf("U%04X $name\n",$i);
 753     }
 754   }
 755 }
 756
 757 sub output_ucm_page
 758 {
 759   my ($cmap,$a,$t,$pre) = @_;
 760   # warn sprintf("Page %x\n",$pre);
 761   my $raw = $t->{Raw};
 762   foreach my $key (sort keys %$raw) {
 763     #  RAW_NEXT => 0,
 764     #  RAW_IN_LEN => 1,
 765     #  RAW_OUT_BYTES => 2,
 766     #  RAW_FALLBACK => 3,
 767     my ($next, $in_len, $out_bytes, $fallback) = @{$raw->{$key}};
 768     my $u = ord $key;
 769     $fallback ||= 0;
 770
 771     if ($next != $a && $next != $t) {
 772       output_ucm_page($cmap,$a,$next,(($pre|($u &0x3F)) << 6)&0xFFFF);
 773     } elsif (length $out_bytes) {
 774       if ($pre) {
 775         $u = $pre|($u &0x3f);
 776       }
 777       my $s = sprintf "<U%04X> ",$u;
 778       #foreach my $c (split(//,$out_bytes)) {
 779       #  $s .= sprintf "\\x%02X",ord($c);
 780       #}
 781       # 9.5% faster changing that loop to this:
 782       $s .= sprintf +("\\x%02X" x length $out_bytes), unpack "C*", $out_bytes;
 783       $s .= sprintf " |%d # %s\n",($fallback ? 1 : 0),$uname[$u];
 784       push(@$cmap,$s);
 785     } else {
 786       warn join(',',$u, @{$raw->{$key}},$a,$t);
 787     }
 788   }
 789 }
 790
 791 sub output_ucm
 792 {
 793  my ($fh,$name,$h,$rep,$min_el,$max_el) = @_;
 794  print $fh "# $0 @orig_ARGV\n" unless $opt{'q'};
 795  print $fh "<code_set_name> \"$name\"\n";
 796  char_names();
 797  if (defined $min_el)
 798   {
 799    print $fh "<mb_cur_min> $min_el\n";
 800   }
 801  if (defined $max_el)
 802   {
 803    print $fh "<mb_cur_max> $max_el\n";
 804   }
 805  if (defined $rep)
 806   {
 807    print $fh "<subchar> ";
 808    foreach my $c (split(//,$rep))
 809     {
 810      printf $fh "\\x%02X",ord($c);
 811     }
 812    print $fh "\n";
 813   }
 814  my @cmap;
 815  output_ucm_page(\@cmap,$h,$h,0);
 816  print $fh "#\nCHARMAP\n";
 817  foreach my $line (sort { substr($a,8) cmp substr($b,8) } @cmap)
 818   {
 819    print $fh $line;
 820   }
 821  print $fh "END CHARMAP\n";
 822 }
 823
 824
 825 __END__
 826 With %seen holding array refs:
 827
 828       865.66 real        28.80 user         8.79 sys
 829       7904  maximum resident set size
 830       1356  average shared memory size
 831      18566  average unshared data size
 832        229  average unshared stack size
 833      46080  page reclaims
 834      33373  page faults
 835
 836 With %seen holding simple scalars:
 837
 838       342.16 real        27.11 user         3.54 sys
 839       8388  maximum resident set size
 840       1394  average shared memory size
 841      14969  average unshared data size
 842        236  average unshared stack size
 843      28159  page reclaims
 844       9839  page faults
 845
 846 Yes, 5 minutes is faster than 15. Above is for CP936 in CN. Only difference is
 847 how %seen is storing things its seen. So it is pathalogically bad on a 16M
 848 RAM machine, but it's going to help even on modern machines.
 849 Swapping is bad, m'kay :-)