Commit | Line | Data |
---|---|---|
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 | 11 | sub 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 | 26 | sub 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 | ||
41 | sub 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 | ||
142 | 1 |