This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
56611cb2b428ae4771e8f911dedbff7950de0091
[perl5.git] / regen / ebcdic.pl
1 use v5.16.0;
2 use strict;
3 use warnings;
4
5 BEGIN { unshift @INC, '.' }
6
7 require './regen/regen_lib.pl';
8 require './regen/charset_translations.pl';
9
10 # Generates the EBCDIC translation tables that were formerly hard-coded into
11 # utfebcdic.h
12
13 my $out_fh = open_new('ebcdic_tables.h', '>',
14         {style => '*', by => $0, });
15
16 sub output_table ($$;$) {
17     my $table_ref = shift;
18     my $name = shift;
19
20     # Tables in hex easier to debug, but don't fit into 80 columns
21     my $print_in_hex = shift // 1;
22
23     die "Requres 256 entries in table $name, got @$table_ref" if @$table_ref != 256;
24
25     my $declaration = "EXTCONST U8 $name\[\]";
26     print $out_fh <<EOF;
27 #  ifndef DOINIT
28 #    $declaration;
29 #  else
30 #    $declaration = {
31 EOF
32
33     my $column_numbers= "/*_0   _1   _2   _3   _4   _5   _6   _7   _8   _9   _A   _B   _C   _D   _E  _F*/\n";
34     print $out_fh $column_numbers if $print_in_hex;
35     for my $i (0 .. 255) {
36         if ($print_in_hex) {
37             printf $out_fh "/*%X_*/ ", $i / 16 if $i % 16 == 0;
38             printf $out_fh "0x%02X", $table_ref->[$i];
39         }
40         else {
41             printf $out_fh "%4d", $table_ref->[$i];
42         }
43         print $out_fh ",", if $i < 255;
44         #print $out_fh ($i < 255) ? "," : " ";
45         #printf $out_fh " /* %X_ */", $i / 16 if $print_in_hex && $i % 16 == 15;
46         print $out_fh "\n" if $i % 16 == 15;
47     }
48     print $out_fh $column_numbers if $print_in_hex;
49     print $out_fh "};\n#  endif\n\n";
50 }
51
52 print $out_fh <<END;
53
54 #ifndef PERL_EBCDIC_TABLES_H_   /* Guard against nested #includes */
55 #define PERL_EBCDIC_TABLES_H_   1
56
57 /* This file contains definitions for various tables used in EBCDIC handling.
58  * More info is in utfebcdic.h */
59 END
60
61 my @charsets = get_supported_code_pages();
62 shift @charsets;    # ASCII is the 0th, and we don't deal with that here.
63 foreach my $charset (@charsets) {
64     # we process the whole array several times, make a copy
65     my @a2e = @{get_a2n($charset)};
66
67     print $out_fh "\n" . get_conditional_compile_line_start($charset);
68     print $out_fh "\n";
69
70     print $out_fh "/* Index is ASCII platform code point; value is $charset equivalent */\n";
71     output_table(\@a2e, "PL_a2e");
72
73     { # Construct the inverse
74         my @e2a;
75         for my $i (0 .. 255) {
76             $e2a[$a2e[$i]] = $i;
77         }
78         print $out_fh "/* Index is $charset code point; value is ASCII platform equivalent */\n";
79         output_table(\@e2a, "PL_e2a");
80     }
81
82     my @i82utf = @{get_I8_2_utf($charset)};
83     print $out_fh <<END;
84 /* (Confusingly named) Index is $charset I8 byte; value is
85  * $charset UTF-EBCDIC equivalent */
86 END
87     output_table(\@i82utf, "PL_utf2e");
88
89     { #Construct the inverse
90         my @utf2i8;
91         for my $i (0 .. 255) {
92             $utf2i8[$i82utf[$i]] = $i;
93         }
94         print $out_fh <<END;
95 /* (Confusingly named) Index is $charset UTF-EBCDIC byte; value is
96  * $charset I8 equivalent */
97 END
98         output_table(\@utf2i8, "PL_e2utf");
99     }
100
101     {
102         my @utf8skip;
103
104         # These are invariants or continuation bytes.
105         for my $i (0 .. 0xBF) {
106             $utf8skip[$i82utf[$i]] = 1;
107         }
108
109         # These are start bytes;  The skip is the number of consecutive highest
110         # order 1-bits (up to 7)
111         for my $i (0xC0 .. 255) {
112             my $count;
113             if ($i == 0b11111111) {
114                 no warnings 'once';
115                 $count = $CHARSET_TRANSLATIONS::UTF_EBCDIC_MAXBYTES;
116             }
117             elsif (($i & 0b11111110) == 0b11111110) {
118                 $count= 7;
119             }
120             elsif (($i & 0b11111100) == 0b11111100) {
121                 $count= 6;
122             }
123             elsif (($i & 0b11111000) == 0b11111000) {
124                 $count= 5;
125             }
126             elsif (($i & 0b11110000) == 0b11110000) {
127                 $count= 4;
128             }
129             elsif (($i & 0b11100000) == 0b11100000) {
130                 $count= 3;
131             }
132             elsif (($i & 0b11000000) == 0b11000000) {
133                 $count= 2;
134             }
135             else {
136                 die "Something wrong for UTF8SKIP calculation for $i";
137             }
138             $utf8skip[$i82utf[$i]] = $count;
139         }
140
141         print $out_fh <<END;
142 /* Index is $charset UTF-EBCDIC byte; value is UTF8SKIP for start bytes
143  * (including for overlongs); 1 for continuation.  Adapted from the shadow
144  * flags table in tr16.  The entries marked 9 in tr16 are continuation bytes
145  * and are marked as length 1 here so that we can recover. */
146 END
147         output_table(\@utf8skip, "PL_utf8skip", 0);  # The 0 means don't print
148                                                      # in hex
149     }
150
151     use feature 'unicode_strings';
152
153     {
154         my @lc;
155         for my $i (0 .. 255) {
156             $lc[$a2e[$i]] = $a2e[ord lc chr $i];
157         }
158         print $out_fh "/* Index is $charset code point; value is its lowercase equivalent */\n";
159         output_table(\@lc, "PL_latin1_lc");
160     }
161
162     {
163         my @uc;
164         for my $i (0 .. 255) {
165             my $uc = uc chr $i;
166             if (length $uc > 1 || ord $uc > 255) {
167                 $uc = "\N{LATIN SMALL LETTER Y WITH DIAERESIS}";
168             }
169             $uc[$a2e[$i]] = $a2e[ord $uc];
170         }
171         print $out_fh <<END;
172 /* Index is $charset code point; value is its uppercase equivalent.
173  * The 'mod' in the name means that codepoints whose uppercase is above 255 or
174  * longer than 1 character map to LATIN SMALL LETTER Y WITH DIARESIS */
175 END
176         output_table(\@uc, "PL_mod_latin1_uc");
177     }
178
179     { # PL_fold
180         my @ascii_fold;
181         for my $i (0 .. 255) {  # Initialise to identity map
182             $ascii_fold[$i] = $i;
183         }
184
185         # Overwrite the entries that aren't identity
186         for my $chr ('A' .. 'Z') {
187             $ascii_fold[$a2e[ord $chr]] = $a2e[ord lc $chr];
188         }
189         for my $chr ('a' .. 'z') {
190             $ascii_fold[$a2e[ord $chr]] = $a2e[ord uc $chr];
191         }
192         print $out_fh <<END;
193 /* Index is $charset code point; For A-Z, value is a-z; for a-z, value
194  * is A-Z; all other code points map to themselves */
195 END
196         output_table(\@ascii_fold, "PL_fold");
197     }
198
199     {
200         my @latin1_fold;
201         for my $i (0 .. 255) {
202             my $char = chr $i;
203             my $lc = lc $char;
204
205             # lc and uc adequately proxy for fold-case pairs in this 0-255
206             # range
207             my $uc = uc $char;
208             $uc = $char if length $uc > 1 || ord $uc > 255;
209             if ($lc ne $char) {
210                 $latin1_fold[$a2e[$i]] = $a2e[ord $lc];
211             }
212             elsif ($uc ne $char) {
213                 $latin1_fold[$a2e[$i]] = $a2e[ord $uc];
214             }
215             else {
216                 $latin1_fold[$a2e[$i]] = $a2e[$i];
217             }
218         }
219         print $out_fh <<END;
220 /* Index is $charset code point; value is its other fold-pair equivalent
221  * (A => a; a => A, etc) in the 0-255 range.  If no such equivalent, value is
222  * the code point itself */
223 END
224         output_table(\@latin1_fold, "PL_fold_latin1");
225     }
226
227     print $out_fh get_conditional_compile_line_end();
228 }
229
230 print $out_fh "\n#endif /* PERL_EBCDIC_TABLES_H_ */\n";
231
232 read_only_bottom_close_and_rename($out_fh);