Re: [perl #36521] perlbug AutoReply: Deep recursion on subroutine "CGI::Carp::warn"

[Dave Mitchell]

On Wed, Jul 13, 2005 at 01:40:03PM -0700, Michael G Schwern wrote:
> The problem is the use of goto &foo inside a __WARN__ when &foo also calls
> warn().  I suspect whatever magic that keeps warn() from calling 
> $SIG{__WARN__} when its already inside one is lost.
> 
>   #!/sw/bin/perl -w
> 
>   my $warn = sub { warn(join "\n", caller, @_) };
> 
>   $SIG{__WARN__} = sub {
>       # &$warn;      # this is ok
>       goto &$warn;   # this segfaults
>   };
> 
>   warn "foo";

the disabling of $SIG{__WARN__} was done by cheking the call depth of the
associated sub. The goto &foo ensured that this was always at zero.

The change below fixes this by localsised PL_warnhook t6o zero within a
call to a warn hook.

-- 
Britain, Britain, Britain! Discovered by Sir Henry Britain in
sixteen-oh-ten. Sold to Germany a year later for a pfennig and the promise
of a kiss. Destroyed in eighteen thirty-fourty two, and rebuilt a week
later by a man. This we know. Hello. But what of the people of Britain?
Who they? What do? And why?   -- Little Britain


Change 25160 by [EMAIL PROTECTED] on 2005/07/17 20:12:54

        $SIG{__WARN__} = sub { goto &foo } could recurse infinitely

Affected files ...

... //depot/perl/t/op/goto.t#30 edit
... //depot/perl/util.c#484 edit

Differences ...

==== //depot/perl/t/op/goto.t#30 (xtext) ====

@@ -10,7 +10,7 @@
 
 use warnings;
 use strict;
-plan tests => 56;
+plan tests => 57;
 
 our $foo;
 while ($?) {
@@ -436,3 +436,13 @@
 like($@, qr/Can't goto subroutine from an eval-string/, 'eval string');
 eval { goto &null };
 like($@, qr/Can't goto subroutine from an eval-block/, 'eval block');
+
+# [perl #36521] goto &foo in warn handler could defeat recursion avoider
+
+{
+    my $r = runperl(
+               stderr => 1,
+               prog => 'my $d; my $w = sub { return if $d++; warn q(bar)}; 
local $SIG{__WARN__} = sub { goto &$w; }; warn q(foo);'
+    );
+    like($r, qr/bar/, "goto &foo in warn");
+}

==== //depot/perl/util.c#484 (text) ====

@@ -1278,6 +1278,8 @@
            SV *msg;
 
            ENTER;
+           SAVESPTR(PL_warnhook);
+           PL_warnhook = Nullsv;
            save_re_context();
            msg = newSVpvn(message, msglen);
            SvFLAGS(msg) |= utf8;