From c5df3096702d4a814b3774dff243e7eb74814257 Mon Sep 17 00:00:00 2001 From: Zefram Date: Fri, 23 Apr 2010 01:52:47 +0100 Subject: [PATCH] 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. --- MANIFEST | 1 + embed.fnc | 23 ++-- embed.h | 30 +++-- global.sym | 4 + mg.c | 2 +- pp_ctl.c | 11 +- pp_sys.c | 115 +++++++++--------- proto.h | 39 ++++-- t/op/warn.t | 108 +++++++++++++++++ util.c | 387 ++++++++++++++++++++++++++++++++++++++++++++---------------- 10 files changed, 519 insertions(+), 201 deletions(-) create mode 100644 t/op/warn.t 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. + +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 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 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 is true, then the function is permitted (but not +required) to modify and return C 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 and C 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. + +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, except for the return type. +It should be used only where the C 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, except for the return type. +It should be used only where the C 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 function. + +C 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. + +The error message or object will be used as an exception, by default +returning control to the nearest enclosing C, but subject to +modification by a C<$SIG{__DIE__}> handler. In any case, the C +function never returns normally. + +To die with a simple string message, the L 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 function. + +C and C 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. - 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, but subject to +modification by a C<$SIG{__DIE__}> handler. In any case, the C +function never returns normally. - die_where(msv); +For historical reasons, if C is null then the contents of C +(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 function, which does not involve clobbering C. + +=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 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. + +The error message will be used as an exception, by default +returning control to the nearest enclosing C, but subject to +modification by a C<$SIG{__DIE__}> handler. In any case, the C +function never returns normally. + +For historical reasons, if C is null then the contents of C +(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 function, which does not involve clobbering C. + +=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 function. -This is the XSUB-writer's interface to Perl's C function. -Normally call this function the same way you call the C C -function. Calling C returns control directly to Perl, -sidestepping the normal C order of execution. See C. +C 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. -If you want to throw an exception object, assign the object to -C<$@> and then pass C 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 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 function. + +C and C 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. + +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, C 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 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. + +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, C 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 function. Call this -function the same way you call the C C function. See C. - -=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); -- 1.8.3.1