Convert some SvREFCNT_dec's to SvREFCNT_dec_NN's for efficiency
[perl.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 string
132
133 03C5 string
134
135 2010 string
136 D800 first FIRST_SURROGATE
137
138 007F native
139 00DF native
140 00E5 native
141 00C5 native
142 00FF native
143 00B5 native
144 0085 native