In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/975fe8546427b5f6259103912b13925be148becd?hp=5e965771417d0c5da2ee767d610c735b6e1267e0>
- Log ----------------------------------------------------------------- commit 975fe8546427b5f6259103912b13925be148becd Author: Karl Williamson <[email protected]> Date: Thu Dec 11 12:29:49 2014 -0700 Generalize Carp for non-ASCII platforms This includes making some {} optional in arg_regexp.t, as I couldn't get them to consistently appear. M dist/Carp/lib/Carp.pm M dist/Carp/t/arg_regexp.t M dist/Carp/t/arg_string.t commit 7b6c24ebb3691ddc8d373cbbb4181b9814f715e7 Author: Karl Williamson <[email protected]> Date: Thu Dec 11 12:37:01 2014 -0700 Carp: Fix off-by-one error for early Perl versions This error occurred only when running Perl before 5.14, and included DEL as a printable instead of excluding it. M dist/Carp/lib/Carp.pm commit db1c86081ea5f36bc936ba37e7589e85b7fbe1ed Author: Karl Williamson <[email protected]> Date: Fri Feb 6 15:10:48 2015 -0700 Increment Carp version to 0.35 M dist/Carp/lib/Carp.pm M dist/Carp/lib/Carp/Heavy.pm ----------------------------------------------------------------------- Summary of changes: dist/Carp/lib/Carp.pm | 51 ++++++++++++++++++++++++++++++++++++--------- dist/Carp/lib/Carp/Heavy.pm | 2 +- dist/Carp/t/arg_regexp.t | 34 +++++++++++++++++++----------- dist/Carp/t/arg_string.t | 23 ++++++++++++++------ 4 files changed, 81 insertions(+), 29 deletions(-) diff --git a/dist/Carp/lib/Carp.pm b/dist/Carp/lib/Carp.pm index 99b6945..62aa679 100644 --- a/dist/Carp/lib/Carp.pm +++ b/dist/Carp/lib/Carp.pm @@ -87,7 +87,7 @@ BEGIN { } } -our $VERSION = '1.34'; +our $VERSION = '1.35'; our $MaxEvalLen = 0; our $Verbose = 0; @@ -299,12 +299,32 @@ sub format_arg { next; } my $o = ord($c); - substr $arg, $i, 1, sprintf("\\x{%x}", $o) - if $o < 0x20 || $o > 0x7f; + + # 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 > 0x7f; + + # 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>, diff --git a/dist/Carp/lib/Carp/Heavy.pm b/dist/Carp/lib/Carp/Heavy.pm index 86237cb..8863618 100644 --- a/dist/Carp/lib/Carp/Heavy.pm +++ b/dist/Carp/lib/Carp/Heavy.pm @@ -2,7 +2,7 @@ package Carp::Heavy; use Carp (); -our $VERSION = '1.34'; +our $VERSION = '1.35'; # Carp::Heavy was merged into Carp in version 1.12. Any mismatched versions # after this point are not significant and can be ignored. diff --git a/dist/Carp/t/arg_regexp.t b/dist/Carp/t/arg_regexp.t index 9d598dc..15a2e00 100644 --- a/dist/Carp/t/arg_regexp.t +++ b/dist/Carp/t/arg_regexp.t @@ -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; diff --git a/dist/Carp/t/arg_string.t b/dist/Carp/t/arg_string.t index 8a219f1..a6c2749 100644 --- a/dist/Carp/t/arg_string.t +++ b/dist/Carp/t/arg_string.t @@ -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; -- Perl5 Master Repository
