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