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