From: Karl Williamson <khw@khw-desktop.(none)>
Date: Sun, 30 May 2010 20:11:52 +0000 (-0600)
Subject: PATCH: uniprops.t take advantage of EBCDIC test.pl
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=66fd7fd0f5a20fad5e7cda931bc1dd21789dc9b2;p=p5sagit%2Fp5-mst-13.2.git

PATCH: uniprops.t take advantage of EBCDIC test.pl

This patch removes the partial solution to testing on EBCDIC platforms
that was in uniprops.t (generated by mktables), and replaces it with the
simple complete solution now in test.pl
---

diff --git a/lib/unicore/mktables b/lib/unicore/mktables
index ebf8309..fc2b83b 100644
--- a/lib/unicore/mktables
+++ b/lib/unicore/mktables
@@ -3954,8 +3954,6 @@ sub trace { return main::trace(@_); }
         return $self->_add_delete('+', $start, $end, "");
     }
 
-    my $non_ASCII = (ord('A') != 65);   # Assumes test on same platform
-
     sub is_code_point_usable {
         # This used only for making the test script.  See if the input
         # proposed trial code point is one that Perl will handle.  If second
@@ -3968,15 +3966,6 @@ sub trace { return main::trace(@_); }
 
         return 0 if $code < 0;                # Never use a negative
 
-        # For non-ASCII, we shun the characters that don't have Perl encoding-
-        # independent symbols for them.  'A' is such a symbol, so is "\n".
-        return $try_hard if $non_ASCII
-                            && $code <= 0xFF
-                            && ($code >= 0x7F
-                                || ($code >= 0x0E && $code <= 0x1F)
-                                || ($code >= 0x01 && $code <= 0x06)
-                                || $code == 0x0B);
-
         # shun null.  I'm (khw) not sure why this was done, but NULL would be
         # the character very frequently used.
         return $try_hard if $code == 0x0000;
@@ -11006,7 +10995,7 @@ sub compile_perl() {
                         Initialize => $Blank + $Graph - $gc->table('Control'),
                         );
     $perl->add_match_table("PosixPrint",
-                            Description => 
+                            Description =>
                               '[- 0-9A-Za-z!"#$%&\'()*+,./:;<>?@[\\\]^_`{|}~]',
                             Initialize => $Print & $ASCII,
                             );
@@ -14111,6 +14100,11 @@ __DATA__
 use strict;
 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";
+
 # Test qr/\X/ and the \p{} regular expression constructs.  This file is
 # constructed by mktables from the tables it generates, so if mktables is
 # buggy, this won't necessarily catch those bugs.  Tests are generated for all
@@ -14123,42 +14117,6 @@ use warnings;
 my $Tests = 0;
 my $Fails = 0;
 
-my $non_ASCII = (ord('A') != 65);
-
-# The 256 8-bit characters in ASCII ordinal order, with the ones that don't
-# have Perl names replaced by -1
-my @ascii_ordered_chars = (
-    "\0",
-    (-1) x 6,
-    "\a", "\b", "\t", "\n",
-    -1,   # No Vt
-    "\f", "\r",
-    (-1) x 18,
-    " ", "!", "\"", "#", '$', "%", "&", "'",
-    "(", ")", "*", "+", ",", "-", ".", "/",
-    "0", "1", "2", "3", "4", "5", "6", "7", "8", "9",
-    ":", ";", "<", "=", ">", "?", "@",
-    "A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M",
-    "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z",
-    "[", "\\", "]", "^", "_", "`",
-    "a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m",
-    "n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z",
-    "{", "|", "}", "~",
-    (-1) x 129
-);
-
-sub ASCII_ord_to_native ($) {
-    # Converts input ordinal number to the native one, if can be done easily.
-    # Returns -1 otherwise.
-
-    my $ord = shift;
-
-    return $ord if $ord > 255 || ! $non_ASCII;
-    my $result = $ascii_ordered_chars[$ord];
-    return $result if $result eq '-1';
-    return ord($result);
-}
-
 sub Expect($$$$) {
     my $expected = shift;
     my $ord = shift;
@@ -14166,17 +14124,7 @@ sub Expect($$$$) {
     my $warning_type = shift;   # Type of warning message, like 'deprecated'
                                 # or empty if none
     my $line   = (caller)[2];
-
-    # Convert the non-ASCII code points expressible as characters to their
-    # ASCII equivalents, and skip the others.
-    $ord = ASCII_ord_to_native($ord);
-    if ($ord < 0) {
-        $Tests++;
-        print "ok $Tests - "
-              . sprintf("\"\\x{%04X}\"", $ord)
-              . " =~ $regex # Skipped: non-ASCII\n";
-        return;
-    }
+    $ord = ord(latin1_to_native(chr($ord)));
 
     # Convert the code point to hex form
     my $string = sprintf "\"\\x{%04X}\"", $ord;
@@ -14307,13 +14255,7 @@ sub Test_X($) {
         my $this_string = "";
         my $this_display = "";
         foreach my $code_point (@code_points) {
-            my $ord = ASCII_ord_to_native(hex $code_point);
-            if ($ord < 0) {
-                $Tests++;
-                print "ok $Tests - String containing $code_point =~ /(\\X)/g # Skipped: non-ASCII\n";
-                return;
-            }
-            $this_string .= chr $ord;
+            $this_string .= latin1_to_native(chr(hex $code_point));
             $this_display .= "\\x{$code_point}";
         }