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