From: Dave Mitchell <davem@fdisolutions.com>
Date: Wed, 10 May 2006 01:32:10 +0000 (+0000)
Subject: disable WARN and DIE hooks during constant folding
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=5f2d99664d8a6923d24892ffc0569f4e03e22edd;p=p5sagit%2Fp5-mst-13.2.git

disable WARN and DIE hooks during constant folding

p4raw-id: //depot/perl@28148
---

diff --git a/op.c b/op.c
index 1421e05..f5e24fc 100644
--- a/op.c
+++ b/op.c
@@ -2135,6 +2135,8 @@ Perl_fold_constants(pTHX_ register OP *o)
     int ret = 0;
     I32 oldscope;
     OP *old_next;
+    SV * const oldwarnhook = PL_warnhook;
+    SV * const olddiehook  = PL_diehook;
     dJMPENV;
 
     if (PL_opargs[type] & OA_RETSCALAR)
@@ -2196,6 +2198,8 @@ Perl_fold_constants(pTHX_ register OP *o)
     oldscope = PL_scopestack_ix;
     create_eval_scope(G_FAKINGEVAL);
 
+    PL_warnhook = PERL_WARNHOOK_FATAL;
+    PL_diehook  = NULL;
     JMPENV_PUSH(ret);
 
     switch (ret) {
@@ -2209,11 +2213,6 @@ Perl_fold_constants(pTHX_ register OP *o)
 	    SvTEMP_off(sv);
 	}
 	break;
-    case 2:
-	/* my_exit() was called; propagate it */
-	JMPENV_POP;
-	JMPENV_JUMP(2);
-	/* NOTREACHED */
     case 3:
 	/* Something tried to die.  Abandon constant folding.  */
 	/* Pretend the error never happened.  */
@@ -2222,11 +2221,16 @@ Perl_fold_constants(pTHX_ register OP *o)
 	break;
     default:
 	JMPENV_POP;
-	/* Don't expect 1 (setjmp failed) */
+	/* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
+	PL_warnhook = oldwarnhook;
+	PL_diehook  = olddiehook;
+	/* XXX note that this croak may fail as we've already blown away
+	 * the stack - eg any nested evals */
 	Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
     }
-
     JMPENV_POP;
+    PL_warnhook = oldwarnhook;
+    PL_diehook  = olddiehook;
 
     if (PL_scopestack_ix > oldscope)
 	delete_eval_scope();
diff --git a/t/comp/fold.t b/t/comp/fold.t
index f063c20..92a4fbe 100644
--- a/t/comp/fold.t
+++ b/t/comp/fold.t
@@ -8,7 +8,7 @@ BEGIN {
 use strict;
 use warnings;
 
-plan (8);
+plan (13);
 
 # Historically constant folding was performed by evaluating the ops, and if
 # they threw an exception compilation failed. This was seen as buggy, because
@@ -17,6 +17,7 @@ plan (8);
 # making constant folding consistent with many other languages, and purely an
 # optimisation rather than a behaviour change.
 
+
 my $a;
 $a = eval '$b = 0/0 if 0; 3';
 is ($a, 3);
@@ -36,3 +37,20 @@ $a = eval q{
 is ($a, 5);
 is ($@, "");
 
+# warn and die hooks should be disabled during constant folding
+
+{
+    my $c = 0;
+    local $SIG{__WARN__} = sub { $c++   };
+    local $SIG{__DIE__}  = sub { $c+= 2 };
+    eval q{
+	is($c, 0, "premature warn/die: $c");
+	my $x = "a"+5;
+	is($c, 1, "missing warn hook");
+	is($x, 5, "a+5");
+	$c = 0;
+	$x = 1/0;
+    };
+    like ($@, qr/division/, "eval caught division");
+    is($c, 2, "missing die hook");
+}
diff --git a/util.c b/util.c
index ba531b4..fb461cc 100644
--- a/util.c
+++ b/util.c
@@ -1456,7 +1456,7 @@ void
 Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
 {
     dVAR;
-    if (ckDEAD(err)) {
+    if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
 	SV * const msv = vmess(pat, args);
 	STRLEN msglen;
 	const char * const message = SvPV_const(msv, msglen);
diff --git a/warnings.h b/warnings.h
index aa830c0..423a21a 100644
--- a/warnings.h
+++ b/warnings.h
@@ -24,6 +24,9 @@
 #define specialWARN(x)		((x) == pWARN_STD || (x) == pWARN_ALL ||	\
 				 (x) == pWARN_NONE)
 
+/* if PL_warnhook is set to this value, then warnings die */
+#define PERL_WARNHOOK_FATAL	(((SV*)0) + 1)
+
 /* Warnings Categories added in Perl 5.008 */
 
 #define WARN_ALL		0
diff --git a/warnings.pl b/warnings.pl
index 853a04a..0cb5bbd 100644
--- a/warnings.pl
+++ b/warnings.pl
@@ -282,6 +282,9 @@ print WARN <<'EOM' ;
 
 #define specialWARN(x)		((x) == pWARN_STD || (x) == pWARN_ALL ||	\
 				 (x) == pWARN_NONE)
+
+/* if PL_warnhook is set to this value, then warnings die */
+#define PERL_WARNHOOK_FATAL	(((SV*)0) + 1)
 EOM
 
 my $offset = 0 ;