| 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 | |
| 11 | sub native_to_uni($) { |
| 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 | |
| 26 | sub uni_to_native($) { |
| 27 | my $string = shift; |
| 28 | |
| 29 | return $string if $::IS_ASCII; |
| 30 | my $output = ""; |
| 31 | for my $i (0 .. length($string) - 1) { |
| 32 | $output .= chr(utf8::unicode_to_native(ord(substr($string, $i, 1)))); |
| 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 |