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;
11 my @orig_ARGV = @ARGV;
12 our $VERSION = do { my @r = (q$Revision: 2.4 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
14 # These may get re-ordered.
15 # RAW is a do_now as inserted by &enter
16 # AGG is an aggreagated do_now, as built up by &process
33 # (See the algorithm in encengine.c - we're building structures for it)
35 # There are two sorts of structures.
36 # "do_now" (an array, two variants of what needs storing) is whatever we need
37 # to do now we've read an input byte.
38 # It's housed in a "do_next" (which is how we got to it), and in turn points
39 # to a "do_next" which contains all the "do_now"s for the next input byte.
41 # There will be a "do_next" which is the start state.
42 # For a single byte encoding it's the only "do_next" - each "do_now" points
43 # back to it, and each "do_now" will cause bytes. There is no state.
45 # For a multi-byte encoding where all characters in the input are the same
46 # length, then there will be a tree of "do_now"->"do_next"->"do_now"
47 # branching out from the start state, one step for each input byte.
48 # The leaf "do_now"s will all be at the same distance from the start state,
49 # only the leaf "do_now"s cause output bytes, and they in turn point back to
52 # For an encoding where there are varaible length input byte sequences, you
53 # will encounter a leaf "do_now" sooner for the shorter input sequences, but
54 # as before the leaves will point back to the start state.
56 # The system will cope with escape encodings (imagine them as a mostly
57 # self-contained tree for each escape state, and cross links between trees
58 # at the state-switching characters) but so far no input format defines these.
60 # The system will also cope with having output "leaves" in the middle of
61 # the bifurcating branches, not just at the extremities, but again no
62 # input format does this yet.
64 # There are two variants of the "do_now" structure. The first, smaller variant
65 # is generated by &enter as the input file is read. There is one structure
66 # for each input byte. Say we are mapping a single byte encoding to a
67 # single byte encoding, with "ABCD" going "abcd". There will be
68 # 4 "do_now"s, {"A" => [...,"a",...], "B" => [...,"b",...], "C"=>..., "D"=>...}
70 # &process then walks the tree, building aggregate "do_now" structres for
71 # adjacent bytes where possible. The aggregate is for a contiguous range of
72 # bytes which each produce the same length of output, each move to the
73 # same next state, and each have the same fallback flag.
74 # So our 4 RAW "do_now"s above become replaced by a single structure
76 # ["A", "D", "abcd", 1, ...]
77 # ie, for an input byte $_ in "A".."D", output 1 byte, found as
78 # substr ("abcd", (ord $_ - ord "A") * 1, 1)
79 # which maps very nicely into pointer arithmetic in C for encengine.c
83 # UTF-8 encode long hand - only covers part of perl's range
85 # chr() works in native space so convert value from table
86 # into that space before using chr().
87 my $ch = chr(utf8::unicode_to_native($_[0]));
88 # Now get core perl to encode that the way it likes.
96 ## my ($ch,$page) = @_; return chr($ch);
102 # encode double byte MS byte first
103 ## my ($ch,$page) = @_; return chr($page).chr($ch);
104 return chr ($_[1]) . chr $_[0];
109 # encode Multi-byte - single for 0..255 otherwise double
110 ## my ($ch,$page) = @_;
111 ## return &encode_D if $page;
113 return chr ($_[1]) . chr $_[0] if $_[1];
117 my %encode_types = (U => \&encode_U,
123 # Win32 does not expand globs on command line
124 eval "\@ARGV = map(glob(\$_),\@ARGV)" if ($^O eq 'MSWin32');
128 # -Q to disable the duplicate codepoint test
129 # -S make mapping errors fatal
130 # -q to remove comments written to output files
131 # -O to enable the (brute force) substring optimiser
132 # -o <output> to specify the output file name (else it's the first arg)
133 # -f <inlist> to give a file with a list of input files (else use the args)
134 # -n <name> to name the encoding (else use the basename of the input file.
135 getopts('CM:SQqOo:f:n:',\%opt);
137 $opt{M} and make_makefile_pl($opt{M}, @ARGV);
138 $opt{C} and make_configlocal_pm($opt{C}, @ARGV);
140 # This really should go first, else the die here causes empty (non-erroneous)
141 # output files to be written.
143 if (exists $opt{'f'}) {
144 # -F is followed by name of file containing list of filenames
145 my $flist = $opt{'f'};
146 open(FLIST,$flist) || die "Cannot open $flist:$!";
147 chomp(@encfiles = <FLIST>);
153 my $cname = (exists $opt{'o'}) ? $opt{'o'} : shift(@ARGV);
154 chmod(0666,$cname) if -f $cname && !-w $cname;
155 open(C,">$cname") || die "Cannot open $cname:$!";
160 my ($doC,$doEnc,$doUcm,$doPet);
162 if ($cname =~ /\.(c|xs)$/i) # VMS may have upcased filenames with DECC$ARGV_PARSE_STYLE defined
165 $dname =~ s/(\.[^\.]*)?$/.exh/;
166 chmod(0666,$dname) if -f $cname && !-w $dname;
167 open(D,">$dname") || die "Cannot open $dname:$!";
168 $hname =~ s/(\.[^\.]*)?$/.h/;
169 chmod(0666,$hname) if -f $cname && !-w $hname;
170 open(H,">$hname") || die "Cannot open $hname:$!";
172 foreach my $fh (\*C,\*D,\*H)
174 print $fh <<"END" unless $opt{'q'};
176 !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
177 This file was autogenerated by:
183 if ($cname =~ /(\w+)\.xs$/)
185 print C "#include <EXTERN.h>\n";
186 print C "#include <perl.h>\n";
187 print C "#include <XSUB.h>\n";
188 print C "#define U8 U8\n";
190 print C "#include \"encode.h\"\n\n";
193 elsif ($cname =~ /\.enc$/)
197 elsif ($cname =~ /\.ucm$/)
201 elsif ($cname =~ /\.pet$/)
217 if ($a =~ /^.*-(\d+)/)
220 if ($b =~ /^.*-(\d+)/)
230 foreach my $enc (sort cmp_name @encfiles)
232 my ($name,$sfx) = $enc =~ /^.*?([\w-]+)\.(enc|ucm)$/;
233 $name = $opt{'n'} if exists $opt{'n'};
238 compile_enc(\*E,lc($name));
242 compile_ucm(\*E,lc($name));
247 warn "Cannot open $enc for $name:$!";
253 print STDERR "Writing compiled form\n";
254 foreach my $name (sort cmp_name keys %encoding)
256 my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}};
257 process($name.'_utf8',$e2u);
258 addstrings(\*C,$e2u);
260 process('utf8_'.$name,$u2e);
261 addstrings(\*C,$u2e);
263 outbigstring(\*C,"enctable");
264 foreach my $name (sort cmp_name keys %encoding)
266 my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}};
267 outtable(\*C,$e2u, "enctable");
268 outtable(\*C,$u2e, "enctable");
270 # push(@{$encoding{$name}},outstring(\*C,$e2u->{Cname}.'_def',$erep));
272 foreach my $enc (sort cmp_name keys %encoding)
274 # my ($e2u,$u2e,$rep,$min_el,$max_el,$rsym) = @{$encoding{$enc}};
275 my ($e2u,$u2e,$rep,$min_el,$max_el) = @{$encoding{$enc}};
276 #my @info = ($e2u->{Cname},$u2e->{Cname},$rsym,length($rep),$min_el,$max_el);
278 $replen++ while($rep =~ /\G\\x[0-9A-Fa-f]/g);
279 my $sym = "${enc}_encoding";
281 my @info = ($e2u->{Cname},$u2e->{Cname},"${sym}_rep_character",$replen,
283 print C "static const U8 ${sym}_rep_character[] = \"$rep\";\n";
284 print C "static const char ${sym}_enc_name[] = \"$enc\";\n\n";
285 print C "const encode_t $sym = \n";
286 # This is to make null encoding work -- dankogai
287 for (my $i = (scalar @info) - 1; $i >= 0; --$i){
290 # end of null tweak -- dankogai
291 print C " {",join(',',@info,"{${sym}_enc_name,(const char *)0}"),"};\n\n";
294 foreach my $enc (sort cmp_name keys %encoding)
296 my $sym = "${enc}_encoding";
298 print H "extern encode_t $sym;\n";
299 print D " Encode_XSEncoding(aTHX_ &$sym);\n";
302 if ($cname =~ /(\w+)\.xs$/)
308 Encode_XSEncoding(pTHX_ encode_t *enc)
311 HV *stash = gv_stashpv("Encode::XS", TRUE);
312 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(enc))),stash);
318 const char *name = enc->name[i++];
319 XPUSHs(sv_2mortal(newSVpvn(name,strlen(name))));
322 call_pv("Encode::define_encoding",G_DISCARD);
328 print C "\nMODULE = Encode::$mod\tPACKAGE = Encode::$mod\n\n";
329 print C "BOOT:\n{\n";
330 print C "#include \"$dname\"\n";
333 # Close in void context is bad, m'kay
334 close(D) or warn "Error closing '$dname': $!";
335 close(H) or warn "Error closing '$hname': $!";
337 my $perc_saved = $saved/($strings + $saved) * 100;
338 my $perc_subsaved = $subsave/($strings + $subsave) * 100;
339 printf STDERR "%d bytes in string tables\n",$strings;
340 printf STDERR "%d bytes (%.3g%%) saved spotting duplicates\n",
341 $saved, $perc_saved if $saved;
342 printf STDERR "%d bytes (%.3g%%) saved using substrings\n",
343 $subsave, $perc_subsaved if $subsave;
347 foreach my $name (sort cmp_name keys %encoding)
349 my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}};
350 output_enc(\*C,$name,$e2u);
355 foreach my $name (sort cmp_name keys %encoding)
357 my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}};
358 output_ucm(\*C,$name,$u2e,$erep,$min_el,$max_el);
362 # writing half meg files and then not checking to see if you just filled the
364 close(C) or die "Error closing '$cname': $!";
366 # End of the main program.
378 last if /^\s*CHARMAP\s*$/i;
379 if (/^\s*<(\w+)>\s+"?([^"]*)"?\s*$/i) # " # Grrr
384 if (!defined($cs = $attr{'code_set_name'}))
386 warn "No <code_set_name> in $name\n";
390 $name = $cs unless exists $opt{'n'};
396 if (exists $attr{'subchar'})
399 #$attr{'subchar'} =~ /^\s*/cg;
400 #push(@byte,$1) while $attr{'subchar'} =~ /\G\\x([0-9a-f]+)/icg;
401 #$erep = join('',map(chr(hex($_)),@byte));
402 $erep = $attr{'subchar'};
403 $erep =~ s/^\s+//; $erep =~ s/\s+$//;
405 print "Reading $name ($cs)\n";
411 last if /^\s*END\s+CHARMAP\s*$/i;
413 my (@uni, @byte) = ();
414 my ($uni, $byte, $fb) = m/^(\S+)\s+(\S+)\s+(\S+)\s+/o
415 or die "Bad line: $_";
416 while ($uni =~ m/\G<([U0-9a-fA-F\+]+)>/g){
417 push @uni, map { substr($_, 1) } split(/\+/, $1);
419 while ($byte =~ m/\G\\x([0-9a-fA-F]+)/g){
424 my $uch = join('', map { encode_U(hex($_)) } @uni );
425 my $ech = join('',map(chr(hex($_)),@byte));
426 my $el = length($ech);
427 $max_el = $el if (!defined($max_el) || $el > $max_el);
428 $min_el = $el if (!defined($min_el) || $el < $min_el);
439 # $fb is fallback flag
440 # 0 - round trip safe
441 # 1 - fallback for unicode -> enc
442 # 2 - skip sub-char mapping
443 # 3 - fallback enc -> unicode
444 enter($u2e,$uch,$ech,$u2e,$fb+0) if ($fb =~ /[01]/);
445 enter($e2u,$ech,$uch,$e2u,$fb+0) if ($fb =~ /[03]/);
454 die "$nfb entries without fallback, $hfb entries with\n";
456 $encoding{$name} = [$e2u,$u2e,$erep,$min_el,$max_el];
468 while ($type = <$fh>)
470 last if $type !~ /^\s*#/;
473 return if $type eq 'E';
474 # Do the hash lookup once, rather than once per function call. 4% speedup.
475 my $type_func = $encode_types{$type};
476 my ($def,$sym,$pages) = split(/\s+/,scalar(<$fh>));
477 warn "$type encoded $name\n";
479 # Save a defined test by setting these to defined values.
480 my $min_el = ~0; # A very big integer
481 my $max_el = 0; # Anything must be longer than 0
484 $rep = &$type_func($v & 0xFF, ($v >> 8) & 0xffe);
488 # use -Q to silence the seen test. Makefile.PL uses this by default.
489 $seen = {} unless $opt{Q};
494 my $page = hex($line);
499 # So why is it 1% faster to leave the my here?
501 $line =~ s/\r\n$/\n/;
502 die "$.:${line}Line should be exactly 65 characters long including
503 newline (".length($line).")" unless length ($line) == 65;
504 # Split line into groups of 4 hex digits, convert groups to ints
506 # map {hex $_} $line =~ /(....)/g
507 # This takes 63.75 (2.5% less time)
508 # unpack "n*", pack "H*", $line
509 # There's an implicit loop in map. Loops are bad, m'kay. Ops are bad, m'kay
510 # Doing it as while ($line =~ /(....)/g) took 74.63
511 foreach my $val (unpack "n*", pack "H*", $line)
513 next if $val == 0xFFFD;
514 my $ech = &$type_func($ch,$page);
515 if ($val || (!$ch && !$page))
517 my $el = length($ech);
518 $max_el = $el if $el > $max_el;
519 $min_el = $el if $el < $min_el;
520 my $uch = encode_U($val);
522 # We're doing the test.
523 # We don't need to read this quickly, so storing it as a scalar,
524 # rather than 3 (anon array, plus the 2 scalars it holds) saves
525 # RAM and may make us faster on low RAM systems. [see __END__]
526 if (exists $seen->{$uch})
528 warn sprintf("U%04X is %02X%02X and %04X\n",
529 $val,$page,$ch,$seen->{$uch});
534 $seen->{$uch} = $page << 8 | $ch;
537 # Passing 2 extra args each time is 3.6% slower!
538 # Even with having to add $fallback ||= 0 later
539 enter_fb0($e2u,$ech,$uch);
540 enter_fb0($u2e,$uch,$ech);
544 # No character at this position
545 # enter($e2u,$ech,undef,$e2u);
551 die "\$min_el=$min_el, \$max_el=$max_el - seems we read no lines"
552 if $min_el > $max_el;
553 die "$errors mapping conflicts\n" if ($errors && $opt{'S'});
554 $encoding{$name} = [$e2u,$u2e,$rep,$min_el,$max_el];
557 # my ($a,$s,$d,$t,$fb) = @_;
559 my ($current,$inbytes,$outbytes,$next,$fallback) = @_;
560 # state we shift to after this (multibyte) input character defaults to same
563 # Making sure it is defined seems to be faster than {no warnings;} in
564 # &process, or passing it in as 0 explicity.
565 # XXX $fallback ||= 0;
567 # Start at the beginning and work forwards through the string to zero.
568 # effectively we are removing 1 character from the front each time
569 # but we don't actually edit the string. [this alone seems to be 14% speedup]
570 # Hence -$pos is the length of the remaining string.
571 my $pos = -length $inbytes;
573 my $byte = substr $inbytes, $pos, 1;
576 # RAW_OUT_BYTES => 2,
578 # to unicode an array would seem to be better, because the pages are dense.
579 # from unicode can be very sparse, favouring a hash.
580 # hash using the bytes (all length 1) as keys rather than ord value,
581 # as it's easier to sort these in &process.
583 # It's faster to always add $fallback even if it's undef, rather than
584 # choosing between 3 and 4 element array. (hence why we set it defined
586 my $do_now = $current->{Raw}{$byte} ||= [{},-$pos,'',$fallback];
587 # When $pos was -1 we were at the last input character.
589 $do_now->[RAW_OUT_BYTES] = $outbytes;
590 $do_now->[RAW_NEXT] = $next;
593 # Tail recursion. The intermdiate state may not have a name yet.
594 $current = $do_now->[RAW_NEXT];
598 # This is purely for optimistation. It's just &enter hard coded for $fallback
599 # of 0, using only a 3 entry array ref to save memory for every entry.
601 my ($current,$inbytes,$outbytes,$next) = @_;
604 my $pos = -length $inbytes;
606 my $byte = substr $inbytes, $pos, 1;
607 my $do_now = $current->{Raw}{$byte} ||= [{},-$pos,''];
609 $do_now->[RAW_OUT_BYTES] = $outbytes;
610 $do_now->[RAW_NEXT] = $next;
613 $current = $do_now->[RAW_NEXT];
623 my ($l, $agg_max_in, $agg_next, $agg_in_len, $agg_out_len, $agg_fallback);
626 foreach my $key (sort keys %$raw) {
629 # RAW_OUT_BYTES => 2,
631 my ($next, $in_len, $out_bytes, $fallback) = @{$raw->{$key}};
632 # Now we are converting from raw to aggregate, switch from 1 byte strings
637 # If this == fails, we're going to reset $agg_max_in below anyway.
638 $b == ++$agg_max_in &&
639 # References in numeric context give the pointer as an int.
640 $agg_next == $next &&
641 $agg_in_len == $in_len &&
642 $agg_out_len == length $out_bytes &&
643 $agg_fallback == $fallback
644 # && length($l->[AGG_OUT_BYTES]) < 16
646 # my $i = ord($b)-ord($l->[AGG_MIN_IN]);
647 # we can aggregate this byte onto the end.
648 $l->[AGG_MAX_IN] = $b;
649 $l->[AGG_OUT_BYTES] .= $out_bytes;
653 # AGG_OUT_BYTES => 2,
658 # Reset the last thing we saw, plus set 5 lexicals to save some derefs.
659 # (only gains .6% on euc-jp -- is it worth it?)
660 push @ent, $l = [$b, $agg_max_in = $b, $out_bytes, $agg_next = $next,
661 $agg_in_len = $in_len, $agg_out_len = length $out_bytes,
662 $agg_fallback = $fallback];
664 if (exists $next->{Cname}) {
665 $next->{'Forward'} = 1 if $next != $a;
667 process(sprintf("%s_%02x",$name,$b),$next);
670 # encengine.c rules say that last entry must be for 255
671 if ($agg_max_in < 255) {
672 push @ent, [1+$agg_max_in, 255,undef,$a,0,0];
674 $a->{'Entries'} = \@ent;
681 my $name = $a->{'Cname'};
683 foreach my $b (@{$a->{'Entries'}})
685 next unless $b->[AGG_OUT_LEN];
686 $strings{$b->[AGG_OUT_BYTES]} = undef;
690 my $var = $^O eq 'MacOS' ? 'extern' : 'static';
691 print $fh "$var const encpage_t $name\[",scalar(@{$a->{'Entries'}}),"];\n";
693 $a->{'DoneStrings'} = 1;
694 foreach my $b (@{$a->{'Entries'}})
696 my ($s,$e,$out,$t,$end,$l) = @$b;
697 addstrings($fh,$t) unless $t->{'DoneStrings'};
707 # Make the big string in the string accumulator. Longest first, on the hope
708 # that this makes it more likely that we find the short strings later on.
709 # Not sure if it helps sorting strings of the same length lexcically.
710 foreach my $s (sort {length $b <=> length $a || $a cmp $b} keys %strings) {
711 my $index = index $string_acc, $s;
713 $saved += length($s);
714 $strings_in_acc{$s} = $index;
718 my $sublength = length $s;
719 while (--$sublength > 0) {
720 # progressively lop characters off the end, to see if the start of
721 # the new string overlaps the end of the accumulator.
722 if (substr ($string_acc, -$sublength)
723 eq substr ($s, 0, $sublength)) {
724 $subsave += $sublength;
725 $strings_in_acc{$s} = length ($string_acc) - $sublength;
726 # append the last bit on the end.
727 $string_acc .= substr ($s, $sublength);
730 # or if the end of the new string overlaps the start of the
732 next unless substr ($string_acc, 0, $sublength)
733 eq substr ($s, -$sublength);
734 # well, the last $sublength characters of the accumulator match.
735 # so as we're prepending to the accumulator, need to shift all our
736 # existing offsets forwards
737 $_ += $sublength foreach values %strings_in_acc;
738 $subsave += $sublength;
739 $strings_in_acc{$s} = 0;
740 # append the first bit on the start.
741 $string_acc = substr ($s, 0, -$sublength) . $string_acc;
745 # Optimiser (if it ran) found nothing, so just going have to tack the
746 # whole thing on the end.
747 $strings_in_acc{$s} = length $string_acc;
753 $strings = length $string_acc;
754 my $definition = "\nstatic const U8 $name\[$strings] = { " .
755 join(',',unpack "C*",$string_acc);
756 # We have a single long line. Split it at convenient commas.
757 print $fh $1, "\n" while $definition =~ /\G(.{74,77},)/gcs;
758 print $fh substr ($definition, pos $definition), " };\n";
763 my $offset = $strings_in_acc{$s};
764 die "Can't find string " . join (',',unpack "C*",$s) . " in accumulator"
765 unless defined $offset;
771 my ($fh,$a,$bigname) = @_;
772 my $name = $a->{'Cname'};
774 foreach my $b (@{$a->{'Entries'}})
776 my ($s,$e,$out,$t,$end,$l) = @$b;
777 outtable($fh,$t,$bigname) unless $t->{'Done'};
779 print $fh "\nstatic const encpage_t $name\[",
780 scalar(@{$a->{'Entries'}}), "] = {\n";
781 foreach my $b (@{$a->{'Entries'}})
783 my ($sc,$ec,$out,$t,$end,$l,$fb) = @$b;
784 # $end |= 0x80 if $fb; # what the heck was on your mind, Nick? -- Dan
788 printf $fh findstring($bigname,$out);
794 print $fh ",",$t->{Cname};
795 printf $fh ",0x%02x,0x%02x,$l,$end},\n",$sc,$ec;
802 my ($fh,$name,$a) = @_;
803 die "Changed - fix me for new structure";
804 foreach my $b (sort keys %$a)
806 my ($s,$e,$out,$t,$end,$l,$fb) = @{$a->{$b}};
818 my $s = do "unicore/Name.pl";
819 die "char_names: unicore/Name.pl: $!\n" unless defined $s;
821 while ($s =~ /\G([0-9a-f]+)\t([0-9a-f]*)\t(.*?)\s*\n/igc)
825 last if $s >= 0x10000;
826 my $e = length($2) ? hex($2) : $s;
827 for (my $i = $s; $i <= $e; $i++)
830 # print sprintf("U%04X $name\n",$i);
837 my ($cmap,$a,$t,$pre) = @_;
838 # warn sprintf("Page %x\n",$pre);
840 foreach my $key (sort keys %$raw) {
843 # RAW_OUT_BYTES => 2,
845 my ($next, $in_len, $out_bytes, $fallback) = @{$raw->{$key}};
849 if ($next != $a && $next != $t) {
850 output_ucm_page($cmap,$a,$next,(($pre|($u &0x3F)) << 6)&0xFFFF);
851 } elsif (length $out_bytes) {
853 $u = $pre|($u &0x3f);
855 my $s = sprintf "<U%04X> ",$u;
856 #foreach my $c (split(//,$out_bytes)) {
857 # $s .= sprintf "\\x%02X",ord($c);
859 # 9.5% faster changing that loop to this:
860 $s .= sprintf +("\\x%02X" x length $out_bytes), unpack "C*", $out_bytes;
861 $s .= sprintf " |%d # %s\n",($fallback ? 1 : 0),$uname[$u];
864 warn join(',',$u, @{$raw->{$key}},$a,$t);
871 my ($fh,$name,$h,$rep,$min_el,$max_el) = @_;
872 print $fh "# $0 @orig_ARGV\n" unless $opt{'q'};
873 print $fh "<code_set_name> \"$name\"\n";
877 print $fh "<mb_cur_min> $min_el\n";
881 print $fh "<mb_cur_max> $max_el\n";
885 print $fh "<subchar> ";
886 foreach my $c (split(//,$rep))
888 printf $fh "\\x%02X",ord($c);
893 output_ucm_page(\@cmap,$h,$h,0);
894 print $fh "#\nCHARMAP\n";
895 foreach my $line (sort { substr($a,8) cmp substr($b,8) } @cmap)
899 print $fh "END CHARMAP\n";
913 eval { require File::Find; };
916 push @inc, $inc unless $inc eq '.'; #skip current dir
920 my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
921 $atime,$mtime,$ctime,$blksize,$blocks)
922 = lstat($_) or return;
926 $e2x_dir{$File::Find::dir} ||= $mtime;
930 warn join("\n", keys %e2x_dir), "\n";
931 for my $d (sort {$e2x_dir{$a} <=> $e2x_dir{$b}} keys %e2x_dir){
933 # warn "$_E2X => ", scalar localtime($e2x_dir{$d});
940 eval { require Encode; };
941 $@ and die "You need to install Encode to use enc2xs -M\nerror: $@\n";
942 # our used for variable expanstion
944 $_Version = $VERSION;
947 $_TableFiles = join(",", map {qq('$_')} @_);
948 $_Now = scalar localtime();
950 eval { require File::Spec; };
951 _print_expand(File::Spec->catfile($_E2X,"Makefile_PL.e2x"),"Makefile.PL");
952 _print_expand(File::Spec->catfile($_E2X,"_PM.e2x"), "$_Name.pm");
953 _print_expand(File::Spec->catfile($_E2X,"_T.e2x"), "t/$_Name.t");
954 _print_expand(File::Spec->catfile($_E2X,"README.e2x"), "README");
955 _print_expand(File::Spec->catfile($_E2X,"Changes.e2x"), "Changes");
964 sub make_configlocal_pm {
965 eval { require Encode; };
966 $@ and die "Unable to require Encode: $@\n";
967 eval { require File::Spec; };
969 # our used for variable expanstion
970 my %in_core = map { $_ => 1 } (
971 'ascii', 'iso-8859-1', 'utf8',
972 'ascii-ctrl', 'null', 'utf-8-strict'
979 $File::Find::name =~ /\A\./ and return;
980 $File::Find::name =~ /\.pm\z/ or return;
981 $File::Find::name =~ m/\bEncode\b/ or return;
982 my $mod = $File::Find::name;
983 $mod =~ s/.*\bEncode\b/Encode/o;
986 warn qq{ require $mod;\n};
987 eval qq{ require $mod; };
988 $@ and die "Can't require $mod: $@\n";
989 for my $enc ( Encode->encodings() ) {
991 $in_core{$enc} and next;
992 $Encode::Config::ExtModule{$enc} and next;
993 $LocalMod{$enc} ||= $mod;
996 File::Find::find({wanted => $wanted}, @INC);
998 for my $enc ( sort keys %LocalMod ) {
1000 qq(\$Encode::ExtModule{'$enc'} = "$LocalMod{$enc}";\n);
1003 $_LocalVer = _mkversion();
1005 $_Inc = $INC{"Encode.pm"};
1006 $_Inc =~ s/\.pm$//o;
1007 _print_expand( File::Spec->catfile( $_E2X, "ConfigLocal_PM.e2x" ),
1008 File::Spec->catfile( $_Inc, "ConfigLocal.pm" ), 1 );
1013 # v-string is now depreciated; use time() instead;
1014 #my ($ss,$mm,$hh,$dd,$mo,$yyyy) = localtime();
1015 #$yyyy += 1900, $mo +=1;
1016 #return sprintf("v%04d.%04d.%04d", $yyyy, $mo*100+$dd, $hh*100+$mm);
1021 eval { require File::Basename; };
1022 $@ and die "File::Basename needed. Are you on miniperl?;\nerror: $@\n";
1023 File::Basename->import();
1024 my ($src, $dst, $clobber) = @_;
1025 if (!$clobber and -e $dst){
1026 warn "$dst exists. skipping\n";
1029 warn "Generating $dst...\n";
1030 open my $in, $src or die "$src : $!";
1031 if ((my $d = dirname($dst)) ne '.'){
1032 -d $d or mkdir $d, 0755 or die "mkdir $d : $!";
1034 open my $out, ">$dst" or die "$!";
1037 if (/^#### END_OF_HEADER/){
1040 s/(\$_[A-Z][A-Za-z0-9]+)_/$1/gee unless $asis;
1048 enc2xs -- Perl Encode Module Generator
1053 enc2xs -M ModName mapfiles...
1058 F<enc2xs> builds a Perl extension for use by Encode from either
1059 Unicode Character Mapping files (.ucm) or Tcl Encoding Files (.enc).
1060 Besides being used internally during the build process of the Encode
1061 module, you can use F<enc2xs> to add your own encoding to perl.
1062 No knowledge of XS is necessary.
1066 If you want to know as little about Perl as possible but need to
1067 add a new encoding, just read this chapter and forget the rest.
1073 Have a .ucm file ready. You can get it from somewhere or you can write
1074 your own from scratch or you can grab one from the Encode distribution
1075 and customize it. For the UCM format, see the next Chapter. In the
1076 example below, I'll call my theoretical encoding myascii, defined
1077 in I<my.ucm>. C<$> is a shell prompt.
1084 Issue a command as follows;
1086 $ enc2xs -M My my.ucm
1087 generating Makefile.PL
1092 Now take a look at your current directory. It should look like this.
1095 Makefile.PL My.pm my.ucm t/
1097 The following files were created.
1099 Makefile.PL - MakeMaker script
1100 My.pm - Encode submodule
1107 If you want *.ucm installed together with the modules, do as follows;
1111 $ enc2xs -M My Encode/*ucm
1117 Edit the files generated. You don't have to if you have no time AND no
1118 intention to give it to someone else. But it is a good idea to edit
1119 the pod and to add more tests.
1123 Now issue a command all Perl Mongers love:
1126 Writing Makefile for Encode::My
1130 Now all you have to do is make.
1133 cp My.pm blib/lib/Encode/My.pm
1134 /usr/local/bin/perl /usr/local/bin/enc2xs -Q -O \
1135 -o encode_t.c -f encode_t.fnm
1136 Reading myascii (myascii)
1137 Writing compiled form
1138 128 bytes in string tables
1139 384 bytes (75%) saved spotting duplicates
1140 1 bytes (0.775%) saved using substrings
1142 chmod 644 blib/arch/auto/Encode/My/My.bs
1145 The time it takes varies depending on how fast your machine is and
1146 how large your encoding is. Unless you are working on something big
1147 like euc-tw, it won't take too long.
1151 You can "make install" already but you should test first.
1154 PERL_DL_NONLAZY=1 /usr/local/bin/perl -Iblib/arch -Iblib/lib \
1155 -e 'use Test::Harness qw(&runtests $verbose); \
1156 $verbose=0; runtests @ARGV;' t/*.t
1158 All tests successful.
1159 Files=1, Tests=2, 0 wallclock secs
1160 ( 0.09 cusr + 0.01 csys = 0.09 CPU)
1164 If you are content with the test result, just "make install"
1168 If you want to add your encoding to Encode's demand-loading list
1169 (so you don't have to "use Encode::YourEncoding"), run
1173 to update Encode::ConfigLocal, a module that controls local settings.
1174 After that, "use Encode;" is enough to load your encodings on demand.
1178 =head1 The Unicode Character Map
1180 Encode uses the Unicode Character Map (UCM) format for source character
1181 mappings. This format is used by IBM's ICU package and was adopted
1182 by Nick Ing-Simmons for use with the Encode module. Since UCM is
1183 more flexible than Tcl's Encoding Map and far more user-friendly,
1184 this is the recommended formet for Encode now.
1186 A UCM file looks like this.
1191 <code_set_name> "US-ascii" # Required
1192 <code_set_alias> "ascii" # Optional
1193 <mb_cur_min> 1 # Required; usually 1
1194 <mb_cur_max> 1 # Max. # of bytes/char
1195 <subchar> \x3F # Substitution char
1198 <U0000> \x00 |0 # <control>
1199 <U0001> \x01 |0 # <control>
1200 <U0002> \x02 |0 # <control>
1202 <U007C> \x7C |0 # VERTICAL LINE
1203 <U007D> \x7D |0 # RIGHT CURLY BRACKET
1204 <U007E> \x7E |0 # TILDE
1205 <U007F> \x7F |0 # <control>
1212 Anything that follows C<#> is treated as a comment.
1216 The header section continues until a line containing the word
1217 CHARMAP. This section has a form of I<E<lt>keywordE<gt> value>, one
1218 pair per line. Strings used as values must be quoted. Barewords are
1219 treated as numbers. I<\xXX> represents a byte.
1221 Most of the keywords are self-explanatory. I<subchar> means
1222 substitution character, not subcharacter. When you decode a Unicode
1223 sequence to this encoding but no matching character is found, the byte
1224 sequence defined here will be used. For most cases, the value here is
1225 \x3F; in ASCII, this is a question mark.
1229 CHARMAP starts the character map section. Each line has a form as
1232 <UXXXX> \xXX.. |0 # comment
1234 | | +- Fallback flag
1235 | +-------- Encoded byte sequence
1236 +-------------- Unicode Character ID in hex
1238 The format is roughly the same as a header section except for the
1239 fallback flag: | followed by 0..3. The meaning of the possible
1240 values is as follows:
1246 Round trip safe. A character decoded to Unicode encodes back to the
1247 same byte sequence. Most characters have this flag.
1251 Fallback for unicode -> encoding. When seen, enc2xs adds this
1252 character for the encode map only.
1256 Skip sub-char mapping should there be no code point.
1260 Fallback for encoding -> unicode. When seen, enc2xs adds this
1261 character for the decode map only.
1267 And finally, END OF CHARMAP ends the section.
1271 When you are manually creating a UCM file, you should copy ascii.ucm
1272 or an existing encoding which is close to yours, rather than write
1273 your own from scratch.
1275 When you do so, make sure you leave at least B<U0000> to B<U0020> as
1276 is, unless your environment is EBCDIC.
1278 B<CAVEAT>: not all features in UCM are implemented. For example,
1279 icu:state is not used. Because of that, you need to write a perl
1280 module if you want to support algorithmical encodings, notably
1281 the ISO-2022 series. Such modules include L<Encode::JP::2022_JP>,
1282 L<Encode::KR::2022_KR>, and L<Encode::TW::HZ>.
1284 =head2 Coping with duplicate mappings
1286 When you create a map, you SHOULD make your mappings round-trip safe.
1287 That is, C<encode('your-encoding', decode('your-encoding', $data)) eq
1288 $data> stands for all characters that are marked as C<|0>. Here is
1295 Sort your map in Unicode order.
1299 When you have a duplicate entry, mark either one with '|1' or '|3'.
1303 And make sure the '|1' or '|3' entry FOLLOWS the '|0' entry.
1307 Here is an example from big5-eten.
1312 Internally Encoding -> Unicode and Unicode -> Encoding Map looks like
1316 --------------------------------------
1317 \xF9\xF9 => U2550 U2550 => \xF9\xF9
1320 So it is round-trip safe for \xF9\xF9. But if the line above is upside
1321 down, here is what happens.
1324 --------------------------------------
1325 \xA2\xA4 => U2550 U2550 => \xF9\xF9
1326 (\xF9\xF9 => U2550 is now overwritten!)
1328 The Encode package comes with F<ucmlint>, a crude but sufficient
1329 utility to check the integrity of a UCM file. Check under the
1330 Encode/bin directory for this.
1332 When in doubt, you can use F<ucmsort>, yet another utility under
1333 Encode/bin directory.
1342 L<http://oss.software.ibm.com/icu/>
1346 ICU Character Mapping Tables
1347 L<http://oss.software.ibm.com/icu/charset/>
1352 L<http://oss.software.ibm.com/icu/userguide/conversion-data.html>
1364 # -Q to disable the duplicate codepoint test
1365 # -S make mapping errors fatal
1366 # -q to remove comments written to output files
1367 # -O to enable the (brute force) substring optimiser
1368 # -o <output> to specify the output file name (else it's the first arg)
1369 # -f <inlist> to give a file with a list of input files (else use the args)
1370 # -n <name> to name the encoding (else use the basename of the input file.
1372 With %seen holding array refs:
1374 865.66 real 28.80 user 8.79 sys
1375 7904 maximum resident set size
1376 1356 average shared memory size
1377 18566 average unshared data size
1378 229 average unshared stack size
1382 With %seen holding simple scalars:
1384 342.16 real 27.11 user 3.54 sys
1385 8388 maximum resident set size
1386 1394 average shared memory size
1387 14969 average unshared data size
1388 236 average unshared stack size
1392 Yes, 5 minutes is faster than 15. Above is for CP936 in CN. Only difference is
1393 how %seen is storing things its seen. So it is pathalogically bad on a 16M
1394 RAM machine, but it's going to help even on modern machines.
1395 Swapping is bad, m'kay :-)