summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/bin/enc2xs
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/bin/enc2xs')
-rwxr-xr-xMaster/tlpkg/tlperl/bin/enc2xs1407
1 files changed, 0 insertions, 1407 deletions
diff --git a/Master/tlpkg/tlperl/bin/enc2xs b/Master/tlpkg/tlperl/bin/enc2xs
deleted file mode 100755
index 773c0a09fba..00000000000
--- a/Master/tlpkg/tlperl/bin/enc2xs
+++ /dev/null
@@ -1,1407 +0,0 @@
-#!./perl
-BEGIN {
- # @INC poking no longer needed w/ new MakeMaker and Makefile.PL's
- # with $ENV{PERL_CORE} set
- # In case we need it in future...
- require Config; import Config;
-}
-use strict;
-use warnings;
-use Getopt::Std;
-use Config;
-my @orig_ARGV = @ARGV;
-our $VERSION = do { my @r = (q$Revision: 2.7 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
-
-# These may get re-ordered.
-# RAW is a do_now as inserted by &enter
-# AGG is an aggreagated do_now, as built up by &process
-
-use constant {
- RAW_NEXT => 0,
- RAW_IN_LEN => 1,
- RAW_OUT_BYTES => 2,
- RAW_FALLBACK => 3,
-
- AGG_MIN_IN => 0,
- AGG_MAX_IN => 1,
- AGG_OUT_BYTES => 2,
- AGG_NEXT => 3,
- AGG_IN_LEN => 4,
- AGG_OUT_LEN => 5,
- AGG_FALLBACK => 6,
-};
-
-# (See the algorithm in encengine.c - we're building structures for it)
-
-# There are two sorts of structures.
-# "do_now" (an array, two variants of what needs storing) is whatever we need
-# to do now we've read an input byte.
-# It's housed in a "do_next" (which is how we got to it), and in turn points
-# to a "do_next" which contains all the "do_now"s for the next input byte.
-
-# There will be a "do_next" which is the start state.
-# For a single byte encoding it's the only "do_next" - each "do_now" points
-# back to it, and each "do_now" will cause bytes. There is no state.
-
-# For a multi-byte encoding where all characters in the input are the same
-# length, then there will be a tree of "do_now"->"do_next"->"do_now"
-# branching out from the start state, one step for each input byte.
-# The leaf "do_now"s will all be at the same distance from the start state,
-# only the leaf "do_now"s cause output bytes, and they in turn point back to
-# the start state.
-
-# For an encoding where there are varaible length input byte sequences, you
-# will encounter a leaf "do_now" sooner for the shorter input sequences, but
-# as before the leaves will point back to the start state.
-
-# The system will cope with escape encodings (imagine them as a mostly
-# self-contained tree for each escape state, and cross links between trees
-# at the state-switching characters) but so far no input format defines these.
-
-# The system will also cope with having output "leaves" in the middle of
-# the bifurcating branches, not just at the extremities, but again no
-# input format does this yet.
-
-# There are two variants of the "do_now" structure. The first, smaller variant
-# is generated by &enter as the input file is read. There is one structure
-# for each input byte. Say we are mapping a single byte encoding to a
-# single byte encoding, with "ABCD" going "abcd". There will be
-# 4 "do_now"s, {"A" => [...,"a",...], "B" => [...,"b",...], "C"=>..., "D"=>...}
-
-# &process then walks the tree, building aggregate "do_now" structres for
-# adjacent bytes where possible. The aggregate is for a contiguous range of
-# bytes which each produce the same length of output, each move to the
-# same next state, and each have the same fallback flag.
-# So our 4 RAW "do_now"s above become replaced by a single structure
-# containing:
-# ["A", "D", "abcd", 1, ...]
-# ie, for an input byte $_ in "A".."D", output 1 byte, found as
-# substr ("abcd", (ord $_ - ord "A") * 1, 1)
-# which maps very nicely into pointer arithmetic in C for encengine.c
-
-sub encode_U
-{
- # UTF-8 encode long hand - only covers part of perl's range
- ## my $uv = shift;
- # chr() works in native space so convert value from table
- # into that space before using chr().
- my $ch = chr(utf8::unicode_to_native($_[0]));
- # Now get core perl to encode that the way it likes.
- utf8::encode($ch);
- return $ch;
-}
-
-sub encode_S
-{
- # encode single byte
- ## my ($ch,$page) = @_; return chr($ch);
- return chr $_[0];
-}
-
-sub encode_D
-{
- # encode double byte MS byte first
- ## my ($ch,$page) = @_; return chr($page).chr($ch);
- return chr ($_[1]) . chr $_[0];
-}
-
-sub encode_M
-{
- # encode Multi-byte - single for 0..255 otherwise double
- ## my ($ch,$page) = @_;
- ## return &encode_D if $page;
- ## return &encode_S;
- return chr ($_[1]) . chr $_[0] if $_[1];
- return chr $_[0];
-}
-
-my %encode_types = (U => \&encode_U,
- S => \&encode_S,
- D => \&encode_D,
- M => \&encode_M,
- );
-
-# Win32 does not expand globs on command line
-eval "\@ARGV = map(glob(\$_),\@ARGV)" if ($^O eq 'MSWin32');
-
-my %opt;
-# I think these are:
-# -Q to disable the duplicate codepoint test
-# -S make mapping errors fatal
-# -q to remove comments written to output files
-# -O to enable the (brute force) substring optimiser
-# -o <output> to specify the output file name (else it's the first arg)
-# -f <inlist> to give a file with a list of input files (else use the args)
-# -n <name> to name the encoding (else use the basename of the input file.
-getopts('CM:SQqOo:f:n:',\%opt);
-
-$opt{M} and make_makefile_pl($opt{M}, @ARGV);
-$opt{C} and make_configlocal_pm($opt{C}, @ARGV);
-
-# This really should go first, else the die here causes empty (non-erroneous)
-# output files to be written.
-my @encfiles;
-if (exists $opt{'f'}) {
- # -F is followed by name of file containing list of filenames
- my $flist = $opt{'f'};
- open(FLIST,$flist) || die "Cannot open $flist:$!";
- chomp(@encfiles = <FLIST>);
- close(FLIST);
-} else {
- @encfiles = @ARGV;
-}
-
-my $cname = (exists $opt{'o'}) ? $opt{'o'} : shift(@ARGV);
-chmod(0666,$cname) if -f $cname && !-w $cname;
-open(C,">$cname") || die "Cannot open $cname:$!";
-
-my $dname = $cname;
-my $hname = $cname;
-
-my ($doC,$doEnc,$doUcm,$doPet);
-
-if ($cname =~ /\.(c|xs)$/i) # VMS may have upcased filenames with DECC$ARGV_PARSE_STYLE defined
- {
- $doC = 1;
- $dname =~ s/(\.[^\.]*)?$/.exh/;
- chmod(0666,$dname) if -f $cname && !-w $dname;
- open(D,">$dname") || die "Cannot open $dname:$!";
- $hname =~ s/(\.[^\.]*)?$/.h/;
- chmod(0666,$hname) if -f $cname && !-w $hname;
- open(H,">$hname") || die "Cannot open $hname:$!";
-
- foreach my $fh (\*C,\*D,\*H)
- {
- print $fh <<"END" unless $opt{'q'};
-/*
- !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
- This file was autogenerated by:
- $^X $0 @orig_ARGV
- enc2xs VERSION $VERSION
-*/
-END
- }
-
- if ($cname =~ /(\w+)\.xs$/)
- {
- print C "#include <EXTERN.h>\n";
- print C "#include <perl.h>\n";
- print C "#include <XSUB.h>\n";
- print C "#define U8 U8\n";
- }
- print C "#include \"encode.h\"\n\n";
-
- }
-elsif ($cname =~ /\.enc$/)
- {
- $doEnc = 1;
- }
-elsif ($cname =~ /\.ucm$/)
- {
- $doUcm = 1;
- }
-elsif ($cname =~ /\.pet$/)
- {
- $doPet = 1;
- }
-
-my %encoding;
-my %strings;
-my $string_acc;
-my %strings_in_acc;
-
-my $saved = 0;
-my $subsave = 0;
-my $strings = 0;
-
-sub cmp_name
-{
- if ($a =~ /^.*-(\d+)/)
- {
- my $an = $1;
- if ($b =~ /^.*-(\d+)/)
- {
- my $r = $an <=> $1;
- return $r if $r;
- }
- }
- return $a cmp $b;
-}
-
-
-foreach my $enc (sort cmp_name @encfiles)
- {
- my ($name,$sfx) = $enc =~ /^.*?([\w-]+)\.(enc|ucm)$/;
- $name = $opt{'n'} if exists $opt{'n'};
- if (open(E,$enc))
- {
- if ($sfx eq 'enc')
- {
- compile_enc(\*E,lc($name));
- }
- else
- {
- compile_ucm(\*E,lc($name));
- }
- }
- else
- {
- warn "Cannot open $enc for $name:$!";
- }
- }
-
-if ($doC)
- {
- print STDERR "Writing compiled form\n";
- foreach my $name (sort cmp_name keys %encoding)
- {
- my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}};
- process($name.'_utf8',$e2u);
- addstrings(\*C,$e2u);
-
- process('utf8_'.$name,$u2e);
- addstrings(\*C,$u2e);
- }
- outbigstring(\*C,"enctable");
- foreach my $name (sort cmp_name keys %encoding)
- {
- my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}};
- outtable(\*C,$e2u, "enctable");
- outtable(\*C,$u2e, "enctable");
-
- # push(@{$encoding{$name}},outstring(\*C,$e2u->{Cname}.'_def',$erep));
- }
- my $cpp = ($Config{d_cplusplus} || '') eq 'define';
- my $exta = $cpp ? 'extern "C" ' : "static";
- my $extb = $cpp ? 'extern "C" ' : "";
- foreach my $enc (sort cmp_name keys %encoding)
- {
- # my ($e2u,$u2e,$rep,$min_el,$max_el,$rsym) = @{$encoding{$enc}};
- my ($e2u,$u2e,$rep,$min_el,$max_el) = @{$encoding{$enc}};
- #my @info = ($e2u->{Cname},$u2e->{Cname},$rsym,length($rep),$min_el,$max_el);
- my $replen = 0;
- $replen++ while($rep =~ /\G\\x[0-9A-Fa-f]/g);
- my $sym = "${enc}_encoding";
- $sym =~ s/\W+/_/g;
- my @info = ($e2u->{Cname},$u2e->{Cname},"${sym}_rep_character",$replen,
- $min_el,$max_el);
- print C "${exta} const U8 ${sym}_rep_character[] = \"$rep\";\n";
- print C "${exta} const char ${sym}_enc_name[] = \"$enc\";\n\n";
- print C "${extb} const encode_t $sym = \n";
- # This is to make null encoding work -- dankogai
- for (my $i = (scalar @info) - 1; $i >= 0; --$i){
- $info[$i] ||= 1;
- }
- # end of null tweak -- dankogai
- print C " {",join(',',@info,"{${sym}_enc_name,(const char *)0}"),"};\n\n";
- }
-
- foreach my $enc (sort cmp_name keys %encoding)
- {
- my $sym = "${enc}_encoding";
- $sym =~ s/\W+/_/g;
- print H "extern encode_t $sym;\n";
- print D " Encode_XSEncoding(aTHX_ &$sym);\n";
- }
-
- if ($cname =~ /(\w+)\.xs$/)
- {
- my $mod = $1;
- print C <<'END';
-
-static void
-Encode_XSEncoding(pTHX_ encode_t *enc)
-{
- dSP;
- HV *stash = gv_stashpv("Encode::XS", TRUE);
- SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(enc))),stash);
- int i = 0;
- PUSHMARK(sp);
- XPUSHs(sv);
- while (enc->name[i])
- {
- const char *name = enc->name[i++];
- XPUSHs(sv_2mortal(newSVpvn(name,strlen(name))));
- }
- PUTBACK;
- call_pv("Encode::define_encoding",G_DISCARD);
- SvREFCNT_dec(sv);
-}
-
-END
-
- print C "\nMODULE = Encode::$mod\tPACKAGE = Encode::$mod\n\n";
- print C "BOOT:\n{\n";
- print C "#include \"$dname\"\n";
- print C "}\n";
- }
- # Close in void context is bad, m'kay
- close(D) or warn "Error closing '$dname': $!";
- close(H) or warn "Error closing '$hname': $!";
-
- my $perc_saved = $saved/($strings + $saved) * 100;
- my $perc_subsaved = $subsave/($strings + $subsave) * 100;
- printf STDERR "%d bytes in string tables\n",$strings;
- printf STDERR "%d bytes (%.3g%%) saved spotting duplicates\n",
- $saved, $perc_saved if $saved;
- printf STDERR "%d bytes (%.3g%%) saved using substrings\n",
- $subsave, $perc_subsaved if $subsave;
- }
-elsif ($doEnc)
- {
- foreach my $name (sort cmp_name keys %encoding)
- {
- my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}};
- output_enc(\*C,$name,$e2u);
- }
- }
-elsif ($doUcm)
- {
- foreach my $name (sort cmp_name keys %encoding)
- {
- my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}};
- output_ucm(\*C,$name,$u2e,$erep,$min_el,$max_el);
- }
- }
-
-# writing half meg files and then not checking to see if you just filled the
-# disk is bad, m'kay
-close(C) or die "Error closing '$cname': $!";
-
-# End of the main program.
-
-sub compile_ucm
-{
- my ($fh,$name) = @_;
- my $e2u = {};
- my $u2e = {};
- my $cs;
- my %attr;
- while (<$fh>)
- {
- s/#.*$//;
- last if /^\s*CHARMAP\s*$/i;
- if (/^\s*<(\w+)>\s+"?([^"]*)"?\s*$/i) # " # Grrr
- {
- $attr{$1} = $2;
- }
- }
- if (!defined($cs = $attr{'code_set_name'}))
- {
- warn "No <code_set_name> in $name\n";
- }
- else
- {
- $name = $cs unless exists $opt{'n'};
- }
- my $erep;
- my $urep;
- my $max_el;
- my $min_el;
- if (exists $attr{'subchar'})
- {
- #my @byte;
- #$attr{'subchar'} =~ /^\s*/cg;
- #push(@byte,$1) while $attr{'subchar'} =~ /\G\\x([0-9a-f]+)/icg;
- #$erep = join('',map(chr(hex($_)),@byte));
- $erep = $attr{'subchar'};
- $erep =~ s/^\s+//; $erep =~ s/\s+$//;
- }
- print "Reading $name ($cs)\n";
- my $nfb = 0;
- my $hfb = 0;
- while (<$fh>)
- {
- s/#.*$//;
- last if /^\s*END\s+CHARMAP\s*$/i;
- next if /^\s*$/;
- my (@uni, @byte) = ();
- my ($uni, $byte, $fb) = m/^(\S+)\s+(\S+)\s+(\S+)\s+/o
- or die "Bad line: $_";
- while ($uni =~ m/\G<([U0-9a-fA-F\+]+)>/g){
- push @uni, map { substr($_, 1) } split(/\+/, $1);
- }
- while ($byte =~ m/\G\\x([0-9a-fA-F]+)/g){
- push @byte, $1;
- }
- if (@uni)
- {
- my $uch = join('', map { encode_U(hex($_)) } @uni );
- my $ech = join('',map(chr(hex($_)),@byte));
- my $el = length($ech);
- $max_el = $el if (!defined($max_el) || $el > $max_el);
- $min_el = $el if (!defined($min_el) || $el < $min_el);
- if (length($fb))
- {
- $fb = substr($fb,1);
- $hfb++;
- }
- else
- {
- $nfb++;
- $fb = '0';
- }
- # $fb is fallback flag
- # 0 - round trip safe
- # 1 - fallback for unicode -> enc
- # 2 - skip sub-char mapping
- # 3 - fallback enc -> unicode
- enter($u2e,$uch,$ech,$u2e,$fb+0) if ($fb =~ /[01]/);
- enter($e2u,$ech,$uch,$e2u,$fb+0) if ($fb =~ /[03]/);
- }
- else
- {
- warn $_;
- }
- }
- if ($nfb && $hfb)
- {
- die "$nfb entries without fallback, $hfb entries with\n";
- }
- $encoding{$name} = [$e2u,$u2e,$erep,$min_el,$max_el];
-}
-
-
-
-sub compile_enc
-{
- my ($fh,$name) = @_;
- my $e2u = {};
- my $u2e = {};
-
- my $type;
- while ($type = <$fh>)
- {
- last if $type !~ /^\s*#/;
- }
- chomp($type);
- return if $type eq 'E';
- # Do the hash lookup once, rather than once per function call. 4% speedup.
- my $type_func = $encode_types{$type};
- my ($def,$sym,$pages) = split(/\s+/,scalar(<$fh>));
- warn "$type encoded $name\n";
- my $rep = '';
- # Save a defined test by setting these to defined values.
- my $min_el = ~0; # A very big integer
- my $max_el = 0; # Anything must be longer than 0
- {
- my $v = hex($def);
- $rep = &$type_func($v & 0xFF, ($v >> 8) & 0xffe);
- }
- my $errors;
- my $seen;
- # use -Q to silence the seen test. Makefile.PL uses this by default.
- $seen = {} unless $opt{Q};
- do
- {
- my $line = <$fh>;
- chomp($line);
- my $page = hex($line);
- my $ch = 0;
- my $i = 16;
- do
- {
- # So why is it 1% faster to leave the my here?
- my $line = <$fh>;
- $line =~ s/\r\n$/\n/;
- die "$.:${line}Line should be exactly 65 characters long including
- newline (".length($line).")" unless length ($line) == 65;
- # Split line into groups of 4 hex digits, convert groups to ints
- # This takes 65.35
- # map {hex $_} $line =~ /(....)/g
- # This takes 63.75 (2.5% less time)
- # unpack "n*", pack "H*", $line
- # There's an implicit loop in map. Loops are bad, m'kay. Ops are bad, m'kay
- # Doing it as while ($line =~ /(....)/g) took 74.63
- foreach my $val (unpack "n*", pack "H*", $line)
- {
- next if $val == 0xFFFD;
- my $ech = &$type_func($ch,$page);
- if ($val || (!$ch && !$page))
- {
- my $el = length($ech);
- $max_el = $el if $el > $max_el;
- $min_el = $el if $el < $min_el;
- my $uch = encode_U($val);
- if ($seen) {
- # We're doing the test.
- # We don't need to read this quickly, so storing it as a scalar,
- # rather than 3 (anon array, plus the 2 scalars it holds) saves
- # RAM and may make us faster on low RAM systems. [see __END__]
- if (exists $seen->{$uch})
- {
- warn sprintf("U%04X is %02X%02X and %04X\n",
- $val,$page,$ch,$seen->{$uch});
- $errors++;
- }
- else
- {
- $seen->{$uch} = $page << 8 | $ch;
- }
- }
- # Passing 2 extra args each time is 3.6% slower!
- # Even with having to add $fallback ||= 0 later
- enter_fb0($e2u,$ech,$uch);
- enter_fb0($u2e,$uch,$ech);
- }
- else
- {
- # No character at this position
- # enter($e2u,$ech,undef,$e2u);
- }
- $ch++;
- }
- } while --$i;
- } while --$pages;
- die "\$min_el=$min_el, \$max_el=$max_el - seems we read no lines"
- if $min_el > $max_el;
- die "$errors mapping conflicts\n" if ($errors && $opt{'S'});
- $encoding{$name} = [$e2u,$u2e,$rep,$min_el,$max_el];
-}
-
-# my ($a,$s,$d,$t,$fb) = @_;
-sub enter {
- my ($current,$inbytes,$outbytes,$next,$fallback) = @_;
- # state we shift to after this (multibyte) input character defaults to same
- # as current state.
- $next ||= $current;
- # Making sure it is defined seems to be faster than {no warnings;} in
- # &process, or passing it in as 0 explicity.
- # XXX $fallback ||= 0;
-
- # Start at the beginning and work forwards through the string to zero.
- # effectively we are removing 1 character from the front each time
- # but we don't actually edit the string. [this alone seems to be 14% speedup]
- # Hence -$pos is the length of the remaining string.
- my $pos = -length $inbytes;
- while (1) {
- my $byte = substr $inbytes, $pos, 1;
- # RAW_NEXT => 0,
- # RAW_IN_LEN => 1,
- # RAW_OUT_BYTES => 2,
- # RAW_FALLBACK => 3,
- # to unicode an array would seem to be better, because the pages are dense.
- # from unicode can be very sparse, favouring a hash.
- # hash using the bytes (all length 1) as keys rather than ord value,
- # as it's easier to sort these in &process.
-
- # It's faster to always add $fallback even if it's undef, rather than
- # choosing between 3 and 4 element array. (hence why we set it defined
- # above)
- my $do_now = $current->{Raw}{$byte} ||= [{},-$pos,'',$fallback];
- # When $pos was -1 we were at the last input character.
- unless (++$pos) {
- $do_now->[RAW_OUT_BYTES] = $outbytes;
- $do_now->[RAW_NEXT] = $next;
- return;
- }
- # Tail recursion. The intermdiate state may not have a name yet.
- $current = $do_now->[RAW_NEXT];
- }
-}
-
-# This is purely for optimistation. It's just &enter hard coded for $fallback
-# of 0, using only a 3 entry array ref to save memory for every entry.
-sub enter_fb0 {
- my ($current,$inbytes,$outbytes,$next) = @_;
- $next ||= $current;
-
- my $pos = -length $inbytes;
- while (1) {
- my $byte = substr $inbytes, $pos, 1;
- my $do_now = $current->{Raw}{$byte} ||= [{},-$pos,''];
- unless (++$pos) {
- $do_now->[RAW_OUT_BYTES] = $outbytes;
- $do_now->[RAW_NEXT] = $next;
- return;
- }
- $current = $do_now->[RAW_NEXT];
- }
-}
-
-sub process
-{
- my ($name,$a) = @_;
- $name =~ s/\W+/_/g;
- $a->{Cname} = $name;
- my $raw = $a->{Raw};
- my ($l, $agg_max_in, $agg_next, $agg_in_len, $agg_out_len, $agg_fallback);
- my @ent;
- $agg_max_in = 0;
- foreach my $key (sort keys %$raw) {
- # RAW_NEXT => 0,
- # RAW_IN_LEN => 1,
- # RAW_OUT_BYTES => 2,
- # RAW_FALLBACK => 3,
- my ($next, $in_len, $out_bytes, $fallback) = @{$raw->{$key}};
- # Now we are converting from raw to aggregate, switch from 1 byte strings
- # to numbers
- my $b = ord $key;
- $fallback ||= 0;
- if ($l &&
- # If this == fails, we're going to reset $agg_max_in below anyway.
- $b == ++$agg_max_in &&
- # References in numeric context give the pointer as an int.
- $agg_next == $next &&
- $agg_in_len == $in_len &&
- $agg_out_len == length $out_bytes &&
- $agg_fallback == $fallback
- # && length($l->[AGG_OUT_BYTES]) < 16
- ) {
- # my $i = ord($b)-ord($l->[AGG_MIN_IN]);
- # we can aggregate this byte onto the end.
- $l->[AGG_MAX_IN] = $b;
- $l->[AGG_OUT_BYTES] .= $out_bytes;
- } else {
- # AGG_MIN_IN => 0,
- # AGG_MAX_IN => 1,
- # AGG_OUT_BYTES => 2,
- # AGG_NEXT => 3,
- # AGG_IN_LEN => 4,
- # AGG_OUT_LEN => 5,
- # AGG_FALLBACK => 6,
- # Reset the last thing we saw, plus set 5 lexicals to save some derefs.
- # (only gains .6% on euc-jp -- is it worth it?)
- push @ent, $l = [$b, $agg_max_in = $b, $out_bytes, $agg_next = $next,
- $agg_in_len = $in_len, $agg_out_len = length $out_bytes,
- $agg_fallback = $fallback];
- }
- if (exists $next->{Cname}) {
- $next->{'Forward'} = 1 if $next != $a;
- } else {
- process(sprintf("%s_%02x",$name,$b),$next);
- }
- }
- # encengine.c rules say that last entry must be for 255
- if ($agg_max_in < 255) {
- push @ent, [1+$agg_max_in, 255,undef,$a,0,0];
- }
- $a->{'Entries'} = \@ent;
-}
-
-
-sub addstrings
-{
- my ($fh,$a) = @_;
- my $name = $a->{'Cname'};
- # String tables
- foreach my $b (@{$a->{'Entries'}})
- {
- next unless $b->[AGG_OUT_LEN];
- $strings{$b->[AGG_OUT_BYTES]} = undef;
- }
- if ($a->{'Forward'})
- {
- my $cpp = ($Config{d_cplusplus} || '') eq 'define';
- my $var = $^O eq 'MacOS' || $cpp ? 'extern' : 'static';
- my $const = $cpp ? '' : 'const';
- print $fh "$var $const encpage_t $name\[",scalar(@{$a->{'Entries'}}),"];\n";
- }
- $a->{'DoneStrings'} = 1;
- foreach my $b (@{$a->{'Entries'}})
- {
- my ($s,$e,$out,$t,$end,$l) = @$b;
- addstrings($fh,$t) unless $t->{'DoneStrings'};
- }
-}
-
-sub outbigstring
-{
- my ($fh,$name) = @_;
-
- $string_acc = '';
-
- # Make the big string in the string accumulator. Longest first, on the hope
- # that this makes it more likely that we find the short strings later on.
- # Not sure if it helps sorting strings of the same length lexcically.
- foreach my $s (sort {length $b <=> length $a || $a cmp $b} keys %strings) {
- my $index = index $string_acc, $s;
- if ($index >= 0) {
- $saved += length($s);
- $strings_in_acc{$s} = $index;
- } else {
- OPTIMISER: {
- if ($opt{'O'}) {
- my $sublength = length $s;
- while (--$sublength > 0) {
- # progressively lop characters off the end, to see if the start of
- # the new string overlaps the end of the accumulator.
- if (substr ($string_acc, -$sublength)
- eq substr ($s, 0, $sublength)) {
- $subsave += $sublength;
- $strings_in_acc{$s} = length ($string_acc) - $sublength;
- # append the last bit on the end.
- $string_acc .= substr ($s, $sublength);
- last OPTIMISER;
- }
- # or if the end of the new string overlaps the start of the
- # accumulator
- next unless substr ($string_acc, 0, $sublength)
- eq substr ($s, -$sublength);
- # well, the last $sublength characters of the accumulator match.
- # so as we're prepending to the accumulator, need to shift all our
- # existing offsets forwards
- $_ += $sublength foreach values %strings_in_acc;
- $subsave += $sublength;
- $strings_in_acc{$s} = 0;
- # append the first bit on the start.
- $string_acc = substr ($s, 0, -$sublength) . $string_acc;
- last OPTIMISER;
- }
- }
- # Optimiser (if it ran) found nothing, so just going have to tack the
- # whole thing on the end.
- $strings_in_acc{$s} = length $string_acc;
- $string_acc .= $s;
- };
- }
- }
-
- $strings = length $string_acc;
- my $cpp = ($Config{d_cplusplus} || '') eq 'define';
- my $var = $cpp ? '' : 'static';
- my $definition = "\n$var const U8 $name\[$strings] = { " .
- join(',',unpack "C*",$string_acc);
- # We have a single long line. Split it at convenient commas.
- print $fh $1, "\n" while $definition =~ /\G(.{74,77},)/gcs;
- print $fh substr ($definition, pos $definition), " };\n";
-}
-
-sub findstring {
- my ($name,$s) = @_;
- my $offset = $strings_in_acc{$s};
- die "Can't find string " . join (',',unpack "C*",$s) . " in accumulator"
- unless defined $offset;
- "$name + $offset";
-}
-
-sub outtable
-{
- my ($fh,$a,$bigname) = @_;
- my $name = $a->{'Cname'};
- $a->{'Done'} = 1;
- foreach my $b (@{$a->{'Entries'}})
- {
- my ($s,$e,$out,$t,$end,$l) = @$b;
- outtable($fh,$t,$bigname) unless $t->{'Done'};
- }
- my $cpp = ($Config{d_cplusplus} || '') eq 'define';
- my $var = $cpp ? '' : 'static';
- my $const = $cpp ? '' : 'const';
- print $fh "\n$var $const encpage_t $name\[",
- scalar(@{$a->{'Entries'}}), "] = {\n";
- foreach my $b (@{$a->{'Entries'}})
- {
- my ($sc,$ec,$out,$t,$end,$l,$fb) = @$b;
- # $end |= 0x80 if $fb; # what the heck was on your mind, Nick? -- Dan
- print $fh "{";
- if ($l)
- {
- printf $fh findstring($bigname,$out);
- }
- else
- {
- print $fh "0";
- }
- print $fh ",",$t->{Cname};
- printf $fh ",0x%02x,0x%02x,$l,$end},\n",$sc,$ec;
- }
- print $fh "};\n";
-}
-
-sub output_enc
-{
- my ($fh,$name,$a) = @_;
- die "Changed - fix me for new structure";
- foreach my $b (sort keys %$a)
- {
- my ($s,$e,$out,$t,$end,$l,$fb) = @{$a->{$b}};
- }
-}
-
-sub decode_U
-{
- my $s = shift;
-}
-
-my @uname;
-sub char_names
-{
- my $s = do "unicore/Name.pl";
- die "char_names: unicore/Name.pl: $!\n" unless defined $s;
- pos($s) = 0;
- while ($s =~ /\G([0-9a-f]+)\t([0-9a-f]*)\t(.*?)\s*\n/igc)
- {
- my $name = $3;
- my $s = hex($1);
- last if $s >= 0x10000;
- my $e = length($2) ? hex($2) : $s;
- for (my $i = $s; $i <= $e; $i++)
- {
- $uname[$i] = $name;
-# print sprintf("U%04X $name\n",$i);
- }
- }
-}
-
-sub output_ucm_page
-{
- my ($cmap,$a,$t,$pre) = @_;
- # warn sprintf("Page %x\n",$pre);
- my $raw = $t->{Raw};
- foreach my $key (sort keys %$raw) {
- # RAW_NEXT => 0,
- # RAW_IN_LEN => 1,
- # RAW_OUT_BYTES => 2,
- # RAW_FALLBACK => 3,
- my ($next, $in_len, $out_bytes, $fallback) = @{$raw->{$key}};
- my $u = ord $key;
- $fallback ||= 0;
-
- if ($next != $a && $next != $t) {
- output_ucm_page($cmap,$a,$next,(($pre|($u &0x3F)) << 6)&0xFFFF);
- } elsif (length $out_bytes) {
- if ($pre) {
- $u = $pre|($u &0x3f);
- }
- my $s = sprintf "<U%04X> ",$u;
- #foreach my $c (split(//,$out_bytes)) {
- # $s .= sprintf "\\x%02X",ord($c);
- #}
- # 9.5% faster changing that loop to this:
- $s .= sprintf +("\\x%02X" x length $out_bytes), unpack "C*", $out_bytes;
- $s .= sprintf " |%d # %s\n",($fallback ? 1 : 0),$uname[$u];
- push(@$cmap,$s);
- } else {
- warn join(',',$u, @{$raw->{$key}},$a,$t);
- }
- }
-}
-
-sub output_ucm
-{
- my ($fh,$name,$h,$rep,$min_el,$max_el) = @_;
- print $fh "# $0 @orig_ARGV\n" unless $opt{'q'};
- print $fh "<code_set_name> \"$name\"\n";
- char_names();
- if (defined $min_el)
- {
- print $fh "<mb_cur_min> $min_el\n";
- }
- if (defined $max_el)
- {
- print $fh "<mb_cur_max> $max_el\n";
- }
- if (defined $rep)
- {
- print $fh "<subchar> ";
- foreach my $c (split(//,$rep))
- {
- printf $fh "\\x%02X",ord($c);
- }
- print $fh "\n";
- }
- my @cmap;
- output_ucm_page(\@cmap,$h,$h,0);
- print $fh "#\nCHARMAP\n";
- foreach my $line (sort { substr($a,8) cmp substr($b,8) } @cmap)
- {
- print $fh $line;
- }
- print $fh "END CHARMAP\n";
-}
-
-use vars qw(
- $_Enc2xs
- $_Version
- $_Inc
- $_E2X
- $_Name
- $_TableFiles
- $_Now
-);
-
-sub find_e2x{
- eval { require File::Find; };
- my (@inc, %e2x_dir);
- for my $inc (@INC){
- push @inc, $inc unless $inc eq '.'; #skip current dir
- }
- File::Find::find(
- sub {
- my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
- $atime,$mtime,$ctime,$blksize,$blocks)
- = lstat($_) or return;
- -f _ or return;
- if (/^.*\.e2x$/o){
- no warnings 'once';
- $e2x_dir{$File::Find::dir} ||= $mtime;
- }
- return;
- }, @inc);
- warn join("\n", keys %e2x_dir), "\n";
- for my $d (sort {$e2x_dir{$a} <=> $e2x_dir{$b}} keys %e2x_dir){
- $_E2X = $d;
- # warn "$_E2X => ", scalar localtime($e2x_dir{$d});
- return $_E2X;
- }
-}
-
-sub make_makefile_pl
-{
- eval { require Encode; };
- $@ and die "You need to install Encode to use enc2xs -M\nerror: $@\n";
- # our used for variable expanstion
- $_Enc2xs = $0;
- $_Version = $VERSION;
- $_E2X = find_e2x();
- $_Name = shift;
- $_TableFiles = join(",", map {qq('$_')} @_);
- $_Now = scalar localtime();
-
- eval { require File::Spec; };
- _print_expand(File::Spec->catfile($_E2X,"Makefile_PL.e2x"),"Makefile.PL");
- _print_expand(File::Spec->catfile($_E2X,"_PM.e2x"), "$_Name.pm");
- _print_expand(File::Spec->catfile($_E2X,"_T.e2x"), "t/$_Name.t");
- _print_expand(File::Spec->catfile($_E2X,"README.e2x"), "README");
- _print_expand(File::Spec->catfile($_E2X,"Changes.e2x"), "Changes");
- exit;
-}
-
-use vars qw(
- $_ModLines
- $_LocalVer
- );
-
-sub make_configlocal_pm {
- eval { require Encode; };
- $@ and die "Unable to require Encode: $@\n";
- eval { require File::Spec; };
-
- # our used for variable expanstion
- my %in_core = map { $_ => 1 } (
- 'ascii', 'iso-8859-1', 'utf8',
- 'ascii-ctrl', 'null', 'utf-8-strict'
- );
- my %LocalMod = ();
- # check @enc;
- use File::Find ();
- my $wanted = sub{
- -f $_ or return;
- $File::Find::name =~ /\A\./ and return;
- $File::Find::name =~ /\.pm\z/ or return;
- $File::Find::name =~ m/\bEncode\b/ or return;
- my $mod = $File::Find::name;
- $mod =~ s/.*\bEncode\b/Encode/o;
- $mod =~ s/\.pm\z//o;
- $mod =~ s,/,::,og;
- warn qq{ require $mod;\n};
- eval qq{ require $mod; };
- $@ and die "Can't require $mod: $@\n";
- for my $enc ( Encode->encodings() ) {
- no warnings;
- $in_core{$enc} and next;
- $Encode::Config::ExtModule{$enc} and next;
- $LocalMod{$enc} ||= $mod;
- }
- };
- File::Find::find({wanted => $wanted}, @INC);
- $_ModLines = "";
- for my $enc ( sort keys %LocalMod ) {
- $_ModLines .=
- qq(\$Encode::ExtModule{'$enc'} = "$LocalMod{$enc}";\n);
- }
- warn $_ModLines;
- $_LocalVer = _mkversion();
- $_E2X = find_e2x();
- $_Inc = $INC{"Encode.pm"};
- $_Inc =~ s/\.pm$//o;
- _print_expand( File::Spec->catfile( $_E2X, "ConfigLocal_PM.e2x" ),
- File::Spec->catfile( $_Inc, "ConfigLocal.pm" ), 1 );
- exit;
-}
-
-sub _mkversion{
- # v-string is now depreciated; use time() instead;
- #my ($ss,$mm,$hh,$dd,$mo,$yyyy) = localtime();
- #$yyyy += 1900, $mo +=1;
- #return sprintf("v%04d.%04d.%04d", $yyyy, $mo*100+$dd, $hh*100+$mm);
- return time();
-}
-
-sub _print_expand{
- eval { require File::Basename; };
- $@ and die "File::Basename needed. Are you on miniperl?;\nerror: $@\n";
- File::Basename->import();
- my ($src, $dst, $clobber) = @_;
- if (!$clobber and -e $dst){
- warn "$dst exists. skipping\n";
- return;
- }
- warn "Generating $dst...\n";
- open my $in, $src or die "$src : $!";
- if ((my $d = dirname($dst)) ne '.'){
- -d $d or mkdir $d, 0755 or die "mkdir $d : $!";
- }
- open my $out, ">$dst" or die "$!";
- my $asis = 0;
- while (<$in>){
- if (/^#### END_OF_HEADER/){
- $asis = 1; next;
- }
- s/(\$_[A-Z][A-Za-z0-9]+)_/$1/gee unless $asis;
- print $out $_;
- }
-}
-__END__
-
-=head1 NAME
-
-enc2xs -- Perl Encode Module Generator
-
-=head1 SYNOPSIS
-
- enc2xs -[options]
- enc2xs -M ModName mapfiles...
- enc2xs -C
-
-=head1 DESCRIPTION
-
-F<enc2xs> builds a Perl extension for use by Encode from either
-Unicode Character Mapping files (.ucm) or Tcl Encoding Files (.enc).
-Besides being used internally during the build process of the Encode
-module, you can use F<enc2xs> to add your own encoding to perl.
-No knowledge of XS is necessary.
-
-=head1 Quick Guide
-
-If you want to know as little about Perl as possible but need to
-add a new encoding, just read this chapter and forget the rest.
-
-=over 4
-
-=item 0.
-
-Have a .ucm file ready. You can get it from somewhere or you can write
-your own from scratch or you can grab one from the Encode distribution
-and customize it. For the UCM format, see the next Chapter. In the
-example below, I'll call my theoretical encoding myascii, defined
-in I<my.ucm>. C<$> is a shell prompt.
-
- $ ls -F
- my.ucm
-
-=item 1.
-
-Issue a command as follows;
-
- $ enc2xs -M My my.ucm
- generating Makefile.PL
- generating My.pm
- generating README
- generating Changes
-
-Now take a look at your current directory. It should look like this.
-
- $ ls -F
- Makefile.PL My.pm my.ucm t/
-
-The following files were created.
-
- Makefile.PL - MakeMaker script
- My.pm - Encode submodule
- t/My.t - test file
-
-=over 4
-
-=item 1.1.
-
-If you want *.ucm installed together with the modules, do as follows;
-
- $ mkdir Encode
- $ mv *.ucm Encode
- $ enc2xs -M My Encode/*ucm
-
-=back
-
-=item 2.
-
-Edit the files generated. You don't have to if you have no time AND no
-intention to give it to someone else. But it is a good idea to edit
-the pod and to add more tests.
-
-=item 3.
-
-Now issue a command all Perl Mongers love:
-
- $ perl Makefile.PL
- Writing Makefile for Encode::My
-
-=item 4.
-
-Now all you have to do is make.
-
- $ make
- cp My.pm blib/lib/Encode/My.pm
- /usr/local/bin/perl /usr/local/bin/enc2xs -Q -O \
- -o encode_t.c -f encode_t.fnm
- Reading myascii (myascii)
- Writing compiled form
- 128 bytes in string tables
- 384 bytes (75%) saved spotting duplicates
- 1 bytes (0.775%) saved using substrings
- ....
- chmod 644 blib/arch/auto/Encode/My/My.bs
- $
-
-The time it takes varies depending on how fast your machine is and
-how large your encoding is. Unless you are working on something big
-like euc-tw, it won't take too long.
-
-=item 5.
-
-You can "make install" already but you should test first.
-
- $ make test
- PERL_DL_NONLAZY=1 /usr/local/bin/perl -Iblib/arch -Iblib/lib \
- -e 'use Test::Harness qw(&runtests $verbose); \
- $verbose=0; runtests @ARGV;' t/*.t
- t/My....ok
- All tests successful.
- Files=1, Tests=2, 0 wallclock secs
- ( 0.09 cusr + 0.01 csys = 0.09 CPU)
-
-=item 6.
-
-If you are content with the test result, just "make install"
-
-=item 7.
-
-If you want to add your encoding to Encode's demand-loading list
-(so you don't have to "use Encode::YourEncoding"), run
-
- enc2xs -C
-
-to update Encode::ConfigLocal, a module that controls local settings.
-After that, "use Encode;" is enough to load your encodings on demand.
-
-=back
-
-=head1 The Unicode Character Map
-
-Encode uses the Unicode Character Map (UCM) format for source character
-mappings. This format is used by IBM's ICU package and was adopted
-by Nick Ing-Simmons for use with the Encode module. Since UCM is
-more flexible than Tcl's Encoding Map and far more user-friendly,
-this is the recommended format for Encode now.
-
-A UCM file looks like this.
-
- #
- # Comments
- #
- <code_set_name> "US-ascii" # Required
- <code_set_alias> "ascii" # Optional
- <mb_cur_min> 1 # Required; usually 1
- <mb_cur_max> 1 # Max. # of bytes/char
- <subchar> \x3F # Substitution char
- #
- CHARMAP
- <U0000> \x00 |0 # <control>
- <U0001> \x01 |0 # <control>
- <U0002> \x02 |0 # <control>
- ....
- <U007C> \x7C |0 # VERTICAL LINE
- <U007D> \x7D |0 # RIGHT CURLY BRACKET
- <U007E> \x7E |0 # TILDE
- <U007F> \x7F |0 # <control>
- END CHARMAP
-
-=over 4
-
-=item *
-
-Anything that follows C<#> is treated as a comment.
-
-=item *
-
-The header section continues until a line containing the word
-CHARMAP. This section has a form of I<E<lt>keywordE<gt> value>, one
-pair per line. Strings used as values must be quoted. Barewords are
-treated as numbers. I<\xXX> represents a byte.
-
-Most of the keywords are self-explanatory. I<subchar> means
-substitution character, not subcharacter. When you decode a Unicode
-sequence to this encoding but no matching character is found, the byte
-sequence defined here will be used. For most cases, the value here is
-\x3F; in ASCII, this is a question mark.
-
-=item *
-
-CHARMAP starts the character map section. Each line has a form as
-follows:
-
- <UXXXX> \xXX.. |0 # comment
- ^ ^ ^
- | | +- Fallback flag
- | +-------- Encoded byte sequence
- +-------------- Unicode Character ID in hex
-
-The format is roughly the same as a header section except for the
-fallback flag: | followed by 0..3. The meaning of the possible
-values is as follows:
-
-=over 4
-
-=item |0
-
-Round trip safe. A character decoded to Unicode encodes back to the
-same byte sequence. Most characters have this flag.
-
-=item |1
-
-Fallback for unicode -> encoding. When seen, enc2xs adds this
-character for the encode map only.
-
-=item |2
-
-Skip sub-char mapping should there be no code point.
-
-=item |3
-
-Fallback for encoding -> unicode. When seen, enc2xs adds this
-character for the decode map only.
-
-=back
-
-=item *
-
-And finally, END OF CHARMAP ends the section.
-
-=back
-
-When you are manually creating a UCM file, you should copy ascii.ucm
-or an existing encoding which is close to yours, rather than write
-your own from scratch.
-
-When you do so, make sure you leave at least B<U0000> to B<U0020> as
-is, unless your environment is EBCDIC.
-
-B<CAVEAT>: not all features in UCM are implemented. For example,
-icu:state is not used. Because of that, you need to write a perl
-module if you want to support algorithmical encodings, notably
-the ISO-2022 series. Such modules include L<Encode::JP::2022_JP>,
-L<Encode::KR::2022_KR>, and L<Encode::TW::HZ>.
-
-=head2 Coping with duplicate mappings
-
-When you create a map, you SHOULD make your mappings round-trip safe.
-That is, C<encode('your-encoding', decode('your-encoding', $data)) eq
-$data> stands for all characters that are marked as C<|0>. Here is
-how to make sure:
-
-=over 4
-
-=item *
-
-Sort your map in Unicode order.
-
-=item *
-
-When you have a duplicate entry, mark either one with '|1' or '|3'.
-
-=item *
-
-And make sure the '|1' or '|3' entry FOLLOWS the '|0' entry.
-
-=back
-
-Here is an example from big5-eten.
-
- <U2550> \xF9\xF9 |0
- <U2550> \xA2\xA4 |3
-
-Internally Encoding -> Unicode and Unicode -> Encoding Map looks like
-this;
-
- E to U U to E
- --------------------------------------
- \xF9\xF9 => U2550 U2550 => \xF9\xF9
- \xA2\xA4 => U2550
-
-So it is round-trip safe for \xF9\xF9. But if the line above is upside
-down, here is what happens.
-
- E to U U to E
- --------------------------------------
- \xA2\xA4 => U2550 U2550 => \xF9\xF9
- (\xF9\xF9 => U2550 is now overwritten!)
-
-The Encode package comes with F<ucmlint>, a crude but sufficient
-utility to check the integrity of a UCM file. Check under the
-Encode/bin directory for this.
-
-When in doubt, you can use F<ucmsort>, yet another utility under
-Encode/bin directory.
-
-=head1 Bookmarks
-
-=over 4
-
-=item *
-
-ICU Home Page
-L<http://www.icu-project.org/>
-
-=item *
-
-ICU Character Mapping Tables
-L<http://site.icu-project.org/charts/charset>
-
-=item *
-
-ICU:Conversion Data
-L<http://www.icu-project.org/userguide/conversion-data.html>
-
-=back
-
-=head1 SEE ALSO
-
-L<Encode>,
-L<perlmod>,
-L<perlpod>
-
-=cut
-
-# -Q to disable the duplicate codepoint test
-# -S make mapping errors fatal
-# -q to remove comments written to output files
-# -O to enable the (brute force) substring optimiser
-# -o <output> to specify the output file name (else it's the first arg)
-# -f <inlist> to give a file with a list of input files (else use the args)
-# -n <name> to name the encoding (else use the basename of the input file.
-
-With %seen holding array refs:
-
- 865.66 real 28.80 user 8.79 sys
- 7904 maximum resident set size
- 1356 average shared memory size
- 18566 average unshared data size
- 229 average unshared stack size
- 46080 page reclaims
- 33373 page faults
-
-With %seen holding simple scalars:
-
- 342.16 real 27.11 user 3.54 sys
- 8388 maximum resident set size
- 1394 average shared memory size
- 14969 average unshared data size
- 236 average unshared stack size
- 28159 page reclaims
- 9839 page faults
-
-Yes, 5 minutes is faster than 15. Above is for CP936 in CN. Only difference is
-how %seen is storing things its seen. So it is pathalogically bad on a 16M
-RAM machine, but it's going to help even on modern machines.
-Swapping is bad, m'kay :-)