This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
regen/unicode_constants.pl: Add name parameter
[perl5.git] / regen / unicode_constants.pl
1 use v5.16.0;
2 use strict;
3 use warnings;
4 require 'regen/regen_lib.pl';
5 use charnames qw(:loose);
6
7 my $out_fh = open_new('unicode_constants.h', '>',
8                       {style => '*', by => $0,
9                       from => "Unicode data"});
10
11 print $out_fh <<END;
12
13 #ifndef H_UNICODE_CONSTANTS   /* Guard against nested #includes */
14 #define H_UNICODE_CONSTANTS   1
15
16 /* This file contains #defines for various Unicode code points.  The values
17  * the macros expand to are the native Unicode code point, or all or portions
18  * of the UTF-8 encoding for the code point.  In the former case, the macro
19  * name has the suffix "_NATIVE"; otherwise, the suffix "_UTF8".
20  *
21  * The macros that have the suffix "_UTF8" may have further suffixes, as
22  * follows:
23  *  "_FIRST_BYTE" if the value is just the first byte of the UTF-8
24  *                representation; the value will be a numeric constant.
25  *  "_TAIL"       if instead it represents all but the first byte.  This, and
26  *                with no additional suffix are both string constants */
27
28 END
29
30 # The data are at the end of this file.  A blank line is output as-is.
31 # Otherwise, each line represents one #define, and begins with either a
32 # Unicode character name with the blanks in it squeezed out or replaced by
33 # underscores; or it may be a hexadecimal Unicode code point.  In the latter
34 # case, the name will be looked-up to use as the name of the macro.  In either
35 # case, the macro name will have suffixes as listed above, and all blanks will
36 # be replaced by underscores.
37 #
38 # Each line may optionally have one of the following flags on it, separated by
39 # white space from the initial token.
40 #   string  indicates that the output is to be of the string form
41 #           described in the comments above that are placed in the file.
42 #   first   indicates that the output is to be of the FIRST_BYTE form.
43 #   tail    indicates that the output is of the _TAIL form.
44 #   native  indicates that the output is the code point, converted to the
45 #           platform's native character set if applicable
46 #
47 # If the code point has no official name, the desired name may be appended
48 # after the flag, which will be ignored if there is an official name.
49 #
50 # This program is used to make it convenient to create compile time constants
51 # of UTF-8, and to generate proper EBCDIC as well as ASCII without manually
52 # having to figure things out.
53
54 while ( <DATA> ) {
55     if ($_ !~ /\S/) {
56         print $out_fh "\n";
57         next;
58     }
59
60     chomp;
61     unless ($_ =~ m/ ^ ( [^\ ]* )           # Name or code point token
62                        (?: [\ ]+ ( [^ ]* ) )?  # optional flag
63                        (?: [\ ]+ ( .* ) )?  # name if unnamed; flag is required
64                    /x)
65     {
66         die "Unexpected syntax at line $.: $_\n";
67     }
68
69     my $name_or_cp = $1;
70     my $flag = $2;
71     my $desired_name = $3;
72
73     my $name;
74     my $cp;
75
76     if ($name_or_cp =~ /[^[:xdigit:]]/) {
77
78         # Anything that isn't a hex value must be a name.
79         $name = $name_or_cp;
80         $cp = charnames::vianame($name =~ s/_/ /gr);
81         die "Unknown name '$name' at line $.: $_\n" unless defined $name;
82     }
83     else {
84         $cp = $name_or_cp;
85         $name = charnames::viacode("0$cp") // ""; # viacode requires a leading
86                                                   # zero to be sure that the
87                                                   # argument is hex
88         die "Unknown code point '$cp' at line $.: $_\n" unless defined $cp;
89     }
90
91     $name = $desired_name if $name eq "";
92     $name =~ s/ /_/g;   # The macro name can have no blanks in it
93
94     my $str = join "", map { sprintf "\\x%02X", $_ }
95                        unpack("U0C*", pack("U", hex $cp));
96
97     my $suffix = '_UTF8';
98     if (! defined $flag  || $flag eq 'string') {
99         $str = "\"$str\"";  # Will be a string constant
100     } elsif ($flag eq 'tail') {
101             $str =~ s/\\x..//;  # Remove the first byte
102             $suffix .= '_TAIL';
103             $str = "\"$str\"";  # Will be a string constant
104     }
105     elsif ($flag eq 'first') {
106         $str =~ s/ \\x ( .. ) .* /$1/x; # Get the two nibbles of the 1st byte
107         $suffix .= '_FIRST_BYTE';
108         $str = "0x$str";        # Is a numeric constant
109     }
110     elsif ($flag eq 'native') {
111         die "Are you sure you want to run this on an above-Latin1 code point?" if hex $cp > 0xff;
112         $suffix = '_NATIVE';
113         $str = utf8::unicode_to_native(hex $cp);
114         $str = "0x$cp";        # Is a numeric constant
115     }
116     else {
117         die "Unknown flag at line $.: $_\n";
118     }
119     print $out_fh "#define ${name}$suffix $str    /* U+$cp */\n";
120 }
121
122 print $out_fh "\n#endif /* H_UNICODE_CONSTANTS */\n";
123
124 read_only_bottom_close_and_rename($out_fh);
125
126 __DATA__
127 0300 string
128 0301 string
129 0308 string
130
131 03B9 first
132 03B9 tail
133
134 03C5 first
135 03C5 tail
136
137 2010 string
138 D800 first FIRST_SURROGATE
139
140 007F native
141 00DF native
142 00E5 native
143 00C5 native
144 00FF native
145 00B5 native
146 0085 native