/* ... 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)
-#define VMG_CB_CALL_EVAL 4
-STATIC int vmg_cb_call(pTHX_ SV *cb, SV *sv, SV *data, unsigned int flags, ...){
+STATIC int vmg_cb_call(pTHX_ SV *cb, unsigned int flags, SV *sv, ...) {
va_list ap;
- SV *svr;
int ret;
- unsigned int i, args, opinfo, eval;
+ unsigned int i, args, opinfo;
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;
ENTER;
SAVETMPS;
PUSHMARK(SP);
- EXTEND(SP, args + 2);
+ EXTEND(SP, args + 1);
PUSHs(sv_2mortal(newRV_inc(sv)));
- PUSHs(data ? data : &PL_sv_undef);
- va_start(ap, flags);
+ va_start(ap, sv);
for (i = 0; i < args; ++i) {
SV *sva = va_arg(ap, SV *);
PUSHs(sva ? sva : &PL_sv_undef);
XPUSHs(vmg_op_info(opinfo));
PUTBACK;
- call_sv(cb, G_SCALAR | eval);
+ call_sv(cb, G_SCALAR);
- 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;
return ret;
}
-#define vmg_cb_call1(I, S, D) \
- vmg_cb_call(aTHX_ (I), (S), (D), (flags << VMG_CB_CALL_ARGS_SHIFT))
-#define vmg_cb_call2(I, S, D, S2) \
- vmg_cb_call(aTHX_ (I), (S), (D), ((flags << VMG_CB_CALL_ARGS_SHIFT) | 1), (S2))
-#define vmg_cb_call3(I, S, D, S2, S3) \
- vmg_cb_call(aTHX_ (I), (S), (D), ((flags << VMG_CB_CALL_ARGS_SHIFT) | 2), (S2), (S3))
+#define vmg_cb_call1(I, F, S, A1) \
+ vmg_cb_call(aTHX_ (I), (((F) << VMG_CB_CALL_ARGS_SHIFT) | 1), (S), (A1))
+#define vmg_cb_call2(I, F, S, A1, A2) \
+ vmg_cb_call(aTHX_ (I), (((F) << VMG_CB_CALL_ARGS_SHIFT) | 2), (S), (A1), (A2))
+#define vmg_cb_call3(I, F, S, A1, A2, A3) \
+ vmg_cb_call(aTHX_ (I), (((F) << VMG_CB_CALL_ARGS_SHIFT) | 3), (S), (A1), (A2), (A3))
STATIC int vmg_svt_get(pTHX_ SV *sv, MAGIC *mg) {
const MGWIZ *w = SV2MGWIZ(mg->mg_ptr);
- unsigned int flags = w->opinfo;
- return vmg_cb_call1(w->cb_get, sv, mg->mg_obj);
+ return vmg_cb_call1(w->cb_get, w->opinfo, sv, mg->mg_obj);
}
STATIC int vmg_svt_set(pTHX_ SV *sv, MAGIC *mg) {
const MGWIZ *w = SV2MGWIZ(mg->mg_ptr);
- unsigned int flags = w->opinfo;
- return vmg_cb_call1(w->cb_set, sv, mg->mg_obj);
+ return vmg_cb_call1(w->cb_set, w->opinfo, sv, mg->mg_obj);
}
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;
STATIC int vmg_svt_clear(pTHX_ SV *sv, MAGIC *mg) {
const MGWIZ *w = SV2MGWIZ(mg->mg_ptr);
- unsigned int flags = w->opinfo;
- return vmg_cb_call1(w->cb_clear, sv, mg->mg_obj);
+ return vmg_cb_call1(w->cb_clear, w->opinfo, sv, mg->mg_obj);
}
STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) {
const MGWIZ *w;
- unsigned int flags;
+ unsigned int had_err, has_err, flags = G_SCALAR | G_EVAL;
int ret = 0;
+ dSP;
+
/* Don't even bother if we are in global destruction - the wizard is prisoner
* of circular references and we are way beyond user realm */
if (PL_dirty)
return 0;
w = SV2MGWIZ(mg->mg_ptr);
- flags = w->opinfo | VMG_CB_CALL_EVAL;
- /* So that it survives the temp cleanup in vmg_cb_call */
+ /* So that it survives the temp cleanup below */
SvREFCNT_inc(sv);
#if !VMG_HAS_PERL_MAINT(5, 11, 0, 32686)
SvMAGIC_set(sv, mg);
#endif
- ret = vmg_cb_call1(w->cb_free, sv, mg->mg_obj);
+ ENTER;
+ SAVETMPS;
+
+ PUSHMARK(SP);
+ EXTEND(SP, 2);
+ PUSHs(sv_2mortal(newRV_inc(sv)));
+ PUSHs(mg->mg_obj ? mg->mg_obj : &PL_sv_undef);
+ if (w->opinfo)
+ XPUSHs(vmg_op_info(w->opinfo));
+ PUTBACK;
+
+ had_err = SvTRUE(ERRSV);
+ if (had_err)
+ flags |= G_KEEPERR;
+
+ call_sv(w->cb_free, flags);
+
+ has_err = SvTRUE(ERRSV);
+ if (IN_PERL_COMPILETIME && !had_err && has_err)
+ ++PL_error_count;
+
+ 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));
+ }
/* Calling SvREFCNT_dec() will trigger destructors in an infinite loop, so
* we have to rely on SvREFCNT() being a lvalue. Heck, even the core does it */
) {
SV *keysv;
const MGWIZ *w = SV2MGWIZ(mg->mg_ptr);
- unsigned int flags = w->opinfo;
int ret;
if (keylen == HEf_SVKEY) {
keysv = newSVpvn(key, keylen);
}
- ret = vmg_cb_call3(w->cb_copy, sv, mg->mg_obj, keysv, nsv);
+ ret = vmg_cb_call3(w->cb_copy, w->opinfo, sv, mg->mg_obj, keysv, nsv);
if (keylen != HEf_SVKEY) {
SvREFCNT_dec(keysv);
#if MGf_LOCAL
STATIC int vmg_svt_local(pTHX_ SV *nsv, MAGIC *mg) {
const MGWIZ *w = SV2MGWIZ(mg->mg_ptr);
- unsigned int flags = w->opinfo;
- return vmg_cb_call1(w->cb_local, nsv, mg->mg_obj);
+ return vmg_cb_call1(w->cb_local, w->opinfo, nsv, mg->mg_obj);
}
#endif /* MGf_LOCAL */
action &= HV_FETCH_ISSTORE | HV_FETCH_ISEXISTS | HV_FETCH_LVALUE | HV_DELETE;
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
const MGWIZ *w;
- unsigned int flags;
switch (mg->mg_type) {
case PERL_MAGIC_ext:
break;
if (mg->mg_private < SIG_MIN || mg->mg_private > SIG_MAX)
continue;
w = SV2MGWIZ(mg->mg_ptr);
- flags = w->opinfo;
switch (w->uvar) {
case 0:
continue;
}
switch (action) {
case 0:
- if (w->cb_fetch) { vmg_cb_call2(w->cb_fetch, sv, mg->mg_obj, key); }
+ if (w->cb_fetch)
+ vmg_cb_call2(w->cb_fetch, w->opinfo, sv, mg->mg_obj, key);
break;
case HV_FETCH_ISSTORE:
case HV_FETCH_LVALUE:
case (HV_FETCH_ISSTORE|HV_FETCH_LVALUE):
- if (w->cb_store) { vmg_cb_call2(w->cb_store, sv, mg->mg_obj, key); }
+ if (w->cb_store)
+ vmg_cb_call2(w->cb_store, w->opinfo, sv, mg->mg_obj, key);
break;
case HV_FETCH_ISEXISTS:
- if (w->cb_exists) { vmg_cb_call2(w->cb_exists, sv, mg->mg_obj, key); }
+ if (w->cb_exists)
+ vmg_cb_call2(w->cb_exists, w->opinfo, sv, mg->mg_obj, key);
break;
case HV_DELETE:
- if (w->cb_delete) { vmg_cb_call2(w->cb_delete, sv, mg->mg_obj, key); }
+ if (w->cb_delete)
+ vmg_cb_call2(w->cb_delete, w->opinfo, sv, mg->mg_obj, key);
break;
}
}