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