File: unidata_to_charset.pl

package info (click to toggle)
guile-2.0 2.0.13%2B1-5.1
  • links: PTS
  • area: main
  • in suites: buster
  • size: 27,104 kB
  • sloc: ansic: 133,697; lisp: 67,499; sh: 4,762; makefile: 2,031; perl: 243; awk: 37
file content (404 lines) | stat: -rwxr-xr-x 12,267 bytes parent folder | download | duplicates (9)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
#!/usr/bin/perl
# unidata_to_charset.pl --- Compute SRFI-14 charsets from UnicodeData.txt
#
# Copyright (C) 2009, 2010 Free Software Foundation, Inc.
#
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Lesser General Public
# License as published by the Free Software Foundation; either
# version 3 of the License, or (at your option) any later version.
#
# This library is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# Lesser General Public License for more details.
#
# You should have received a copy of the GNU Lesser General Public
# License along with this library; if not, write to the Free Software
# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

open(my $in,  "<",  "UnicodeData.txt")  or die "Can't open UnicodeData.txt: $!";           
open(my $out, ">",  "srfi-14.i.c") or die "Can't open srfi-14.i.c: $!";

# For Unicode, we follow Java's specification: a character is
# lowercase if
#    * it is not in the range [U+2000,U+2FFF], and
#    * the Unicode attribute table does not give a lowercase mapping
#      for it, and
#    * at least one of the following is true:
#          o the Unicode attribute table gives a mapping to uppercase
#            for the character, or
#          o the name for the character in the Unicode attribute table
#            contains the words "SMALL LETTER" or "SMALL LIGATURE".

sub lower_case {
    my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
    if (($codepoint < 0x2000 || $codepoint > 0x2FFF)
        && (!defined($lowercase) || $lowercase eq "")
        && ((defined($uppercase) && $uppercase ne "")
            || ($name =~ /(SMALL LETTER|SMALL LIGATURE)/))) {
        return 1;
    } else {
        return 0;
    }
}

# For Unicode, we follow Java's specification: a character is
# uppercase if
#    * it is not in the range [U+2000,U+2FFF], and
#    * the Unicode attribute table does not give an uppercase mapping
#      for it (this excludes titlecase characters), and
#    * at least one of the following is true:
#          o the Unicode attribute table gives a mapping to lowercase
#            for the character, or
#          o the name for the character in the Unicode attribute table
#            contains the words "CAPITAL LETTER" or "CAPITAL LIGATURE".

sub upper_case {
    my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
    if (($codepoint < 0x2000 || $codepoint > 0x2FFF)
        && (!defined($uppercase) || $uppercase eq "")
        && ((defined($lowercase) && $lowercase ne "")
            || ($name =~ /(CAPITAL LETTER|CAPITAL LIGATURE)/))) {
        return 1;
    } else {
        return 0;
    }
}

# A character is titlecase if it has the category Lt in the character
# attribute database.

sub title_case {
    my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
    if (defined($category) && $category eq "Lt") {
        return 1;
    } else {
        return 0;
    }
}

# A letter is any character with one of the letter categories (Lu, Ll,
# Lt, Lm, Lo) in the Unicode character database.

sub letter {
    my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
    if (defined($category) && ($category eq "Lu"
                               || $category eq "Ll"
                               || $category eq "Lt"
                               || $category eq "Lm"
                               || $category eq "Lo")) {
        return 1;
    } else {
        return 0;
    }
}

# A character is a digit if it has the category Nd in the character
# attribute database. In Latin-1 and ASCII, the only such characters
# are 0123456789. In Unicode, there are other digit characters in
# other code blocks, such as Gujarati digits and Tibetan digits.

sub digit {
    my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
    if (defined($category) && $category eq "Nd") {
        return 1;
    } else {
        return 0;
    }
}

# The only hex digits are 0123456789abcdefABCDEF. 

sub hex_digit {
    my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
    if (($codepoint >= 0x30 && $codepoint <= 0x39)
        || ($codepoint >= 0x41 && $codepoint <= 0x46)
        || ($codepoint >= 0x61 && $codepoint <= 0x66)) {
        return 1;
    } else {
        return 0;
    }
}

# The union of char-set:letter and char-set:digit.

sub letter_plus_digit {
    my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
    if (letter($codepoint, $name, $category, $uppercase, $lowercase)
        || digit($codepoint, $name, $category, $uppercase, $lowercase)) {
        return 1;
    } else {
        return 0;
    }
}

# Characters that would 'use ink' when printed
sub graphic {
    my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
    if ($category =~ (/L|M|N|P|S/)) {
        return 1;
    } else {
        return 0;
    }
}

# A whitespace character is either
#    * a character with one of the space, line, or paragraph separator
#      categories (Zs, Zl or Zp) of the Unicode character database.
#    * U+0009 Horizontal tabulation (\t control-I)
#    * U+000A Line feed (\n control-J)
#    * U+000B Vertical tabulation (\v control-K)
#    * U+000C Form feed (\f control-L)
#    * U+000D Carriage return (\r control-M)

sub whitespace {
    my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
    if ($category =~ (/Zs|Zl|Zp/)
        || $codepoint == 0x9
        || $codepoint == 0xA 
        || $codepoint == 0xB 
        || $codepoint == 0xC 
        || $codepoint == 0xD) { 
        return 1;
    } else {
        return 0;
    }
}

# A printing character is one that would occupy space when printed,
# i.e., a graphic character or a space character. char-set:printing is
# the union of char-set:whitespace and char-set:graphic.

sub printing {
    my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
    if (whitespace($codepoint, $name, $category, $uppercase, $lowercase)
        || graphic($codepoint, $name, $category, $uppercase, $lowercase)) {
        return 1;
    } else {
        return 0;
    }
}

# The ISO control characters are the Unicode/Latin-1 characters in the
# ranges [U+0000,U+001F] and [U+007F,U+009F].

sub iso_control {
    my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
    if (($codepoint >= 0x00 && $codepoint <= 0x1F)
        || ($codepoint >= 0x7F && $codepoint <= 0x9F)) {
        return 1;
    } else {
        return 0;
    }
}

# A punctuation character is any character that has one of the
# punctuation categories in the Unicode character database (Pc, Pd,
# Ps, Pe, Pi, Pf, or Po.)

# Note that srfi-14 gives conflicting requirements!!  It claims that
# only the Unicode punctuation is necessary, but, explicitly calls out
# the soft hyphen character (U+00AD) as punctution.  Current versions
# of Unicode consider U+00AD to be a formatting character, not
# punctuation.

sub punctuation {
    my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
    if ($category =~ (/P/)) {
        return 1;
    } else {
        return 0;
    }
}
        
# A symbol is any character that has one of the symbol categories in
# the Unicode character database (Sm, Sc, Sk, or So).

sub symbol {
    my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
    if ($category =~ (/S/)) {
        return 1;
    } else {
        return 0;
    }
}
        
# Blank chars are horizontal whitespace.  A blank character is either
#    * a character with the space separator category (Zs) in the
#      Unicode character database.
#    * U+0009 Horizontal tabulation (\t control-I) 
sub blank {
    my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
    if ($category =~ (/Zs/)
        || $codepoint == 0x9) { 
        return 1;
    } else {
        return 0;
    }
}

# ASCII
sub ascii {
    my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
    if ($codepoint <= 0x7F) {
        return 1;
    } else {
        return 0;
    }
}

# Empty
sub empty {
    my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
    return 0;
}

# Designated -- All characters except for the surrogates
sub designated {
    my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
    if ($category =~ (/Cs/)) {
        return 0;
    } else {
        return 1;
    }
}


# The procedure generates the two C structures necessary to describe a
# given category.
sub compute {
    my($f) = @_;
    my $start = -1;
    my $end = -1;
    my $len = 0;
    my @rstart = (-1);
    my @rend = (-1);

    seek($in, 0, 0) or die "Can't seek to beginning of file: $!";

    print "$f\n";

    while (<$in>) {
        # Parse the 14 column, semicolon-delimited UnicodeData.txt
        # file
        chomp;
        my(@fields) = split(/;/);

        # The codepoint: an integer
        my $codepoint = hex($fields[0]); 

        # If this is a character range, the last character in this
        # range
        my $codepoint_end = $codepoint;  

        # The name of the character
        my $name = $fields[1];    

        # A two-character category code, such as Ll (lower-case
        # letter)
        my $category = $fields[2];       

        # The codepoint of the uppercase version of this char
        my $uppercase = $fields[12];   

        # The codepoint of the lowercase version of this char
        my $lowercase = $fields[13];    

        my $pass = &$f($codepoint,$name,$category,$uppercase,$lowercase);
        if ($pass == 1) {

            # Some pairs of lines in UnicodeData.txt delimit ranges of
            # characters.
            if ($name =~ /First/) {
                $line = <$in>;
                die $! if $!;
                $codepoint_end = hex( (split(/;/, $line))[0] );
            }                 

            # Compute ranges of characters [start:end] that meet the
            # criteria.  Store the ranges.
            if ($start == -1) {
                $start = $codepoint;
                $end = $codepoint_end;
            } elsif ($end + 1 == $codepoint) {
                $end = $codepoint_end;
            } else {
                $rstart[$len] = $start;
                $rend[$len] = $end;
                $len++;
                $start = $codepoint;
                $end = $codepoint_end;
            }
        }
    }

    # Extra logic to ensure that the last range is included
    if ($start != -1) {
        if ($len > 0 && $rstart[@rstart-1] != $start) {
            $rstart[$len] = $start;
            $rend[$len] = $end;
            $len++;
        } elsif ($len == 0) {
	    $rstart[0] = $start;
	    $rend[0] = $end;
	    $len++;
        }
    }

    # Print the C struct that contains the range list.
    print $out "scm_t_char_range cs_" . $f . "_ranges[] = {\n";
    if ($rstart[0] != -1) {
        for (my $i=0; $i<@rstart-1; $i++) {
            printf $out "  {0x%04x, 0x%04x},\n", $rstart[$i], $rend[$i];
        }
        printf $out "  {0x%04x, 0x%04x}\n", $rstart[@rstart-1], $rend[@rstart-1];
    }
    print $out "};\n\n";

    # Print the C struct that contains the range list length and
    # pointer to the range list.
    print $out "scm_t_char_set cs_${f} = {\n";
    print $out "  $len,\n";
    print $out "  cs_" . $f . "_ranges\n";
    print $out "};\n\n";
}

# Write a bit of a header
print $out "/* srfi-14.i.c -- standard SRFI-14 character set data */\n\n";
print $out "/* This file is #include'd by srfi-14.c.  */\n\n";
print $out "/* This file was generated from\n";
print $out "   http://unicode.org/Public/UNIDATA/UnicodeData.txt\n";
print $out "   with the unidata_to_charset.pl script.  */\n\n";

# Write the C structs for each SRFI-14 charset
compute "lower_case";
compute "upper_case";
compute "title_case";
compute "letter";
compute "digit";
compute "hex_digit";
compute "letter_plus_digit";
compute "graphic";
compute "whitespace";
compute "printing";
compute "iso_control";
compute "punctuation";
compute "symbol";
compute "blank";
compute "ascii";
compute "empty";
compute "designated";

close $in;
close $out;

exec ('indent srfi-14.i.c') or print STDERR "call to 'indent' failed: $!";

# And we're done.