t/charset_tools.pl

   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