Skip to content

Commit

Permalink
[perl #92446] fix recursion introduced in original patch
Browse files Browse the repository at this point in the history
Some of the other interfaces format_arg() calls can cluck(), confess() or
longmess().  Avoid infinite recursion in those cases.

Also, instead of die() on format_arg recursion, fallback to basic
CLASS=HASH(...) output.

This fixes issues with CGI-Application, Devel-TrackSIG and Class-Std.

- for CGI-Application we ended up calling can(CARP_TRACE) on a CGI.pm
  object, which instead of returning false, croak()s

- Devel-TrackSIG calls Carp::longmess when we set the __DIE__ handler
  • Loading branch information
tonycoz committed Aug 15, 2013
1 parent 0139029 commit fdf5fcd
Show file tree
Hide file tree
Showing 2 changed files with 47 additions and 24 deletions.
39 changes: 23 additions & 16 deletions dist/Carp/lib/Carp.pm
Expand Up @@ -186,39 +186,46 @@ sub caller_info {
}

# Transform an argument to a function into a string.
our $no_recurse;
our $in_recurse;
sub format_arg {
my $arg = shift;
die "recursion\n" if $no_recurse;

if ( ref($arg) ) {
local $SIG{__DIE__} = sub{}; # legitimate, let's not leak it.
if (do {
local $@;
# legitimate, let's not leak it.
if (!$in_recurse &&
do {
local $@;
local $in_recurse = 1;
local $SIG{__DIE__} = sub{};
eval {$arg->can('CARP_TRACE') }
})
{
$arg = $arg->CARP_TRACE();
}
elsif (do {
elsif (!$in_recurse &&
do {
local $@;
local $in_recurse = 1;
local $SIG{__DIE__} = sub{};
eval {$arg = $RefArgFormatter->($arg); 1}
})
{
1;
}
elsif (defined($overload::VERSION))
{
do {
local $@;
eval {
local $no_recurse = 1;
$arg = "$arg";
1;
}
} or do {
$arg = overload::StrVal($arg);
};
if ($in_recurse ||
!do {
local $@;
local $in_recurse = 1;
local $SIG{__DIE__} = sub{};
eval {
$arg = "$arg";
1;
}
}) {
$arg = overload::StrVal($arg);
}
}
else
{
Expand Down
32 changes: 24 additions & 8 deletions dist/Carp/t/Carp_overload.t
@@ -1,6 +1,6 @@
use warnings;
no warnings 'once';
use Test::More 0.98 tests => 9;
use Test::More 0.98 tests => 10;

use Carp;

Expand Down Expand Up @@ -29,11 +29,19 @@ ok($o->{called}, "CARP_TRACE called");
like($msg, qr/'TRACE:CarpTracable=Bax'/, "CARP_TRACE output used") or diag explain $msg;
like($msg, qr/'HASH\(0x[[:xdigit:]]+\)'/, "HASH not stringified again");

$o = CarpBad->new(key => 'Zoo');
$msg = call(\&with_longmess, $o, {bar => 'kill'});
unlike($msg, qr/THIS SHOULD NEVER HAPPEN|Zoo/, "Didn't get the as-string version");
like($msg, qr/CarpBad=HASH/,"Normal non-overload string conversion");
diag explain $msg;
{
my @warn;
local $SIG{__WARN__} = sub { push @warn, "@_" };
$o = CarpBad->new(key => 'Zoo');
$msg = call(\&with_longmess, $o, {bar => 'kill'});
like($msg, qr/THIS CAN NOW HAPPEN|Zoo/, "Didn't get the as-string version");
like($warn[0], qr/this is now allowed/, "check warning produced");
@warn = ();

$o = CarpBad2->new(key => 'Apple');
$msg = call(\&with_longmess, $o, {bar => 'kill'});
like($msg, qr/CarpBad2=HASH/,"Normal non-overload string conversion");
}

sub call
{
Expand Down Expand Up @@ -77,8 +85,16 @@ use parent -norequire => 'Stringable';

sub as_string
{
Carp::cluck("woops, this isn't allowed");
"THIS SHOULD NEVER HAPPEN";
Carp::cluck("this is now allowed");
"THIS CAN NOW HAPPEN";
}

package CarpBad2;

use parent -norequire => 'Stringable';

sub as_string
{
confess("this should fallback");
"THIS SHOULD NEVER HAPPEN";
}

0 comments on commit fdf5fcd

Please sign in to comment.