Test::Test.pm: EBCDIC fixes

We are getting Perl working again for EBCDIC in v5.22.  The changes here
are necessary to work for these platforms.  For modern Perls, there is
one code path for both ASCII and EBCDIC platforms; this wasn't possible
to do for earlier versions.

One perhaps not obvious change is that [^:ascii:] doesn't include \177
which the earlier version does.  However \177 was changed in the
substitute in the line above, so this change has no practical effect.

1 files changed, 26 insertions, 4 deletions

diff --git a/dist/Test/lib/Test.pm b/dist/Test/lib/Test.pm
index 6d82139ba5..553fe08f3a 100644
--- a/dist/Test/lib/Test.pm
+++ b/dist/Test/lib/Test.pm
@@ -20,7 +20,7 @@ sub _reset_globals {
     $planned    = 0;
 }
 
-$VERSION = '1.26';
+$VERSION = '1.27';
 require Exporter;
 @ISA=('Exporter');
 
@@ -239,9 +239,31 @@ sub _quote {
     $str =~ s/\n/\\n/g;
     $str =~ s/\r/\\r/g;
     $str =~ s/\t/\\t/g;
-    $str =~ s/([\0-\037])(?!\d)/sprintf('\\%o',ord($1))/eg;
-    $str =~ s/([\0-\037\177-\377])/sprintf('\\x%02X',ord($1))/eg;
-    $str =~ s/([^\0-\176])/sprintf('\\x{%X}',ord($1))/eg;
+    if (defined $^V && $^V ge v5.6) {
+        $str =~ s/([[:cntrl:]])(?!\d)/sprintf('\\%o',ord($1))/eg;
+        $str =~ s/([[:^print:]])/sprintf('\\x%02X',ord($1))/eg;
+        $str =~ s/([[:^ascii:]])/sprintf('\\x{%X}',ord($1))/eg;
+    }
+    elsif (ord("A") == 65) {
+        $str =~ s/([\0-\037])(?!\d)/sprintf('\\%o',ord($1))/eg;
+        $str =~ s/([\0-\037\177-\377])/sprintf('\\x%02X',ord($1))/eg;
+        $str =~ s/([^\0-\176])/sprintf('\\x{%X}',ord($1))/eg;
+    }
+    else { # Assuming EBCDIC on this ancient Perl
+
+        # The controls except for one are 0-\077, so almost all controls on
+        # EBCDIC platforms will be expressed in octal, instead of just the C0
+        # ones.
+        $str =~ s/([\0-\077])(?!\d)/sprintf('\\%o',ord($1))/eg;
+        $str =~ s/([\0-\077])/sprintf('\\x%02X',ord($1))/eg;
+
+        $str =~ s/([^\0-\xFF])/sprintf('\\x{%X}',ord($1))/eg;
+
+        # What remains to be escaped are the non-ASCII-range characters,
+        # including the one control that isn't in the 0-077 range.
+        # (We don't escape further any ASCII printables.)
+        $str =~ s<[^ !"\$\%#'()*+,\-./0123456789:;\<=\>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\\\]^_`abcdefghijklmnopqrstuvwxyz{|}~]><sprintf('\\x%02X',ord($1))>eg;
+    }
     #if( $_[1] ) {
     #  substr( $str , 218-3 ) = "..."
     #   if length($str) >= 218 and !$ENV{PERL_TEST_NO_TRUNC};