From: Zefram Date: Sun, 25 Aug 2013 11:23:19 +0000 (+0100) Subject: install useful Regexp::CARP_TRACE from Carp X-Git-Tag: v5.19.4~418 X-Git-Url: https://perl5.git.perl.org/perl5.git/commitdiff_plain/e94bb4701fe9ef6ea7467f3fbc456bd68d184ef0 install useful Regexp::CARP_TRACE from Carp Regexp is a built-in class for which no module is normally loaded, so it can't provide its own CARP_TRACE method. Carp must therefore supply it. The method formats a regexp reference as a qr() expression as much as possible. Like string arg formatting, it uses \x{} escapes for literal characters that are not ASCII printable, and it truncates according to $Carp::MaxArgLen. The truncation happens at a different stage of processing from its position in string arg formatting, because regexp stringification presents an already-partly-escaped form of the regexp. --- diff --git a/MANIFEST b/MANIFEST index 6aed370..7ee5d51 100644 --- a/MANIFEST +++ b/MANIFEST @@ -2982,6 +2982,7 @@ dist/bignum/t/scope_r.t See if no bigrat works dist/Carp/lib/Carp/Heavy.pm Error message retired workhorse dist/Carp/lib/Carp.pm Error message extension dist/Carp/Makefile.PL makefile writer for Carp +dist/Carp/t/arg_regexp.t See if Carp formats regexp args OK in stack traces dist/Carp/t/arg_string.t See if Carp formats string args OK in stack traces dist/Carp/t/baduni.t See if Carp handles non-char Unicode dist/Carp/t/baduni_warnings.t See if Carp handles non-char Unicode when loaded via warnings.pm diff --git a/dist/Carp/lib/Carp.pm b/dist/Carp/lib/Carp.pm index 3053040..324d3e7 100644 --- a/dist/Carp/lib/Carp.pm +++ b/dist/Carp/lib/Carp.pm @@ -308,6 +308,31 @@ sub format_arg { return "\"".$arg."\"".$suffix; } +sub Regexp::CARP_TRACE { + my $arg = "$_[0]"; + downgrade($arg, 1); + if(UTF8_REGEXP_PROBLEM && is_utf8($arg)) { + 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; + } + } else { + $arg =~ s/([^ -~])/sprintf("\\x{%x}",ord($1))/eg; + } + downgrade($arg, 1); + my $suffix = ""; + if($arg =~ /\A\(\?\^?([a-z]*)(?:-[a-z]*)?:(.*)\)\z/s) { + ($suffix, $arg) = ($1, $2); + } + if ( 2 < $MaxArgLen and $MaxArgLen < length($arg) ) { + substr ( $arg, $MaxArgLen - 3 ) = ""; + $suffix = "...".$suffix; + } + return "qr($arg)$suffix"; +} + # Takes an inheritance cache and a package and returns # an anon hash of known inheritances and anon array of # inheritances which consequences have not been figured @@ -831,14 +856,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. -If a subroutine argument in a stack trace is a reference to a regexp -object, the manner in which it is shown in the stack trace depends on -whether the L module has been loaded. This happens because -regexp objects effectively have overloaded stringification behaviour -without using the L module. As a workaround, deliberately -loading the L module will mean that Carp consistently provides -the intended behaviour (of bypassing the overloading). - Some of the Carp code assumes that Perl's basic character encoding is ASCII, and will go wrong on an EBCDIC platform. diff --git a/dist/Carp/t/arg_regexp.t b/dist/Carp/t/arg_regexp.t new file mode 100644 index 0000000..9d598dc --- /dev/null +++ b/dist/Carp/t/arg_regexp.t @@ -0,0 +1,61 @@ +use warnings; +use strict; + +use Test::More tests => 42; + +use Carp (); + +sub lmm { Carp::longmess("x") } +sub lm { lmm() } +sub rx { qr/$_[0]/ } + +# 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 $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\}/; + +like lm(qr/3/), qr/main::lm\(qr\(3\)u?\)/; +like lm(qr/a.b/), qr/main::lm\(qr\(a\.b\)u?\)/; +like lm(qr/a.b/s), qr/main::lm\(qr\(a\.b\)u?s\)/; +like lm(qr/a.b$/s), qr/main::lm\(qr\(a\.b\$\)u?s\)/; +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(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?\)/; + +$Carp::MaxArgLen = 5; +foreach my $arg ("foo bar baz", "foo bar ba", "foo bar b", "foo bar ", "foo bar", "foo ba") { + like lm(rx($arg)), qr/main::lm\(qr\(fo\)\.\.\.u?\)/; +} +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/foo\x{2603}/), qr/main::lm\(qr\(fo\)\.\.\.u?\)/; +like lm(rx("foo\x{2603}")), qr/main::lm\(qr\(fo\)\.\.\.u?\)/; + +$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?\)/; + +1; diff --git a/dist/Carp/t/vivify_gv.t b/dist/Carp/t/vivify_gv.t index 0ac67f7..0083425 100644 --- a/dist/Carp/t/vivify_gv.t +++ b/dist/Carp/t/vivify_gv.t @@ -7,7 +7,7 @@ our $has_strval; BEGIN { $has_strval = exists($overload::{"StrVal"}); } our $has_sv2obj; BEGIN { $has_sv2obj = exists($B::{"svref_2object"}); } use Carp; -sub { sub { Carp::longmess("x") }->() }->(\1, "\x{2603}"); +sub { sub { Carp::longmess("x") }->() }->(\1, "\x{2603}", qr/\x{2603}/); print !(exists($utf8::{"is_utf8"}) xor $has_is_utf8) ? "" : "not ", "ok 1\n"; print !(exists($utf8::{"downgrade"}) xor $has_dgrade) ? "" : "not ", "ok 2\n"; diff --git a/dist/Carp/t/vivify_stash.t b/dist/Carp/t/vivify_stash.t index 97dbf42..0ac66d8 100644 --- a/dist/Carp/t/vivify_stash.t +++ b/dist/Carp/t/vivify_stash.t @@ -5,7 +5,7 @@ our $has_overload; BEGIN { $has_overload = exists($::{"overload::"}); } our $has_B; BEGIN { $has_B = exists($::{"B::"}); } use Carp; -sub { sub { Carp::longmess("x") }->() }->(\1, "\x{2603}"); +sub { sub { Carp::longmess("x") }->() }->(\1, "\x{2603}", qr/\x{2603}/); print !(exists($::{"utf8::"}) xor $has_utf8) ? "" : "not ", "ok 1\n"; print !(exists($::{"overload::"}) xor $has_overload) ? "" : "not ", "ok 2\n";