3 unshift @INC, qw(../../lib ../../../lib);
4 $ENV{PATH} .= ';../..;../../..' if $^O eq 'MSWin32';
11 # These may get re-ordered.
12 # RAW is a do_now as inserted by &enter
13 # AGG is an aggreagated do_now, as built up by &process
28 # (See the algorithm in encengine.c - we're building structures for it)
30 # There are two sorts of structures.
31 # "do_now" (an array, two variants of what needs storing) is whatever we need
32 # to do now we've read an input byte.
33 # It's housed in a "do_next" (which is how we got to it), and in turn points
34 # to a "do_next" which contains all the "do_now"s for the next input byte.
36 # There will be a "do_next" which is the start state.
37 # For a single byte encoding it's the only "do_next" - each "do_now" points
38 # back to it, and each "do_now" will cause bytes. There is no state.
40 # For a multi-byte encoding where all characters in the input are the same
41 # length, then there will be a tree of "do_now"->"do_next"->"do_now"
42 # branching out from the start state, one step for each input byte.
43 # The leaf "do_now"s will all be at the same distance from the start state,
44 # only the leaf "do_now"s cause output bytes, and they in turn point back to
47 # For an encoding where there are varaible length input byte sequences, you
48 # will encounter a leaf "do_now" sooner for the shorter input sequences, but
49 # as before the leaves will point back to the start state.
51 # The system will cope with escape encodings (imagine them as a mostly
52 # self-contained tree for each escape state, and cross links between trees
53 # at the state-switching characters) but so far no input format defines these.
55 # The system will also cope with having output "leaves" in the middle of
56 # the bifurcating branches, not just at the extremities, but again no
57 # input format does this yet.
59 # There are two variants of the "do_now" structure. The first, smaller variant
60 # is generated by &enter as the input file is read. There is one structure
61 # for each input byte. Say we are mapping a single byte encoding to a
62 # single byte encoding, with "ABCD" going "abcd". There will be
63 # 4 "do_now"s, {"A" => [...,"a",...], "B" => [...,"b",...], "C"=>..., "D"=>...}
65 # &process then walks the tree, building aggregate "do_now" structres for
66 # adjacent bytes where possible. The aggregate is for a contiguous range of
67 # bytes which each produce the same length of output, each move to the
68 # same next state, and each have the same fallback flag.
69 # So our 4 RAW "do_now"s above become replaced by a single structure
71 # ["A", "D", "abcd", 1, ...]
72 # ie, for an input byte $_ in "A".."D", output 1 byte, found as
73 # substr ("abcd", (ord $_ - ord "A") * 1, 1)
74 # which maps very nicely into pointer arithmetic in C for encengine.c
78 # UTF-8 encode long hand - only covers part of perl's range
80 # chr() works in native space so convert value from table
81 # into that space before using chr().
82 my $ch = chr(utf8::unicode_to_native($_[0]));
83 # Now get core perl to encode that the way it likes.
91 ## my ($ch,$page) = @_; return chr($ch);
97 # encode double byte MS byte first
98 ## my ($ch,$page) = @_; return chr($page).chr($ch);
99 return chr ($_[1]) . chr $_[0];
104 # encode Multi-byte - single for 0..255 otherwise double
105 ## my ($ch,$page) = @_;
106 ## return &encode_D if $page;
108 return chr ($_[1]) . chr $_[0] if $_[1];
112 my %encode_types = (U => \&encode_U,
118 # Win32 does not expand globs on command line
119 eval "\@ARGV = map(glob(\$_),\@ARGV)" if ($^O eq 'MSWin32');
123 # -Q to disable the duplicate codepoint test
124 # -S make mapping errors fatal
125 # -q to remove comments written to output files
126 # -O to enable the (brute force) substring optimiser
127 # -o <output> to specify the output file name (else it's the first arg)
128 # -f <inlist> to give a file with a list of input files (else use the args)
129 # -n <name> to name the encoding (else use the basename of the input file.
130 getopts('SQqOo:f:n:',\%opt);
132 # This really should go first, else the die here causes empty (non-erroneous)
133 # output files to be written.
135 if (exists $opt{'f'}) {
136 # -F is followed by name of file containing list of filenames
137 my $flist = $opt{'f'};
138 open(FLIST,$flist) || die "Cannot open $flist:$!";
139 chomp(@encfiles = <FLIST>);
145 my $cname = (exists $opt{'o'}) ? $opt{'o'} : shift(@ARGV);
146 chmod(0666,$cname) if -f $cname && !-w $cname;
147 open(C,">$cname") || die "Cannot open $cname:$!";
152 my ($doC,$doEnc,$doUcm,$doPet);
154 if ($cname =~ /\.(c|xs)$/)
157 $dname =~ s/(\.[^\.]*)?$/_def.h/;
158 chmod(0666,$dname) if -f $cname && !-w $dname;
159 open(D,">$dname") || die "Cannot open $dname:$!";
160 $hname =~ s/(\.[^\.]*)?$/.h/;
161 chmod(0666,$hname) if -f $cname && !-w $hname;
162 open(H,">$hname") || die "Cannot open $hname:$!";
164 foreach my $fh (\*C,\*D,\*H)
166 print $fh <<"END" unless $opt{'q'};
168 !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
169 This file was autogenerated by:
175 if ($cname =~ /(\w+)\.xs$/)
177 print C "#include <EXTERN.h>\n";
178 print C "#include <perl.h>\n";
179 print C "#include <XSUB.h>\n";
180 print C "#define U8 U8\n";
182 print C "#include \"encode.h\"\n";
185 elsif ($cname =~ /\.enc$/)
189 elsif ($cname =~ /\.ucm$/)
193 elsif ($cname =~ /\.pet$/)
206 if ($a =~ /^.*-(\d+)/)
209 if ($b =~ /^.*-(\d+)/)
219 foreach my $enc (sort cmp_name @encfiles)
221 my ($name,$sfx) = $enc =~ /^.*?([\w-]+)\.(enc|ucm)$/;
222 $name = $opt{'n'} if exists $opt{'n'};
227 compile_enc(\*E,lc($name));
231 compile_ucm(\*E,lc($name));
236 warn "Cannot open $enc for $name:$!";
242 print STDERR "Writing compiled form\n";
243 foreach my $name (sort cmp_name keys %encoding)
245 my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}};
246 output(\*C,$name.'_utf8',$e2u);
247 output(\*C,'utf8_'.$name,$u2e);
248 push(@{$encoding{$name}},outstring(\*C,$e2u->{Cname}.'_def',$erep));
250 foreach my $enc (sort cmp_name keys %encoding)
252 my ($e2u,$u2e,$rep,$min_el,$max_el,$rsym) = @{$encoding{$enc}};
253 my @info = ($e2u->{Cname},$u2e->{Cname},$rsym,length($rep),$min_el,$max_el);
254 my $sym = "${enc}_encoding";
256 print C "encode_t $sym = \n";
257 print C " {",join(',',@info,"{\"$enc\",(const char *)0}"),"};\n\n";
260 foreach my $enc (sort cmp_name keys %encoding)
262 my $sym = "${enc}_encoding";
264 print H "extern encode_t $sym;\n";
265 print D " Encode_XSEncoding(aTHX_ &$sym);\n";
268 if ($cname =~ /(\w+)\.xs$/)
274 Encode_XSEncoding(pTHX_ encode_t *enc)
277 HV *stash = gv_stashpv("Encode::XS", TRUE);
278 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(enc))),stash);
284 const char *name = enc->name[i++];
285 XPUSHs(sv_2mortal(newSVpvn(name,strlen(name))));
288 call_pv("Encode::define_encoding",G_DISCARD);
294 print C "\nMODULE = Encode::$mod\tPACKAGE = Encode::$mod\n\n";
295 print C "BOOT:\n{\n";
296 print C "#include \"$dname\"\n";
299 # Close in void context is bad, m'kay
300 close(D) or warn "Error closing '$dname': $!";
301 close(H) or warn "Error closing '$hname': $!";
303 my $perc_saved = $strings/($strings + $saved) * 100;
304 my $perc_subsaved = $strings/($strings + $subsave) * 100;
305 printf STDERR "%d bytes in string tables\n",$strings;
306 printf STDERR "%d bytes (%.3g%%) saved spotting duplicates\n",
307 $saved, $perc_saved if $saved;
308 printf STDERR "%d bytes (%.3g%%) saved using substrings\n",
309 $subsave, $perc_subsaved if $subsave;
313 foreach my $name (sort cmp_name keys %encoding)
315 my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}};
316 output_enc(\*C,$name,$e2u);
321 foreach my $name (sort cmp_name keys %encoding)
323 my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}};
324 output_ucm(\*C,$name,$u2e,$erep,$min_el,$max_el);
328 # writing half meg files and then not checking to see if you just filled the
330 close(C) or die "Error closing '$cname': $!";
332 # End of the main program.
344 last if /^\s*CHARMAP\s*$/i;
345 if (/^\s*<(\w+)>\s+"?([^"]*)"?\s*$/i) # " # Grrr
350 if (!defined($cs = $attr{'code_set_name'}))
352 warn "No <code_set_name> in $name\n";
356 $name = $cs unless exists $opt{'n'};
362 if (exists $attr{'subchar'})
365 $attr{'subchar'} =~ /^\s*/cg;
366 push(@byte,$1) while $attr{'subchar'} =~ /\G\\x([0-9a-f]+)/icg;
367 $erep = join('',map(chr(hex($_)),@byte));
369 print "Reading $name ($cs)\n";
375 last if /^\s*END\s+CHARMAP\s*$/i;
379 $u = $1 if (/^<U([0-9a-f]+)>\s+/igc);
380 push(@byte,$1) while /\G\\x([0-9a-f]+)/igc;
381 $fb = $1 if /\G\s*(\|[0-3])/gc;
382 # warn "$_: $u @byte | $fb\n";
383 die "Bad line:$_" unless /\G\s*(#.*)?$/gc;
386 my $uch = encode_U(hex($u));
387 my $ech = join('',map(chr(hex($_)),@byte));
388 my $el = length($ech);
389 $max_el = $el if (!defined($max_el) || $el > $max_el);
390 $min_el = $el if (!defined($min_el) || $el < $min_el);
401 # $fb is fallback flag
402 # 0 - round trip safe
403 # 1 - fallback for unicode -> enc
404 # 2 - skip sub-char mapping
405 # 3 - fallback enc -> unicode
406 enter($u2e,$uch,$ech,$u2e,$fb+0) if ($fb =~ /[01]/);
407 enter($e2u,$ech,$uch,$e2u,$fb+0) if ($fb =~ /[03]/);
416 die "$nfb entries without fallback, $hfb entries with\n";
418 $encoding{$name} = [$e2u,$u2e,$erep,$min_el,$max_el];
428 while ($type = <$fh>)
430 last if $type !~ /^\s*#/;
433 return if $type eq 'E';
434 # Do the hash lookup once, rather than once per function call. 4% speedup.
435 my $type_func = $encode_types{$type};
436 my ($def,$sym,$pages) = split(/\s+/,scalar(<$fh>));
437 warn "$type encoded $name\n";
439 # Save a defined test by setting these to defined values.
440 my $min_el = ~0; # A very big integer
441 my $max_el = 0; # Anything must be longer than 0
444 $rep = &$type_func($v & 0xFF, ($v >> 8) & 0xffe);
448 # use -Q to silence the seen test. Makefile.PL uses this by default.
449 $seen = {} unless $opt{Q};
454 my $page = hex($line);
459 # So why is it 1% faster to leave the my here?
461 die "Line should be exactly 65 characters long including newline"
462 unless length ($line) == 65;
463 # Split line into groups of 4 hex digits, convert groups to ints
465 # map {hex $_} $line =~ /(....)/g
466 # This takes 63.75 (2.5% less time)
467 # unpack "n*", pack "H*", $line
468 # There's an implicit loop in map. Loops are bad, m'kay. Ops are bad, m'kay
469 # Doing it as while ($line =~ /(....)/g) took 74.63
470 foreach my $val (unpack "n*", pack "H*", $line)
472 next if $val == 0xFFFD;
473 my $ech = &$type_func($ch,$page);
474 if ($val || (!$ch && !$page))
476 my $el = length($ech);
477 $max_el = $el if $el > $max_el;
478 $min_el = $el if $el < $min_el;
479 my $uch = encode_U($val);
481 # We're doing the test.
482 # We don't need to read this quickly, so storing it as a scalar,
483 # rather than 3 (anon array, plus the 2 scalars it holds) saves
484 # RAM and may make us faster on low RAM systems. [see __END__]
485 if (exists $seen->{$uch})
487 warn sprintf("U%04X is %02X%02X and %04X\n",
488 $val,$page,$ch,$seen->{$uch});
493 $seen->{$uch} = $page << 8 | $ch;
496 # Passing 2 extra args each time is 3.6% slower!
497 # Even with having to add $fallback ||= 0 later
498 enter_fb0($e2u,$ech,$uch);
499 enter_fb0($u2e,$uch,$ech);
503 # No character at this position
504 # enter($e2u,$ech,undef,$e2u);
510 die "\$min_el=$min_el, \$max_el=$max_el - seems we read no lines"
511 if $min_el > $max_el;
512 die "$errors mapping conflicts\n" if ($errors && $opt{'S'});
513 $encoding{$name} = [$e2u,$u2e,$rep,$min_el,$max_el];
516 # my ($a,$s,$d,$t,$fb) = @_;
518 my ($current,$inbytes,$outbytes,$next,$fallback) = @_;
519 # state we shift to after this (multibyte) input character defaults to same
522 # Making sure it is defined seems to be faster than {no warnings;} in
523 # &process, or passing it in as 0 explicity.
524 # XXX $fallback ||= 0;
526 # Start at the beginning and work forwards through the string to zero.
527 # effectively we are removing 1 character from the front each time
528 # but we don't actually edit the string. [this alone seems to be 14% speedup]
529 # Hence -$pos is the length of the remaining string.
530 my $pos = -length $inbytes;
532 my $byte = substr $inbytes, $pos, 1;
535 # RAW_OUT_BYTES => 2,
537 # to unicode an array would seem to be better, because the pages are dense.
538 # from unicode can be very sparse, favouring a hash.
539 # hash using the bytes (all length 1) as keys rather than ord value,
540 # as it's easier to sort these in &process.
542 # It's faster to always add $fallback even if it's undef, rather than
543 # choosing between 3 and 4 element array. (hence why we set it defined
545 my $do_now = $current->{Raw}{$byte} ||= [{},-$pos,'',$fallback];
546 # When $pos was -1 we were at the last input character.
548 $do_now->[RAW_OUT_BYTES] = $outbytes;
549 $do_now->[RAW_NEXT] = $next;
552 # Tail recursion. The intermdiate state may not have a name yet.
553 $current = $do_now->[RAW_NEXT];
557 # This is purely for optimistation. It's just &enter hard coded for $fallback
558 # of 0, using only a 3 entry array ref to save memory for every entry.
560 my ($current,$inbytes,$outbytes,$next) = @_;
563 my $pos = -length $inbytes;
565 my $byte = substr $inbytes, $pos, 1;
566 my $do_now = $current->{Raw}{$byte} ||= [{},-$pos,''];
568 $do_now->[RAW_OUT_BYTES] = $outbytes;
569 $do_now->[RAW_NEXT] = $next;
572 $current = $do_now->[RAW_NEXT];
579 my ($fh,$name,$s) = @_;
580 my $sym = $strings{$s};
583 $saved += length($s);
588 foreach my $o (keys %strings)
590 next unless (my $i = index($o,$s)) >= 0;
592 $sym .= sprintf("+0x%02x",$i) if ($i);
593 $subsave += length($s);
594 return $strings{$s} = $sym;
597 $strings{$s} = $sym = $name;
598 $strings += length($s);
599 my $definition = sprintf "static const U8 %s[%d] = { ",$name,length($s);
600 # Maybe we should assert that these are all <256.
601 $definition .= join(',',unpack "C*",$s);
602 # We have a single long line. Split it at convenient commas.
603 $definition =~ s/(.{74,77},)/$1\n/g;
604 print $fh "$definition };\n\n";
615 my ($l, $agg_max_in, $agg_next, $agg_in_len, $agg_out_len, $agg_fallback);
618 foreach my $key (sort keys %$raw) {
621 # RAW_OUT_BYTES => 2,
623 my ($next, $in_len, $out_bytes, $fallback) = @{$raw->{$key}};
624 # Now we are converting from raw to aggregate, switch from 1 byte strings
629 # If this == fails, we're going to reset $agg_max_in below anyway.
630 $b == ++$agg_max_in &&
631 # References in numeric context give the pointer as an int.
632 $agg_next == $next &&
633 $agg_in_len == $in_len &&
634 $agg_out_len == length $out_bytes &&
635 $agg_fallback == $fallback
636 # && length($l->[AGG_OUT_BYTES]) < 16
638 # my $i = ord($b)-ord($l->[AGG_MIN_IN]);
639 # we can aggregate this byte onto the end.
640 $l->[AGG_MAX_IN] = $b;
641 $l->[AGG_OUT_BYTES] .= $out_bytes;
645 # AGG_OUT_BYTES => 2,
650 # Reset the last thing we saw, plus set 5 lexicals to save some derefs.
651 # (only gains .6% on euc-jp -- is it worth it?)
652 push @ent, $l = [$b, $agg_max_in = $b, $out_bytes, $agg_next = $next,
653 $agg_in_len = $in_len, $agg_out_len = length $out_bytes,
654 $agg_fallback = $fallback];
656 if (exists $next->{Cname}) {
657 $next->{'Forward'} = 1 if $next != $a;
659 process(sprintf("%s_%02x",$name,$b),$next);
662 # encengine.c rules say that last entry must be for 255
663 if ($agg_max_in < 255) {
664 push @ent, [1+$agg_max_in, 255,undef,$a,0,0];
666 $a->{'Entries'} = \@ent;
672 my $name = $a->{'Cname'};
674 foreach my $b (@{$a->{'Entries'}})
676 next unless $b->[AGG_OUT_LEN];
677 my $s = $b->[AGG_MIN_IN];
678 my $e = $b->[AGG_MAX_IN];
679 outstring($fh,sprintf("%s__%02x_%02x",$name,$s,$e),$b->[AGG_OUT_BYTES]);
683 print $fh "\nstatic encpage_t $name\[",scalar(@{$a->{'Entries'}}),"];\n";
686 foreach my $b (@{$a->{'Entries'}})
688 my ($s,$e,$out,$t,$end,$l) = @$b;
689 outtable($fh,$t) unless $t->{'Done'};
691 print $fh "\nstatic encpage_t $name\[",scalar(@{$a->{'Entries'}}),"] = {\n";
692 foreach my $b (@{$a->{'Entries'}})
694 my ($sc,$ec,$out,$t,$end,$l,$fb) = @$b;
699 printf $fh outstring($fh,'',$out);
705 print $fh ",",$t->{Cname};
706 printf $fh ",0x%02x,0x%02x,$l,$end},\n",$sc,$ec;
713 my ($fh,$name,$a) = @_;
721 my ($fh,$name,$a) = @_;
722 die "Changed - fix me for new structure";
723 foreach my $b (sort keys %$a)
725 my ($s,$e,$out,$t,$end,$l,$fb) = @{$a->{$b}};
737 my $s = do "unicore/Name.pl";
738 die "char_names: unicore/Name.pl: $!\n" unless defined $s;
740 while ($s =~ /\G([0-9a-f]+)\t([0-9a-f]*)\t(.*?)\s*\n/igc)
744 last if $s >= 0x10000;
745 my $e = length($2) ? hex($2) : $s;
746 for (my $i = $s; $i <= $e; $i++)
749 # print sprintf("U%04X $name\n",$i);
756 my ($cmap,$a,$t,$pre) = @_;
757 # warn sprintf("Page %x\n",$pre);
759 foreach my $key (sort keys %$raw) {
762 # RAW_OUT_BYTES => 2,
764 my ($next, $in_len, $out_bytes, $fallback) = @{$raw->{$key}};
768 if ($next != $a && $next != $t) {
769 output_ucm_page($cmap,$a,$next,(($pre|($u &0x3F)) << 6)&0xFFFF);
770 } elsif (length $out_bytes) {
772 $u = $pre|($u &0x3f);
774 my $s = sprintf "<U%04X> ",$u;
775 #foreach my $c (split(//,$out_bytes)) {
776 # $s .= sprintf "\\x%02X",ord($c);
778 # 9.5% faster changing that loop to this:
779 $s .= sprintf +("\\x%02X" x length $out_bytes), unpack "C*", $out_bytes;
780 $s .= sprintf " |%d # %s\n",($fallback ? 1 : 0),$uname[$u];
783 warn join(',',$u, @{$raw->{$key}},$a,$t);
790 my ($fh,$name,$h,$rep,$min_el,$max_el) = @_;
791 print $fh "# $0 @orig_ARGV\n" unless $opt{'q'};
792 print $fh "<code_set_name> \"$name\"\n";
796 print $fh "<mb_cur_min> $min_el\n";
800 print $fh "<mb_cur_max> $max_el\n";
804 print $fh "<subchar> ";
805 foreach my $c (split(//,$rep))
807 printf $fh "\\x%02X",ord($c);
812 output_ucm_page(\@cmap,$h,$h,0);
813 print $fh "#\nCHARMAP\n";
814 foreach my $line (sort { substr($a,8) cmp substr($b,8) } @cmap)
818 print $fh "END CHARMAP\n";
823 With %seen holding array refs:
825 865.66 real 28.80 user 8.79 sys
826 7904 maximum resident set size
827 1356 average shared memory size
828 18566 average unshared data size
829 229 average unshared stack size
833 With %seen holding simple scalars:
835 342.16 real 27.11 user 3.54 sys
836 8388 maximum resident set size
837 1394 average shared memory size
838 14969 average unshared data size
839 236 average unshared stack size
843 Yes, 5 minutes is faster than 15. Above is for CP936 in CN. Only difference is
844 how %seen is storing things its seen. So it is pathalogically bad on a 16M
845 RAM machine, but it's going to help even on modern machines.
846 Swapping is bad, m'kay :-)