This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
fix special-case recreation of *::
[perl5.git] / t / charset_tools.pl
CommitLineData
173ee337
KW
1# Tools to aid testing across platforms with different character sets.
2
3$::IS_ASCII = ord 'A' == 65;
4$::IS_EBCDIC = ord 'A' == 193;
5
6# The following functions allow tests to work on both EBCDIC and ASCII-ish
7# platforms. They convert string scalars between the native character set and
8# the set of 256 characters which is usually called Latin1. However, they
9# will work properly with any character input, not just Latin1.
10
d1cef54a 11sub native_to_uni($) {
173ee337
KW
12 my $string = shift;
13
14 return $string if $::IS_ASCII;
15 my $output = "";
16 for my $i (0 .. length($string) - 1) {
17 $output .= chr(utf8::native_to_unicode(ord(substr($string, $i, 1))));
18 }
19 # Preserve utf8ness of input onto the output, even if it didn't need to be
20 # utf8
21 utf8::upgrade($output) if utf8::is_utf8($string);
22
23 return $output;
24}
25
d1cef54a 26sub uni_to_native($) {
173ee337
KW
27 my $string = shift;
28
29 return $string if $::IS_ASCII;
30 my $output = "";
31 for my $i (0 .. length($string) - 1) {
98c62be8 32 $output .= chr(utf8::unicode_to_native(ord(substr($string, $i, 1))));
173ee337
KW
33 }
34 # Preserve utf8ness of input onto the output, even if it didn't need to be
35 # utf8
36 utf8::upgrade($output) if utf8::is_utf8($string);
37
38 return $output;
39}
40
41sub byte_utf8a_to_utf8n {
42 # Convert a UTF-8 byte sequence into the platform's native UTF-8
43 # equivalent, currently only UTF-8 and UTF-EBCDIC.
44
45 my @utf8_skip = (
46 # This translates a utf-8-encoded byte into how many bytes the full utf8
47 # character occupies.
48
49 # 0 1 2 3 4 5 6 7 8 9 A B C D E F
50 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, # 0
51 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, # 1
52 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, # 2
53 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, # 3
54 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, # 4
55 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, # 5
56 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, # 6
57 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, # 7
58 -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, # 8
59 -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, # 9
60 -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, # A
61 -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, # B
62 -1,-1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, # C
63 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, # D
64 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, # E
65 4, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 6, 6, 7,13, # F
66 );
67
68 my $string = shift;
69 die "Input to byte_utf8a-to_utf8n() must not be flagged UTF-8"
70 if utf8::is_utf8($string);
71 return $string if $::IS_ASCII;
72 die "Expecting ASCII or EBCDIC" unless $::IS_EBCDIC;
73
74 my $length = length($string);
75 #diag($string);
76 #diag($length);
77 my $out = "";
78 for ($i = 0; $i < $length; $i++) {
79 my $byte = ord substr($string, $i, 1);
80 my $byte_count = $utf8_skip[$byte];
81 #diag($byte);
82 #diag($byte_count);
83
84 die "Illegal start byte" if $byte_count < 0;
85 if ($i + $byte_count > $length) {
86 die "Attempt to read " . $i + $byte_count - $length . " beyond end-of-string";
87 }
88
89 # Just translate UTF-8 invariants directly.
90 if ($byte_count == 1) {
91 $out .= chr utf8::unicode_to_native($byte);
92 next;
93 }
94
95 # Otherwise calculate the code point ordinal represented by the
96 # sequence beginning with this byte, using the algorithm adapted from
97 # utf8.c. We absorb each byte in the sequence as we go along
98 my $ord = $byte & (0x1F >> ($byte_count - 2));
99 my $bytes_remaining = $byte_count - 1;
100 while ($bytes_remaining > 0) {
101 $byte = ord substr($string, ++$i, 1);
102 unless (($byte & 0xC0) == 0x80) {
103 die sprintf "byte '%X' is not a valid continuation", $byte;
104 }
105 $ord = $ord << 6 | ($byte & 0x3f);
106 $bytes_remaining--;
107 }
108 #diag($byte);
109 #diag($ord);
110
111 my $expected_bytes = $ord < 0x80
112 ? 1
113 : $ord < 0x800
114 ? 2
115 : $ord < 0x10000
116 ? 3
117 : $ord < 0x200000
118 ? 4
119 : $ord < 0x4000000
120 ? 5
121 : $ord < 0x80000000
122 ? 6
123 : 7;
124 #: (uv) < UTF8_QUAD_MAX ? 7 : 13 )
125
126 # Make sure is not an overlong sequence
127 if ($byte_count != $expected_bytes) {
128 die sprintf "character U+%X should occupy %d bytes, not %d",
129 $ord, $expected_bytes, $byte_count;
130 }
131
132 # Now that we have found the code point the original UTF-8 meant, we
133 # use the native chr function to get its native string equivalent.
134 $out .= chr utf8::unicode_to_native($ord);
135 }
136
137 utf8::encode($out); # Turn off utf8 flag.
138 #diag($out);
139 return $out;
140}
141
1421