From: Zefram <zefram@fysh.org>
Date: Fri, 23 Apr 2010 00:52:47 +0000 (+0100)
Subject: SV-based interfaces for dieing and warning
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c5df3096702d4a814b3774dff243e7eb74814257;p=p5sagit%2Fp5-mst-13.2.git

SV-based interfaces for dieing and warning

New functions croak_sv(), die_sv(), mess_sv(), and warn_sv(), each act
much like their _sv-less counterparts, but take a single SV argument
instead of sprintf-like format and args.  They will accept RVs, passing
them through as such.  This means there's no more need to clobber ERRSV
in order to throw a structured exception.

pp_warn() and pp_die() are rewritten to use the _sv interfaces.
This fixes part of [perl #74538].  It also means that a structured
warning object will be passed through to $SIG{__WARN__} instead of
being stringified, thus bringing warn in line with die with respect to
structured exception objects.

The new functions and their existing counterparts are all fully
documented.
---

diff --git a/MANIFEST b/MANIFEST
index 6ae1626..62e5587 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -4513,6 +4513,7 @@ t/op/utftaint.t			See if utf8 and taint work together
 t/op/vec.t			See if vectors work
 t/op/ver.t			See if v-strings and the %v format flag work
 t/op/wantarray.t		See if wantarray works
+t/op/warn.t			See if warn works
 t/op/while_readdir.t		See if while(readdir) works
 t/op/write.t			See if write works (formats work)
 t/op/yadayada.t			See if ... works
diff --git a/embed.fnc b/embed.fnc
index f93d27c..1c1bb2d 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -230,9 +230,10 @@ ApR	|I32	|my_chsize	|int fd|Off_t length
 pR	|OP*	|convert	|I32 optype|I32 flags|NULLOK OP* o
 : Used in op.c and perl.c
 pM	|PERL_CONTEXT*	|create_eval_scope|U32 flags
+Aprd	|void	|croak_sv	|NN SV *baseex
 : croak()'s first parm can be NULL.  Otherwise, mod_perl breaks.
 Afprd	|void	|croak		|NULLOK const char* pat|...
-Apr	|void	|vcroak		|NULLOK const char* pat|NULLOK va_list* args
+Aprd	|void	|vcroak		|NULLOK const char* pat|NULLOK va_list* args
 Aprd	|void	|croak_xs_usage	|NN const CV *const cv \
 				|NN const char *const params
 
@@ -286,12 +287,10 @@ Anp	|char*	|delimcpy	|NN char* to|NN const char* toend|NN const char* from \
 				|NN const char* fromend|int delim|NN I32* retlen
 : Used in op.c, perl.c
 pM	|void	|delete_eval_scope
-Afp	|OP*	|die		|NULLOK const char* pat|...
-#if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT)
-s	|OP*	|vdie		|NULLOK const char* pat|NULLOK va_list* args
-#endif
+Apd	|OP*	|die_sv		|NN SV *baseex
+Afpd	|OP*	|die		|NULLOK const char* pat|...
 : Used in util.c
-pr	|void	|die_where	|NULLOK SV* msv
+pr	|void	|die_unwind	|NN SV* ex
 Ap	|void	|dounwind	|I32 cxix
 : FIXME
 pmb	|bool	|do_aexec	|NULLOK SV* really|NN SV** mark|NN SV** sp
@@ -687,8 +686,9 @@ p	|int	|magic_setcollxfrm|NN SV* sv|NN MAGIC* mg
 : Defined in locale.c, used only in sv.c
 p	|char*	|mem_collxfrm	|NN const char* s|STRLEN len|NN STRLEN* xlen
 #endif
-Afp	|SV*	|mess		|NN const char* pat|...
-Ap	|SV*	|vmess		|NN const char* pat|NULLOK va_list* args
+Afpd	|SV*	|mess		|NN const char* pat|...
+Apd	|SV*	|mess_sv	|NN SV* basemsg|bool consume
+Apd	|SV*	|vmess		|NN const char* pat|NULLOK va_list* args
 : FIXME - either make it public, or stop exporting it. (Data::Alias uses this)
 : Used in gv.c, op.c, toke.c
 EXp	|void	|qerror		|NN SV* err
@@ -1285,8 +1285,9 @@ pR	|UV	|get_hash_seed
 p	|void	|report_evil_fh	|NULLOK const GV *gv|NULLOK const IO *io|I32 op
 : Used in mg.c, pp.c, pp_hot.c, regcomp.c
 XEpd	|void	|report_uninit	|NULLOK const SV *uninit_sv
+Apd	|void	|warn_sv	|NN SV *baseex
 Afpd	|void	|warn		|NN const char* pat|...
-Ap	|void	|vwarn		|NN const char* pat|NULLOK va_list* args
+Apd	|void	|vwarn		|NN const char* pat|NULLOK va_list* args
 Afp	|void	|warner		|U32 err|NN const char* pat|...
 Afp	|void	|ck_warner	|U32 err|NN const char* pat|...
 Afp	|void	|ck_warner_d	|U32 err|NN const char* pat|...
@@ -1952,8 +1953,8 @@ s	|char*	|stdize_locale	|NN char* locs
 #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT)
 s	|const COP*|closest_cop	|NN const COP *cop|NULLOK const OP *o
 s	|SV*	|mess_alloc
-s	|SV *|vdie_croak_common|NULLOK const char *pat|NULLOK va_list *args
-s	|bool	|vdie_common	|NULLOK SV *message|bool warn
+s	|SV *|with_queued_errors|NN SV *ex
+s	|bool	|invoke_exception_hook|NULLOK SV *ex|bool warn
 sr	|char *	|write_no_mem
 #if defined(PERL_MEM_LOG) && !defined(PERL_MEM_LOG_NOIMPL)
 sn	|void	|mem_log_common	|enum mem_log_type mlt|const UV n|const UV typesize \
diff --git a/embed.h b/embed.h
index 663cb6b..128cd467 100644
--- a/embed.h
+++ b/embed.h
@@ -102,6 +102,7 @@
 #define convert			Perl_convert
 #define create_eval_scope	Perl_create_eval_scope
 #endif
+#define croak_sv		Perl_croak_sv
 #define croak			Perl_croak
 #define vcroak			Perl_vcroak
 #define croak_xs_usage		Perl_croak_xs_usage
@@ -154,14 +155,10 @@
 #ifdef PERL_CORE
 #define delete_eval_scope	Perl_delete_eval_scope
 #endif
+#define die_sv			Perl_die_sv
 #define die			Perl_die
-#if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT)
-#ifdef PERL_CORE
-#define vdie			S_vdie
-#endif
-#endif
 #ifdef PERL_CORE
-#define die_where		Perl_die_where
+#define die_unwind		Perl_die_unwind
 #endif
 #define dounwind		Perl_dounwind
 #ifdef PERL_CORE
@@ -520,6 +517,7 @@
 #endif
 #endif
 #define mess			Perl_mess
+#define mess_sv			Perl_mess_sv
 #define vmess			Perl_vmess
 #if defined(PERL_CORE) || defined(PERL_EXT)
 #define qerror			Perl_qerror
@@ -1072,6 +1070,7 @@
 #if defined(PERL_CORE) || defined(PERL_EXT)
 #define report_uninit		Perl_report_uninit
 #endif
+#define warn_sv			Perl_warn_sv
 #define warn			Perl_warn
 #define vwarn			Perl_vwarn
 #define warner			Perl_warner
@@ -1673,8 +1672,8 @@
 #ifdef PERL_CORE
 #define closest_cop		S_closest_cop
 #define mess_alloc		S_mess_alloc
-#define vdie_croak_common	S_vdie_croak_common
-#define vdie_common		S_vdie_common
+#define with_queued_errors	S_with_queued_errors
+#define invoke_exception_hook	S_invoke_exception_hook
 #define write_no_mem		S_write_no_mem
 #endif
 #if defined(PERL_MEM_LOG) && !defined(PERL_MEM_LOG_NOIMPL)
@@ -2519,6 +2518,7 @@
 #define convert(a,b,c)		Perl_convert(aTHX_ a,b,c)
 #define create_eval_scope(a)	Perl_create_eval_scope(aTHX_ a)
 #endif
+#define croak_sv(a)		Perl_croak_sv(aTHX_ a)
 #define vcroak(a,b)		Perl_vcroak(aTHX_ a,b)
 #define croak_xs_usage(a,b)	Perl_croak_xs_usage(aTHX_ a,b)
 #if defined(PERL_IMPLICIT_CONTEXT)
@@ -2554,13 +2554,9 @@
 #ifdef PERL_CORE
 #define delete_eval_scope()	Perl_delete_eval_scope(aTHX)
 #endif
-#if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT)
-#ifdef PERL_CORE
-#define vdie(a,b)		S_vdie(aTHX_ a,b)
-#endif
-#endif
+#define die_sv(a)		Perl_die_sv(aTHX_ a)
 #ifdef PERL_CORE
-#define die_where(a)		Perl_die_where(aTHX_ a)
+#define die_unwind(a)		Perl_die_unwind(aTHX_ a)
 #endif
 #define dounwind(a)		Perl_dounwind(aTHX_ a)
 #ifdef PERL_CORE
@@ -2930,6 +2926,7 @@
 #define mem_collxfrm(a,b,c)	Perl_mem_collxfrm(aTHX_ a,b,c)
 #endif
 #endif
+#define mess_sv(a,b)		Perl_mess_sv(aTHX_ a,b)
 #define vmess(a,b)		Perl_vmess(aTHX_ a,b)
 #if defined(PERL_CORE) || defined(PERL_EXT)
 #define qerror(a)		Perl_qerror(aTHX_ a)
@@ -3482,6 +3479,7 @@
 #if defined(PERL_CORE) || defined(PERL_EXT)
 #define report_uninit(a)	Perl_report_uninit(aTHX_ a)
 #endif
+#define warn_sv(a)		Perl_warn_sv(aTHX_ a)
 #define vwarn(a,b)		Perl_vwarn(aTHX_ a,b)
 #define vwarner(a,b,c)		Perl_vwarner(aTHX_ a,b,c)
 #ifdef PERL_CORE
@@ -4089,8 +4087,8 @@
 #ifdef PERL_CORE
 #define closest_cop(a,b)	S_closest_cop(aTHX_ a,b)
 #define mess_alloc()		S_mess_alloc(aTHX)
-#define vdie_croak_common(a,b)	S_vdie_croak_common(aTHX_ a,b)
-#define vdie_common(a,b)	S_vdie_common(aTHX_ a,b)
+#define with_queued_errors(a)	S_with_queued_errors(aTHX_ a)
+#define invoke_exception_hook(a,b)	S_invoke_exception_hook(aTHX_ a,b)
 #define write_no_mem()		S_write_no_mem(aTHX)
 #endif
 #if defined(PERL_MEM_LOG) && !defined(PERL_MEM_LOG_NOIMPL)
diff --git a/global.sym b/global.sym
index 7788338..334e2c9 100644
--- a/global.sym
+++ b/global.sym
@@ -60,6 +60,7 @@ Perl_cast_i32
 Perl_cast_iv
 Perl_cast_uv
 Perl_my_chsize
+Perl_croak_sv
 Perl_croak
 Perl_vcroak
 Perl_croak_xs_usage
@@ -96,6 +97,7 @@ Perl_debop
 Perl_debstack
 Perl_debstackptrs
 Perl_delimcpy
+Perl_die_sv
 Perl_die
 Perl_dounwind
 Perl_do_aexec
@@ -280,6 +282,7 @@ Perl_grok_numeric_radix
 Perl_grok_oct
 Perl_markstack_grow
 Perl_mess
+Perl_mess_sv
 Perl_vmess
 Perl_qerror
 Perl_sortsv
@@ -639,6 +642,7 @@ Perl_sv_uni_display
 Perl_vivify_defelem
 Perl_seed
 Perl_report_uninit
+Perl_warn_sv
 Perl_warn
 Perl_vwarn
 Perl_warner
diff --git a/mg.c b/mg.c
index 0341f6e..abe3e60 100644
--- a/mg.c
+++ b/mg.c
@@ -2988,7 +2988,7 @@ Perl_sighandler(int sig)
 	(void)rsignal(sig, PL_csighandlerp);
 #endif
 #endif /* !PERL_MICRO */
-	Perl_die(aTHX_ NULL);
+	die_sv(ERRSV);
     }
 cleanup:
     if (flags & 1)
diff --git a/pp_ctl.c b/pp_ctl.c
index 921688d..f401fc7 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1572,11 +1572,12 @@ Perl_qerror(pTHX_ SV *err)
 }
 
 void
-Perl_die_where(pTHX_ SV *msv)
+Perl_die_unwind(pTHX_ SV *msv)
 {
     dVAR;
-    SV *exceptsv = sv_mortalcopy(msv ? msv : ERRSV);
+    SV *exceptsv = sv_mortalcopy(msv);
     U8 in_eval = PL_in_eval;
+    PERL_ARGS_ASSERT_DIE_UNWIND;
 
     if (in_eval) {
 	I32 cxix;
@@ -1631,7 +1632,7 @@ Perl_die_where(pTHX_ SV *msv)
 		DIE(aTHX_ "%sCompilation failed in require",
 		    *msg ? msg : "Unknown error\n");
 	    }
-	    if ((in_eval & EVAL_KEEPERR) && msv) {
+	    if (in_eval & EVAL_KEEPERR) {
                 static const char prefix[] = "\t(in cleanup) ";
 		SV * const err = ERRSV;
 		const char *e = NULL;
@@ -2879,7 +2880,7 @@ S_docatch(pTHX_ OP *o)
 	/* die caught by an inner eval - continue inner loop */
 
 	/* NB XXX we rely on the old popped CxEVAL still being at the top
-	 * of the stack; the way die_where() currently works, this
+	 * of the stack; the way die_unwind() currently works, this
 	 * assumption is valid. In theory The cur_top_env value should be
 	 * returned in another global, the way retop (aka PL_restartop)
 	 * is. */
@@ -3925,7 +3926,7 @@ PP(pp_leaveeval)
 	SV * const nsv = cx->blk_eval.old_namesv;
 	(void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
 	retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
-	/* die_where() did LEAVE, or we won't be here */
+	/* die_unwind() did LEAVE, or we won't be here */
     }
     else {
 	LEAVE_with_name("eval");
diff --git a/pp_sys.c b/pp_sys.c
index 8dd8bc0..f57bd1a 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -403,100 +403,91 @@ PP(pp_rcatline)
 PP(pp_warn)
 {
     dVAR; dSP; dMARK;
-    SV *tmpsv;
-    const char *tmps;
+    SV *exsv;
+    const char *pv;
     STRLEN len;
     if (SP - MARK > 1) {
 	dTARGET;
 	do_join(TARG, &PL_sv_no, MARK, SP);
-	tmpsv = TARG;
+	exsv = TARG;
 	SP = MARK + 1;
     }
     else if (SP == MARK) {
-	tmpsv = &PL_sv_no;
+	exsv = &PL_sv_no;
 	EXTEND(SP, 1);
 	SP = MARK + 1;
     }
     else {
-	tmpsv = TOPs;
-    }
-    tmps = SvPV_const(tmpsv, len);
-    if ((!tmps || !len) && PL_errgv) {
-  	SV * const error = ERRSV;
-	SvUPGRADE(error, SVt_PV);
-	if (SvPOK(error) && SvCUR(error))
-	    sv_catpvs(error, "\t...caught");
-	tmpsv = error;
-	tmps = SvPV_const(tmpsv, len);
+	exsv = TOPs;
     }
-    if (!tmps || !len)
-	tmpsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP);
 
-    Perl_warn(aTHX_ "%"SVf, SVfARG(tmpsv));
+    if (SvROK(exsv) || (pv = SvPV_const(exsv, len), len)) {
+	/* well-formed exception supplied */
+    }
+    else if (SvROK(ERRSV)) {
+	exsv = ERRSV;
+    }
+    else if (SvPOK(ERRSV) && SvCUR(ERRSV)) {
+	exsv = sv_mortalcopy(ERRSV);
+	sv_catpvs(exsv, "\t...caught");
+    }
+    else {
+	exsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP);
+    }
+    warn_sv(exsv);
     RETSETYES;
 }
 
 PP(pp_die)
 {
     dVAR; dSP; dMARK;
-    const char *tmps;
-    SV *tmpsv;
+    SV *exsv;
+    const char *pv;
     STRLEN len;
-    bool multiarg = 0;
 #ifdef VMS
     VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
 #endif
     if (SP - MARK != 1) {
 	dTARGET;
 	do_join(TARG, &PL_sv_no, MARK, SP);
-	tmpsv = TARG;
-	tmps = SvPV_const(tmpsv, len);
-	multiarg = 1;
+	exsv = TARG;
 	SP = MARK + 1;
     }
     else {
-	tmpsv = TOPs;
-        tmps = SvROK(tmpsv) ? (const char *)NULL : SvPV_const(tmpsv, len);
-    }
-    if (!tmps || !len) {
-	SV * const error = ERRSV;
-	SvUPGRADE(error, SVt_PV);
-	if (multiarg ? SvROK(error) : SvROK(tmpsv)) {
-	    if (!multiarg)
-		SvSetSV(error,tmpsv);
-	    else if (sv_isobject(error)) {
-		HV * const stash = SvSTASH(SvRV(error));
-		GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
-		if (gv) {
-		    SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
-		    SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
-		    EXTEND(SP, 3);
-		    PUSHMARK(SP);
-		    PUSHs(error);
-		    PUSHs(file);
- 		    PUSHs(line);
-		    PUTBACK;
-		    call_sv(MUTABLE_SV(GvCV(gv)),
-			    G_SCALAR|G_EVAL|G_KEEPERR);
-		    sv_setsv(error,*PL_stack_sp--);
-		}
+	exsv = TOPs;
+    }
+
+    if (SvROK(exsv) || (pv = SvPV_const(exsv, len), len)) {
+	/* well-formed exception supplied */
+    }
+    else if (SvROK(ERRSV)) {
+	exsv = ERRSV;
+	if (sv_isobject(exsv)) {
+	    HV * const stash = SvSTASH(SvRV(exsv));
+	    GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
+	    if (gv) {
+		SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
+		SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
+		EXTEND(SP, 3);
+		PUSHMARK(SP);
+		PUSHs(exsv);
+		PUSHs(file);
+		PUSHs(line);
+		PUTBACK;
+		call_sv(MUTABLE_SV(GvCV(gv)),
+			G_SCALAR|G_EVAL|G_KEEPERR);
+		exsv = sv_mortalcopy(*PL_stack_sp--);
 	    }
-	    DIE(aTHX_ NULL);
-	}
-	else {
-	    if (SvPOK(error) && SvCUR(error))
-		sv_catpvs(error, "\t...propagated");
-	    tmpsv = error;
-	    if (SvOK(tmpsv))
-		tmps = SvPV_const(tmpsv, len);
-	    else
-		tmps = NULL;
 	}
     }
-    if (!tmps || !len)
-	tmpsv = newSVpvs_flags("Died", SVs_TEMP);
-
-    DIE(aTHX_ "%"SVf, SVfARG(tmpsv));
+    else if (SvPOK(ERRSV) && SvCUR(ERRSV)) {
+	exsv = sv_mortalcopy(ERRSV);
+	sv_catpvs(exsv, "\t...propagated");
+    }
+    else {
+	exsv = newSVpvs_flags("Died", SVs_TEMP);
+    }
+    die_sv(exsv);
     RETURN;
 }
 
diff --git a/proto.h b/proto.h
index 979076f..71240e5 100644
--- a/proto.h
+++ b/proto.h
@@ -321,6 +321,12 @@ PERL_CALLCONV OP*	Perl_convert(pTHX_ I32 optype, I32 flags, OP* o)
 			__attribute__warn_unused_result__;
 
 PERL_CALLCONV PERL_CONTEXT*	Perl_create_eval_scope(pTHX_ U32 flags);
+PERL_CALLCONV void	Perl_croak_sv(pTHX_ SV *baseex)
+			__attribute__noreturn__
+			__attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CROAK_SV	\
+	assert(baseex)
+
 PERL_CALLCONV void	Perl_croak(pTHX_ const char* pat, ...)
 			__attribute__noreturn__
 			__attribute__format__null_ok__(__printf__,pTHX_1,pTHX_2);
@@ -523,14 +529,19 @@ PERL_CALLCONV char*	Perl_delimcpy(char* to, const char* toend, const char* from,
 	assert(to); assert(toend); assert(from); assert(fromend); assert(retlen)
 
 PERL_CALLCONV void	Perl_delete_eval_scope(pTHX);
+PERL_CALLCONV OP*	Perl_die_sv(pTHX_ SV *baseex)
+			__attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DIE_SV	\
+	assert(baseex)
+
 PERL_CALLCONV OP*	Perl_die(pTHX_ const char* pat, ...)
 			__attribute__format__null_ok__(__printf__,pTHX_1,pTHX_2);
 
-#if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT)
-STATIC OP*	S_vdie(pTHX_ const char* pat, va_list* args);
-#endif
-PERL_CALLCONV void	Perl_die_where(pTHX_ SV* msv)
-			__attribute__noreturn__;
+PERL_CALLCONV void	Perl_die_unwind(pTHX_ SV* ex)
+			__attribute__noreturn__
+			__attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DIE_UNWIND	\
+	assert(ex)
 
 PERL_CALLCONV void	Perl_dounwind(pTHX_ I32 cxix);
 /* PERL_CALLCONV bool	Perl_do_aexec(pTHX_ SV* really, SV** mark, SV** sp)
@@ -1922,6 +1933,11 @@ PERL_CALLCONV SV*	Perl_mess(pTHX_ const char* pat, ...)
 #define PERL_ARGS_ASSERT_MESS	\
 	assert(pat)
 
+PERL_CALLCONV SV*	Perl_mess_sv(pTHX_ SV* basemsg, bool consume)
+			__attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_MESS_SV	\
+	assert(basemsg)
+
 PERL_CALLCONV SV*	Perl_vmess(pTHX_ const char* pat, va_list* args)
 			__attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_VMESS	\
@@ -3821,6 +3837,11 @@ PERL_CALLCONV UV	Perl_get_hash_seed(pTHX)
 
 PERL_CALLCONV void	Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op);
 PERL_CALLCONV void	Perl_report_uninit(pTHX_ const SV *uninit_sv);
+PERL_CALLCONV void	Perl_warn_sv(pTHX_ SV *baseex)
+			__attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_WARN_SV	\
+	assert(baseex)
+
 PERL_CALLCONV void	Perl_warn(pTHX_ const char* pat, ...)
 			__attribute__format__(__printf__,pTHX_1,pTHX_2)
 			__attribute__nonnull__(pTHX_1);
@@ -6050,8 +6071,12 @@ STATIC const COP*	S_closest_cop(pTHX_ const COP *cop, const OP *o)
 	assert(cop)
 
 STATIC SV*	S_mess_alloc(pTHX);
-STATIC SV *	S_vdie_croak_common(pTHX_ const char *pat, va_list *args);
-STATIC bool	S_vdie_common(pTHX_ SV *message, bool warn);
+STATIC SV *	S_with_queued_errors(pTHX_ SV *ex)
+			__attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS	\
+	assert(ex)
+
+STATIC bool	S_invoke_exception_hook(pTHX_ SV *ex, bool warn);
 STATIC char *	S_write_no_mem(pTHX)
 			__attribute__noreturn__;
 
diff --git a/t/op/warn.t b/t/op/warn.t
new file mode 100644
index 0000000..ec3b9ca
--- /dev/null
+++ b/t/op/warn.t
@@ -0,0 +1,108 @@
+#!./perl
+#line 3 warn.t
+
+print "1..18\n";
+my $test_num = 0;
+sub ok {
+    print $_[0] ? "" : "not ", "ok ", ++$test_num, "\n";
+}
+
+my @warnings;
+my $wa = []; my $ea = [];
+$SIG{__WARN__} = sub { push @warnings, $_[0] };
+
+@warnings = ();
+$@ = "";
+warn "foo\n";
+ok @warnings==1 && $warnings[0] eq "foo\n";
+
+@warnings = ();
+$@ = "";
+warn "foo", "bar\n";
+ok @warnings==1 && $warnings[0] eq "foobar\n";
+
+@warnings = ();
+$@ = "";
+warn "foo";
+ok @warnings==1 && $warnings[0] eq "foo at warn.t line 26.\n";
+
+@warnings = ();
+$@ = "";
+warn $wa;
+ok @warnings==1 && ref($warnings[0]) eq "ARRAY" && $warnings[0] == $wa;
+
+@warnings = ();
+$@ = "";
+warn "";
+ok @warnings==1 &&
+    $warnings[0] eq "Warning: something's wrong at warn.t line 36.\n";
+
+@warnings = ();
+$@ = "";
+warn;
+ok @warnings==1 &&
+    $warnings[0] eq "Warning: something's wrong at warn.t line 42.\n";
+
+@warnings = ();
+$@ = "ERR\n";
+warn "foo\n";
+ok @warnings==1 && $warnings[0] eq "foo\n";
+
+@warnings = ();
+$@ = "ERR\n";
+warn "foo", "bar\n";
+ok @warnings==1 && $warnings[0] eq "foobar\n";
+
+@warnings = ();
+$@ = "ERR\n";
+warn "foo";
+ok @warnings==1 && $warnings[0] eq "foo at warn.t line 58.\n";
+
+@warnings = ();
+$@ = "ERR\n";
+warn $wa;
+ok @warnings==1 && ref($warnings[0]) eq "ARRAY" && $warnings[0] == $wa;
+
+@warnings = ();
+$@ = "ERR\n";
+warn "";
+ok @warnings==1 &&
+    $warnings[0] eq "ERR\n\t...caught at warn.t line 68.\n";
+
+@warnings = ();
+$@ = "ERR\n";
+warn;
+ok @warnings==1 &&
+    $warnings[0] eq "ERR\n\t...caught at warn.t line 74.\n";
+
+@warnings = ();
+$@ = $ea;
+warn "foo\n";
+ok @warnings==1 && $warnings[0] eq "foo\n";
+
+@warnings = ();
+$@ = $ea;
+warn "foo", "bar\n";
+ok @warnings==1 && $warnings[0] eq "foobar\n";
+
+@warnings = ();
+$@ = $ea;
+warn "foo";
+ok @warnings==1 && $warnings[0] eq "foo at warn.t line 90.\n";
+
+@warnings = ();
+$@ = $ea;
+warn $wa;
+ok @warnings==1 && ref($warnings[0]) eq "ARRAY" && $warnings[0] == $wa;
+
+@warnings = ();
+$@ = $ea;
+warn "";
+ok @warnings==1 && ref($warnings[0]) eq "ARRAY" && $warnings[0] == $ea;
+
+@warnings = ();
+$@ = $ea;
+warn;
+ok @warnings==1 && ref($warnings[0]) eq "ARRAY" && $warnings[0] == $ea;
+
+1;
diff --git a/util.c b/util.c
index 89fea23..99a9511 100644
--- a/util.c
+++ b/util.c
@@ -1124,6 +1124,21 @@ Perl_vform(pTHX_ const char *pat, va_list *args)
     return SvPVX(sv);
 }
 
+/*
+=for apidoc Am|SV *|mess|const char *pat|...
+
+Take a sprintf-style format pattern and argument list.  These are used to
+generate a string message.  If the message does not end with a newline,
+then it will be extended with some indication of the current location
+in the code, as described for L</mess_sv>.
+
+Normally, the resulting message is returned in a new mortal SV.
+During global destruction a single SV may be shared between uses of
+this function.
+
+=cut
+*/
+
 #if defined(PERL_IMPLICIT_CONTEXT)
 SV *
 Perl_mess_nocontext(const char *pat, ...)
@@ -1186,15 +1201,57 @@ S_closest_cop(pTHX_ const COP *cop, const OP *o)
     return NULL;
 }
 
+/*
+=for apidoc Am|SV *|mess_sv|SV *basemsg|bool consume
+
+Expands a message, intended for the user, to include an indication of
+the current location in the code, if the message does not already appear
+to be complete.
+
+C<basemsg> is the initial message or object.  If it is a reference, it
+will be used as-is and will be the result of this function.  Otherwise it
+is used as a string, and if it already ends with a newline, it is taken
+to be complete, and the result of this function will be the same string.
+If the message does not end with a newline, then a segment such as C<at
+foo.pl line 37> will be appended, and possibly other clauses indicating
+the current state of execution.  The resulting message will end with a
+dot and a newline.
+
+Normally, the resulting message is returned in a new mortal SV.
+During global destruction a single SV may be shared between uses of this
+function.  If C<consume> is true, then the function is permitted (but not
+required) to modify and return C<basemsg> instead of allocating a new SV.
+
+=cut
+*/
+
 SV *
-Perl_vmess(pTHX_ const char *pat, va_list *args)
+Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
 {
     dVAR;
-    SV * const sv = mess_alloc();
+    SV *sv;
 
-    PERL_ARGS_ASSERT_VMESS;
+    PERL_ARGS_ASSERT_MESS_SV;
+
+    if (SvROK(basemsg)) {
+	if (consume) {
+	    sv = basemsg;
+	}
+	else {
+	    sv = mess_alloc();
+	    sv_setsv(sv, basemsg);
+	}
+	return sv;
+    }
+
+    if (SvPOK(basemsg) && consume) {
+	sv = basemsg;
+    }
+    else {
+	sv = mess_alloc();
+	sv_copypv(sv, basemsg);
+    }
 
-    sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
     if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
 	/*
 	 * Try and find the file and line for PL_op.  This will usually be
@@ -1228,6 +1285,34 @@ Perl_vmess(pTHX_ const char *pat, va_list *args)
     return sv;
 }
 
+/*
+=for apidoc Am|SV *|vmess|const char *pat|va_list *args
+
+C<pat> and C<args> are a sprintf-style format pattern and encapsulated
+argument list.  These are used to generate a string message.  If the
+message does not end with a newline, then it will be extended with
+some indication of the current location in the code, as described for
+L</mess_sv>.
+
+Normally, the resulting message is returned in a new mortal SV.
+During global destruction a single SV may be shared between uses of
+this function.
+
+=cut
+*/
+
+SV *
+Perl_vmess(pTHX_ const char *pat, va_list *args)
+{
+    dVAR;
+    SV * const sv = mess_alloc();
+
+    PERL_ARGS_ASSERT_VMESS;
+
+    sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
+    return mess_sv(sv, 1);
+}
+
 void
 Perl_write_to_stderr(pTHX_ SV* msv)
 {
@@ -1279,10 +1364,26 @@ Perl_write_to_stderr(pTHX_ SV* msv)
     }
 }
 
-/* Common code used by vcroak, vdie, vwarn and vwarner  */
+/*
+=head1 Warning and Dieing
+*/
+
+/* Common code used in dieing and warning */
+
+STATIC SV *
+S_with_queued_errors(pTHX_ SV *ex)
+{
+    PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS;
+    if (PL_errors && SvCUR(PL_errors) && !SvROK(ex)) {
+	sv_catsv(PL_errors, ex);
+	ex = sv_mortalcopy(PL_errors);
+	SvCUR_set(PL_errors, 0);
+    }
+    return ex;
+}
 
 STATIC bool
-S_vdie_common(pTHX_ SV *message, bool warn)
+S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
 {
     dVAR;
     HV *stash;
@@ -1292,7 +1393,8 @@ S_vdie_common(pTHX_ SV *message, bool warn)
     /* sv_2cv might call Perl_croak() or Perl_warner() */
     SV * const oldhook = *hook;
 
-    assert(oldhook);
+    if (!oldhook)
+	return FALSE;
 
     ENTER;
     SAVESPTR(*hook);
@@ -1301,7 +1403,7 @@ S_vdie_common(pTHX_ SV *message, bool warn)
     LEAVE;
     if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
 	dSP;
-	SV *msg;
+	SV *exarg;
 
 	ENTER;
 	save_re_context();
@@ -1309,18 +1411,13 @@ S_vdie_common(pTHX_ SV *message, bool warn)
 	    SAVESPTR(*hook);
 	    *hook = NULL;
 	}
-	if (warn || message) {
-	    msg = newSVsv(message);
-	    SvREADONLY_on(msg);
-	    SAVEFREESV(msg);
-	}
-	else {
-	    msg = ERRSV;
-	}
+	exarg = newSVsv(ex);
+	SvREADONLY_on(exarg);
+	SAVEFREESV(exarg);
 
 	PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
 	PUSHMARK(SP);
-	XPUSHs(msg);
+	XPUSHs(exarg);
 	PUTBACK;
 	call_sv(MUTABLE_SV(cv), G_DISCARD);
 	POPSTACK;
@@ -1330,81 +1427,147 @@ S_vdie_common(pTHX_ SV *message, bool warn)
     return FALSE;
 }
 
-STATIC SV *
-S_vdie_croak_common(pTHX_ const char* pat, va_list* args)
-{
-    dVAR;
-    SV *message;
+/*
+=for apidoc Am|OP *|die_sv|SV *baseex
 
-    if (pat) {
-	SV * const msv = vmess(pat, args);
-	if (PL_errors && SvCUR(PL_errors)) {
-	    sv_catsv(PL_errors, msv);
-	    message = sv_mortalcopy(PL_errors);
-	    SvCUR_set(PL_errors, 0);
-	}
-	else
-	    message = msv;
-    }
-    else {
-	message = NULL;
-    }
+Behaves the same as L</croak_sv>, except for the return type.
+It should be used only where the C<OP *> return type is required.
+The function never actually returns.
 
-    if (PL_diehook) {
-	S_vdie_common(aTHX_ message, FALSE);
-    }
-    return message;
-}
+=cut
+*/
 
-static OP *
-S_vdie(pTHX_ const char* pat, va_list *args)
+OP *
+Perl_die_sv(pTHX_ SV *baseex)
 {
-    dVAR;
-    SV *message;
-
-    message = vdie_croak_common(pat, args);
-
-    die_where(message);
+    PERL_ARGS_ASSERT_DIE_SV;
+    croak_sv(baseex);
     /* NOTREACHED */
     return NULL;
 }
 
+/*
+=for apidoc Am|OP *|die|const char *pat|...
+
+Behaves the same as L</croak>, except for the return type.
+It should be used only where the C<OP *> return type is required.
+The function never actually returns.
+
+=cut
+*/
+
 #if defined(PERL_IMPLICIT_CONTEXT)
 OP *
 Perl_die_nocontext(const char* pat, ...)
 {
     dTHX;
-    OP *o;
     va_list args;
     va_start(args, pat);
-    o = vdie(pat, &args);
+    vcroak(pat, &args);
+    /* NOTREACHED */
     va_end(args);
-    return o;
+    return NULL;
 }
 #endif /* PERL_IMPLICIT_CONTEXT */
 
 OP *
 Perl_die(pTHX_ const char* pat, ...)
 {
-    OP *o;
     va_list args;
     va_start(args, pat);
-    o = vdie(pat, &args);
+    vcroak(pat, &args);
+    /* NOTREACHED */
     va_end(args);
-    return o;
+    return NULL;
 }
 
+/*
+=for apidoc Am|void|croak_sv|SV *baseex
+
+This is an XS interface to Perl's C<die> function.
+
+C<baseex> is the error message or object.  If it is a reference, it
+will be used as-is.  Otherwise it is used as a string, and if it does
+not end with a newline then it will be extended with some indication of
+the current location in the code, as described for L</mess_sv>.
+
+The error message or object will be used as an exception, by default
+returning control to the nearest enclosing C<eval>, but subject to
+modification by a C<$SIG{__DIE__}> handler.  In any case, the C<croak_sv>
+function never returns normally.
+
+To die with a simple string message, the L</croak> function may be
+more convenient.
+
+=cut
+*/
+
 void
-Perl_vcroak(pTHX_ const char* pat, va_list *args)
+Perl_croak_sv(pTHX_ SV *baseex)
 {
-    dVAR;
-    SV *msv;
+    SV *ex = with_queued_errors(mess_sv(baseex, 0));
+    PERL_ARGS_ASSERT_CROAK_SV;
+    invoke_exception_hook(ex, FALSE);
+    die_unwind(ex);
+}
+
+/*
+=for apidoc Am|void|vcroak|const char *pat|va_list *args
+
+This is an XS interface to Perl's C<die> function.
+
+C<pat> and C<args> are a sprintf-style format pattern and encapsulated
+argument list.  These are used to generate a string message.  If the
+message does not end with a newline, then it will be extended with
+some indication of the current location in the code, as described for
+L</mess_sv>.
 
-    msv = S_vdie_croak_common(aTHX_ pat, args);
+The error message will be used as an exception, by default
+returning control to the nearest enclosing C<eval>, but subject to
+modification by a C<$SIG{__DIE__}> handler.  In any case, the C<croak>
+function never returns normally.
 
-    die_where(msv);
+For historical reasons, if C<pat> is null then the contents of C<ERRSV>
+(C<$@>) will be used as an error message or object instead of building an
+error message from arguments.  If you want to throw a non-string object,
+or build an error message in an SV yourself, it is preferable to use
+the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
+
+=cut
+*/
+
+void
+Perl_vcroak(pTHX_ const char* pat, va_list *args)
+{
+    SV *ex = with_queued_errors(pat ? vmess(pat, args) : mess_sv(ERRSV, 0));
+    invoke_exception_hook(ex, FALSE);
+    die_unwind(ex);
 }
 
+/*
+=for apidoc Am|void|croak|const char *pat|...
+
+This is an XS interface to Perl's C<die> function.
+
+Take a sprintf-style format pattern and argument list.  These are used to
+generate a string message.  If the message does not end with a newline,
+then it will be extended with some indication of the current location
+in the code, as described for L</mess_sv>.
+
+The error message will be used as an exception, by default
+returning control to the nearest enclosing C<eval>, but subject to
+modification by a C<$SIG{__DIE__}> handler.  In any case, the C<croak>
+function never returns normally.
+
+For historical reasons, if C<pat> is null then the contents of C<ERRSV>
+(C<$@>) will be used as an error message or object instead of building an
+error message from arguments.  If you want to throw a non-string object,
+or build an error message in an SV yourself, it is preferable to use
+the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
+
+=cut
+*/
+
 #if defined(PERL_IMPLICIT_CONTEXT)
 void
 Perl_croak_nocontext(const char *pat, ...)
@@ -1418,51 +1581,89 @@ Perl_croak_nocontext(const char *pat, ...)
 }
 #endif /* PERL_IMPLICIT_CONTEXT */
 
+void
+Perl_croak(pTHX_ const char *pat, ...)
+{
+    va_list args;
+    va_start(args, pat);
+    vcroak(pat, &args);
+    /* NOTREACHED */
+    va_end(args);
+}
+
 /*
-=head1 Warning and Dieing
+=for apidoc Am|void|warn_sv|SV *baseex
 
-=for apidoc croak
+This is an XS interface to Perl's C<warn> function.
 
-This is the XSUB-writer's interface to Perl's C<die> function.
-Normally call this function the same way you call the C C<printf>
-function.  Calling C<croak> returns control directly to Perl,
-sidestepping the normal C order of execution. See C<warn>.
+C<baseex> is the error message or object.  If it is a reference, it
+will be used as-is.  Otherwise it is used as a string, and if it does
+not end with a newline then it will be extended with some indication of
+the current location in the code, as described for L</mess_sv>.
 
-If you want to throw an exception object, assign the object to
-C<$@> and then pass C<NULL> to croak():
+The error message or object will by default be written to standard error,
+but this is subject to modification by a C<$SIG{__WARN__}> handler.
 
-   errsv = get_sv("@", GV_ADD);
-   sv_setsv(errsv, exception_object);
-   croak(NULL);
+To warn with a simple string message, the L</warn> function may be
+more convenient.
 
 =cut
 */
 
 void
-Perl_croak(pTHX_ const char *pat, ...)
+Perl_warn_sv(pTHX_ SV *baseex)
 {
-    va_list args;
-    va_start(args, pat);
-    vcroak(pat, &args);
-    /* NOTREACHED */
-    va_end(args);
+    SV *ex = mess_sv(baseex, 0);
+    PERL_ARGS_ASSERT_WARN_SV;
+    if (!invoke_exception_hook(ex, TRUE))
+	write_to_stderr(ex);
 }
 
+/*
+=for apidoc Am|void|vwarn|const char *pat|va_list *args
+
+This is an XS interface to Perl's C<warn> function.
+
+C<pat> and C<args> are a sprintf-style format pattern and encapsulated
+argument list.  These are used to generate a string message.  If the
+message does not end with a newline, then it will be extended with
+some indication of the current location in the code, as described for
+L</mess_sv>.
+
+The error message or object will by default be written to standard error,
+but this is subject to modification by a C<$SIG{__WARN__}> handler.
+
+Unlike with L</vcroak>, C<pat> is not permitted to be null.
+
+=cut
+*/
+
 void
 Perl_vwarn(pTHX_ const char* pat, va_list *args)
 {
-    dVAR;
-    SV * const msv = vmess(pat, args);
-
+    SV *ex = vmess(pat, args);
     PERL_ARGS_ASSERT_VWARN;
+    if (!invoke_exception_hook(ex, TRUE))
+	write_to_stderr(ex);
+}
 
-    if (PL_warnhook) {
-	if (vdie_common(msv, TRUE))
-	    return;
-    }
+/*
+=for apidoc Am|void|warn|const char *pat|...
 
-    write_to_stderr(msv);
-}
+This is an XS interface to Perl's C<warn> function.
+
+Take a sprintf-style format pattern and argument list.  These are used to
+generate a string message.  If the message does not end with a newline,
+then it will be extended with some indication of the current location
+in the code, as described for L</mess_sv>.
+
+The error message or object will by default be written to standard error,
+but this is subject to modification by a C<$SIG{__WARN__}> handler.
+
+Unlike with L</croak>, C<pat> is not permitted to be null.
+
+=cut
+*/
 
 #if defined(PERL_IMPLICIT_CONTEXT)
 void
@@ -1477,15 +1678,6 @@ Perl_warn_nocontext(const char *pat, ...)
 }
 #endif /* PERL_IMPLICIT_CONTEXT */
 
-/*
-=for apidoc warn
-
-This is the XSUB-writer's interface to Perl's C<warn> function.  Call this
-function the same way you call the C C<printf> function.  See C<croak>.
-
-=cut
-*/
-
 void
 Perl_warn(pTHX_ const char *pat, ...)
 {
@@ -1553,11 +1745,8 @@ Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
     if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
 	SV * const msv = vmess(pat, args);
 
-	if (PL_diehook) {
-	    assert(msv);
-	    S_vdie_common(aTHX_ msv, FALSE);
-	}
-	die_where(msv);
+	invoke_exception_hook(msv, FALSE);
+	die_unwind(msv);
     }
     else {
 	Perl_vwarn(aTHX_ pat, args);