[p5sagit/p5-mst-13.2.git] / ext / Encode / compile

#!../../perl -w
BEGIN {
    unshift @INC, qw(../../lib ../../../lib);
    $ENV{PATH} .= ';../..;../../..' if $^O eq 'MSWin32';
}
use strict;
use Getopt::Std;
my @orig_ARGV = @ARGV;

# 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;
getopts('qOo:f:n:',\%opt);
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;
$dname =~ s/(\.[^\.]*)?$/_def.h/;

my ($doC,$doEnc,$doUcm,$doPet);

if ($cname =~ /\.(c|xs)$/)
 {
  $doC = 1;
  chmod(0666,$dname) if -f $cname && !-w $dname;
  open(D,">$dname") || die "Cannot open $dname:$!";
  my $hname = $cname;
  $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
*/
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";

 }
elsif ($cname =~ /\.enc$/)
 {
  $doEnc = 1;
 }
elsif ($cname =~ /\.ucm$/)
 {
  $doUcm = 1;
 }
elsif ($cname =~ /\.pet$/)
 {
  $doPet = 1;
 }

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 %encoding;
my %strings;
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}};
    output(\*C,$name.'_utf8',$e2u);
    output(\*C,'utf8_'.$name,$u2e);
    push(@{$encoding{$name}},outstring(\*C,$e2u->{Cname}.'_def',$erep));
   }
  foreach my $enc (sort cmp_name keys %encoding)
   {
    my ($e2u,$u2e,$rep,$min_el,$max_el,$rsym) = @{$encoding{$enc}};
    my @info = ($e2u->{Cname},$u2e->{Cname},$rsym,length($rep),$min_el,$max_el);
    my $sym = "${enc}_encoding";
    $sym =~ s/\W+/_/g;
    print C "encode_t $sym = \n";
    print C " {",join(',',@info,"{\"$enc\",(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(D);
  close(H);
  printf STDERR "%d bytes in string tables\n",$strings;
  printf STDERR "%d bytes (%.3g%%) saved spotting duplicates\n",$saved,100*$saved/$strings if $saved;
  printf STDERR "%d bytes (%.3g%%) saved using substrings\n",$subsave,100*$subsave/$strings 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);
   }
 }

close(C);


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));
  }
 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 ($u,@byte);
   my $fb = '';
   $u = $1 if (/^<U([0-9a-f]+)>\s+/igc);
   push(@byte,$1) while /\G\\x([0-9a-f]+)/igc;
   $fb = $1 if /\G\s*(\|[0-3])/gc;
   # warn "$_: $u @byte | $fb\n";
   die "Bad line:$_" unless /\G\s*(#.*)?$/gc;
   if (defined($u))
    {
     my $uch = encode_U(hex($u));
     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';
 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 = &{$encode_types{$type}}($v & 0xFF, ($v >> 8) & 0xffe);
 }
 my %seen;
 while ($pages--)
  {
   my $line = <$fh>;
   chomp($line);
   my $page = hex($line);
   my $ch = 0;
   for (0..15)
    {
     my $line = <$fh>;
     die "Line should be exactly 65 characters long including newline"
       unless length ($line) == 65;
     # Split line into groups of 4 hex digits, convert groups to ints
     for my $val (map {hex $_} $line =~ /(....)/g)
      {
       next if $val == 0xFFFD;
       my $ech = &{$encode_types{$type}}($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 (exists $seen{$uch})
          {
           warn sprintf("U%04X is %02X%02X and %02X%02X\n",
                        $val,$page,$ch,@{$seen{$uch}});
          }
         else
          {
           $seen{$uch} = [$page,$ch];
          }
         # Passing 2 extra args each time is 3.6% slower!
         # Even with having to add $fallback ||= 0 in &process
         enter($e2u,$ech,$uch);
         enter($u2e,$uch,$ech);
        }
       else
        {
         # No character at this position
         # enter($e2u,$ech,undef,$e2u);
        }
       $ch++;
      }
    }
  }
 die "\$min_el=$min_el, \$max_el=$max_el - seems we read no lines"
   if $min_el > $max_el;
 $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.
  $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];
  }
}


sub outstring
{
 my ($fh,$name,$s) = @_;
 my $sym = $strings{$s};
 if ($sym)
  {
   $saved += length($s);
  }
 else
  {
   if ($opt{'O'}) {
       foreach my $o (keys %strings)
        {
         my $i = index($o,$s);
         if ($i >= 0)
          {
           $sym = $strings{$o};
           $sym .= sprintf("+0x%02x",$i) if ($i);
           $subsave += length($s);
           $strings{$s} = $sym;
           return $sym;
          }
        }
   }
   $strings{$s} = $sym = $name;
   $strings += length($s);
   my $definition = sprintf "static const U8 %s[%d] = { ",$name,length($s);
   # Maybe we should assert that these are all <256.
   $definition .= join(',',unpack "C*",$s);
   # We have a single long line. Split it at convenient commas.
   $definition =~ s/(.{74,77},)/$1\n/g;
   print $fh "$definition };\n\n";
  }
 return $sym;
}

sub process
{
  my ($name,$a) = @_;
  $name =~ s/\W+/_/g;
  $a->{Cname} = $name;
  my @raw = sort keys %{$a->{Raw}};
  my ($l, $agg_max_in, $agg_next, $agg_in_len, $agg_out_len, $agg_fallback);
  my @ent;
  foreach my $key (@raw) {
    #  RAW_NEXT => 0,
    #  RAW_IN_LEN => 1,
    #  RAW_OUT_BYTES => 2,
    #  RAW_FALLBACK => 3,
    my ($next, $in_len, $out_bytes, $fallback) = @{$a->{Raw}{$key}};
    # Now we are converting from raw to aggregate, switch from 1 byte strings
    # to numbers
    my $b = ord $key;
    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 (ord $raw[-1] < 255) {
    push @ent, [1+ord $raw[-1], 255,undef,$a,0,0];
  }
  $a->{'Entries'} = \@ent;
}

sub outtable
{
 my ($fh,$a) = @_;
 my $name = $a->{'Cname'};
 # String tables
 foreach my $b (@{$a->{'Entries'}})
  {
   next unless $b->[AGG_OUT_LEN];
   my $s = $b->[AGG_MIN_IN];
   my $e = $b->[AGG_MAX_IN];
   outstring($fh,sprintf("%s__%02x_%02x",$name,$s,$e),$b->[AGG_OUT_BYTES]);
  }
 if ($a->{'Forward'})
  {
   print $fh "\nstatic encpage_t $name\[",scalar(@{$a->{'Entries'}}),"];\n";
  }
 $a->{'Done'} = 1;
 foreach my $b (@{$a->{'Entries'}})
  {
   my ($s,$e,$out,$t,$end,$l) = @$b;
   outtable($fh,$t) unless $t->{'Done'};
  }
 print $fh "\nstatic 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;
   print  $fh "{";
   if ($l)
    {
     printf $fh outstring($fh,'',$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
{
 my ($fh,$name,$a) = @_;
 process($name,$a);
 # Sub-tables
 outtable($fh,$a);
}

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);
 foreach my $b (sort keys %$t)
  {
    die "Changed - fix me for new structure";
   my ($s,$e,$out,$n,$end,$l,$fb) = @{$t->{$b}};
   die "oops $s $e" unless $s eq $e;
   my $u = ord($s);
   if ($n != $a && $n != $t)
    {
     output_ucm_page($cmap,$a,$n,(($pre|($u &0x3F)) << 6)&0xFFFF);
    }
   elsif (length($out))
    {
     if ($pre)
      {
       $u = $pre|($u &0x3f);
      }
     my $s = sprintf "<U%04X> ",$u;
     foreach my $c (split(//,$out))
      {
       $s .= sprintf "\\x%02X",ord($c);
      }
     $s .= sprintf " |%d # %s\n",($fb ? 1 : 0),$uname[$u];
     push(@$cmap,$s);
    }
   else
    {
     warn join(',',@{$t->{$b}},$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";
}