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.

4 files changed, 88 insertions, 10 deletions

diff --git a/dist/Carp/lib/Carp.pm b/dist/Carp/lib/Carp.pm
index 305304021d..324d3e7384 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<overload> module has been loaded.  This happens because
-regexp objects effectively have overloaded stringification behaviour
-without using the L<overload> module.  As a workaround, deliberately
-loading the L<overload> 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 0000000000..9d598dc34e
--- /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 0ac67f70c4..008342526a 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 97dbf42208..0ac66d89e0 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";