ext/Encode/compile

   1 #!../../perl -w
   2 BEGIN { @INC = '../../lib' };
   3 use strict;
   4 use Getopt::Std;
   5 my @orig_ARGV = @ARGV;
   6
   7 sub encode_U
   8 {
   9  # UTF-8 encode long hand - only covers part of perl's range
  10  my $uv = shift;
  11  if ($uv < 0x80)
  12   {
  13    return chr($uv)
  14   }
  15  if ($uv < 0x800)
  16   {
  17    return chr(($uv >> 6)        | 0xC0).
  18           chr(($uv & 0x3F)      | 0x80);
  19   }
  20  return chr(($uv >> 12)         | 0xE0).
  21         chr((($uv >> 6) & 0x3F) | 0x80).
  22         chr(($uv & 0x3F)        | 0x80);
  23 }
  24
  25 sub encode_S
  26 {
  27  # encode single byte
  28  my ($ch,$page) = @_;
  29  return chr($ch);
  30 }
  31
  32 sub encode_D
  33 {
  34  # encode double byte MS byte first
  35  my ($ch,$page) = @_;
  36  return chr($page).chr($ch);
  37 }
  38
  39 sub encode_M
  40 {
  41  # encode Multi-byte - single for 0..255 otherwise double
  42  my ($ch,$page) = @_;
  43  return &encode_D if $page;
  44  return &encode_S;
  45 }
  46
  47 # Win32 does not expand globs on command line
  48 eval "\@ARGV = map(glob(\$_),\@ARGV)" if ($^O eq 'MSWin32');
  49
  50 my %opt;
  51 getopts('qo:F:',\%opt);
  52 my $cname = (exists $opt{'o'}) ? $opt{'o'} : shift(@ARGV);
  53 chmod(0666,$cname) if -f $cname && !-w $cname;
  54 open(C,">$cname") || die "Cannot open $cname:$!";
  55
  56
  57 my $dname = $cname;
  58 $dname =~ s/(\.[^\.]*)?$/.def/;
  59
  60 my ($doC,$doEnc,$doUcm);
  61
  62 if ($cname =~ /\.(c|xs)$/)
  63  {
  64   $doC = 1;
  65   chmod(0666,$dname) if -f $cname && !-w $dname;
  66   open(D,">$dname") || die "Cannot open $dname:$!";
  67   my $hname = $cname;
  68   $hname =~ s/(\.[^\.]*)?$/.h/;
  69   chmod(0666,$hname) if -f $cname && !-w $hname;
  70   open(H,">$hname") || die "Cannot open $hname:$!";
  71
  72   foreach my $fh (\*C,\*D,\*H)
  73   {
  74    print $fh <<"END" unless $opt{'q'};
  75 /*
  76  !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
  77  This file was autogenerated by:
  78  $^X $0 $cname @orig_ARGV
  79 */
  80 END
  81   }
  82
  83   if ($cname =~ /(\w+)\.xs$/)
  84    {
  85     print C "#include <EXTERN.h>\n";
  86     print C "#include <perl.h>\n";
  87     print C "#include <XSUB.h>\n";
  88     print C "#define U8 U8\n";
  89    }
  90   print C "#include \"encode.h\"\n";
  91  }
  92 elsif ($cname =~ /\.enc$/)
  93  {
  94   $doEnc = 1;
  95  }
  96 elsif ($cname =~ /\.ucm$/)
  97  {
  98   $doUcm = 1;
  99  }
 100
 101 my @encfiles;
 102 if (exists $opt{'F'})
 103  {
 104   # -F is followed by name of file containing list of filenames
 105   my $flist = $opt{'F'};
 106   open(FLIST,$flist) || die "Cannot open $flist:$!";
 107   chomp(@encfiles = <FLIST>);
 108   close(FLIST);
 109  }
 110 else
 111  {
 112   @encfiles = @ARGV;
 113  }
 114
 115 my %encoding;
 116 my %strings;
 117
 118 sub cmp_name
 119 {
 120  if ($a =~ /^.*-(\d+)/)
 121   {
 122    my $an = $1;
 123    if ($b =~ /^.*-(\d+)/)
 124     {
 125      my $r = $an <=> $1;
 126      return $r if $r;
 127     }
 128   }
 129  return $a cmp $b;
 130 }
 131
 132 foreach my $enc (sort cmp_name @encfiles)
 133  {
 134   my ($name,$sfx) = $enc =~ /^.*?([\w-]+)\.(enc|ucm)$/;
 135   if (open(E,$enc))
 136    {
 137     if ($sfx eq 'enc')
 138      {
 139       compile_enc(\*E,lc($name),\*C);
 140      }
 141     else
 142      {
 143       compile_ucm(\*E,lc($name),\*C);
 144      }
 145    }
 146   else
 147    {
 148     warn "Cannot open $enc for $name:$!";
 149    }
 150  }
 151
 152 if ($doC)
 153  {
 154   foreach my $enc (sort cmp_name keys %encoding)
 155    {
 156     my $sym = "${enc}_encoding";
 157     $sym =~ s/\W+/_/g;
 158     print C "encode_t $sym = \n";
 159     print C " {",join(',',"\"$enc\"",@{$encoding{$enc}}),"};\n\n";
 160    }
 161
 162   foreach my $enc (sort cmp_name keys %encoding)
 163    {
 164     my $sym = "${enc}_encoding";
 165     $sym =~ s/\W+/_/g;
 166     print H "extern encode_t $sym;\n";
 167     print D " Encode_Define(aTHX_ &$sym);\n";
 168    }
 169
 170   if ($cname =~ /(\w+)\.xs$/)
 171    {
 172     my $mod = $1;
 173     print C "\nMODULE = Encode::$mod\tPACKAGE = Encode::$mod\n\n";
 174     print C "BOOT:\n{\n";
 175     print C "#include \"$dname\"\n";
 176     print C "}\n";
 177    }
 178   close(D);
 179   close(H);
 180  }
 181 close(C);
 182
 183
 184 sub compile_ucm
 185 {
 186  my ($fh,$name,$ch) = @_;
 187  my $e2u = {};
 188  my $u2e = {};
 189  my $cs;
 190  my %attr;
 191  while (<$fh>)
 192   {
 193    s/#.*$//;
 194    last if /^\s*CHARMAP\s*$/i;
 195    if (/^\s*<(\w+)>\s+"?([^"]*)"?\s*$/i)
 196     {
 197      $attr{$1} = $2;
 198     }
 199   }
 200  if (!defined($cs =  $attr{'code_set_name'}))
 201   {
 202    warn "No <code_set_name> in $name\n";
 203   }
 204  else
 205   {
 206    # $name = lc($cs);
 207   }
 208  my $erep;
 209  my $urep;
 210  my $max_el;
 211  my $min_el;
 212  if (exists $attr{'subchar'})
 213   {
 214    my @byte;
 215    $attr{'subchar'} =~ /^\s*/cg;
 216    push(@byte,$1) while $attr{'subchar'} =~ /\G\\x([0-9a-f]+)/icg;
 217    $erep = join('',map(chr(hex($_)),@byte));
 218   }
 219  warn "Scanning $name ($cs)\n";
 220  my $nfb = 0;
 221  my $hfb = 0;
 222  while (<$fh>)
 223   {
 224    s/#.*$//;
 225    last if /^\s*END\s+CHARMAP\s*$/i;
 226    next if /^\s*$/;
 227    my ($u,@byte);
 228    my $fb = '';
 229    $u = $1 if (/^<U([0-9a-f]+)>\s+/igc);
 230    push(@byte,$1) while /\G\\x([0-9a-f]+)/igc;
 231    $fb = $1 if /\G\s*(\|[0-3])/gc;
 232    # warn "$_: $u @byte | $fb\n";
 233    die "Bad line:$_" unless /\G\s*(#.*)?$/gc;
 234    if (defined($u))
 235     {
 236      my $uch = encode_U(hex($u));
 237      my $ech = join('',map(chr(hex($_)),@byte));
 238      my $el  = length($ech);
 239      $max_el = $el if (!defined($max_el) || $el > $max_el);
 240      $min_el = $el if (!defined($min_el) || $el < $min_el);
 241      if (length($fb))
 242       {
 243        $fb = substr($fb,1);
 244        $hfb++;
 245       }
 246      else
 247       {
 248        $nfb++;
 249        $fb = '0';
 250       }
 251      # $fb is fallback flag
 252      # 0 - round trip safe
 253      # 1 - fallback for unicode -> enc
 254      # 2 - skip sub-char mapping
 255      # 3 - fallback enc -> unicode
 256      enter($u2e,$uch,$ech,$u2e,$fb+0) if ($fb =~ /[01]/);
 257      enter($e2u,$ech,$uch,$e2u,$fb+0) if ($fb =~ /[03]/);
 258     }
 259    else
 260     {
 261      warn $_;
 262     }
 263   }
 264  if ($nfb && $hfb)
 265   {
 266    die "$nfb entries without fallback, $hfb entries with\n";
 267   }
 268  if ($doC)
 269   {
 270    output($ch,$name.'_utf8',$e2u);
 271    output($ch,'utf8_'.$name,$u2e);
 272    $encoding{$name} = [$e2u->{Cname},$u2e->{Cname},
 273                        outstring($ch,$e2u->{Cname}.'_def',$erep),length($erep)];
 274   }
 275  elsif ($doEnc)
 276   {
 277    output_enc($ch,$name,$e2u);
 278   }
 279  elsif ($doUcm)
 280   {
 281    output_ucm($ch,$name,$u2e,$erep,$min_el,$max_el);
 282   }
 283 }
 284
 285 sub compile_enc
 286 {
 287  my ($fh,$name,$ch) = @_;
 288  my $e2u = {};
 289  my $u2e = {};
 290
 291  my $type;
 292  while ($type = <$fh>)
 293   {
 294    last if $type !~ /^\s*#/;
 295   }
 296  chomp($type);
 297  return if $type eq 'E';
 298  my ($def,$sym,$pages) = split(/\s+/,scalar(<$fh>));
 299  warn "$type encoded $name\n";
 300  my $rep = '';
 301  my $min_el;
 302  my $max_el;
 303  {
 304   my $v = hex($def);
 305   no strict 'refs';
 306   $rep = &{"encode_$type"}($v & 0xFF, ($v >> 8) & 0xffe);
 307  }
 308  while ($pages--)
 309   {
 310    my $line = <$fh>;
 311    chomp($line);
 312    my $page = hex($line);
 313    my $ch = 0;
 314    for (my $i = 0; $i < 16; $i++)
 315     {
 316      my $line = <$fh>;
 317      for (my $j = 0; $j < 16; $j++)
 318       {
 319        no strict 'refs';
 320        my $ech = &{"encode_$type"}($ch,$page);
 321        my $val = hex(substr($line,0,4,''));
 322        if ($val || (!$ch && !$page))
 323         {
 324          my $el  = length($ech);
 325          $max_el = $el if (!defined($max_el) || $el > $max_el);
 326          $min_el = $el if (!defined($min_el) || $el < $min_el);
 327          my $uch = encode_U($val);
 328          enter($e2u,$ech,$uch,$e2u,0);
 329          enter($u2e,$uch,$ech,$u2e,0);
 330         }
 331        else
 332         {
 333          # No character at this position
 334          # enter($e2u,$ech,undef,$e2u);
 335         }
 336        $ch++;
 337       }
 338     }
 339   }
 340  if ($doC)
 341   {
 342    output($ch,$name.'_utf8',$e2u);
 343    output($ch,'utf8_'.$name,$u2e);
 344    $encoding{$name} = [$e2u->{Cname},$u2e->{Cname},
 345                        outstring($ch,$e2u->{Cname}.'_def',$rep),length($rep)];
 346   }
 347  elsif ($doEnc)
 348   {
 349    output_enc($ch,$name,$e2u);
 350   }
 351  elsif ($doUcm)
 352   {
 353    output_ucm($ch,$name,$u2e,$rep,$min_el,$max_el);
 354   }
 355 }
 356
 357 sub enter
 358 {
 359  my ($a,$s,$d,$t,$fb) = @_;
 360  $t = $a if @_ < 4;
 361  my $b = substr($s,0,1);
 362  my $e = $a->{$b};
 363  unless ($e)
 364   {     # 0  1  2  3         4  5
 365    $e = [$b,$b,'',{},length($s),0,$fb];
 366    $a->{$b} = $e;
 367   }
 368  if (length($s) > 1)
 369   {
 370    enter($e->[3],substr($s,1),$d,$t,$fb);
 371   }
 372  else
 373   {
 374    $e->[2] = $d;
 375    $e->[3] = $t;
 376    $e->[5] = length($d);
 377   }
 378 }
 379
 380 sub outstring
 381 {
 382  my ($fh,$name,$s) = @_;
 383  my $sym = $strings{$s};
 384  unless ($sym)
 385   {
 386    foreach my $o (keys %strings)
 387     {
 388      my $i = index($o,$s);
 389      if ($i >= 0)
 390       {
 391        $sym = $strings{$o};
 392        $sym .= sprintf("+0x%02x",$i) if ($i);
 393        return $sym;
 394       }
 395     }
 396    $strings{$s} = $sym = $name;
 397    printf $fh "\nstatic const U8 %s[%d] =\n",$name,length($s);
 398    # Do in chunks of 16 chars to constrain line length
 399    # Assumes ANSI C adjacent string litteral concatenation
 400    while (length($s))
 401     {
 402      my $c = substr($s,0,16,'');
 403      print  $fh '"',join('',map(sprintf('\x%02x',ord($_)),split(//,$c))),'"';
 404      print  $fh "\n" if length($s);
 405     }
 406    printf $fh ";\n";
 407   }
 408  return $sym;
 409 }
 410
 411 sub process
 412 {
 413  my ($name,$a) = @_;
 414  $name =~ s/\W+/_/g;
 415  $a->{Cname} = $name;
 416  my @keys = grep(ref($a->{$_}),sort keys %$a);
 417  my $l;
 418  my @ent;
 419  foreach my $b (@keys)
 420   {
 421    my ($s,$f,$out,$t,$end) = @{$a->{$b}};
 422    if (defined($l) &&
 423        ord($b) == ord($a->{$l}[1])+1 &&
 424        $a->{$l}[3] == $a->{$b}[3] &&
 425        $a->{$l}[4] == $a->{$b}[4] &&
 426        $a->{$l}[5] == $a->{$b}[5] &&
 427        $a->{$l}[6] == $a->{$b}[6]
 428        # && length($a->{$l}[2]) < 16
 429       )
 430     {
 431      my $i = ord($b)-ord($a->{$l}[0]);
 432      $a->{$l}[1]  = $b;
 433      $a->{$l}[2] .= $a->{$b}[2];
 434     }
 435    else
 436     {
 437      $l = $b;
 438      push(@ent,$b);
 439     }
 440    if (exists $t->{Cname})
 441     {
 442      $t->{'Forward'} = 1 if $t != $a;
 443     }
 444    else
 445     {
 446      process(sprintf("%s_%02x",$name,ord($s)),$t);
 447     }
 448   }
 449  if (ord($keys[-1]) < 255)
 450   {
 451    my $t = chr(ord($keys[-1])+1);
 452    $a->{$t} = [$t,chr(255),undef,$a,0,0];
 453    push(@ent,$t);
 454   }
 455  $a->{'Entries'} = \@ent;
 456 }
 457
 458 sub outtable
 459 {
 460  my ($fh,$a) = @_;
 461  my $name = $a->{'Cname'};
 462  # String tables
 463  foreach my $b (@{$a->{'Entries'}})
 464   {
 465    next unless $a->{$b}[5];
 466    my $s = ord($a->{$b}[0]);
 467    my $e = ord($a->{$b}[1]);
 468    outstring($fh,sprintf("%s__%02x_%02x",$name,$s,$e),$a->{$b}[2]);
 469   }
 470  if ($a->{'Forward'})
 471   {
 472    print $fh "\nstatic encpage_t $name\[",scalar(@{$a->{'Entries'}}),"];\n";
 473   }
 474  $a->{'Done'} = 1;
 475  foreach my $b (@{$a->{'Entries'}})
 476   {
 477    my ($s,$e,$out,$t,$end,$l) = @{$a->{$b}};
 478    outtable($fh,$t) unless $t->{'Done'};
 479   }
 480  print $fh "\nstatic encpage_t $name\[",scalar(@{$a->{'Entries'}}),"] = {\n";
 481  foreach my $b (@{$a->{'Entries'}})
 482   {
 483    my ($s,$e,$out,$t,$end,$l,$fb) = @{$a->{$b}};
 484    my $sc = ord($s);
 485    my $ec = ord($e);
 486    $end |= 0x80 if $fb;
 487    print  $fh "{";
 488    if ($l)
 489     {
 490      printf $fh outstring($fh,'',$out);
 491     }
 492    else
 493     {
 494      print  $fh "0";
 495     }
 496    print  $fh ",",$t->{Cname};
 497    printf $fh ",0x%02x,0x%02x,$l,$end},\n",$sc,$ec;
 498   }
 499  print $fh "};\n";
 500 }
 501
 502 sub output
 503 {
 504  my ($fh,$name,$a) = @_;
 505  process($name,$a);
 506  # Sub-tables
 507  outtable($fh,$a);
 508 }
 509
 510 sub output_enc
 511 {
 512  my ($fh,$name,$a) = @_;
 513  foreach my $b (sort keys %$a)
 514   {
 515    my ($s,$e,$out,$t,$end,$l,$fb) = @{$a->{$b}};
 516   }
 517 }
 518
 519 sub decode_U
 520 {
 521  my $s = shift;
 522 }
 523
 524 sub output_ucm_page
 525 {
 526  my ($fh,$a,$t,$pre) = @_;
 527  # warn sprintf("Page %x\n",$pre);
 528  foreach my $b (sort keys %$t)
 529   {
 530    my ($s,$e,$out,$n,$end,$l,$fb) = @{$t->{$b}};
 531    die "oops $s $e" unless $s eq $e;
 532    my $u = ord($s);
 533    if ($n != $a && $n != $t)
 534     {
 535      output_ucm_page($fh,$a,$n,(($pre|($u &0x3F)) << 6)&0xFFFF);
 536     }
 537    elsif (length($out))
 538     {
 539      if ($pre)
 540       {
 541        $u = $pre|($u &0x3f);
 542       }
 543      printf $fh "<U%04X> ",$u;
 544      foreach my $c (split(//,$out))
 545       {
 546        printf $fh "\\x%02X",ord($c);
 547       }
 548      printf $fh " |%d\n",($fb ? 1 : 0);
 549     }
 550    else
 551     {
 552      warn join(',',@{$t->{$b}},$a,$t);
 553     }
 554   }
 555 }
 556
 557 sub output_ucm
 558 {
 559  my ($fh,$name,$a,$rep,$min_el,$max_el) = @_;
 560  print $fh "# Written by $0 @orig_ARGV\n" unless $opt{'q'};
 561  print $fh "<code_set_name> \"$name\"\n";
 562  if (defined $min_el)
 563   {
 564    print $fh "<mb_cur_min> $min_el\n";
 565   }
 566  if (defined $max_el)
 567   {
 568    print $fh "<mb_cur_max> $max_el\n";
 569   }
 570  if (defined $rep)
 571   {
 572    print $fh "<subchar> ";
 573    foreach my $c (split(//,$rep))
 574     {
 575      printf $fh "\\x%02X",ord($c);
 576     }
 577    print $fh "\n";
 578   }
 579  print $fh "#\nCHARMAP\n";
 580  output_ucm_page($fh,$a,$a,0);
 581  print $fh "END CHARMAP\n";
 582 }
 583