/* ... svt callbacks ....................................................... */
+#define VMG_CB_CALL_SET_RET(D) \
+ { \
+ SV *svr; \
+ SPAGAIN; \
+ svr = POPs; \
+ ret = SvOK(svr) ? SvIV(svr) : (D); \
+ PUTBACK; \
+ }
+
#define VMG_CB_CALL_ARGS_MASK 15
#define VMG_CB_CALL_ARGS_SHIFT 4
#define VMG_CB_CALL_OPINFO (VMG_OP_INFO_NAME|VMG_OP_INFO_OBJECT)
STATIC int vmg_cb_call(pTHX_ SV *cb, SV *sv, SV *data, unsigned int flags, ...){
va_list ap;
- SV *svr;
int ret;
- unsigned int i, args, opinfo, eval;
+ unsigned int i, args, opinfo, eval, has_err = 0;
dSP;
args = flags & VMG_CB_CALL_ARGS_MASK;
flags >>= VMG_CB_CALL_ARGS_SHIFT;
opinfo = flags & VMG_CB_CALL_OPINFO;
- eval = flags & VMG_CB_CALL_EVAL ? G_EVAL : 0;
+ eval = flags & VMG_CB_CALL_EVAL;
ENTER;
SAVETMPS;
XPUSHs(vmg_op_info(opinfo));
PUTBACK;
- call_sv(cb, G_SCALAR | eval);
+ if (!eval) {
+ call_sv(cb, G_SCALAR);
+ } else {
+ unsigned int flags = G_SCALAR | G_EVAL;
+ unsigned int had_err = SvTRUE(ERRSV);
+ if (had_err)
+ flags |= G_KEEPERR;
+ call_sv(cb, flags);
+ has_err = SvTRUE(ERRSV);
+ if (IN_PERL_COMPILETIME && !had_err && has_err)
+ ++PL_error_count;
+ }
- SPAGAIN;
- if (eval && IN_PERL_COMPILETIME && SvTRUE(ERRSV))
- ++PL_error_count;
- svr = POPs;
- ret = SvOK(svr) ? SvIV(svr) : 0;
- PUTBACK;
+ VMG_CB_CALL_SET_RET(0);
FREETMPS;
LEAVE;
+ if (has_err) {
+ /* Get the eval context that was pushed by call_sv, and fake an entry for the
+ * namesv, as die_where will need it to be non NULL later */
+ PERL_CONTEXT *cx = cxstack + cxstack_ix + 1;
+ if (!cx->blk_eval.old_namesv)
+ cx->blk_eval.old_namesv
+ = sv_2mortal(newSVpvn_share("Variable/Magic/DUMMY.pm", 23, 0));
+ }
+
return ret;
}
}
STATIC U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) {
- SV *svr;
const MGWIZ *w = SV2MGWIZ(mg->mg_ptr);
unsigned int opinfo = w->opinfo;
U32 len, ret;
call_sv(w->cb_len, G_SCALAR);
- SPAGAIN;
- svr = POPs;
- ret = SvOK(svr) ? SvUV(svr) : len;
- PUTBACK;
+ VMG_CB_CALL_SET_RET(len);
FREETMPS;
LEAVE;