$SIG{__WARN__} and PL_warnhook can have different values (but shouldn't) #14766
Comments
From @CorionCreated by @CorionAfter thinking a bit more about the problems of Coro and %SIG, I For example, PerlIO_find_layer assigns directly to PL_warnhook I think Perl should take the code from Coro to make $SIG{__WARN__} The code to do this can be found in Coro/State.xs , but if nobody With this change, Coro could eliminate its workaround of patching -max Perl Info |
From @iabynOn Fri, Jun 19, 2015 at 06:48:41AM -0700, Max Maischein wrote:
+1 -- |
|
The RT System itself - Status changed from 'new' to 'open' |
From @CorionHi all, Am 24.06.2015 um 14:35 schrieb Dave Mitchell via RT:
I've attached a patch that adds a (failing) test for this to int /* Are we fetching a signal entry? */ PERL_ARGS_ASSERT_MAGIC_GETSIG; if (!i) { sv_setsv (sv, ssv); I hope somebody sees what's obviously wrong with this, as PL_warnhook ..\perl.exe -e "BEGIN{$|=1;$SIG{__WARN__}=sub{eval {print$_[0]}; die The expected output is foo The output I get is foo Frustrated, |
From @Corion0001-Add-failing-test-for-setting-PL_warnhook-via-XS.patchFrom da10ba1daf7141e384bc91e7479341fc8ba158a8 Mon Sep 17 00:00:00 2001
From: Max Maischein <[email protected]>
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
|
From @jkeenanOn Mon Sep 28 12:31:00 2015, corion@cpan.org wrote:
[snip]
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. -- |
From @rurbanOn Wed Jun 24 05:35:29 2015, davem wrote:
+1 I cleaned up Coro to work on 5.22 in https://github.com/rurban/Coro/tree/5.22 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: With my 5.22 Coro most localized warning and die handler work fine, just not all. |
From @CorionHello all,
I have attached my work in progress. Moving the getsig() access to The attached changes still fail a lot of the test suite, most likely -max |
From @Corion0001-SIG-__WARN__-always-accesses-PL_warnhook-always-a-co.patchFrom 507e6ccc67d9f37f14c098272491e35f38b2445e Mon Sep 17 00:00:00 2001
From: Max Maischein <[email protected]>
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
|
From @LeontOn Fri Oct 16 12:45:50 2015, corion@cpan.org 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 |
From @Leont0001-Handle-warnhook-and-diehook-better-is-SIG-get.patchFrom 4c4fd04d526aec1a032f55c550202ad80a51ef58 Mon Sep 17 00:00:00 2001
From: Leon Timmermans <[email protected]>
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
|
From @bulk88On Tue May 03 00:58:59 2016, LeonT wrote:
+ const char *s = MgPV_const(mg,siglen); Dont fetch/execute that unless i > 0. -- |
From @cpansproutOn Tue May 03 00:58:59 2016, LeonT wrote:
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 |
|
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. |
It never was. There is a test case in https://www.nntp.perl.org/group/perl.perl5.porters/;msgid=20160505114931.GS2048%40ceres.etla.org which still fails. I support moving this to a PR, but the ticket should stay open until that PR is made and can be referenced from here. |
Migrated from rt.perl.org#125439 (status was 'open')
Searchable as RT125439$
The text was updated successfully, but these errors were encountered: