6 # Process a blue zone character data file.
8 # Copyright 2013, 2014 by
9 # David Turner, Robert Wilhelm, and Werner Lemberg.
11 # This file is part of the FreeType project, and may only be used,
12 # modified, and distributed under the terms of the FreeType project
13 # license, LICENSE.TXT. By continuing to use, modify, or distribute
14 # this file you indicate that you have read the license and
15 # understand and accept it fully.
19 use English
'-no_match_vars';
20 use open ':std', ':encoding(UTF-8)';
23 my $prog = $PROGRAM_NAME;
24 $prog =~ s
| .* / ||x
; # Remove path.
26 die "usage: $prog datafile < infile > outfile\n" if $#ARGV != 0;
29 my $datafile = $ARGV[0];
31 my %diversions; # The extracted and massaged data from `datafile'.
32 my @else_stack; # Booleans to track else-clauses.
33 my @name_stack; # Stack of integers used for names of aux. variables.
35 my $curr_enum; # Name of the current enumeration.
36 my $curr_array; # Name of the current array.
37 my $curr_max; # Name of the current maximum value.
39 my $curr_enum_element; # Name of the current enumeration element.
40 my $curr_offset; # The offset relative to current aux. variable.
41 my $curr_elem_size; # The size of the current string or block.
43 my $have_sections = 0; # Boolean; set if start of a section has been seen.
44 my $have_strings; # Boolean; set if current section contains strings.
45 my $have_blocks; # Boolean; set if current section contains blocks.
47 my $have_enum_element; # Boolean; set if we have an enumeration element.
48 my $in_string; # Boolean; set if a string has been parsed.
50 my $num_sections = 0; # Number of sections seen so far.
52 my $last_aux; # Name of last auxiliary variable.
55 # Regular expressions.
57 # [<ws>] <enum_name> <ws> <array_name> <ws> <max_name> [<ws>] ':' [<ws>] '\n'
58 my $section_re = qr/ ^ \s* (\S+) \s+ (\S+) \s+ (\S+) \s* : \s* $ /x;
60 # [<ws>] <enum_element_name> [<ws>] '\n'
61 my $enum_element_re = qr/ ^ \s* ( [A-Za-z0-9_]+ ) \s* $ /x;
63 # '#' <preprocessor directive> '\n'
64 my $preprocessor_re = qr/ ^ \# /x;
66 # [<ws>] '/' '/' <comment> '\n'
67 my $comment_re = qr
| ^ \s
* // |x
;
70 my $whitespace_only_re = qr/ ^ \s* $ /x;
72 # [<ws>] '"' <string> '"' [<ws>] '\n' (<string> doesn't contain newlines)
73 my $string_re = qr
/ ^ \s
*
74 " ( (?> (?: (?> [^"\\]+ ) | \\. )* ) ) "
77 # [<ws>] '{' <block> '}' [<ws>] '\n' (<block> can contain newlines)
78 my $block_start_re = qr/ ^ \s* \{ /x;
80 # We need the capturing group for `split' to make it return the separator
81 # tokens (i.e., the opening and closing brace) also.
82 my $brace_re = qr/ ( [{}] ) /x;
88 warn "$datafile:$INPUT_LINE_NUMBER: warning
: $message\n";
95 die "$datafile:$INPUT_LINE_NUMBER: error
: $message\n";
99 my $warned_before = 0;
103 Warn("data before first section gets ignored
") unless $warned_before;
117 # Append final null byte to string.
120 push @{$diversions{$curr_array}}, " '\\0',\n" if $in_string;
128 sub update_max_elem_size
132 my $max = pop @{$diversions{$curr_max}};
133 $max = $curr_elem_size if $curr_elem_size > $max;
134 push @{$diversions{$curr_max}}, $max;
139 sub convert_non_ascii_char
141 # A UTF-8 character outside of the printable ASCII range, with possibly a
142 # leading backslash character.
145 # Here we count characters, not bytes.
146 $curr_elem_size += length $s;
149 $s = uc unpack 'H*', $s;
151 $curr_offset += $s =~ s/\G(..)/'\\x$1', /sg;
157 sub convert_ascii_chars
159 # A series of ASCII characters in the printable range.
165 my $count = $s =~ s/\G(.)/'$1', /g;
166 $curr_offset += $count;
167 $curr_elem_size += $count;
178 # ASCII printables and space
179 my $safe_re = '\x20-\x7E';
180 # ASCII printables and space, no backslash
181 my $safe_no_backslash_re = '\x20-\x5B\x5D-\x7E';
184 (?: \\? ( [^$safe_re] )
185 | ( (?: [$safe_no_backslash_re]
186 | \\ [$safe_re] )+ ) )
189 defined($1) ? convert_non_ascii_char($1)
190 : convert_ascii_chars($2)
193 # We assume that `$orig' doesn't contain `*/'
194 return $s . " /* $orig */";
200 return "af_blue_
" . $num_sections. "_
" . join('_', @name_stack);
206 $name_stack[$#name_stack]++;
207 my $name = aux_name();
208 $name_stack[$#name_stack]--;
216 # Build string that holds code to save the current offset in an
217 # enumeration element.
220 my $add = ($last_aux eq "af_blue_
" . $num_sections . "_0
" )
224 return " $aux = $add$curr_offset,\n";
231 open(DATA, $datafile) || die "$prog: can
't open \`$datafile': $OS_ERROR\n";
237 next if /$comment_re/;
238 next if /$whitespace_only_re/;
242 Warn("previous section is empty
") if ($have_sections
247 update_max_elem_size();
249 # Save captured groups from `section_re'.
254 $curr_enum_element = "";
257 Warn("overwriting already
defined enumeration \
`$curr_enum'")
258 if exists($diversions{$curr_enum});
259 Warn("overwriting already defined array \`$curr_array'")
260 if exists($diversions{$curr_array});
261 Warn("overwriting already defined maximum value \`$curr_max'")
262 if exists($diversions{$curr_max});
264 $diversions{$curr_enum} = [];
265 $diversions{$curr_array} = [];
266 $diversions{$curr_max} = [];
268 push @{$diversions{$curr_max}}, 0;
277 $have_enum_element = 0;
283 $last_aux = aux_name();
288 if (/$preprocessor_re/)
292 # Having preprocessor conditionals complicates the computation of
293 # correct offset values. We have to introduce auxiliary enumeration
294 # elements with the name `af_blue_<s>_<n1>_<n2>_...' that store
295 # offsets to be used in conditional clauses. `<s>' is the number of
296 # sections seen so far, `<n1>' is the number of `#if' and `#endif'
297 # conditionals seen so far in the topmost level, `<n2>' the number of
298 # `#if' and `#endif' conditionals seen so far one level deeper, etc.
299 # As a consequence, uneven values are used within a clause, and even
300 # values after a clause, since the C standard doesn't allow the
301 # redefinition of an enumeration value. For example, the name
302 # `af_blue_5_1_6' is used to construct enumeration values in the fifth
303 # section after the third (second-level) if-clause within the first
304 # (top-level) if-clause. After the first top-level clause has
305 # finished, `af_blue_5_2' is used. The current offset is then
306 # relative to the value stored in the current auxiliary element.
308 if (/ ^ \# \s* if /x)
312 $name_stack[$#name_stack]++;
314 push @{$diversions{$curr_enum}}, enum_val_string(aux_name());
315 $last_aux = aux_name();
321 elsif (/ ^ \# \s* elif /x)
323 Die("unbalanced
#elif") unless @else_stack;
327 push @
{$diversions{$curr_enum}}, enum_val_string
(aux_name_next
());
328 $last_aux = aux_name
();
334 elsif (/ ^ \# \s* else /x)
336 my $prev_else = pop @else_stack;
337 Die
("unbalanced #else") unless defined($prev_else);
338 Die
("#else already seen") if $prev_else;
343 push @
{$diversions{$curr_enum}}, enum_val_string
(aux_name_next
());
344 $last_aux = aux_name
();
350 elsif (/ ^ (\# \s*) endif /x)
352 my $prev_else = pop @else_stack;
353 Die
("unbalanced #endif") unless defined($prev_else);
357 # If there is no else-clause for an if-clause, we add one. This is
358 # necessary to have correct offsets.
361 # Use amount of whitespace from `endif'.
362 push @
{$diversions{$curr_enum}}, enum_val_string
(aux_name_next
())
364 $last_aux = aux_name
();
369 $name_stack[$#name_stack]++;
371 push @
{$diversions{$curr_enum}}, enum_val_string
(aux_name
());
372 $last_aux = aux_name
();
377 # Handle (probably continued) preprocessor lines.
384 push @
{$diversions{$curr_enum}}, $ARG . "\n";
385 push @
{$diversions{$curr_array}}, $ARG . "\n";
387 last CONTINUED_LOOP
unless / \\ $ /x;
400 if (/$enum_element_re/)
403 update_max_elem_size
();
405 $curr_enum_element = $1;
406 $have_enum_element = 1;
416 Die
("strings and blocks can't be mixed in a section") if $have_blocks;
418 # Save captured group from `string_re'.
421 if ($have_enum_element)
423 push @
{$diversions{$curr_enum}}, enum_val_string
($curr_enum_element);
424 $have_enum_element = 0;
427 $string = convert_literal
($string);
429 push @
{$diversions{$curr_array}}, " $string\n";
442 if (/$block_start_re/)
446 Die
("strings and blocks can't be mixed in a section") if $have_strings;
452 # Count braces while getting the block.
459 foreach my $substring (split(/$brace_re/))
463 Die
("invalid data after last matching closing brace")
464 if $substring !~ /$whitespace_only_re/;
467 $block .= $substring;
469 if ($substring eq '{')
473 elsif ($substring eq '}')
477 $block_end = 1 if $depth == 0;
481 # If we are here, we have run out of substrings, so get next line
483 last BRACE_LOOP
if $block_end;
490 if ($have_enum_element)
492 push @
{$diversions{$curr_enum}}, enum_val_string
($curr_enum_element);
493 $have_enum_element = 0;
496 push @
{$diversions{$curr_array}}, $block . ",\n";
511 # Garbage. We weren't able to parse the data.
517 update_max_elem_size
();
520 # Filter stdin to stdout, replacing `@...@' templates.
524 my $diversion_name = shift;
525 return (exists($diversions{$1})) ?
"@{$diversions{$1}}"
526 : "@" . $diversion_name . "@";
530 $LIST_SEPARATOR = '';
532 my $s1 = "This file has been generated by the Perl script \`$prog',";
533 my $s1len = length $s1;
534 my $s2 = "using data from file \`$datafile'.";
535 my $s2len = length $s2;
536 my $slen = ($s1len > $s2len) ?
$s1len : $s2len;
538 print "/* " . $s1 . " " x
($slen - $s1len) . " */\n"
539 . "/* " . $s2 . " " x
($slen - $s2len) . " */\n"
544 s/ @ ( [A-Za-z0-9_]+? ) @ / emit_diversion($1) /egx;