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 11sub 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 26sub 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 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 142my @i8_to_native = ( # Only code page 1047 so far. 143# _0 _1 _2 _3 _4 _5 _6 _7 _8 _9 _A _B _C _D _E _F 1440x00,0x01,0x02,0x03,0x37,0x2D,0x2E,0x2F,0x16,0x05,0x15,0x0B,0x0C,0x0D,0x0E,0x0F, 1450x10,0x11,0x12,0x13,0x3C,0x3D,0x32,0x26,0x18,0x19,0x3F,0x27,0x1C,0x1D,0x1E,0x1F, 1460x40,0x5A,0x7F,0x7B,0x5B,0x6C,0x50,0x7D,0x4D,0x5D,0x5C,0x4E,0x6B,0x60,0x4B,0x61, 1470xF0,0xF1,0xF2,0xF3,0xF4,0xF5,0xF6,0xF7,0xF8,0xF9,0x7A,0x5E,0x4C,0x7E,0x6E,0x6F, 1480x7C,0xC1,0xC2,0xC3,0xC4,0xC5,0xC6,0xC7,0xC8,0xC9,0xD1,0xD2,0xD3,0xD4,0xD5,0xD6, 1490xD7,0xD8,0xD9,0xE2,0xE3,0xE4,0xE5,0xE6,0xE7,0xE8,0xE9,0xAD,0xE0,0xBD,0x5F,0x6D, 1500x79,0x81,0x82,0x83,0x84,0x85,0x86,0x87,0x88,0x89,0x91,0x92,0x93,0x94,0x95,0x96, 1510x97,0x98,0x99,0xA2,0xA3,0xA4,0xA5,0xA6,0xA7,0xA8,0xA9,0xC0,0x4F,0xD0,0xA1,0x07, 1520x20,0x21,0x22,0x23,0x24,0x25,0x06,0x17,0x28,0x29,0x2A,0x2B,0x2C,0x09,0x0A,0x1B, 1530x30,0x31,0x1A,0x33,0x34,0x35,0x36,0x08,0x38,0x39,0x3A,0x3B,0x04,0x14,0x3E,0xFF, 1540x41,0x42,0x43,0x44,0x45,0x46,0x47,0x48,0x49,0x4A,0x51,0x52,0x53,0x54,0x55,0x56, 1550x57,0x58,0x59,0x62,0x63,0x64,0x65,0x66,0x67,0x68,0x69,0x6A,0x70,0x71,0x72,0x73, 1560x74,0x75,0x76,0x77,0x78,0x80,0x8A,0x8B,0x8C,0x8D,0x8E,0x8F,0x90,0x9A,0x9B,0x9C, 1570x9D,0x9E,0x9F,0xA0,0xAA,0xAB,0xAC,0xAE,0xAF,0xB0,0xB1,0xB2,0xB3,0xB4,0xB5,0xB6, 1580xB7,0xB8,0xB9,0xBA,0xBB,0xBC,0xBE,0xBF,0xCA,0xCB,0xCC,0xCD,0xCE,0xCF,0xDA,0xDB, 1590xDC,0xDD,0xDE,0xDF,0xE1,0xEA,0xEB,0xEC,0xED,0xEE,0xEF,0xFA,0xFB,0xFC,0xFD,0xFE, 160); 161 162my @native_to_i8; 163for (my $i = 0; $i < 256; $i++) { 164 $native_to_i8[$i8_to_native[$i]] = $i; 165} 166 167*I8_to_native = ($::IS_ASCII) 168 ? sub { return shift } 169 : sub { return join "", map { chr $i8_to_native[ord $_] } 170 split "", shift }; 171*native_to_I8 = ($::IS_ASCII) 172 ? sub { return shift } 173 : sub { return join "", map { chr $native_to_i8[ord $_] } 174 split "", shift }; 175 1761 177