Integrate mainline
[p5sagit/p5-mst-13.2.git] / 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 :-)