The #11132 missed singleton characters (not part
[p5sagit/p5-mst-13.2.git] / lib / unicode / mktables.PL
1 #!../../miniperl
2
3 use bytes;
4
5 $UnicodeData = "Unicode.txt";
6 $SyllableData = "syllables.txt";
7 $PropData = "PropList.txt";
8
9
10 # Note: we try to keep filenames unique within first 8 chars.  Using
11 # subdirectories for the following helps.
12 mkdir "In", 0755;
13 mkdir "Is", 0755;
14 mkdir "To", 0755;
15
16 @todo = (
17 # typical
18
19     # 005F: SPACING UNDERSCROE
20     ['IsWord',   '$cat =~ /^[LMN]/ or $code eq "005F"', ''],
21     ['IsAlnum',  '$cat =~ /^[LMN]/',    ''],
22     ['IsAlpha',  '$cat =~ /^[LM]/',     ''],
23     # 0009: HORIZONTAL TABULATION
24     # 000A: LINE FEED
25     # 000B: VERTICAL TABULATION
26     # 000C: FORM FEED
27     # 000D: CARRIAGE RETURN
28     # 0020: SPACE
29     ['IsSpace',  '$cat  =~ /^Z/ ||
30                   $code =~ /^(0009|000A|000B|000C|000D)$/',     ''],
31     ['IsSpacePerl',
32                  '$cat  =~ /^Z/ ||
33                   $code =~ /^(0009|000A|000C|000D)$/',          ''],
34     ['IsBlank',  '$code =~ /^(0020|0009)$/ ||
35                   $cat  =~ /^Z[^lp]$/', ''],
36     ['IsDigit',  '$cat =~ /^Nd$/',      ''],
37     ['IsUpper',  '$cat =~ /^L[ut]$/',   ''],
38     ['IsLower',  '$cat =~ /^Ll$/',      ''],
39     ['IsASCII',  '$code le "007f"',     ''],
40     ['IsCntrl',  '$cat =~ /^C/',        ''],
41     ['IsGraph',  '$cat =~ /^([LMNPS]|Co)/',     ''],
42     ['IsPrint',  '$cat =~ /^([LMNPS]|Co|Zs)/',  ''],
43     ['IsPunct',  '$cat =~ /^P/',        ''],
44     # 003[0-9]: DIGIT ZERO..NINE, 00[46][1-6]: A..F, a..f
45     ['IsXDigit', '$code =~ /^00(3[0-9]|[46][1-6])$/',   ''],
46     ['ToUpper',  '$up',                 '$up'],
47     ['ToLower',  '$down',               '$down'],
48     ['ToTitle',  '$title',              '$title'],
49     ['ToDigit',  '$dec ne ""',          '$dec'],
50
51 # Name
52
53     ['Name',    '$name',                '$name'],
54
55 # Category
56
57     ['Category', '$cat',                '$cat'],
58
59 # Normative
60
61     ['IsM',     '$cat =~ /^M/',         ''],    # Mark
62     ['IsMn',    '$cat eq "Mn"',         ''],    # Mark, Non-Spacing 
63     ['IsMc',    '$cat eq "Mc"',         ''],    # Mark, Combining
64     ['IsMe',    '$cat eq "Me"',         ''],    # Mark, Enclosing
65
66     ['IsN',     '$cat =~ /^N/',         ''],    # Number
67     ['IsNd',    '$cat eq "Nd"',         ''],    # Number, Decimal Digit
68     ['IsNo',    '$cat eq "No"',         ''],    # Number, Other
69     ['IsNl',    '$cat eq "Nl"',         ''],    # Number, Letter
70
71     ['IsZ',     '$cat =~ /^Z/',         ''],    # Separator
72     ['IsZs',    '$cat eq "Zs"',         ''],    # Separator, Space
73     ['IsZl',    '$cat eq "Zl"',         ''],    # Separator, Line
74     ['IsZp',    '$cat eq "Zp"',         ''],    # Separator, Paragraph
75
76     ['IsC',     '$cat =~ /^C/',         ''],    # Crazy
77     ['IsCc',    '$cat eq "Cc"',         ''],    # Other, Control or Format
78     ['IsCo',    '$cat eq "Co"',         ''],    # Other, Private Use
79     ['IsCn',    '$cat eq "Cn"',         ''],    # Other, Not Assigned
80     ['IsCf',    '$cat eq "Cf"',         ''],    # Other, Format
81     ['IsCs',    '$cat eq "Cs"',         ''],    # Other, Surrogate
82     ['IsCn',    'Unassigned Code Value',$PropData],     # Other, Not Assigned
83  
84 # Informative
85
86     ['IsL',     '$cat =~ /^L/',         ''],    # Letter
87     ['IsLu',    '$cat eq "Lu"',         ''],    # Letter, Uppercase
88     ['IsLl',    '$cat eq "Ll"',         ''],    # Letter, Lowercase
89     ['IsLt',    '$cat eq "Lt"',         ''],    # Letter, Titlecase 
90     ['IsLm',    '$cat eq "Lm"',         ''],    # Letter, Modifier
91     ['IsLo',    '$cat eq "Lo"',         ''],    # Letter, Other 
92
93     ['IsP',     '$cat =~ /^P/',         ''],    # Punctuation
94     ['IsPd',    '$cat eq "Pd"',         ''],    # Punctuation, Dash
95     ['IsPs',    '$cat eq "Ps"',         ''],    # Punctuation, Open
96     ['IsPe',    '$cat eq "Pe"',         ''],    # Punctuation, Close
97     ['IsPo',    '$cat eq "Po"',         ''],    # Punctuation, Other
98     ['IsPc',    '$cat eq "Pc"',         ''],    # Punctuation, Connector
99     ['IsPi',    '$cat eq "Pi"',         ''],    # Punctuation, Initial quote
100     ['IsPf',    '$cat eq "Pf"',         ''],    # Punctuation, Final quote
101
102     ['IsS',     '$cat =~ /^S/',         ''],    # Symbol
103     ['IsSm',    '$cat eq "Sm"',         ''],    # Symbol, Math
104     ['IsSk',    '$cat eq "Sk"',         ''],    # Symbol, Modifier
105     ['IsSc',    '$cat eq "Sc"',         ''],    # Symbol, Currency
106     ['IsSo',    '$cat eq "So"',         ''],    # Symbol, Other
107
108 # Combining class
109     ['CombiningClass', '$comb',         '$comb'],
110
111 # BIDIRECTIONAL PROPERTIES
112  
113     ['Bidirectional', '$bid',           '$bid'],
114
115 # Strong types:
116
117     ['IsBidiL', '$bid eq "L"',          ''],    # Left-Right; Most alphabetic,
118                                                 # syllabic, and logographic
119                                                 # characters (e.g., CJK
120                                                 # ideographs)
121     ['IsBidiR', '$bid eq "R"',          ''],    # Right-Left; Arabic, Hebrew,
122                                                 # and punctuation specific to
123                                                 # those scripts
124
125     ['IsBidiLRE', '$bid eq "LRE"',       ''],    # Left-to-Right Embedding
126     ['IsBidiLRO', '$bid eq "LRO"',       ''],    # Left-to-Right Override
127     ['IsBidiAL', '$bid eq "AL"',         ''],    # Right-to-Left Arabic
128     ['IsBidiRLE', '$bid eq "RLE"',       ''],    # Right-to-Left Embedding
129     ['IsBidiRLO', '$bid eq "RLO"',       ''],    # Right-to-Left Override
130     ['IsBidiPDF', '$bid eq "PDF"',       ''],    # Pop Directional Format
131     ['IsBidiNSM', '$bid eq "NSM"',       ''],    # Non-Spacing Mark
132     ['IsBidiBN', '$bid eq "BN"',         ''],    # Boundary Neutral
133
134 # Weak types:
135
136     ['IsBidiEN','$bid eq "EN"',         ''],    # European Number
137     ['IsBidiES','$bid eq "ES"',         ''],    # European Number Separator
138     ['IsBidiET','$bid eq "ET"',         ''],    # European Number Terminator
139     ['IsBidiAN','$bid eq "AN"',         ''],    # Arabic Number
140     ['IsBidiCS','$bid eq "CS"',         ''],    # Common Number Separator
141
142 # Separators:
143
144     ['IsBidiB', '$bid eq "B"',          ''],    # Block Separator
145     ['IsBidiS', '$bid eq "S"',          ''],    # Segment Separator
146
147 # Neutrals:
148
149     ['IsBidiWS','$bid eq "WS"',         ''],    # Whitespace
150     ['IsBidiON','$bid eq "ON"',         ''],    # Other Neutrals ; All other
151                                                 # characters: punctuation,
152                                                 # symbols
153
154 # Decomposition
155
156     ['Decomposition',   '$decomp',      '$decomp'],
157     ['IsDecoCanon',     '$decomp && $decomp !~ /^</',   ''],
158     ['IsDecoCompat',    '$decomp =~ /^</',              ''],
159     ['IsDCfont',        '$decomp =~ /^<font>/',         ''],
160     ['IsDCnoBreak',     '$decomp =~ /^<noBreak>/',      ''],
161     ['IsDCinitial',     '$decomp =~ /^<initial>/',      ''],
162     ['IsDCmedial',      '$decomp =~ /^<medial>/',       ''],
163     ['IsDCfinal',       '$decomp =~ /^<final>/',        ''],
164     ['IsDCisolated',    '$decomp =~ /^<isolated>/',     ''],
165     ['IsDCcircle',      '$decomp =~ /^<circle>/',       ''],
166     ['IsDCsuper',       '$decomp =~ /^<super>/',        ''],
167     ['IsDCsub',         '$decomp =~ /^<sub>/',          ''],
168     ['IsDCvertical',    '$decomp =~ /^<vertical>/',     ''],
169     ['IsDCwide',        '$decomp =~ /^<wide>/',         ''],
170     ['IsDCnarrow',      '$decomp =~ /^<narrow>/',       ''],
171     ['IsDCsmall',       '$decomp =~ /^<small>/',        ''],
172     ['IsDCsquare',      '$decomp =~ /^<square>/',       ''],
173     ['IsDCfraction',    '$decomp =~ /^<fraction>/',     ''],
174     ['IsDCcompat',      '$decomp =~ /^<compat>/',       ''],
175
176 # Number
177
178     ['Number',  '$num ne ""',           '$num'],
179
180 # Mirrored
181
182     ['IsMirrored', '$mir eq "Y"',       ''],
183
184 # Arabic
185
186     ['ArabLink',        '1',            '$link'],
187     ['ArabLnkGrp',      '1',            '$linkgroup'],
188
189 # Jamo
190
191     ['JamoShort',       '1',            '$short'],
192
193 # Syllables
194
195     syllable_defs(),
196
197 # Line break properties - Normative
198
199     ['IsLbrkBK','$brk eq "BK"',         ''],    # Mandatory Break
200     ['IsLbrkCR','$brk eq "CR"',         ''],    # Carriage Return
201     ['IsLbrkLF','$brk eq "LF"',         ''],    # Line Feed
202     ['IsLbrkCM','$brk eq "CM"',         ''],    # Attached Characters and Combining Marks
203     ['IsLbrkSG','$brk eq "SG"',         ''],    # Surrogates
204     ['IsLbrkGL','$brk eq "GL"',         ''],    # Non-breaking (Glue)
205     ['IsLbrkCB','$brk eq "CB"',         ''],    # Contingent Break Opportunity
206     ['IsLbrkSP','$brk eq "SP"',         ''],    # Space
207     ['IsLbrkZW','$brk eq "ZW"',         ''],    # Zero Width Space
208
209 # Line break properties - Informative
210     ['IsLbrkXX','$brk eq "XX"',         ''],    # Unknown
211     ['IsLbrkOP','$brk eq "OP"',         ''],    # Opening Punctuation
212     ['IsLbrkCL','$brk eq "CL"',         ''],    # Closing Punctuation
213     ['IsLbrkQU','$brk eq "QU"',         ''],    # Ambiguous Quotation
214     ['IsLbrkNS','$brk eq "NS"',         ''],    # Non Starter
215     ['IsLbrkEX','$brk eq "EX"',         ''],    # Exclamation/Interrogation
216     ['IsLbrkSY','$brk eq "SY"',         ''],    # Symbols Allowing Breaks
217     ['IsLbrkIS','$brk eq "IS"',         ''],    # Infix Separator (Numeric)
218     ['IsLbrkPR','$brk eq "PR"',         ''],    # Prefix (Numeric)
219     ['IsLbrkPO','$brk eq "PO"',         ''],    # Postfix (Numeric)
220     ['IsLbrkNU','$brk eq "NU"',         ''],    # Numeric
221     ['IsLbrkAL','$brk eq "AL"',         ''],    # Ordinary Alphabetic and Symbol Characters
222     ['IsLbrkID','$brk eq "ID"',         ''],    # Ideographic
223     ['IsLbrkIN','$brk eq "IN"',         ''],    # Inseparable
224     ['IsLbrkHY','$brk eq "HY"',         ''],    # Hyphen
225     ['IsLbrkBB','$brk eq "BB"',         ''],    # Break Opportunity Before
226     ['IsLbrkBA','$brk eq "BA"',         ''],    # Break Opportunity After
227     ['IsLbrkSA','$brk eq "SA"',         ''],    # Complex Context (South East Asian)
228     ['IsLbrkAI','$brk eq "AI"',         ''],    # Ambiguous (Alphabetic or Ideographic)
229     ['IsLbrkB2','$brk eq "B2"',         ''],    # Break Opportunity Before and After
230 );
231
232 # This is not written for speed...
233
234 my %InId;
235 my $InId = 0;
236
237 foreach $file (@todo) {
238     my ($table, $wanted, $val) = @$file;
239     next if @ARGV and not grep { $_ eq $table } @ARGV;
240     print $table, "\n";
241     $table =~ s/\W+//g;
242     if ($table =~ /^(Is|To)(.+)/) {
243         open(OUT, ">$1/$2.pl") or die "Can't create $1/$2.pl: $!\n";
244     }
245     else {
246         open(OUT, ">$table.pl") or die "Can't create $table.pl: $!\n";
247     }
248     print OUT <<EOH;
249 # !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!! 
250 # This file is built by $0 from e.g. $UnicodeData.
251 # Any changes made here will be lost!
252 EOH
253     print OUT <<"END";
254 return <<'END';
255 END
256     print OUT proplist($table, $wanted, $val);
257     print OUT "END\n";
258     close OUT;
259 }
260
261 # Do Scripts before Blocks so that in case of naming conflicts
262 # the more natural one (Script) wins over the artificial one (Block).
263
264 print "Scripts\n";
265 open(UD, 'Scripts.txt') or die "Can't open Scripts.txt: $!\n";
266 open(OUT, ">Scripts.pl") or die "Can't create Scripts.pl: $!\n";
267 print OUT <<EOH;
268 # !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!! 
269 # This file is built by $0 from e.g. $UnicodeData.
270 # Any changes made here will be lost!
271 EOH
272 print OUT <<"END";
273 return <<'END';
274 END
275
276 my %Scripts;
277
278 while (<UD>) {
279     next if /^#/;
280     next if /^$/;
281     chomp;
282     ($code, $last, $name) = /^([0-9a-f]+)(?:\.\.([0-9a-f]+))?\s+;\s+(.+)\s+\#/i;
283     if ($name) {
284         my $InName = lc($name);
285         $InName =~ s/\b(\w)/uc($1)/ge;
286         $InName =~ s/\W+//g;
287         my $id;
288         unless (exists $InId{$InName}) {
289             print "\t$InName\n";
290             $id = $Scripts{$InName} = $InId{$InName} = $InId++;
291             open(SCRIPT, ">In/$id.pl") or die "create In/$id.pl: $!\n";
292             print SCRIPT <<EOH;
293 # !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!! 
294 # This file is built by $0 from e.g. $UnicodeData.
295 # Any changes made here will be lost!
296 return <<'END';
297 EOH
298             close(SCRIPT);
299         } else {
300             $id = $InId{$InName};
301         }
302         $last = "" unless defined $last;
303         print OUT "$code\t$last\t$name\t# $InName In/$id.pl\n";
304         open(SCRIPT, ">>In/$id.pl");
305         print SCRIPT <<END;
306 $code   $last
307 END
308         close SCRIPT;
309     }
310 }
311
312 for my $id (values %InId) {
313     open(SCRIPT, ">>In/$id.pl");
314     print SCRIPT <<END2;
315 END
316 END2
317     close(SCRIPT);
318 }
319
320 print OUT "END\n";
321 close OUT;
322
323 # Must treat blocks specially.
324
325 exit if @ARGV and not grep { $_ eq Block } @ARGV;
326 print "Blocks\n";
327 open(UD, 'Blocks.txt') or die "Can't open Blocks.txt: $!\n";
328 open(OUT, ">Blocks.pl") or die "Can't create Blocks.pl: $!\n";
329 print OUT <<EOH;
330 # !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!! 
331 # This file is built by $0 from e.g. $UnicodeData.
332 # Any changes made here will be lost!
333 EOH
334 print OUT <<"END";
335 return <<'END';
336 END
337
338 while (<UD>) {
339     next if /^#/;
340     next if /^$/;
341     chomp;
342     ($code, $last, $name) = /^([0-9a-f]+)\.\.([0-9a-f]+); (.+)/i;
343     if ($name) {
344         my $InName = $name;
345         $InName =~ s/\W+//g;
346         print "\t$InName\n";
347         my $id;
348         # TODO: only the first one of Private Use blocks qualifies
349         unless (exists $InId{$InName}) {
350             $InId{$InName} = $InId++;
351         } elsif (exists $Scripts{$InName}) {
352             $InName .= 'Block';
353             $InId{$InName} = $InId++;
354         }
355         $id = $InId{$InName};
356         open(BLOCK, ">In/$id.pl") or die "create In/$id.pl: $!\n";
357         print OUT "$code\t$last\t$name\t# $InName In/$id.pl\n";
358         print BLOCK <<EOH;
359 # !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!! 
360 # This file is built by $0 from e.g. $UnicodeData.
361 # Any changes made here will be lost!
362 EOH
363         print BLOCK <<"END2";
364 return <<'END';
365 $code   $last
366 END
367 END2
368         close BLOCK;
369     }
370 }
371
372 print OUT "END\n";
373 close OUT;
374
375 open(INID, ">In.pl");
376
377 print INID <<EOH;
378 # !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!! 
379 # This file is built by $0 from e.g. $UnicodeData.
380 # Any changes made here will be lost!
381 %utf8::In = (
382 EOH
383
384 # Order doesn't matter but let's prettyprint anyway.
385 foreach my $in (sort { $InId{$a} <=> $InId{$b} } keys %InId) {
386     printf INID "%-40s => %3d,\n", "'$in'", $InId{$in};
387 }
388
389 print INID ");\n";
390
391 close(INID);
392
393 ##################################################
394
395 sub proplist {
396     my ($table, $wanted, $val) = @_;
397     my @wanted;
398     my $out;
399     my $split;
400
401     return listFromPropFile($wanted) if $val eq $PropData;
402
403     if ($table =~ /^Arab/) {
404         open(UD, "ArabShap.txt") or warn "Can't open $table: $!";
405
406         $split = '($code, $name, $link, $linkgroup) = split(/; */);';
407     }
408     elsif ($table =~ /^Jamo/) {
409         open(UD, "Jamo.txt") or warn "Can't open $table: $!";
410
411         $split = '($code, $short, $name) = split(/; */); $code =~ s/^U\+//;';
412     }
413     elsif ($table =~ /^IsSyl/) {
414         open(UD, $SyllableData) or warn "Can't open $table: $!";
415
416         $split = '($code, $short, $syl) = split(/; */); $code =~ s/^U\+//;';
417     }
418     elsif ($table =~ /^IsLbrk/) {
419         open(UD, "LineBrk.txt") or warn "Can't open $table: $!";
420
421         $split = '($code, $brk, $name) = /^([0-9a-f]+);(\w+) # (.+)/i;';
422     }
423     else {
424         open(UD, $UnicodeData) or warn "Can't open $UnicodeData: $!";
425
426         $split = '($code, $name, $cat, $comb, $bid, $decomp, $dec, $dig, $num, $mir, $uni1,
427                 $comment, $up, $down, $title) = split(/;/);';
428     }
429
430     if ($table =~ /^(?:To|Is)[A-Z]/) {
431         eval <<"END";
432             while (<UD>) {
433                 next if /^#/;
434                 next if /^\\s/;
435                 s/\\s+\$//;
436                 $split
437                 if ($wanted) {
438                     push(\@wanted, [hex \$code, hex $val, \$name =~ /, First>\$/]);
439                 }
440             }
441 END
442         die $@ if $@;
443
444         while (@wanted) {
445             $beg = shift @wanted;
446             $last = $beg;
447             while (@wanted and $wanted[0]->[0] == $last->[0] + 1 and
448                 (not $val or $wanted[0]->[1] == $last->[1] + 1)) {
449                     $last = shift @wanted;
450             }
451             $out .= sprintf "%04x", $beg->[0];
452             if ($beg->[2]) {
453                 $last = shift @wanted;
454             }
455             if ($beg == $last) {
456                 $out .= "\t";
457             }
458             else {
459                 $out .= sprintf "\t%04x", $last->[0];
460             }
461             $out .= sprintf "\t%04x", $beg->[1] if $val;
462             $out .= "\n";
463         }
464     }
465     else {
466         eval <<"END";
467             while (<UD>) {
468                 next if /^#/;
469                 next if /^\\s*\$/;
470                 chop;
471                 $split
472                 if ($wanted) {
473                     push(\@wanted, [hex \$code, $val, \$name =~ /, First>\$/]);
474                 }
475             }
476 END
477         die $@ if $@;
478
479         while (@wanted) {
480             $beg = shift @wanted;
481             $last = $beg;
482             while (@wanted and $wanted[0]->[0] == $last->[0] + 1 and
483                 ($wanted[0]->[1] eq $last->[1])) {
484                     $last = shift @wanted;
485             }
486             $out .= sprintf "%04x", $beg->[0];
487             if ($beg->[2]) {
488                 $last = shift @wanted;
489             }
490             if ($beg == $last) {
491                 $out .= "\t";
492             }
493             else {
494                 $out .= sprintf "\t%04x", $last->[0];
495             }
496             $out .= sprintf "\t%s\n", $beg->[1];
497         }
498     }
499     $out;
500 }
501
502 sub listFromPropFile {
503     my ($wanted) = @_;
504     my $out;
505
506     open (UD, $PropData) or die "Can't open $PropData: $!\n";
507     local($/) = "\n" . '*' x 43 . "\n\nProperty dump for:";   # not 42?
508
509     <UD>;
510     while (<UD>) {
511         chomp;
512         if (s/0x[\d\w]+\s+\((.*?)\)// and $wanted eq $1) {
513             s/\(\d+ chars\)//g;
514             s/^\s+//mg;
515             s/\s+$//mg;
516             s/\.\./\t/g;
517             $out = lc $_;
518             last;
519         }
520     }
521     close (UD);
522     "$out\n";
523 }
524
525 sub syllable_defs {
526     my @defs;
527     my %seen;
528
529     open (SD, $SyllableData) or die "Can't open $SyllableData: $!\n";
530     while (<SD>) {
531         next if /^\s*(#|$)/;
532         s/\s+$//;
533         ($code, $name, $syl) = split /; */;
534         next unless $syl;
535         push (@defs, ["IsSyl$syl", qq{\$syl eq "$syl"}, ''])
536                                                      unless $seen{$syl}++;
537     }
538     close (SD);
539     return (@defs);
540 }
541
542 # eof