This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Generalize Carp for non-ASCII platforms
authorKarl Williamson <khw@cpan.org>
Thu, 11 Dec 2014 19:29:49 +0000 (12:29 -0700)
committerKarl Williamson <khw@cpan.org>
Fri, 6 Feb 2015 22:18:42 +0000 (15:18 -0700)
This includes making some {} optional in arg_regexp.t, as I couldn't get
them to consistently appear.

dist/Carp/lib/Carp.pm
dist/Carp/t/arg_regexp.t
dist/Carp/t/arg_string.t

index a03f7e0..62aa679 100644 (file)
@@ -299,12 +299,32 @@ sub format_arg {
                next;
            }
            my $o = ord($c);
-           substr $arg, $i, 1, sprintf("\\x{%x}", $o)
-               if $o < 0x20 || $o > 0x7e;
+
+            # This code is repeated in Regexp::CARP_TRACE()
+            if ($] ge 5.007_003) {
+                substr $arg, $i, 1, sprintf("\\x{%x}", $o)
+                 if utf8::native_to_unicode($o) < utf8::native_to_unicode(0x20)
+                  || utf8::native_to_unicode($o) > utf8::native_to_unicode(0x7e);
+            } elsif (ord("A") == 65) {
+                substr $arg, $i, 1, sprintf("\\x{%x}", $o)
+                    if $o < 0x20 || $o > 0x7e;
+            } else { # Early EBCDIC
+
+                # 3 EBCDIC code pages supported then;  all controls but one
+                # are the code points below SPACE.  The other one is 0x5F on
+                # POSIX-BC; FF on the other two.
+                substr $arg, $i, 1, sprintf("\\x{%x}", $o)
+                    if $o < ord(" ") || ((ord ("^") == 106)
+                                          ? $o == 0x5f
+                                          : $o == 0xff);
+            }
        }
     } else {
        $arg =~ s/([\"\\\$\@])/\\$1/g;
-       $arg =~ s/([^ -~])/sprintf("\\x{%x}",ord($1))/eg;
+        # This is all the ASCII printables spelled-out.  It is portable to all
+        # Perl versions and platforms (such as EBCDIC).  There are other more
+        # compact ways to do this, but may not work everywhere every version.
+        $arg =~ s/([^ !"\$\%#'()*+,\-.\/0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\\\]^_`abcdefghijklmnopqrstuvwxyz\{|}~])/sprintf("\\x{%x}",ord($1))/eg;
     }
     downgrade($arg, 1);
     return "\"".$arg."\"".$suffix;
@@ -317,11 +337,25 @@ sub Regexp::CARP_TRACE {
        for(my $i = length($arg); $i--; ) {
            my $o = ord(substr($arg, $i, 1));
            my $x = substr($arg, 0, 0);   # work around bug on Perl 5.8.{1,2}
-           substr $arg, $i, 1, sprintf("\\x{%x}", $o)
-               if $o < 0x20 || $o > 0x7e;
+
+            # This code is repeated in format_arg()
+            if ($] ge 5.007_003) {
+                substr $arg, $i, 1, sprintf("\\x{%x}", $o)
+                 if utf8::native_to_unicode($o) < utf8::native_to_unicode(0x20)
+                  || utf8::native_to_unicode($o) > utf8::native_to_unicode(0x7e);
+            } elsif (ord("A") == 65) {
+                substr $arg, $i, 1, sprintf("\\x{%x}", $o)
+                    if $o < 0x20 || $o > 0x7e;
+            } else { # Early EBCDIC
+                substr $arg, $i, 1, sprintf("\\x{%x}", $o)
+                    if $o < ord(" ") || ((ord ("^") == 106)
+                                          ? $o == 0x5f
+                                          : $o == 0xff);
+            }
        }
     } else {
-       $arg =~ s/([^ -~])/sprintf("\\x{%x}",ord($1))/eg;
+        # See comment in format_arg() about this same regex.
+        $arg =~ s/([^ !"\$\%#'()*+,\-.\/0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\\\]^_`abcdefghijklmnopqrstuvwxyz\{|}~])/sprintf("\\x{%x}",ord($1))/eg;
     }
     downgrade($arg, 1);
     my $suffix = "";
@@ -865,9 +899,6 @@ The Carp routines don't handle exception objects currently.
 If called with a first argument that is a reference, they simply
 call die() or warn(), as appropriate.
 
-Some of the Carp code assumes that Perl's basic character encoding is
-ASCII, and will go wrong on an EBCDIC platform.
-
 =head1 SEE ALSO
 
 L<Carp::Always>,
index 9d598dc..15a2e00 100644 (file)
@@ -9,10 +9,20 @@ sub lmm { Carp::longmess("x") }
 sub lm { lmm() }
 sub rx { qr/$_[0]/ }
 
+# Use full generality on sufficiently recent versions.  On early Perl
+# releases, U+E9 is 0x51 on all EBCDIC code pages supported then.
+my $e9 = sprintf "%02x", (($] ge 5.007_003)
+                          ? utf8::unicode_to_native(0xe9)
+                          : ((ord("A" == 193))
+                             ? 0x51
+                             : 0xE9));
+my $chr_e9 = chr eval "0x$e9";
+my $nl_as_hex = sprintf "%x", ord("\n");
+
 # On Perl 5.6 we accept some incorrect quoting of Unicode characters,
 # because upgradedness of regexps isn't preserved by stringification,
 # so it's impossible to implement the correct behaviour.
-my $xe9_rx = "$]" < 5.008 ? qr/\\x\{c3\}\\x\{a9\}|\\x\{e9\}/ : qr/\\x\{e9\}/;
+my $xe9_rx = "$]" < 5.008 ? qr/\\x\{c3\}\\x\{a9\}|\\x\{e9\}/ : qr/\\x\{$e9\}/;
 my $x666_rx = "$]" < 5.008 ? qr/\\x\{d9\}\\x\{a6\}|\\x\{666\}/ : qr/\\x\{666\}/;
 my $x2603_rx = "$]" < 5.008 ? qr/\\x\{e2\}\\x\{98\}\\x\{83\}|\\x\{2603\}/ : qr/\\x\{2603\}/;
 
@@ -24,17 +34,17 @@ like lm(qr/a.b$/sm), qr/main::lm\(qr\(a\.b\$\)u?ms\)/;
 like lm(qr/foo/), qr/main::lm\(qr\(foo\)u?\)/;
 like lm(qr/a\$b\@c\\d/), qr/main::lm\(qr\(a\\\$b\\\@c\\\\d\)u?\)/;
 like lm(qr/a\nb/), qr/main::lm\(qr\(a\\nb\)u?\)/;
-like lm(rx("a\nb")), qr/main::lm\(qr\(a\\x\{a\}b\)u?\)/;
+like lm(rx("a\nb")), qr/main::lm\(qr\(a\\x\{$nl_as_hex\}b\)u?\)/;
 like lm(qr/a\x{666}b/), qr/main::lm\(qr\(a\\x\{666\}b\)u?\)/;
 like lm(rx("a\x{666}b")), qr/main::lm\(qr\(a${x666_rx}b\)u?\)/;
 like lm(qr/\x{666}b/), qr/main::lm\(qr\(\\x\{666\}b\)u?\)/;
 like lm(rx("\x{666}b")), qr/main::lm\(qr\(${x666_rx}b\)u?\)/;
 like lm(qr/a\x{666}/), qr/main::lm\(qr\(a\\x\{666\}\)u?\)/;
 like lm(rx("a\x{666}")), qr/main::lm\(qr\(a${x666_rx}\)u?\)/;
-like lm(qr/L\xe9on/), qr/main::lm\(qr\(L\\xe9on\)u?\)/;
-like lm(rx("L\xe9on")), qr/main::lm\(qr\(L${xe9_rx}on\)u?\)/;
-like lm(qr/L\xe9on \x{2603} !/), qr/main::lm\(qr\(L\\xe9on \\x\{2603\} !\)u?\)/;
-like lm(rx("L\xe9on \x{2603} !")), qr/main::lm\(qr\(L${xe9_rx}on ${x2603_rx} !\)u?\)/;
+like lm(qr/L${chr_e9}on/), qr/main::lm\(qr\(L\\x\{?${e9}\}?on\)u?\)/;
+like lm(rx("L${chr_e9}on")), qr/main::lm\(qr\(L${xe9_rx}on\)u?\)/;
+like lm(qr/L${chr_e9}on \x{2603} !/), qr/main::lm\(qr\(L\\x\{?${e9}\}?on \\x\{2603\} !\)u?\)/;
+like lm(rx("L${chr_e9}on \x{2603} !")), qr/main::lm\(qr\(L${xe9_rx}on ${x2603_rx} !\)u?\)/;
 
 $Carp::MaxArgLen = 5;
 foreach my $arg ("foo bar baz", "foo bar ba", "foo bar b", "foo bar ", "foo bar", "foo ba") {
@@ -44,10 +54,10 @@ foreach my $arg ("foo b", "foo ", "foo", "fo", "f", "") {
     like lm(rx($arg)), qr/main::lm\(qr\(\Q$arg\E\)u?\)/;
 }
 like lm(qr/foo.bar$/sm), qr/main::lm\(qr\(fo\)\.\.\.u?ms\)/;
-like lm(qr/L\xe9on \x{2603} !/), qr/main::lm\(qr\(L\\\)\.\.\.u?\)/;
-like lm(rx("L\xe9on \x{2603} !")), qr/main::lm\(qr\(L\\\)\.\.\.u?\)/;
-like lm(qr/L\xe9on\x{2603}/), qr/main::lm\(qr\(L\\\)\.\.\.u?\)/;
-like lm(rx("L\xe9on\x{2603}")), qr/main::lm\(qr\(L\\\)\.\.\.u?\)/;
+like lm(qr/L${chr_e9}on \x{2603} !/), qr/main::lm\(qr\(L\\\)\.\.\.u?\)/;
+like lm(rx("L${chr_e9}on \x{2603} !")), qr/main::lm\(qr\(L\\\)\.\.\.u?\)/;
+like lm(qr/L${chr_e9}on\x{2603}/), qr/main::lm\(qr\(L\\\)\.\.\.u?\)/;
+like lm(rx("L${chr_e9}on\x{2603}")), qr/main::lm\(qr\(L\\\)\.\.\.u?\)/;
 like lm(qr/foo\x{2603}/), qr/main::lm\(qr\(fo\)\.\.\.u?\)/;
 like lm(rx("foo\x{2603}")), qr/main::lm\(qr\(fo\)\.\.\.u?\)/;
 
@@ -55,7 +65,7 @@ $Carp::MaxArgLen = 0;
 foreach my $arg ("wibble:" x 20, "foo bar baz") {
     like lm(rx($arg)), qr/main::lm\(qr\(\Q$arg\E\)u?\)/;
 }
-like lm(qr/L\xe9on\x{2603}/), qr/main::lm\(qr\(L\\xe9on\\x\{2603\}\)u?\)/;
-like lm(rx("L\xe9on\x{2603}")), qr/main::lm\(qr\(L${xe9_rx}on${x2603_rx}\)u?\)/;
+like lm(qr/L${chr_e9}on\x{2603}/), qr/main::lm\(qr\(L\\x\{?${e9}\}?on\\x\{2603\}\)u?\)/;
+like lm(rx("L${chr_e9}on\x{2603}")), qr/main::lm\(qr\(L${xe9_rx}on${x2603_rx}\)u?\)/;
 
 1;
index 8a219f1..a6c2749 100644 (file)
@@ -8,6 +8,16 @@ use Carp ();
 sub lmm { Carp::longmess("x") }
 sub lm { lmm() }
 
+# Use full generality on sufficiently recent versions.  On early Perl
+# releases, U+E9 is 0x51 on all EBCDIC code pages supported then.
+my $e9 = sprintf "%02x", (($] ge 5.007_003)
+                          ? utf8::unicode_to_native(0xe9)
+                          : ((ord("A" == 193))
+                             ? 0x51
+                             : 0xE9));
+my $chr_e9 = chr utf8::unicode_to_native(0xe9);
+my $nl_as_hex = sprintf "%x", ord("\n");
+
 like lm(3), qr/main::lm\(3\)/;
 like lm(substr("3\x{2603}", 0, 1)), qr/main::lm\(3\)/;
 like lm(-3), qr/main::lm\(-3\)/;
@@ -16,12 +26,13 @@ like lm(-3.5e100), qr/main::lm\(-3\.5[eE]\+?100\)/;
 like lm(""), qr/main::lm\(""\)/;
 like lm("foo"), qr/main::lm\("foo"\)/;
 like lm("a\$b\@c\\d\"e"), qr/main::lm\("a\\\$b\\\@c\\\\d\\\"e"\)/;
-like lm("a\nb"), qr/main::lm\("a\\x\{a\}b"\)/;
+like lm("a\nb"), qr/main::lm\("a\\x\{$nl_as_hex\}b"\)/;
+
 like lm("a\x{666}b"), qr/main::lm\("a\\x\{666\}b"\)/;
 like lm("\x{666}b"), qr/main::lm\("\\x\{666\}b"\)/;
 like lm("a\x{666}"), qr/main::lm\("a\\x\{666\}"\)/;
-like lm("L\xe9on"), qr/main::lm\("L\\x\{e9\}on"\)/;
-like lm("L\xe9on \x{2603} !"), qr/main::lm\("L\\x\{e9\}on \\x\{2603\} !"\)/;
+like lm("L${chr_e9}on"), qr/main::lm\("L\\x\{$e9\}on"\)/;
+like lm("L${chr_e9}on \x{2603} !"), qr/main::lm\("L\\x\{$e9\}on \\x\{2603\} !"\)/;
 
 $Carp::MaxArgLen = 5;
 foreach my $arg ("foo bar baz", "foo bar ba", "foo bar b", "foo bar ", "foo bar", "foo ba") {
@@ -30,14 +41,14 @@ foreach my $arg ("foo bar baz", "foo bar ba", "foo bar b", "foo bar ", "foo bar"
 foreach my $arg ("foo b", "foo ", "foo", "fo", "f", "") {
     like lm($arg), qr/main::lm\("\Q$arg\E"\)/;
 }
-like lm("L\xe9on \x{2603} !"), qr/main::lm\("L\\x\{e9\}"\.\.\.\)/;
-like lm("L\xe9on\x{2603}"), qr/main::lm\("L\\x\{e9\}on\\x\{2603\}"\)/;
+like lm("L${chr_e9}on \x{2603} !"), qr/main::lm\("L\\x\{$e9\}"\.\.\.\)/;
+like lm("L${chr_e9}on\x{2603}"), qr/main::lm\("L\\x\{$e9\}on\\x\{2603\}"\)/;
 like lm("foo\x{2603}"), qr/main::lm\("foo\\x\{2603\}"\)/;
 
 $Carp::MaxArgLen = 0;
 foreach my $arg ("wibble." x 20, "foo bar baz") {
     like lm($arg), qr/main::lm\("\Q$arg\E"\)/;
 }
-like lm("L\xe9on\x{2603}"), qr/main::lm\("L\\x\{e9\}on\\x\{2603\}"\)/;
+like lm("L${chr_e9}on\x{2603}"), qr/main::lm\("L\\x\{$e9\}on\\x\{2603\}"\)/;
 
 1;