From dmuell@gmx.net

This is a bug report for perl from dmuell@​gmx.net,
generated with the help of perlbug 1.35 running under perl v5.8.6.

running this test application crashes perl 5.8.6 or newer (5.8.5 and
older works fine)​:

=== Cut ===
#!/usr/bin/perl

use CGI​::Carp qw(fatalsToBrowser);
use diagnostics;

warn "foo";
=== Cut ===

output is a lot of garbage, and then​:

Deep recursion on subroutine "CGI​::Carp​::warn" at /usr/lib/perl5/5.8.6/diagnostics.pm line 506.
Segmentation fault (core dumped)

Flags​:
  category=core
  severity=high

This perlbug was built using Perl v5.8.6 - Fri Jun 24 16​:05​:45 UTC 2005
It is being executed now by Perl v5.8.6 - Fri Jun 24 16​:00​:32 UTC 2005.

Site configuration information for perl v5.8.6​:

Configured by abuild at Fri Jun 24 16​:00​:32 UTC 2005.

Summary of my perl5 (revision 5 version 8 subversion 6) configuration​:
  Platform​:
  osname=linux, osvers=2.6.12, archname=i586-linux-thread-multi
  uname='linux salieri 2.6.12 #1 smp tue jun 21 14​:03​:10 utc 2005 i686 athlon i386 gnulinux '
  config_args='-ds -e -Dprefix=/usr -Dvendorprefix=/usr -Dinstallusrbinperl -Dusethreads -Di_db -Di_dbm -Di_ndbm -Di_gdbm -Duseshrplib=true -Doptimize=-O2 -march=i586 -mtune=i686 -fmessage-length=0 -Wall -D_FORTIFY_SOURCE=2 -g -Wall -pipe'
  hint=recommended, useposix=true, d_sigaction=define
  usethreads=define use5005threads=undef useithreads=define usemultiplicity=define
  useperlio=define d_sfio=undef uselargefiles=define usesocks=undef
  use64bitint=undef use64bitall=undef uselongdouble=undef
  usemymalloc=n, bincompat5005=undef
  Compiler​:
  cc='cc', ccflags ='-D_REENTRANT -D_GNU_SOURCE -DTHREADS_HAVE_PIDS -DDEBUGGING -fno-strict-aliasing -pipe -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64',
  optimize='-O2 -march=i586 -mtune=i686 -fmessage-length=0 -Wall -D_FORTIFY_SOURCE=2 -g -Wall -pipe',
  cppflags='-D_REENTRANT -D_GNU_SOURCE -DTHREADS_HAVE_PIDS -DDEBUGGING -fno-strict-aliasing -pipe'
  ccversion='', gccversion='4.0.1 20050621 (prerelease) (SUSE Linux)', gccosandvers=''
  intsize=4, longsize=4, ptrsize=4, doublesize=8, byteorder=1234
  d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=12
  ivtype='long', ivsize=4, nvtype='double', nvsize=8, Off_t='off_t', lseeksize=8
  alignbytes=4, prototype=define
  Linker and Libraries​:
  ld='cc', ldflags =''
  libpth=/lib /usr/lib /usr/local/lib
  libs=-lnsl -ldl -lm -lcrypt -lutil -lpthread -lc
  perllibs=-lnsl -ldl -lm -lcrypt -lutil -lpthread -lc
  libc=, so=so, useshrplib=true, libperl=libperl.so
  gnulibc_version='2.3.5'
  Dynamic Linking​:
  dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags='-Wl,-E -Wl,-rpath,/usr/lib/perl5/5.8.6/i586-linux-thread-multi/CORE'
  cccdlflags='-fPIC', lddlflags='-shared'

Locally applied patches​:
 

@​INC for perl v5.8.6​:
  /usr/lib/perl5/5.8.6/i586-linux-thread-multi
  /usr/lib/perl5/5.8.6
  /usr/lib/perl5/site_perl/5.8.6/i586-linux-thread-multi
  /usr/lib/perl5/site_perl/5.8.6
  /usr/lib/perl5/site_perl
  /usr/lib/perl5/vendor_perl/5.8.6/i586-linux-thread-multi
  /usr/lib/perl5/vendor_perl/5.8.6
  /usr/lib/perl5/vendor_perl
  .

Environment for perl v5.8.6​:
  HOME=/home/dirk
  LANG=en_US.UTF-8
  LANGUAGE (unset)
  LD_LIBRARY_PATH (unset)
  LOGDIR (unset)
  PATH=/opt/gcc/bin​:/home/dirk/bin​:/usr/local/bin​:/usr/bin​:/usr/X11R6/bin​:/bin​:/usr/games​:/opt/gnome/bin​:/opt/kde3/bin​:/opt/kde/bin​:/usr/lib/jvm/jre/bin​:/usr/lib/mit/bin​:/usr/lib/mit/sbin​:/opt/kde/bin​:/home/dirk/src/kde/qt/bin
  PERL_BADLANG (unset)
  SHELL=/bin/bash

From dmuell@gmx.net

On Wednesday 13 July 2005 00​:11, perlbug-followup@​perl.org wrote​:

perlbug-followup@​perl.org

And this patch fixes it​:

--- lib/diagnostics.pm
+++ lib/diagnostics.pm
@​@​ -503,7 +503,7 @​@​
  print STDERR $warning;
  }
  }
- goto &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne
\&warn_trap;
+ &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap;
};

sub death_trap {

Dirk

From @schwern

On Tue, Jul 12, 2005 at 03​:11​:49PM -0700, dmuell @​ gmx. net wrote​:

=== Cut ===
#!/usr/bin/perl

use CGI​::Carp qw(fatalsToBrowser);
use diagnostics;

warn "foo";
=== Cut ===

output is a lot of garbage, and then​:

Deep recursion on subroutine "CGI​::Carp​::warn" at /usr/lib/perl5/5.8.6/diagnostics.pm line 506.
Segmentation fault (core dumped)

Deep recursion on subroutine "CGI​::Carp​::warn" at /usr/local/perl/bleadperl/lib/5.9.3/diagnostics.pm line 506.

Program received signal EXC_BAD_ACCESS, Could not access memory.
0x000bec6c in Perl_pad_push ()
(gdb) bt
#0 0x000bec6c in Perl_pad_push ()
#1 0x0007b620 in Perl_pp_goto ()
#2 0x000d1e5c in Perl_runops_standard ()
#3 0x0001e964 in Perl_call_sv ()
#4 0x00005e68 in Perl_vwarn ()
#5 0x000062b8 in Perl_vwarner ()
#6 0x00006078 in Perl_warner ()
#7 0x0007b60c in Perl_pp_goto ()
#8 0x000d1e5c in Perl_runops_standard ()
#9 0x0001e964 in Perl_call_sv ()
#10 0x00005e68 in Perl_vwarn ()
#11 0x00005fe8 in Perl_warn ()
#12 0x00067324 in Perl_pp_warn ()
#13 0x000d1e5c in Perl_runops_standard ()
#14 0x0001e964 in Perl_call_sv ()
#15 0x00005e68 in Perl_vwarn ()
#16 0x00005fe8 in Perl_warn ()
#17 0x00067324 in Perl_pp_warn ()
#18 0x000d1e5c in Perl_runops_standard ()
#19 0x0001e964 in Perl_call_sv ()
#20 0x00005e68 in Perl_vwarn ()
#21 0x00005fe8 in Perl_warn ()
#22 0x00067324 in Perl_pp_warn ()
#23 0x000d1e5c in Perl_runops_standard ()
...and so on until...
#503 0x000d1e5c in Perl_runops_standard ()
#504 0x0001e964 in Perl_call_sv ()
#505 0x00005e68 in Perl_vwarn ()
#506 0x00005fe8 in Perl_warn ()
#507 0x00067324 in Perl_pp_warn ()
#508 0x000d1e5c in Perl_runops_standard ()
#509 0x0001e394 in S_run_body ()
#510 0x0001dff4 in perl_run ()
#511 0x00002d60 in main ()
#512 0x00002780 in _start (argc=2, argv=0x0, envp=0xec09c) at /SourceCache/Csu/Csu-47/crt.c​:267
#513 0x8fe1a278 in __dyld__dyld_start ()

--
Michael G Schwern schwern@​pobox.com http​://www.pobox.com/~schwern
Ahh email, my old friend. Do you know that revenge is a dish that is best
served cold? And it is very cold on the Internet!

The RT System itself - Status changed from 'new' to 'open'

From @schwern

On Wed, Jul 13, 2005 at 03​:51​:38AM +0200, Dirk Mueller wrote​:

And this patch fixes it​:

--- lib/diagnostics.pm
+++ lib/diagnostics.pm
@​@​ -503,7 +503,7 @​@​
print STDERR $warning;
}
}
- goto &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne
\&warn_trap;
+ &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap;
};

sub death_trap {

No, that goto is important. It ensures the old warning handler is called
in the same caller context as when diagnostics.pm is not there.

  #!/usr/bin/perl -w

  BEGIN { $SIG{__WARN__} = sub { print join "\n", caller, @​_ } }
  use diagnostics;

  warn "foo";

If you run that with and without "use diagnostics" the output from the
__WARN__ handler should be the same, it should think its called from line
6. With your patch it thinks its called from inside diagnostics.pm.

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";

--
Michael G Schwern schwern@​pobox.com http​://www.pobox.com/~schwern
Reality is that which, when you stop believing in it, doesn't go away.
  -- Phillip K. Dick

From @iabyn

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 davem@​davem-splatty 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;

@iabyn - Status changed from 'open' to 'resolved'

From @schwern

[davem@​iabyn.com - Sun Jul 17 13​:42​:34 2005]​:

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.

@schwern - Status changed from 'resolved' to 'open'

From @schwern

On Sun, Jul 17, 2005 at 09​:41​:58PM +0100, Dave Mitchell wrote​:

+# [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");

This program does not segfault, it does nothing.

0 ~$ perl5.8.6 -wle 'my $d; my $w = sub { return if $d++; warn q(bar)}; local $SIG{__WARN__} = sub { goto &$w; }; warn q(foo);'
0 ~$

I think the problem is you have code to deliberately avoid the recursion in
the subroutine. "return if $d++". Get rid of that and it segfaults.

0 ~$ perl5.8.6 -wle 'my $d; my $w = sub { warn @​_}; $SIG{__WARN__} = sub { goto &$w; }; warn q(foo);'
Bus error
0 ~$

--
Michael G Schwern schwern@​pobox.com http​://www.pobox.com/~schwern
Don't try the paranormal until you know what's normal.
  -- "Lords and Ladies" by Terry Prachett

From @iabyn

On Sun, Jul 17, 2005 at 02​:27​:35PM -0700, Michael G Schwern wrote​:

On Sun, Jul 17, 2005 at 09​:41​:58PM +0100, Dave Mitchell wrote​:

+# [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");

This program does not segfault, it does nothing.

0 ~$ perl5.8.6 -wle 'my $d; my $w = sub { return if $d++; warn q(bar)}; local $SIG{__WARN__} = sub { goto &$w; }; warn q(foo);'
0 ~$

That's the idea. In fixed bleed, it prints a warning​:

$ ./perl -wle 'my $d; my $w = sub { return if $d++; warn q(bar)}; local $SIG{__WARN__} = sub { goto &$w; }; warn q(foo);'
bar at -e line 1.
$

The test minimally detects bad behaviour while avoiding runaway recursion
and segfault.

--
"Emacs isn't a bad OS once you get used to it.
It just lacks a decent editor."

From @schwern

On Mon, Jul 18, 2005 at 12​:07​:23AM +0100, Dave Mitchell wrote​:

+{
+ 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");

This program does not segfault, it does nothing.

0 ~$ perl5.8.6 -wle 'my $d; my $w = sub { return if $d++; warn q(bar)}; local $SIG{__WARN__} = sub { goto &$w; }; warn q(foo);'
0 ~$

That's the idea. In fixed bleed, it prints a warning​:

$ ./perl -wle 'my $d; my $w = sub { return if $d++; warn q(bar)}; local $SIG{__WARN__} = sub { goto &$w; }; warn q(foo);'
bar at -e line 1.
$

The test minimally detects bad behaviour while avoiding runaway recursion
and segfault.

But with runperl() its ok to segfault, its run in a different process. You
can even reduce it using fresh_perl_like().

fresh_perl_like(<<'CODE', qr/bar/);
  my $w = sub { warn q(bar) }; local $SIG{__WARN__} = sub { goto &$w; }; warn q(foo);
CODE

--
Michael G Schwern schwern@​pobox.com http​://www.pobox.com/~schwern
Insulting our readers is part of our business model.
  http​://somethingpositive.net/sp07122005.shtml

From @iabyn

On Sun, Jul 17, 2005 at 04​:25​:19PM -0700, Michael G Schwern wrote​:

On Mon, Jul 18, 2005 at 12​:07​:23AM +0100, Dave Mitchell wrote​:
But with runperl() its ok to segfault, its run in a different process.

I know. Orignally I was trying to write the test to run in the same process
(thus the need to avoid segfault), but couldn't get round the fact that
when working correctly, it needed to write to STDERR, which is why I then
bunged it in a freshperl.

You can even reduce it using fresh_perl_like().

Ooh, I'll try to remember that in future.

--
SCO - a train crash in slow motion

@iabyn - Status changed from 'open' to 'resolved'