Support preferentially the Unicode 'scripts' definition
[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         print OUT "$code\t$last\t$name\t# $InName In/$id.pl\n";
303         open(SCRIPT, ">>In/$id.pl");
304         print SCRIPT <<END;
305 $code   $last
306 END
307         close SCRIPT;
308     }
309 }
310
311 for my $id (values %InId) {
312     open(SCRIPT, ">>In/$id.pl");
313     print SCRIPT <<END2;
314 END
315 END2
316     close(SCRIPT);
317 }
318
319 print OUT "END\n";
320 close OUT;
321
322 # Must treat blocks specially.
323
324 exit if @ARGV and not grep { $_ eq Block } @ARGV;
325 print "Blocks\n";
326 open(UD, 'Blocks.txt') or die "Can't open Blocks.txt: $!\n";
327 open(OUT, ">Blocks.pl") or die "Can't create Blocks.pl: $!\n";
328 print OUT <<EOH;
329 # !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!! 
330 # This file is built by $0 from e.g. $UnicodeData.
331 # Any changes made here will be lost!
332 EOH
333 print OUT <<"END";
334 return <<'END';
335 END
336
337 while (<UD>) {
338     next if /^#/;
339     next if /^$/;
340     chomp;
341     ($code, $last, $name) = /^([0-9a-f]+)\.\.([0-9a-f]+); (.+)/i;
342     if ($name) {
343         my $InName = $name;
344         $InName =~ s/\W+//g;
345         print "\t$InName\n";
346         my $id;
347         # TODO: only the first one of Private Use blocks qualifies
348         unless (exists $InId{$InName}) {
349             $InId{$InName} = $InId++;
350         } elsif (exists $Scripts{$InName}) {
351             $InName .= 'Block';
352             $InId{$InName} = $InId++;
353         }
354         $id = $InId{$InName};
355         open(BLOCK, ">In/$id.pl") or die "create In/$id.pl: $!\n";
356         print OUT "$code\t$last\t$name\t# $InName In/$id.pl\n";
357         print BLOCK <<EOH;
358 # !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!! 
359 # This file is built by $0 from e.g. $UnicodeData.
360 # Any changes made here will be lost!
361 EOH
362         print BLOCK <<"END2";
363 return <<'END';
364 $code   $last
365 END
366 END2
367         close BLOCK;
368     }
369 }
370
371 print OUT "END\n";
372 close OUT;
373
374 open(INID, ">In.pl");
375
376 print INID <<EOH;
377 # !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!! 
378 # This file is built by $0 from e.g. $UnicodeData.
379 # Any changes made here will be lost!
380 %utf8::In = (
381 EOH
382
383 # Order doesn't matter but let's prettyprint anyway.
384 foreach my $in (sort { $InId{$a} <=> $InId{$b} } keys %InId) {
385     printf INID "%-40s => %3d,\n", "'$in'", $InId{$in};
386 }
387
388 print INID ");\n";
389
390 close(INID);
391
392 ##################################################
393
394 sub proplist {
395     my ($table, $wanted, $val) = @_;
396     my @wanted;
397     my $out;
398     my $split;
399
400     return listFromPropFile($wanted) if $val eq $PropData;
401
402     if ($table =~ /^Arab/) {
403         open(UD, "ArabShap.txt") or warn "Can't open $table: $!";
404
405         $split = '($code, $name, $link, $linkgroup) = split(/; */);';
406     }
407     elsif ($table =~ /^Jamo/) {
408         open(UD, "Jamo.txt") or warn "Can't open $table: $!";
409
410         $split = '($code, $short, $name) = split(/; */); $code =~ s/^U\+//;';
411     }
412     elsif ($table =~ /^IsSyl/) {
413         open(UD, $SyllableData) or warn "Can't open $table: $!";
414
415         $split = '($code, $short, $syl) = split(/; */); $code =~ s/^U\+//;';
416     }
417     elsif ($table =~ /^IsLbrk/) {
418         open(UD, "LineBrk.txt") or warn "Can't open $table: $!";
419
420         $split = '($code, $brk, $name) = /^([0-9a-f]+);(\w+) # (.+)/i;';
421     }
422     else {
423         open(UD, $UnicodeData) or warn "Can't open $UnicodeData: $!";
424
425         $split = '($code, $name, $cat, $comb, $bid, $decomp, $dec, $dig, $num, $mir, $uni1,
426                 $comment, $up, $down, $title) = split(/;/);';
427     }
428
429     if ($table =~ /^(?:To|Is)[A-Z]/) {
430         eval <<"END";
431             while (<UD>) {
432                 next if /^#/;
433                 next if /^\\s/;
434                 s/\\s+\$//;
435                 $split
436                 if ($wanted) {
437                     push(\@wanted, [hex \$code, hex $val, \$name =~ /, First>\$/]);
438                 }
439             }
440 END
441         die $@ if $@;
442
443         while (@wanted) {
444             $beg = shift @wanted;
445             $last = $beg;
446             while (@wanted and $wanted[0]->[0] == $last->[0] + 1 and
447                 (not $val or $wanted[0]->[1] == $last->[1] + 1)) {
448                     $last = shift @wanted;
449             }
450             $out .= sprintf "%04x", $beg->[0];
451             if ($beg->[2]) {
452                 $last = shift @wanted;
453             }
454             if ($beg == $last) {
455                 $out .= "\t";
456             }
457             else {
458                 $out .= sprintf "\t%04x", $last->[0];
459             }
460             $out .= sprintf "\t%04x", $beg->[1] if $val;
461             $out .= "\n";
462         }
463     }
464     else {
465         eval <<"END";
466             while (<UD>) {
467                 next if /^#/;
468                 next if /^\\s*\$/;
469                 chop;
470                 $split
471                 if ($wanted) {
472                     push(\@wanted, [hex \$code, $val, \$name =~ /, First>\$/]);
473                 }
474             }
475 END
476         die $@ if $@;
477
478         while (@wanted) {
479             $beg = shift @wanted;
480             $last = $beg;
481             while (@wanted and $wanted[0]->[0] == $last->[0] + 1 and
482                 ($wanted[0]->[1] eq $last->[1])) {
483                     $last = shift @wanted;
484             }
485             $out .= sprintf "%04x", $beg->[0];
486             if ($beg->[2]) {
487                 $last = shift @wanted;
488             }
489             if ($beg == $last) {
490                 $out .= "\t";
491             }
492             else {
493                 $out .= sprintf "\t%04x", $last->[0];
494             }
495             $out .= sprintf "\t%s\n", $beg->[1];
496         }
497     }
498     $out;
499 }
500
501 sub listFromPropFile {
502     my ($wanted) = @_;
503     my $out;
504
505     open (UD, $PropData) or die "Can't open $PropData: $!\n";
506     local($/) = "\n" . '*' x 43 . "\n\nProperty dump for:";   # not 42?
507
508     <UD>;
509     while (<UD>) {
510         chomp;
511         if (s/0x[\d\w]+\s+\((.*?)\)// and $wanted eq $1) {
512             s/\(\d+ chars\)//g;
513             s/^\s+//mg;
514             s/\s+$//mg;
515             s/\.\./\t/g;
516             $out = lc $_;
517             last;
518         }
519     }
520     close (UD);
521     "$out\n";
522 }
523
524 sub syllable_defs {
525     my @defs;
526     my %seen;
527
528     open (SD, $SyllableData) or die "Can't open $SyllableData: $!\n";
529     while (<SD>) {
530         next if /^\s*(#|$)/;
531         s/\s+$//;
532         ($code, $name, $syl) = split /; */;
533         next unless $syl;
534         push (@defs, ["IsSyl$syl", qq{\$syl eq "$syl"}, ''])
535                                                      unless $seen{$syl}++;
536     }
537     close (SD);
538     return (@defs);
539 }
540
541 # eof