Refactor S_vdie_common so that Perl_vwarn can use it too.

p4raw-id: //depot/perl@26787

4 files changed, 26 insertions, 48 deletions

diff --git a/embed.fnc b/embed.fnc
index dfe412daa1..737fc09149 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1403,7 +1403,8 @@ s	|COP*	|closest_cop	|NN COP *cop|NULLOK const OP *o
 s	|SV*	|mess_alloc
 s	|const char *|vdie_croak_common|NULLOK const char *pat|NULLOK va_list *args \
 				|NULLOK STRLEN *msglen|NULLOK I32* utf8
-s	|void	|vdie_common	|NULLOK const char *message|STRLEN msglen|I32 utf8
+s	|bool	|vdie_common	|NULLOK const char *message|STRLEN msglen\
+				|I32 utf8|bool warn
 sr	|char *	|write_no_mem
 #endif
 
diff --git a/embed.h b/embed.h
index 88804deb60..a8867d8a32 100644
--- a/embed.h
+++ b/embed.h
@@ -3476,7 +3476,7 @@
 #define closest_cop(a,b)	S_closest_cop(aTHX_ a,b)
 #define mess_alloc()		S_mess_alloc(aTHX)
 #define vdie_croak_common(a,b,c,d)	S_vdie_croak_common(aTHX_ a,b,c,d)
-#define vdie_common(a,b,c)	S_vdie_common(aTHX_ a,b,c)
+#define vdie_common(a,b,c,d)	S_vdie_common(aTHX_ a,b,c,d)
 #define write_no_mem()		S_write_no_mem(aTHX)
 #endif
 #endif
diff --git a/proto.h b/proto.h
index d94b93a131..2a7c6d8ae0 100644
--- a/proto.h
+++ b/proto.h
@@ -3881,7 +3881,7 @@ STATIC COP*	S_closest_cop(pTHX_ COP *cop, const OP *o)
 
 STATIC SV*	S_mess_alloc(pTHX);
 STATIC const char *	S_vdie_croak_common(pTHX_ const char *pat, va_list *args, STRLEN *msglen, I32* utf8);
-STATIC void	S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8);
+STATIC bool	S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn);
 STATIC char *	S_write_no_mem(pTHX)
 			__attribute__noreturn__;
 
diff --git a/util.c b/util.c
index 2859a47413..5560fc8a61 100644
--- a/util.c
+++ b/util.c
@@ -1130,23 +1130,25 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen)
     }
 }
 
-/* Common code used by vcroak, vdie and vwarner  */
+/* Common code used by vcroak, vdie, vwarn and vwarner  */
 
-STATIC void
-S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8)
+STATIC bool
+S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn)
 {
     dVAR;
     HV *stash;
     GV *gv;
     CV *cv;
-    /* sv_2cv might call Perl_croak() */
-    SV * const olddiehook = PL_diehook;
+    SV **const hook = warn ? &PL_warnhook : &PL_diehook;
+    /* sv_2cv might call Perl_croak() or Perl_warner() */
+    SV * const oldhook = *hook;
+
+    assert(oldhook);
 
-    assert(PL_diehook);
     ENTER;
-    SAVESPTR(PL_diehook);
-    PL_diehook = Nullsv;
-    cv = sv_2cv(olddiehook, &stash, &gv, 0);
+    SAVESPTR(*hook);
+    *hook = NULL;
+    cv = sv_2cv(oldhook, &stash, &gv, 0);
     LEAVE;
     if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
 	dSP;
@@ -1154,7 +1156,11 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8)
 
 	ENTER;
 	save_re_context();
-	if (message) {
+	if (warn) {
+	    SAVESPTR(*hook);
+	    *hook = NULL;
+	}
+	if (warn || message) {
 	    msg = newSVpvn(message, msglen);
 	    SvFLAGS(msg) |= utf8;
 	    SvREADONLY_on(msg);
@@ -1164,14 +1170,16 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8)
 	    msg = ERRSV;
 	}
 
-	PUSHSTACKi(PERLSI_DIEHOOK);
+	PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
 	PUSHMARK(SP);
 	XPUSHs(msg);
 	PUTBACK;
 	call_sv((SV*)cv, G_DISCARD);
 	POPSTACK;
 	LEAVE;
+	return TRUE;
     }
+    return FALSE;
 }
 
 STATIC const char *
@@ -1200,7 +1208,7 @@ S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen,
 			  "%p: die/croak: message = %s\ndiehook = %p\n",
 			  thr, message, PL_diehook));
     if (PL_diehook) {
-	S_vdie_common(aTHX_ message, *msglen, *utf8);
+	S_vdie_common(aTHX_ message, *msglen, *utf8, FALSE);
     }
     return message;
 }
@@ -1330,39 +1338,8 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args)
     const char * const message = SvPV_const(msv, msglen);
 
     if (PL_warnhook) {
-	/* sv_2cv might call Perl_warn() */
-	SV * const oldwarnhook = PL_warnhook;
-	CV * cv;
-	HV * stash;
-	GV * gv;
-
-	ENTER;
-	SAVESPTR(PL_warnhook);
-	PL_warnhook = Nullsv;
-	cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
-	LEAVE;
-	if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
-	    dSP;
-	    SV *msg;
-
-	    ENTER;
-	    SAVESPTR(PL_warnhook);
-	    PL_warnhook = Nullsv;
-	    save_re_context();
-	    msg = newSVpvn(message, msglen);
-	    SvFLAGS(msg) |= utf8;
-	    SvREADONLY_on(msg);
-	    SAVEFREESV(msg);
-
-	    PUSHSTACKi(PERLSI_WARNHOOK);
-	    PUSHMARK(SP);
-	    XPUSHs(msg);
-	    PUTBACK;
-	    call_sv((SV*)cv, G_DISCARD);
-	    POPSTACK;
-	    LEAVE;
+	if (vdie_common(message, msglen, utf8, TRUE))
 	    return;
-	}
     }
 
     write_to_stderr(message, msglen);
@@ -1431,7 +1408,7 @@ Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
 
 	if (PL_diehook) {
 	    assert(message);
-	    S_vdie_common(aTHX_ message, msglen, utf8);
+	    S_vdie_common(aTHX_ message, msglen, utf8, FALSE);
 	}
 	if (PL_in_eval) {
 	    PL_restartop = die_where(message, msglen);