Typos, POD errors, etc.

[perl5.git] / t / charset_tools.pl

# Tools to aid testing across platforms with different character sets.

$::IS_ASCII  = ord 'A' ==  65;
$::IS_EBCDIC = ord 'A' == 193;

# The following functions allow tests to work on both EBCDIC and ASCII-ish
# platforms.  They convert string scalars between the native character set and
# the set of 256 characters which is usually called Latin1.  However, they
# will work properly with any character input, not just Latin1.

sub native_to_uni($) {
    my $string = shift;

    return $string if $::IS_ASCII;
    my $output = "";
    for my $i (0 .. length($string) - 1) {
        $output .= chr(utf8::native_to_unicode(ord(substr($string, $i, 1))));
    }
    # Preserve utf8ness of input onto the output, even if it didn't need to be
    # utf8
    utf8::upgrade($output) if utf8::is_utf8($string);

    return $output;
}

sub uni_to_native($) {
    my $string = shift;

    return $string if $::IS_ASCII;
    my $output = "";
    for my $i (0 .. length($string) - 1) {
        $output .= chr(utf8::unicode_to_native(ord(substr($string, $i, 1))));
    }
    # Preserve utf8ness of input onto the output, even if it didn't need to be
    # utf8
    utf8::upgrade($output) if utf8::is_utf8($string);

    return $output;
}

sub byte_utf8a_to_utf8n {
    # Convert a UTF-8 byte sequence into the platform's native UTF-8
    # equivalent, currently only UTF-8 and UTF-EBCDIC.

    my @utf8_skip = (
    # This translates a utf-8-encoded byte into how many bytes the full utf8
    # character occupies.

      # 0  1  2  3  4  5  6  7  8  9  A  B  C  D  E  F
        1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,  # 0
        1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,  # 1
        1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,  # 2
        1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,  # 3
        1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,  # 4
        1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,  # 5
        1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,  # 6
        1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,  # 7
       -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,  # 8
       -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,  # 9
       -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,  # A
       -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,  # B
       -1,-1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,  # C
        2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,  # D
        3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,  # E
        4, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 6, 6, 7,13,  # F
    );

    my $string = shift;
    die "Input to byte_utf8a-to_utf8n() must not be flagged UTF-8"
                                                    if utf8::is_utf8($string);
    return $string if $::IS_ASCII;
    die "Expecting ASCII or EBCDIC" unless $::IS_EBCDIC;

    my $length = length($string);
    #diag($string);
    #diag($length);
    my $out = "";
    for ($i = 0; $i < $length; $i++) {
        my $byte = ord substr($string, $i, 1);
        my $byte_count = $utf8_skip[$byte];
        #diag($byte);
        #diag($byte_count);

        die "Illegal start byte" if $byte_count < 0;
        if ($i + $byte_count > $length) {
            die "Attempt to read " . $i + $byte_count - $length . " beyond end-of-string";
        }

        # Just translate UTF-8 invariants directly.
        if ($byte_count == 1) {
            $out .= chr utf8::unicode_to_native($byte);
            next;
        }

        # Otherwise calculate the code point ordinal represented by the
        # sequence beginning with this byte, using the algorithm adapted from
        # utf8.c.  We absorb each byte in the sequence as we go along
        my $ord = $byte & (0x1F >> ($byte_count - 2));
        my $bytes_remaining = $byte_count - 1;
        while ($bytes_remaining > 0) {
            $byte = ord substr($string, ++$i, 1);
            unless (($byte & 0xC0) == 0x80) {
                die sprintf "byte '%X' is not a valid continuation", $byte;
            }
            $ord = $ord << 6 | ($byte & 0x3f);
            $bytes_remaining--;
        }
        #diag($byte);
        #diag($ord);

        my $expected_bytes = $ord < 0x80
                             ? 1
                             : $ord < 0x800
                               ? 2
                               : $ord < 0x10000
                                 ? 3
                                 : $ord < 0x200000
                                   ? 4
                                   : $ord < 0x4000000
                                     ? 5
                                     : $ord < 0x80000000
                                       ? 6
                                       : 7;
                                       #: (uv) < UTF8_QUAD_MAX ? 7 : 13 )

        # Make sure is not an overlong sequence
        if ($byte_count != $expected_bytes) {
            die sprintf "character U+%X should occupy %d bytes, not %d",
                                            $ord, $expected_bytes, $byte_count;
        }

        # Now that we have found the code point the original UTF-8 meant, we
        # use the native chr function to get its native string equivalent.
        $out .= chr utf8::unicode_to_native($ord);
    }

    utf8::encode($out); # Turn off utf8 flag.
    #diag($out);
    return $out;
}

1