Create new testing helper file

This adds t/charset_tools.pl, and populates it with 2 functions removed
from t/test.pl.  The functions are changed very slightly to use the
variables $::IS_ASCII and $::IS_EBCDIC instead of recalculating this
information.

A new function byte_utf8a_to_utf8n() is also placed in charset_tools.
This takes the bytes that form a (ASCII-platform) UTF-8 string and
convert them to the bytes that form that string on the native platform,
hence just returns the input if run on an ASCII platform.

diff --git a/MANIFEST b/MANIFEST
index 47a5400..c23a59b 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -4787,6 +4787,7 @@ t/bigmem/pos.t                    Check that pos() handles large offsets
 t/bigmem/read.t                        Check read() handles large offsets
 t/bigmem/regexp.t              Test regular expressions with large strings
 t/bigmem/vec.t                 Check vec() handles large offsets
+t/charset_tools.pl             To aid in portable testing across platforms with different character sets
 t/cmd/elsif.t                  See if else-if works
 t/cmd/for.t                    See if for loops work
 t/cmd/mod.t                    See if statement modifiers work

diff --git a/lib/unicore/mktables b/lib/unicore/mktables
index 8899cb2..ffbfe74 100644 (file)
--- a/lib/unicore/mktables
+++ b/lib/unicore/mktables
@@ -18605,8 +18605,8 @@ use warnings;
 
 # If run outside the normal test suite on an ASCII platform, you can
 # just create a latin1_to_native() function that just returns its
-# inputs, because that's the only function used from test.pl
-require "test.pl";
+# inputs, because that's the only function used from charset_tools.pl
+require "charset_tools.pl";
 
 # Test qr/\X/ and the \p{} regular expression constructs.  This file is
 # constructed by mktables from the tables it generates, so if mktables is

diff --git a/t/charset_tools.pl b/t/charset_tools.pl
new file mode 100644 (file)
index 0000000..6abf902
--- /dev/null
+++ b/t/charset_tools.pl
@@ -0,0 +1,142 @@
+# 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_latin1($) {
+    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 latin1_to_native($) {
+    my $string = shift;
+
+    return $string if $::IS_ASCII;
+    my $output = "";
+    for my $i (0 .. length($string) - 1) {
+        $output .= chr(ord_latin1_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

diff --git a/t/lib/common.pl b/t/lib/common.pl
index 4ab00b1..367c676 100644 (file)
--- a/t/lib/common.pl
+++ b/t/lib/common.pl
@@ -6,7 +6,7 @@
 # to call cur_test() to find out how many this executed
 
 BEGIN {
-    require './test.pl';
+    require './test.pl'; require './charset_tools.pl';
 }
 
 use Config;

diff --git a/t/op/chop.t b/t/op/chop.t
index 3f2247f..3cf8735 100644 (file)
--- a/t/op/chop.t
+++ b/t/op/chop.t
@@ -3,7 +3,7 @@
 BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
-    require './test.pl';
+    require './test.pl'; require './charset_tools.pl';
 }
 
 plan tests => 143;

diff --git a/t/op/index.t b/t/op/index.t
index eaed4b3..78faeb6 100644 (file)
--- a/t/op/index.t
+++ b/t/op/index.t
@@ -3,7 +3,7 @@
 BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
-    require './test.pl';
+    require './test.pl'; require './charset_tools.pl';
 }
 
 use strict;

diff --git a/t/op/lc.t b/t/op/lc.t
index e01f2b0..bb5d4c1 100644 (file)
--- a/t/op/lc.t
+++ b/t/op/lc.t
@@ -6,7 +6,7 @@ BEGIN {
     chdir 't';
     @INC = '../lib';
     require Config; import Config;
-    require './test.pl';
+    require './test.pl'; require './charset_tools.pl';
     require './loc_tools.pl';   # Contains find_utf8_ctype_locale()
 }
 

diff --git a/t/re/fold_grind.t b/t/re/fold_grind.t
index 2f86113..65f4243 100644 (file)
--- a/t/re/fold_grind.t
+++ b/t/re/fold_grind.t
@@ -5,7 +5,7 @@ binmode STDOUT, ":utf8";
 BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
-    require './test.pl';
+    require './test.pl'; require './charset_tools.pl';
     require Config; import Config;
     skip_all_if_miniperl("no dynamic loading on miniperl, no Encode nor POSIX");
     require './loc_tools.pl';

diff --git a/t/re/pat_advanced.t b/t/re/pat_advanced.t
index 40cca41..3c79b87 100644 (file)
--- a/t/re/pat_advanced.t
+++ b/t/re/pat_advanced.t
@@ -17,7 +17,7 @@ $| = 1;
 BEGIN {
     chdir 't' if -d 't';
     @INC = ('../lib','.');
-    require './test.pl';
+    require './test.pl'; require './charset_tools.pl';
     skip_all_if_miniperl("miniperl can't load Tie::Hash::NamedCapture, need for %+ and %-");
 }
 

diff --git a/t/re/reg_fold.t b/t/re/reg_fold.t
index 2f73980..5da8cd2 100644 (file)
--- a/t/re/reg_fold.t
+++ b/t/re/reg_fold.t
@@ -3,7 +3,7 @@
 BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
-    require './test.pl';
+    require './test.pl'; require './charset_tools.pl';
     skip_all_if_miniperl("no dynamic loading on miniperl, no File::Spec");
 }
 

diff --git a/t/test.pl b/t/test.pl
index 40e08ad..2b56623 100644 (file)
--- a/t/test.pl
+++ b/t/test.pl
@@ -1652,39 +1652,4 @@ WATCHDOG_VIA_ALARM:
     }
 }
 
-# The following 2 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.
-
-sub native_to_latin1($) {
-    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 latin1_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;
-}
-
 1;