3 unshift @INC, qw(../../lib ../../../lib);
4 $ENV{PATH} .= ';../..;../../..' if $^O eq 'MSWin32';
10 # These may get re-ordered.
11 # RAW is a do_now as inserted by &enter
12 # AGG is an aggreagated do_now, as built up by &process
27 # (See the algorithm in encengine.c - we're building structures for it)
29 # There are two sorts of structures.
30 # "do_now" (an array, two variants of what needs storing) is whatever we need
31 # to do now we've read an input byte.
32 # It's housed in a "do_next" (which is how we got to it), and in turn points
33 # to a "do_next" which contains all the "do_now"s for the next input byte.
35 # There will be a "do_next" which is the start state.
36 # For a single byte encoding it's the only "do_next" - each "do_now" points
37 # back to it, and each "do_now" will cause bytes. There is no state.
39 # For a multi-byte encoding where all characters in the input are the same
40 # length, then there will be a tree of "do_now"->"do_next"->"do_now"
41 # branching out from the start state, one step for each input byte.
42 # The leaf "do_now"s will all be at the same distance from the start state,
43 # only the leaf "do_now"s cause output bytes, and they in turn point back to
46 # For an encoding where there are varaible length input byte sequences, you
47 # will encounter a leaf "do_now" sooner for the shorter input sequences, but
48 # as before the leaves will point back to the start state.
50 # The system will cope with escape encodings (imagine them as a mostly
51 # self-contained tree for each escape state, and cross links between trees
52 # at the state-switching characters) but so far no input format defines these.
54 # The system will also cope with having output "leaves" in the middle of
55 # the bifurcating branches, not just at the extremities, but again no
56 # input format does this yet.
58 # There are two variants of the "do_now" structure. The first, smaller variant
59 # is generated by &enter as the input file is read. There is one structure
60 # for each input byte. Say we are mapping a single byte encoding to a
61 # single byte encoding, with "ABCD" going "abcd". There will be
62 # 4 "do_now"s, {"A" => [...,"a",...], "B" => [...,"b",...], "C"=>..., "D"=>...}
64 # &process then walks the tree, building aggregate "do_now" structres for
65 # adjacent bytes where possible. The aggregate is for a contiguous range of
66 # bytes which each produce the same length of output, each move to the
67 # same next state, and each have the same fallback flag.
68 # So our 4 RAW "do_now"s above become replaced by a single structure
70 # ["A", "D", "abcd", 1, ...]
71 # ie, for an input byte $_ in "A".."D", output 1 byte, found as
72 # substr ("abcd", (ord $_ - ord "A") * 1, 1)
73 # which maps very nicely into pointer arithmetic in C for encengine.c
77 # UTF-8 encode long hand - only covers part of perl's range
79 # chr() works in native space so convert value from table
80 # into that space before using chr().
81 my $ch = chr(utf8::unicode_to_native($_[0]));
82 # Now get core perl to encode that the way it likes.
90 ## my ($ch,$page) = @_; return chr($ch);
96 # encode double byte MS byte first
97 ## my ($ch,$page) = @_; return chr($page).chr($ch);
98 return chr ($_[1]) . chr $_[0];
103 # encode Multi-byte - single for 0..255 otherwise double
104 ## my ($ch,$page) = @_;
105 ## return &encode_D if $page;
107 return chr ($_[1]) . chr $_[0] if $_[1];
111 my %encode_types = (U => \&encode_U,
117 # Win32 does not expand globs on command line
118 eval "\@ARGV = map(glob(\$_),\@ARGV)" if ($^O eq 'MSWin32');
121 getopts('qOo:f:n:',\%opt);
122 my $cname = (exists $opt{'o'}) ? $opt{'o'} : shift(@ARGV);
123 chmod(0666,$cname) if -f $cname && !-w $cname;
124 open(C,">$cname") || die "Cannot open $cname:$!";
128 $dname =~ s/(\.[^\.]*)?$/_def.h/;
130 my ($doC,$doEnc,$doUcm,$doPet);
132 if ($cname =~ /\.(c|xs)$/)
135 chmod(0666,$dname) if -f $cname && !-w $dname;
136 open(D,">$dname") || die "Cannot open $dname:$!";
138 $hname =~ s/(\.[^\.]*)?$/.h/;
139 chmod(0666,$hname) if -f $cname && !-w $hname;
140 open(H,">$hname") || die "Cannot open $hname:$!";
142 foreach my $fh (\*C,\*D,\*H)
144 print $fh <<"END" unless $opt{'q'};
146 !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
147 This file was autogenerated by:
153 if ($cname =~ /(\w+)\.xs$/)
155 print C "#include <EXTERN.h>\n";
156 print C "#include <perl.h>\n";
157 print C "#include <XSUB.h>\n";
158 print C "#define U8 U8\n";
160 print C "#include \"encode.h\"\n";
163 elsif ($cname =~ /\.enc$/)
167 elsif ($cname =~ /\.ucm$/)
171 elsif ($cname =~ /\.pet$/)
177 if (exists $opt{'f'})
179 # -F is followed by name of file containing list of filenames
180 my $flist = $opt{'f'};
181 open(FLIST,$flist) || die "Cannot open $flist:$!";
182 chomp(@encfiles = <FLIST>);
198 if ($a =~ /^.*-(\d+)/)
201 if ($b =~ /^.*-(\d+)/)
211 foreach my $enc (sort cmp_name @encfiles)
213 my ($name,$sfx) = $enc =~ /^.*?([\w-]+)\.(enc|ucm)$/;
214 $name = $opt{'n'} if exists $opt{'n'};
219 compile_enc(\*E,lc($name));
223 compile_ucm(\*E,lc($name));
228 warn "Cannot open $enc for $name:$!";
234 print STDERR "Writing compiled form\n";
235 foreach my $name (sort cmp_name keys %encoding)
237 my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}};
238 output(\*C,$name.'_utf8',$e2u);
239 output(\*C,'utf8_'.$name,$u2e);
240 push(@{$encoding{$name}},outstring(\*C,$e2u->{Cname}.'_def',$erep));
242 foreach my $enc (sort cmp_name keys %encoding)
244 my ($e2u,$u2e,$rep,$min_el,$max_el,$rsym) = @{$encoding{$enc}};
245 my @info = ($e2u->{Cname},$u2e->{Cname},$rsym,length($rep),$min_el,$max_el);
246 my $sym = "${enc}_encoding";
248 print C "encode_t $sym = \n";
249 print C " {",join(',',@info,"{\"$enc\",(const char *)0}"),"};\n\n";
252 foreach my $enc (sort cmp_name keys %encoding)
254 my $sym = "${enc}_encoding";
256 print H "extern encode_t $sym;\n";
257 print D " Encode_XSEncoding(aTHX_ &$sym);\n";
260 if ($cname =~ /(\w+)\.xs$/)
266 Encode_XSEncoding(pTHX_ encode_t *enc)
269 HV *stash = gv_stashpv("Encode::XS", TRUE);
270 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(enc))),stash);
276 const char *name = enc->name[i++];
277 XPUSHs(sv_2mortal(newSVpvn(name,strlen(name))));
280 call_pv("Encode::define_encoding",G_DISCARD);
286 print C "\nMODULE = Encode::$mod\tPACKAGE = Encode::$mod\n\n";
287 print C "BOOT:\n{\n";
288 print C "#include \"$dname\"\n";
294 my $perc_saved = $strings/($strings + $saved) * 100;
295 my $perc_subsaved = $strings/($strings + $subsave) * 100;
296 printf STDERR "%d bytes in string tables\n",$strings;
297 printf STDERR "%d bytes (%.3g%%) saved spotting duplicates\n",
298 $saved, $perc_saved if $saved;
299 printf STDERR "%d bytes (%.3g%%) saved using substrings\n",
300 $subsave, $perc_subsaved if $subsave;
304 foreach my $name (sort cmp_name keys %encoding)
306 my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}};
307 output_enc(\*C,$name,$e2u);
312 foreach my $name (sort cmp_name keys %encoding)
314 my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}};
315 output_ucm(\*C,$name,$u2e,$erep,$min_el,$max_el);
333 last if /^\s*CHARMAP\s*$/i;
334 if (/^\s*<(\w+)>\s+"?([^"]*)"?\s*$/i) # " # Grrr
339 if (!defined($cs = $attr{'code_set_name'}))
341 warn "No <code_set_name> in $name\n";
345 $name = $cs unless exists $opt{'n'};
351 if (exists $attr{'subchar'})
354 $attr{'subchar'} =~ /^\s*/cg;
355 push(@byte,$1) while $attr{'subchar'} =~ /\G\\x([0-9a-f]+)/icg;
356 $erep = join('',map(chr(hex($_)),@byte));
358 print "Reading $name ($cs)\n";
364 last if /^\s*END\s+CHARMAP\s*$/i;
368 $u = $1 if (/^<U([0-9a-f]+)>\s+/igc);
369 push(@byte,$1) while /\G\\x([0-9a-f]+)/igc;
370 $fb = $1 if /\G\s*(\|[0-3])/gc;
371 # warn "$_: $u @byte | $fb\n";
372 die "Bad line:$_" unless /\G\s*(#.*)?$/gc;
375 my $uch = encode_U(hex($u));
376 my $ech = join('',map(chr(hex($_)),@byte));
377 my $el = length($ech);
378 $max_el = $el if (!defined($max_el) || $el > $max_el);
379 $min_el = $el if (!defined($min_el) || $el < $min_el);
390 # $fb is fallback flag
391 # 0 - round trip safe
392 # 1 - fallback for unicode -> enc
393 # 2 - skip sub-char mapping
394 # 3 - fallback enc -> unicode
395 enter($u2e,$uch,$ech,$u2e,$fb+0) if ($fb =~ /[01]/);
396 enter($e2u,$ech,$uch,$e2u,$fb+0) if ($fb =~ /[03]/);
405 die "$nfb entries without fallback, $hfb entries with\n";
407 $encoding{$name} = [$e2u,$u2e,$erep,$min_el,$max_el];
417 while ($type = <$fh>)
419 last if $type !~ /^\s*#/;
422 return if $type eq 'E';
423 # Do the hash lookup once, rather than once per function call. 4% speedup.
424 my $type_func = $encode_types{$type};
425 my ($def,$sym,$pages) = split(/\s+/,scalar(<$fh>));
426 warn "$type encoded $name\n";
428 # Save a defined test by setting these to defined values.
429 my $min_el = ~0; # A very big integer
430 my $max_el = 0; # Anything must be longer than 0
433 $rep = &$type_func($v & 0xFF, ($v >> 8) & 0xffe);
440 my $page = hex($line);
445 # So why is it 1% faster to leave the my here?
447 die "Line should be exactly 65 characters long including newline"
448 unless length ($line) == 65;
449 # Split line into groups of 4 hex digits, convert groups to ints
451 # map {hex $_} $line =~ /(....)/g
452 # This takes 63.75 (2.5% less time)
453 # unpack "n*", pack "H*", $line
454 # There's an implicit loop in map. Loops are bad, m'kay. Ops are bad, m'kay
455 # Doing it as while ($line =~ /(....)/g) took 74.63
456 foreach my $val (unpack "n*", pack "H*", $line)
458 next if $val == 0xFFFD;
459 my $ech = &$type_func($ch,$page);
460 if ($val || (!$ch && !$page))
462 my $el = length($ech);
463 $max_el = $el if $el > $max_el;
464 $min_el = $el if $el < $min_el;
465 my $uch = encode_U($val);
466 # We don't need to read this quickly, so storing it as a scalar,
467 # rather than 3 (anon array, plus the 2 scalars it holds) saves
468 # RAM and may make us faster on low RAM systems. [see __END__]
469 if (exists $seen{$uch})
471 warn sprintf("U%04X is %02X%02X and %04X\n",
472 $val,$page,$ch,$seen{$uch});
476 $seen{$uch} = $page << 8 | $ch;
478 # Passing 2 extra args each time is 3.6% slower!
479 # Even with having to add $fallback ||= 0 later
480 enter_fb0($e2u,$ech,$uch);
481 enter_fb0($u2e,$uch,$ech);
485 # No character at this position
486 # enter($e2u,$ech,undef,$e2u);
492 die "\$min_el=$min_el, \$max_el=$max_el - seems we read no lines"
493 if $min_el > $max_el;
494 $encoding{$name} = [$e2u,$u2e,$rep,$min_el,$max_el];
497 # my ($a,$s,$d,$t,$fb) = @_;
499 my ($current,$inbytes,$outbytes,$next,$fallback) = @_;
500 # state we shift to after this (multibyte) input character defaults to same
503 # Making sure it is defined seems to be faster than {no warnings;} in
504 # &process, or passing it in as 0 explicity.
505 # XXX $fallback ||= 0;
507 # Start at the beginning and work forwards through the string to zero.
508 # effectively we are removing 1 character from the front each time
509 # but we don't actually edit the string. [this alone seems to be 14% speedup]
510 # Hence -$pos is the length of the remaining string.
511 my $pos = -length $inbytes;
513 my $byte = substr $inbytes, $pos, 1;
516 # RAW_OUT_BYTES => 2,
518 # to unicode an array would seem to be better, because the pages are dense.
519 # from unicode can be very sparse, favouring a hash.
520 # hash using the bytes (all length 1) as keys rather than ord value,
521 # as it's easier to sort these in &process.
523 # It's faster to always add $fallback even if it's undef, rather than
524 # choosing between 3 and 4 element array. (hence why we set it defined
526 my $do_now = $current->{Raw}{$byte} ||= [{},-$pos,'',$fallback];
527 # When $pos was -1 we were at the last input character.
529 $do_now->[RAW_OUT_BYTES] = $outbytes;
530 $do_now->[RAW_NEXT] = $next;
533 # Tail recursion. The intermdiate state may not have a name yet.
534 $current = $do_now->[RAW_NEXT];
538 # This is purely for optimistation. It's just &enter hard coded for $fallback
539 # of 0, using only a 3 entry array ref to save memory for every entry.
541 my ($current,$inbytes,$outbytes,$next) = @_;
544 my $pos = -length $inbytes;
546 my $byte = substr $inbytes, $pos, 1;
547 my $do_now = $current->{Raw}{$byte} ||= [{},-$pos,''];
549 $do_now->[RAW_OUT_BYTES] = $outbytes;
550 $do_now->[RAW_NEXT] = $next;
553 $current = $do_now->[RAW_NEXT];
560 my ($fh,$name,$s) = @_;
561 my $sym = $strings{$s};
564 $saved += length($s);
569 foreach my $o (keys %strings)
571 next unless (my $i = index($o,$s)) >= 0;
573 $sym .= sprintf("+0x%02x",$i) if ($i);
574 $subsave += length($s);
575 return $strings{$s} = $sym;
578 $strings{$s} = $sym = $name;
579 $strings += length($s);
580 my $definition = sprintf "static const U8 %s[%d] = { ",$name,length($s);
581 # Maybe we should assert that these are all <256.
582 $definition .= join(',',unpack "C*",$s);
583 # We have a single long line. Split it at convenient commas.
584 $definition =~ s/(.{74,77},)/$1\n/g;
585 print $fh "$definition };\n\n";
596 my ($l, $agg_max_in, $agg_next, $agg_in_len, $agg_out_len, $agg_fallback);
599 foreach my $key (sort keys %$raw) {
602 # RAW_OUT_BYTES => 2,
604 my ($next, $in_len, $out_bytes, $fallback) = @{$raw->{$key}};
605 # Now we are converting from raw to aggregate, switch from 1 byte strings
610 # If this == fails, we're going to reset $agg_max_in below anyway.
611 $b == ++$agg_max_in &&
612 # References in numeric context give the pointer as an int.
613 $agg_next == $next &&
614 $agg_in_len == $in_len &&
615 $agg_out_len == length $out_bytes &&
616 $agg_fallback == $fallback
617 # && length($l->[AGG_OUT_BYTES]) < 16
619 # my $i = ord($b)-ord($l->[AGG_MIN_IN]);
620 # we can aggregate this byte onto the end.
621 $l->[AGG_MAX_IN] = $b;
622 $l->[AGG_OUT_BYTES] .= $out_bytes;
626 # AGG_OUT_BYTES => 2,
631 # Reset the last thing we saw, plus set 5 lexicals to save some derefs.
632 # (only gains .6% on euc-jp -- is it worth it?)
633 push @ent, $l = [$b, $agg_max_in = $b, $out_bytes, $agg_next = $next,
634 $agg_in_len = $in_len, $agg_out_len = length $out_bytes,
635 $agg_fallback = $fallback];
637 if (exists $next->{Cname}) {
638 $next->{'Forward'} = 1 if $next != $a;
640 process(sprintf("%s_%02x",$name,$b),$next);
643 # encengine.c rules say that last entry must be for 255
644 if ($agg_max_in < 255) {
645 push @ent, [1+$agg_max_in, 255,undef,$a,0,0];
647 $a->{'Entries'} = \@ent;
653 my $name = $a->{'Cname'};
655 foreach my $b (@{$a->{'Entries'}})
657 next unless $b->[AGG_OUT_LEN];
658 my $s = $b->[AGG_MIN_IN];
659 my $e = $b->[AGG_MAX_IN];
660 outstring($fh,sprintf("%s__%02x_%02x",$name,$s,$e),$b->[AGG_OUT_BYTES]);
664 print $fh "\nstatic encpage_t $name\[",scalar(@{$a->{'Entries'}}),"];\n";
667 foreach my $b (@{$a->{'Entries'}})
669 my ($s,$e,$out,$t,$end,$l) = @$b;
670 outtable($fh,$t) unless $t->{'Done'};
672 print $fh "\nstatic encpage_t $name\[",scalar(@{$a->{'Entries'}}),"] = {\n";
673 foreach my $b (@{$a->{'Entries'}})
675 my ($sc,$ec,$out,$t,$end,$l,$fb) = @$b;
680 printf $fh outstring($fh,'',$out);
686 print $fh ",",$t->{Cname};
687 printf $fh ",0x%02x,0x%02x,$l,$end},\n",$sc,$ec;
694 my ($fh,$name,$a) = @_;
702 my ($fh,$name,$a) = @_;
703 die "Changed - fix me for new structure";
704 foreach my $b (sort keys %$a)
706 my ($s,$e,$out,$t,$end,$l,$fb) = @{$a->{$b}};
718 my $s = do "unicore/Name.pl";
719 die "char_names: unicore/Name.pl: $!\n" unless defined $s;
721 while ($s =~ /\G([0-9a-f]+)\t([0-9a-f]*)\t(.*?)\s*\n/igc)
725 last if $s >= 0x10000;
726 my $e = length($2) ? hex($2) : $s;
727 for (my $i = $s; $i <= $e; $i++)
730 # print sprintf("U%04X $name\n",$i);
737 my ($cmap,$a,$t,$pre) = @_;
738 # warn sprintf("Page %x\n",$pre);
740 foreach my $key (sort keys %$raw) {
743 # RAW_OUT_BYTES => 2,
745 my ($next, $in_len, $out_bytes, $fallback) = @{$raw->{$key}};
749 if ($next != $a && $next != $t) {
750 output_ucm_page($cmap,$a,$next,(($pre|($u &0x3F)) << 6)&0xFFFF);
751 } elsif (length $out_bytes) {
753 $u = $pre|($u &0x3f);
755 my $s = sprintf "<U%04X> ",$u;
756 #foreach my $c (split(//,$out_bytes)) {
757 # $s .= sprintf "\\x%02X",ord($c);
759 # 9.5% faster changing that lloop to this:
760 $s .= sprintf +("\\x%02X" x length $out_bytes), unpack "C*", $out_bytes;
761 $s .= sprintf " |%d # %s\n",($fallback ? 1 : 0),$uname[$u];
764 warn join(',',$u, @{$raw->{$key}},$a,$t);
771 my ($fh,$name,$h,$rep,$min_el,$max_el) = @_;
772 print $fh "# $0 @orig_ARGV\n" unless $opt{'q'};
773 print $fh "<code_set_name> \"$name\"\n";
777 print $fh "<mb_cur_min> $min_el\n";
781 print $fh "<mb_cur_max> $max_el\n";
785 print $fh "<subchar> ";
786 foreach my $c (split(//,$rep))
788 printf $fh "\\x%02X",ord($c);
793 output_ucm_page(\@cmap,$h,$h,0);
794 print $fh "#\nCHARMAP\n";
795 foreach my $line (sort { substr($a,8) cmp substr($b,8) } @cmap)
799 print $fh "END CHARMAP\n";
804 With %seen holding array refs:
806 865.66 real 28.80 user 8.79 sys
807 7904 maximum resident set size
808 1356 average shared memory size
809 18566 average unshared data size
810 229 average unshared stack size
814 With %seen holding simple scalars:
816 342.16 real 27.11 user 3.54 sys
817 8388 maximum resident set size
818 1394 average shared memory size
819 14969 average unshared data size
820 236 average unshared stack size
824 Yes, 5 minutes is faster than 15. Above is for CP936 in CN. Only difference is
825 how %seen is storing things its seen. So it is pathalogically bad on a 16M
826 RAM machine, but it's going to help even on modern machines.
827 Swapping is bad, m'kay :-)