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
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
|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
: 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
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|...
#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 \
#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
#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
#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
#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
#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)
#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)
#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
#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)
#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
#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)
Perl_cast_iv
Perl_cast_uv
Perl_my_chsize
+Perl_croak_sv
Perl_croak
Perl_vcroak
Perl_croak_xs_usage
Perl_debstack
Perl_debstackptrs
Perl_delimcpy
+Perl_die_sv
Perl_die
Perl_dounwind
Perl_do_aexec
Perl_grok_oct
Perl_markstack_grow
Perl_mess
+Perl_mess_sv
Perl_vmess
Perl_qerror
Perl_sortsv
Perl_vivify_defelem
Perl_seed
Perl_report_uninit
+Perl_warn_sv
Perl_warn
Perl_vwarn
Perl_warner
(void)rsignal(sig, PL_csighandlerp);
#endif
#endif /* !PERL_MICRO */
- Perl_die(aTHX_ NULL);
+ die_sv(ERRSV);
}
cleanup:
if (flags & 1)
}
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;
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;
/* 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. */
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");
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;
}
__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);
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)
#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 \
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);
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__;
--- /dev/null
+#!./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;
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, ...)
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
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)
{
}
}
-/* 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;
/* sv_2cv might call Perl_croak() or Perl_warner() */
SV * const oldhook = *hook;
- assert(oldhook);
+ if (!oldhook)
+ return FALSE;
ENTER;
SAVESPTR(*hook);
LEAVE;
if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
dSP;
- SV *msg;
+ SV *exarg;
ENTER;
save_re_context();
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;
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, ...)
}
#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
}
#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, ...)
{
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);
projects / p5sagit/p5-mst-13.2.git / commitdiff