Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

$SIG{__WARN__} and PL_warnhook can have different values (but shouldn't) #14766

Closed
p5pRT opened this issue Jun 19, 2015 · 14 comments
Closed

$SIG{__WARN__} and PL_warnhook can have different values (but shouldn't) #14766

p5pRT opened this issue Jun 19, 2015 · 14 comments

Comments

@p5pRT
Copy link

p5pRT commented Jun 19, 2015

Migrated from rt.perl.org#125439 (status was 'open')

Searchable as RT125439$

@p5pRT
Copy link
Author

p5pRT commented Jun 19, 2015

From @Corion

Created by @Corion

After thinking a bit more about the problems of Coro and %SIG, I
think that %SIG suffers from the same issue that $$ suffers from
(and was patched by me). $SIG{__WARN__} and PL_warnhook are two
different values that should always be the same, but in practice
can deviate.

For example, PerlIO_find_layer assigns directly to PL_warnhook
without updating $SIG{__WARN__} , and buggy XS modules could
do the same.

I think Perl should take the code from Coro to make $SIG{__WARN__}
always write+read PL_warnhook . Analogous for $SIG{__DIE__} .

The code to do this can be found in Coro/State.xs , but if nobody
comes up with a compelling reason to keep $SIG{__WARN__}
and PL_warnhook separate, I will submit a patch to mg.c , which
adds the appropriate code branch to Perl_magic_getsig() to return
PL_warnhook / PL_diehook for __WARN__ and __DIE__ .

With this change, Coro could eliminate its workaround of patching
the magic vtable entries for sig magic and buggy XS modules can't
make PL_warnhook and $SIG{__WARN__} different anymore . There is
a price to pay in the CPU cost of the branch in Perl_magic_getsig()
for handling __WARN__ and __DIE__ , so code reading very
often from %SIG or $SIG{__WARN__} might experience a slowdown.

-max

Perl Info

Flags:
     category=core
     severity=low

This perlbug was built using Perl 5.20.1 - Mon Sep 15 13:28:28 2014
It is being executed now by  Perl 5.23.0 - Tue Jun  9 20:51:10 2015.

Site configuration information for perl 5.23.0:

Configured by Corion at Tue Jun  9 20:51:10 2015.

Summary of my perl5 (revision 5 version 23 subversion 0) configuration:
   Derived from: 268da237d4c8792097559baa7a7581be61dc179e
   Platform:
     osname=MSWin32, osvers=6.1, archname=MSWin32-x64-multi-thread
     uname=''
     config_args='undef'
     hint=recommended, useposix=true, d_sigaction=undef
     useithreads=define, usemultiplicity=define
     use64bitint=define, use64bitall=undef, uselongdouble=undef
     usemymalloc=n, bincompat5005=undef
   Compiler:
     cc='gcc', ccflags =' -s -O2 -DWIN32 -DWIN64 -DCONSERVATIVE 
-DPERL_TEXTMODE_SCRIPTS -DPERL_IMPLICIT_CONTEXT -DPERL_IMPLICIT_SYS 
-fwrapv -fno-strict-aliasing -mms-bitfields',
     optimize='-s -O2',
     cppflags='-DWIN32'
     ccversion='', gccversion='4.8.3', gccosandvers=''
     intsize=4, longsize=4, ptrsize=8, doublesize=8, byteorder=12345678, 
doublekind=3
     d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=8, 
longdblkind=3
     ivtype='long long', ivsize=8, nvtype='double', nvsize=8, 
Off_t='long long', lseeksize=8
     alignbytes=8, prototype=define
   Linker and Libraries:
     ld='g++', ldflags ='-s -L"c:\bleadperl\lib\CORE" -L"C:\MinGW\lib"'
     libpth=C:\MinGW\lib
     libs=-lmoldname -lkernel32 -luser32 -lgdi32 -lwinspool -lcomdlg32 
-ladvapi32 -lshell32 -lole32 -loleaut32 -lnetapi32 -luuid -lws2_32 -lmpr 
-lwinmm -lversion -lodbc32 -lodbccp32 -lcomctl32
     perllibs=-lmoldname -lkernel32 -luser32 -lgdi32 -lwinspool 
-lcomdlg32 -ladvapi32 -lshell32 -lole32 -loleaut32 -lnetapi32 -luuid 
-lws2_32 -lmpr -lwinmm -lversion -lodbc32 -lodbccp32 -lcomctl32
     libc=, so=dll, useshrplib=true, libperl=libperl523.a
     gnulibc_version=''
   Dynamic Linking:
     dlsrc=dl_win32.xs, dlext=dll, d_dlsymun=undef, ccdlflags=' '
     cccdlflags=' ', lddlflags='-mdll -s -L"c:\bleadperl\lib\CORE" 
-L"C:\MinGW\lib"'

Locally applied patches:
     uncommitted-changes


@INC for perl 5.23.0:
     c:/Users/Corion/Projekte/bleadperl/lib
     .


Environment for perl 5.23.0:
     HOME (unset)
     LANG (unset)
     LANGUAGE (unset)
     LD_LIBRARY_PATH (unset)
     LOGDIR (unset)
 
PATH=c:\strawberry-perl-5.20.1.1-x64\perl\bin;c:\strawberry-perl-5.20.1.1-x64\c\bin;c:\strawberry-perl-5.20.1.1-x64\perl\site\bin;C:\Program 
Files\Microsoft IntelliType Pro\;C:\Program Files (x86)\NVIDIA 
Corporation\PhysX\Common;C:\Windows\system32;C:\Windows;C:\Windows\System32\Wbem;C:\Windows\System32\WindowsPowerShell\v1.0\;C:\Program 
Files (x86)\Git\cmd;C:\Program Files\PuTTY;C:\Program Files\MiKTeX 
2.9\miktex\bin\x64\;C:\Program 
Files\nodejs\;C:\strawberry-perl-5.20.1.1-x64\c\bin;C:\strawberry-perl-5.20.1.1-x64\perl\site\bin;C:\strawberry-perl-5.20.1.1-x64\perl\bin;C:\Program 
Files (x86)\Skype\Phone\;C:\Users\Corion\AppData\Roaming\npm;C:\Program 
Files\Oracle\VirtualBox
     PERL_BADLANG (unset)
     SHELL (unset)

@p5pRT
Copy link
Author

p5pRT commented Jun 24, 2015

From @iabyn

On Fri, Jun 19, 2015 at 06​:48​:41AM -0700, Max Maischein wrote​:

After thinking a bit more about the problems of Coro and %SIG, I
think that %SIG suffers from the same issue that $$ suffers from
(and was patched by me). $SIG{__WARN__} and PL_warnhook are two
different values that should always be the same, but in practice
can deviate.

For example, PerlIO_find_layer assigns directly to PL_warnhook
without updating $SIG{__WARN__} , and buggy XS modules could
do the same.

I think Perl should take the code from Coro to make $SIG{__WARN__}
always write+read PL_warnhook . Analogous for $SIG{__DIE__} .

The code to do this can be found in Coro/State.xs , but if nobody
comes up with a compelling reason to keep $SIG{__WARN__}
and PL_warnhook separate, I will submit a patch to mg.c , which
adds the appropriate code branch to Perl_magic_getsig() to return
PL_warnhook / PL_diehook for __WARN__ and __DIE__ .

With this change, Coro could eliminate its workaround of patching
the magic vtable entries for sig magic and buggy XS modules can't
make PL_warnhook and $SIG{__WARN__} different anymore . There is
a price to pay in the CPU cost of the branch in Perl_magic_getsig()
for handling __WARN__ and __DIE__ , so code reading very
often from %SIG or $SIG{__WARN__} might experience a slowdown.

+1

--
"Do not dabble in paradox, Edward, it puts you in danger of fortuitous wit."
  -- Lady Croom, "Arcadia"

@p5pRT
Copy link
Author

p5pRT commented Jun 24, 2015

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

@p5pRT
Copy link
Author

p5pRT commented Sep 28, 2015

From @Corion

Hi all,

Am 24.06.2015 um 14​:35 schrieb Dave Mitchell via RT​:

On Fri, Jun 19, 2015 at 06​:48​:41AM -0700, Max Maischein wrote​:

After thinking a bit more about the problems of Coro and %SIG, I
think that %SIG suffers from the same issue that $$ suffers from
(and was patched by me). $SIG{__WARN__} and PL_warnhook are two
different values that should always be the same, but in practice
can deviate.

For example, PerlIO_find_layer assigns directly to PL_warnhook
without updating $SIG{__WARN__} , and buggy XS modules could
do the same.

I think Perl should take the code from Coro to make $SIG{__WARN__}
always write+read PL_warnhook . Analogous for $SIG{__DIE__} .

+1

I've attached a patch that adds a (failing) test for this to
XS​::APItest. Unfortunately, all my changes to mg.c trying to make
Perl_magic_setsig write to PL_warnhook and Perl_magic_getsig to read
from PL_warnhook made this test pass but various parts of the test suite
fail in nonobvious ways. What I've tried is basically​:

int
Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
{
  STRLEN siglen;
  const char *s = MgPV_const(mg,siglen);

  /* Are we fetching a signal entry? */
  int i = (I16)mg->mg_private;

  PERL_ARGS_ASSERT_MAGIC_GETSIG;

  if (!i) {
  STRLEN siglen;
  mg->mg_private = i = whichsig_pvn(s, siglen);
  }
  if (*s == '_') {
  SV **svp = 0;
  if (memEQs(s, siglen, "__DIE__"))
  svp = &PL_diehook;
  else if (memEQs(s, siglen, "__WARN__")) {
  svp = &PL_warnhook;
  printf("Get​: Read PL_warnhook is %08x\n", PL_warnhook);
  };
  if (svp)
  {
  SV *ssv;
  if (!*svp)
  ssv = &PL_sv_undef;
  else if (SvTYPE (*svp) == SVt_PVCV) // thanks, PerlIO
  ssv = sv_2mortal (newRV_inc (*svp));
  else
  ssv = *svp;

  sv_setsv (sv, ssv);
  }
  } else
  if (i > 0) {

I hope somebody sees what's obviously wrong with this, as PL_warnhook
doesn't seem to keep its value and parts of PL_warnhook don't seem to
get called. I've tried with the following oneliner​:

..\perl.exe -e "BEGIN{$|=1;$SIG{__WARN__}=sub{eval {print$_[0]}; die
qq(bar\n)}; warn qq(foo\n)}"

The expected output is

foo
bar
BEGIN failed--compilation aborted at -e line 1.

The output I get is

foo

Frustrated,
-max

@p5pRT
Copy link
Author

p5pRT commented Sep 28, 2015

From @Corion

0001-Add-failing-test-for-setting-PL_warnhook-via-XS.patch
From da10ba1daf7141e384bc91e7479341fc8ba158a8 Mon Sep 17 00:00:00 2001
From: Max Maischein <corion@corion.net>
Date: Mon, 28 Sep 2015 21:21:15 +0200
Subject: [PATCH] Add failing test for setting PL_warnhook via XS

---
 MANIFEST                    |  1 +
 ext/XS-APItest/APItest.xs   | 32 ++++++++++++++++++++++++++
 ext/XS-APItest/t/sigmagic.t | 56 +++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 89 insertions(+)
 create mode 100644 ext/XS-APItest/t/sigmagic.t

diff --git a/MANIFEST b/MANIFEST
index 26faf67..64fa492 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -3961,6 +3961,7 @@ ext/XS-APItest/t/rmagical.t	XS::APItest extension
 ext/XS-APItest/t/rv2cv_op_cv.t	test rv2cv_op_cv() API
 ext/XS-APItest/t/savehints.t	test SAVEHINTS() API
 ext/XS-APItest/t/scopelessblock.t	test recursive descent statement-sequence parsing
+ext/XS-APItest/t/sigmagic.t		Tests setting PL_warnhook from XS
 ext/XS-APItest/t/sort.t		Test sort(xs_cmp ...)
 ext/XS-APItest/t/stmtasexpr.t	test recursive descent statement parsing
 ext/XS-APItest/t/stmtsasexpr.t	test recursive descent statement-sequence parsing
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index 7a258de..c4c1828 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -5142,3 +5142,35 @@ has_backrefs(SV *sv)
     OUTPUT:
         RETVAL
 
+MODULE = XS::APItest		PACKAGE = XS::APItest::SigMagic
+
+void
+apitest_set_warnhook(SV *sv)
+    PROTOTYPE: $
+    CODE:
+        SvREFCNT_inc_simple_NN(sv);
+        PL_warnhook = sv;
+
+SV *
+apitest_get_warnhook()
+    PROTOTYPE:
+    CODE:
+        RETVAL = PL_warnhook;
+/* Test code for checking that setting PL_warnhook from XS directly is mirrored in $SIG{__WARN__} */
+    OUTPUT:
+        RETVAL
+
+void
+apitest_set_diehook(SV *sv)
+    PROTOTYPE: $
+    CODE:
+        SvREFCNT_inc_simple_NN(sv);
+        PL_diehook = sv;
+
+SV *
+apitest_get_diehook()
+    PROTOTYPE:
+    CODE:
+        RETVAL = PL_diehook;
+    OUTPUT:
+        RETVAL
diff --git a/ext/XS-APItest/t/sigmagic.t b/ext/XS-APItest/t/sigmagic.t
new file mode 100644
index 0000000..a7951c1
--- /dev/null
+++ b/ext/XS-APItest/t/sigmagic.t
@@ -0,0 +1,56 @@
+use strict;
+use warnings;
+use Test::More;
+
+use XS::APItest;
+use Data::Dumper;
+
+my @sig_warnings;
+my @xs_warnings;
+
+my $sig_handler = sub {
+    push @sig_warnings, "sig: @_";
+};
+
+my $xs_handler = sub {
+    push @xs_warnings, "xs : @_";
+};
+
+# Set the one we do not want via %SIG
+$SIG{__WARN__} = $sig_handler;
+
+# Check that we can read what we wrote
+is $SIG{__WARN__}, $sig_handler, "We can retrieve values stored via %SIG from %SIG";
+
+# Check that we can read what we wrote
+my $PL_warnhook;
+$PL_warnhook = XS::APItest::SigMagic::apitest_get_warnhook();
+is $PL_warnhook, $sig_handler, "We can retrieve values stored via %SIG from PL_warnhook";
+
+# Write the one we want via XS directly into PL_warnhook
+XS::APItest::SigMagic::apitest_set_warnhook( $xs_handler );
+
+# Check that we can read what we wrote
+$PL_warnhook = XS::APItest::SigMagic::apitest_get_warnhook();
+is $PL_warnhook, $xs_handler, "We can retrieve values stored via PL_warnhook from PL_warnhook";
+
+# Check that we can read what we wrote
+is $SIG{__WARN__}, $xs_handler, "We can retrieve values stored via PL_warnhook from %SIG";
+
+# Now test that our warning handler actually gets called
+# if it is installed via PL_warnhook instead of %SIG
+
+XS::APItest::SigMagic::apitest_set_warnhook( $xs_handler );
+@sig_warnings = ();
+@xs_warnings = ();
+warn "Test 1";
+
+# Now, remove our handlers again
+delete $SIG{__WARN__};
+
+is 0+@sig_warnings, 0, "The old warning handler was not called"
+    or diag Dumper \@sig_warnings;
+is 0+@xs_warnings, 1, "The new warning handler was called even though it was set directly from XS"
+    or diag Dumper \@xs_warnings;
+
+done_testing;
-- 
2.5.0.windows.1

@p5pRT
Copy link
Author

p5pRT commented Sep 28, 2015

From @jkeenan

On Mon Sep 28 12​:31​:00 2015, corion@​cpan.org wrote​:

Hi all,

[snip]

I've attached a patch that adds a (failing) test for this to
XS​::APItest.

A non-essential question​: Would it be possible to place these tests in an existing file underneath ext/XS-APItest/t/ ?

One less test file to run on systems that have a startup penalty for each such file.

Thank you very much.

--
James E Keenan (jkeenan@​cpan.org)

@p5pRT
Copy link
Author

p5pRT commented Oct 8, 2015

From @rurban

On Wed Jun 24 05​:35​:29 2015, davem wrote​:

+1

+1

I cleaned up Coro to work on 5.22 in https://github.com/rurban/Coro/tree/5.22
by removing all the crazy workarounds schmorp had to do to support this arguable
core bug.

His problem is to override the global mg vtbl, but perl5 now only allows attaching magic to objects, not changing the global default behavior at all anymore. That change is questionable. But​:
But the underlying problem is what Max says. A quirks.

With my 5.22 Coro most localized warning and die handler work fine, just not all.
I rather urge core to fix that also.
--
Reini Urban

@p5pRT
Copy link
Author

p5pRT commented Oct 16, 2015

From @Corion

Hello all,

His problem is to override the global mg vtbl, but perl5 now only
allows attaching magic to objects, not changing the global default
behavior at all anymore. That change is questionable. But​:
But the underlying problem is what Max says. A quirks.

With my 5.22 Coro most localized warning and die handler work fine, just not all.
I rather urge core to fix that also.

I have attached my work in progress. Moving the getsig() access to
always use PL_warnhook is more convoluted than I first thought, because
S_invoke_exception() sets PL_warnhook to NULL temporarily and _then_
invokes get-magic on $SIG{__WARN__}. I've currently hacked around this
by assuming that PL_warnhook being NULL implies to leave the passed in
SV unchanged as it presumably already has the appropriate value.

The attached changes still fail a lot of the test suite, most likely
because somewhere I'm going horribly wrong with the memory management.
If somebody more familiar with XS spots some of the more egregious bad
things I do and corrects them, I'd be more than happy!

-max

@p5pRT
Copy link
Author

p5pRT commented Oct 16, 2015

From @Corion

0001-SIG-__WARN__-always-accesses-PL_warnhook-always-a-co.patch
From 507e6ccc67d9f37f14c098272491e35f38b2445e Mon Sep 17 00:00:00 2001
From: Max Maischein <corion@corion.net>
Date: Mon, 12 Oct 2015 19:40:43 +0200
Subject: [PATCH] $SIG{__WARN__} always accesses PL_warnhook, always a coderef

This addresses RT #125439

PL_warnhook and PL_diehook were written to by magic
on $SIG{__WARN__} and $SIG{__DIE__}. But reading from
%SIG only read back values written to $SIG{__WARN__}
or $SIG{__DIE__}. Values written directly into PL_warnhook
or PL_diehook were not read back.

The change highly entangles S_invoke_exception() with
Perl_magic_getsig().
S_invoke_exception() sets PL_warnhook to NULL, which
means we can't pull the original value out of our hat
anymore in Perl_magic_getsig().

Perl_magic_getsig() assumes that the SV needs no
further modification when PL_warnhook or PL_diehook is NULL,
and we already have set up oldhook appropriately,
everything works out.

I assume that we could now skip
invoking sigmagic for in S_invoke_exception() alltogether
unless we still want to allow implementing alternative
sigmagic implementations.

Most of the change necessary was alluded to in the workaround comments
in Coro.  Thanks to Marc for assiduously commenting his
workaround which pointed me towards the easy solution for this
last part of the puzzle.
---
 mg.c     | 88 ++++++++++++++++++++++++++++++++++++++++++++++------------------
 perlio.c |  7 +++++-
 sv.c     |  3 ++-
 util.c   | 11 +++++++-
 4 files changed, 82 insertions(+), 27 deletions(-)

diff --git a/mg.c b/mg.c
index ea39a67..bd77e30 100644
--- a/mg.c
+++ b/mg.c
@@ -1332,41 +1332,80 @@ restore_sigmask(pTHX_ SV *save_sv)
 int
 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
 {
+    STRLEN siglen;
+    const char *s = MgPV_const(mg,siglen);
+
     /* Are we fetching a signal entry? */
     int i = (I16)mg->mg_private;
 
     PERL_ARGS_ASSERT_MAGIC_GETSIG;
 
     if (!i) {
-        STRLEN siglen;
-        const char * sig = MgPV_const(mg, siglen);
-        mg->mg_private = i = whichsig_pvn(sig, siglen);
+    STRLEN siglen;
+    const char *s = MgPV_const(mg,siglen);
+        mg->mg_private = i = whichsig_pvn(s, siglen);
     }
-
+    if (*s == '_') {
+        SV **svp = 0;
+        if (memEQs(s, siglen, "__DIE__"))
+            svp = &PL_diehook;
+        else if (memEQs(s, siglen, "__WARN__")) {
+            svp = &PL_warnhook;
+        };
+        if (svp)
+        {
+          SV *ssv;
+          if (!*svp)
+            { /* Either we are within S_invoke_exception_hook()
+                 or some XS code set
+                 PL_warnhook = NULL;
+                 We assume that we were invoked from
+                 S_invoke_exception_hook() and leave the SV untouched
+                 to walk up the $SIG{__WARN__} or $SIG{__DIE__} chain
+              */
+            ssv = NULL;
+        }
+          else if (SvTYPE (*svp) == SVt_PVCV) {// thanks, PerlIO
+            ssv = sv_2mortal (newRV_inc (*svp));
+          }
+          else if(SvROK(*svp)) {
+              HV *st; /* Those leak?! */
+              GV *gv;
+              ssv = sv_2mortal( (SV*) sv_2cv(*svp, &st, &gv, GV_ADD));
+          }
+          else
+            ssv = *svp;
+
+          if( ssv ) {
+              sv_setsv (sv, ssv);
+          };
+        }
+    } else
     if (i > 0) {
-    	if(PL_psig_ptr[i])
-    	    sv_setsv(sv,PL_psig_ptr[i]);
-    	else {
-	    Sighandler_t sigstate = rsignal_state(i);
+        if(PL_psig_ptr[i])
+            sv_setsv(sv,PL_psig_ptr[i]);
+        else {
+        Sighandler_t sigstate = rsignal_state(i);
 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
-	    if (PL_sig_handlers_initted && PL_sig_ignoring[i])
-		sigstate = SIG_IGN;
+        if (PL_sig_handlers_initted && PL_sig_ignoring[i])
+        sigstate = SIG_IGN;
 #endif
 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
-	    if (PL_sig_handlers_initted && PL_sig_defaulting[i])
-		sigstate = SIG_DFL;
-#endif
-    	    /* cache state so we don't fetch it again */
-    	    if(sigstate == (Sighandler_t) SIG_IGN)
-    	    	sv_setpvs(sv,"IGNORE");
-    	    else
-    	    	sv_setsv(sv,&PL_sv_undef);
-	    PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
-    	    SvTEMP_off(sv);
-    	}
+        if (PL_sig_handlers_initted && PL_sig_defaulting[i])
+        sigstate = SIG_DFL;
+#endif
+            /* cache state so we don't fetch it again */
+            if(sigstate == (Sighandler_t) SIG_IGN)
+                sv_setpvs(sv,"IGNORE");
+            else
+                sv_setsv(sv,&PL_sv_undef);
+        PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
+            SvTEMP_off(sv);
+        }
     }
     return 0;
 }
+
 int
 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
 {
@@ -1537,7 +1576,6 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
     const char *s = MgPV_const(mg,len);
 
     PERL_ARGS_ASSERT_MAGIC_SETSIG;
-
     if (*s == '_') {
         if (memEQs(s, len, "__DIE__"))
 	    svp = &PL_diehook;
@@ -1620,8 +1658,9 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
 	if (i) {
 	    (void)rsignal(i, PL_csighandlerp);
 	}
-	else
+	else {
 	    *svp = SvREFCNT_inc_simple_NN(sv);
+}
     } else {
 	if (sv && SvOK(sv)) {
 	    s = SvPV_force(sv, len);
@@ -1659,8 +1698,9 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
 				     SV_GMAGIC);
 	    if (i)
 		(void)rsignal(i, PL_csighandlerp);
-	    else
+	    else {
 		*svp = SvREFCNT_inc_simple_NN(sv);
+		}
 	}
     }
 
diff --git a/perlio.c b/perlio.c
index ae8cbc9..31fb869 100644
--- a/perlio.c
+++ b/perlio.c
@@ -730,7 +730,12 @@ PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
 	    SAVEBOOL(PL_in_load_module);
 	    if (cv) {
 		SAVEGENERICSV(PL_warnhook);
-		PL_warnhook = MUTABLE_SV((SvREFCNT_inc_simple_NN(cv)));
+		/*
+		Create a reference to store in PL_warnhook
+		This is unneccessary
+		*/
+		SV * const rv = newRV_inc((SV*) cv);
+		PL_warnhook = MUTABLE_SV(rv);
 	    }
 	    PL_in_load_module = TRUE;
 	    /*
diff --git a/sv.c b/sv.c
index f0c1553..5c29a9f 100644
--- a/sv.c
+++ b/sv.c
@@ -9751,8 +9751,9 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref)
 		*st = CvSTASH(cv);
 		return cv;
 	    }
-	    else if(SvGETMAGIC(sv), isGV_with_GP(sv))
+	    else if(SvGETMAGIC(sv), isGV_with_GP(sv)) {
 		gv = MUTABLE_GV(sv);
+		}
 	    else
 		Perl_croak(aTHX_ "Not a subroutine reference");
 	}
diff --git a/util.c b/util.c
index 616356e..a37f2fb 100644
--- a/util.c
+++ b/util.c
@@ -1527,7 +1527,16 @@ S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
 
     ENTER;
     SAVESPTR(*hook);
-    *hook = NULL;
+    /* This is highly entangled with Perl_magic_getsig().
+       Here, we set PL_warnhook to NULL, which
+       means we can't pull the original value out of our hat anymore
+       in Perl_magic_getsig().
+       
+       Since Perl_magic_getsig() assumes that the SV needs no
+       further modification when PL_warnhook or PL_diehook is NULL,
+       and we already have set up oldhook appropriately, everything works out.
+    */
+    *hook = NULL; 
     cv = sv_2cv(oldhook, &stash, &gv, 0);
     LEAVE;
     if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
-- 
2.5.0.windows.1

@p5pRT
Copy link
Author

p5pRT commented May 3, 2016

From @Leont

On Fri Oct 16 12​:45​:50 2015, corion@​cpan.org wrote​:

Hello all,

His problem is to override the global mg vtbl, but perl5 now only
allows attaching magic to objects, not changing the global default
behavior at all anymore. That change is questionable. But​:
But the underlying problem is what Max says. A quirks.

With my 5.22 Coro most localized warning and die handler work fine,
just not all.
I rather urge core to fix that also.

I have attached my work in progress. Moving the getsig() access to
always use PL_warnhook is more convoluted than I first thought,
because
S_invoke_exception() sets PL_warnhook to NULL temporarily and _then_
invokes get-magic on $SIG{__WARN__}. I've currently hacked around this
by assuming that PL_warnhook being NULL implies to leave the passed in
SV unchanged as it presumably already has the appropriate value.

The attached changes still fail a lot of the test suite, most likely
because somewhere I'm going horribly wrong with the memory management.
If somebody more familiar with XS spots some of the more egregious bad
things I do and corrects them, I'd be more than happy!

-max

I based this patch on yours. It passes the tests, but doesn't quite fix Coro (one failing test). I've been looking into it, but something is still evading me (probably PL_warnhook == NULL related).

Leon

@p5pRT
Copy link
Author

p5pRT commented May 3, 2016

From @Leont

0001-Handle-warnhook-and-diehook-better-is-SIG-get.patch
From 4c4fd04d526aec1a032f55c550202ad80a51ef58 Mon Sep 17 00:00:00 2001
From: Leon Timmermans <fawaka@gmail.com>
Date: Mon, 2 May 2016 19:23:19 +0200
Subject: [PATCH] Handle warnhook and diehook better is %SIG get

---
 mg.c | 25 +++++++++++++++++++++----
 1 file changed, 21 insertions(+), 4 deletions(-)

diff --git a/mg.c b/mg.c
index 064a1ae..048e324 100644
--- a/mg.c
+++ b/mg.c
@@ -1335,15 +1335,32 @@ Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
     /* Are we fetching a signal entry? */
     int i = (I16)mg->mg_private;
 
+    STRLEN siglen;
+    const char *s = MgPV_const(mg,siglen);
+
     PERL_ARGS_ASSERT_MAGIC_GETSIG;
 
     if (!i) {
-        STRLEN siglen;
-        const char * sig = MgPV_const(mg, siglen);
-        mg->mg_private = i = whichsig_pvn(sig, siglen);
+        mg->mg_private = i = whichsig_pvn(s, siglen);
     }
 
-    if (i > 0) {
+    if (*s == '_') {
+        SV **svp = 0;
+        if (memEQs(s, siglen, "__DIE__"))
+            svp = &PL_diehook;
+        else if (memEQs(s, siglen, "__WARN__"))
+            svp = &PL_warnhook;
+        if (svp && *svp) {
+            SV *ssv;
+            if (SvTYPE (*svp) == SVt_PVCV) /* thanks, PerlIO*/
+                ssv = sv_2mortal(newRV_inc (*svp));
+            else
+                ssv = *svp;
+            sv_setsv(sv, ssv);
+            return 0;
+        }
+    }
+    else if (i > 0) {
     	if(PL_psig_ptr[i])
     	    sv_setsv(sv,PL_psig_ptr[i]);
     	else {
-- 
2.8.2-433-g5ace313

@p5pRT
Copy link
Author

p5pRT commented May 3, 2016

From @bulk88

On Tue May 03 00​:58​:59 2016, LeonT wrote​:

I based this patch on yours. It passes the tests, but doesn't quite
fix Coro (one failing test). I've been looking into it, but something
is still evading me (probably PL_warnhook == NULL related).

Leon

+ const char *s = MgPV_const(mg,siglen);

Dont fetch/execute that unless i > 0.

--
bulk88 ~ bulk88 at hotmail.com

@p5pRT
Copy link
Author

p5pRT commented May 6, 2016

From @cpansprout

On Tue May 03 00​:58​:59 2016, LeonT wrote​:

I based this patch on yours. It passes the tests, but doesn't quite
fix Coro (one failing test). I've been looking into it, but something
is still evading me (probably PL_warnhook == NULL related).

Leon

Nicholas Clark posted a variation of the patch to <http​://www.nntp.perl.org/group/perl.perl5.porters/2016/05/msg236187.html>, which gets all of Coro’s and all of core’s tests passing.

Note also that he points out a real Perl bug (not including Coro) that has to do with the warnhook/__WARN__ discrepancy, at <http​://www.nntp.perl.org/group/perl.perl5.porters/2016/05/msg236201.html>. I don’t know whether the patch fixes it, but if it does, it should be added to the test suite and the patch applied.

(But note that the patch is not necessary for Coro to work. See <86840949-52FC-4F12-A3E2-628EEAAE0C66@​cpan.org>.)

--

Father Chrysostomos

@toddr
Copy link
Member

toddr commented Feb 13, 2020

This patch no longer applies and I think it has been resolved in another way. If not, I propose moving this case to a PR with an updated patch.

@toddr toddr closed this as completed Feb 13, 2020
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Projects
None yet
Development

No branches or pull requests

2 participants