#define VMG_SAVE_LAST_CX (!VMG_HAS_PERL(5, 8, 4) || VMG_HAS_PERL(5, 9, 5))
-STATIC I32 vmg_call_sv(pTHX_ SV *sv, I32 flags, I32 destructor) {
+STATIC I32 vmg_call_sv(pTHX_ SV *sv, I32 flags, SV *dsv) {
#define vmg_call_sv(S, F, D) vmg_call_sv(aTHX_ (S), (F), (D))
I32 ret, cxix = 0, in_eval = 0;
#if VMG_SAVE_LAST_CX
if (cxstack_ix < cxstack_max) {
cxix = cxstack_ix + 1;
- if (destructor && CxTYPE(cxstack + cxix) == CXt_EVAL)
+ if (dsv && CxTYPE(cxstack + cxix) == CXt_EVAL)
in_eval = 1;
}
#else
++PL_Ierror_count;
#endif
- } else if (!in_eval)
+ } else if (!in_eval) {
+ if (dsv) {
+ /* We are about to croak() while dsv is being destroyed. Try to clean up
+ * things a bit. */
+ MAGIC *mg = SvMAGIC(dsv);
+ SvREFCNT_dec((SV *) mg->mg_ptr);
+ /* mg->mg_obj may not be refcounted if the data constructor returned the
+ * variable itself. */
+ if (mg->mg_flags & MGf_REFCOUNTED)
+ SvREFCNT_dec(mg->mg_obj);
+ SvMAGIC_set(dsv, mg->mg_moremagic);
+ Safefree(mg);
+ mg_magical(dsv);
+ SvREFCNT_dec(dsv);
+ }
croak(NULL);
+ }
} else {
if (old_err) {
SvREFCNT_dec(ERRSV);
#define vmg_vtable_vtbl(T) (T)->vtbl
-#if VMG_THREADSAFE
STATIC perl_mutex vmg_vtable_refcount_mutex;
-#endif
STATIC vmg_vtable *vmg_vtable_dup(pTHX_ vmg_vtable *t) {
#define vmg_vtable_dup(T) vmg_vtable_dup(aTHX_ (T))
if (!w)
return;
- SvREFCNT_dec(w->cb_data);
- SvREFCNT_dec(w->cb_get);
- SvREFCNT_dec(w->cb_set);
- SvREFCNT_dec(w->cb_len);
- SvREFCNT_dec(w->cb_clear);
- SvREFCNT_dec(w->cb_free);
- SvREFCNT_dec(w->cb_copy);
+ /* During global destruction, any of the callbacks may already have been
+ * freed, so we can't rely on still being able to access them. */
+ if (!PL_dirty) {
+ SvREFCNT_dec(w->cb_data);
+ SvREFCNT_dec(w->cb_get);
+ SvREFCNT_dec(w->cb_set);
+ SvREFCNT_dec(w->cb_len);
+ SvREFCNT_dec(w->cb_clear);
+ SvREFCNT_dec(w->cb_free);
+ SvREFCNT_dec(w->cb_copy);
#if 0
- SvREFCNT_dec(w->cb_dup);
+ SvREFCNT_dec(w->cb_dup);
#endif
#if MGf_LOCAL
- SvREFCNT_dec(w->cb_local);
+ SvREFCNT_dec(w->cb_local);
#endif /* MGf_LOCAL */
#if VMG_UVAR
- SvREFCNT_dec(w->cb_fetch);
- SvREFCNT_dec(w->cb_store);
- SvREFCNT_dec(w->cb_exists);
- SvREFCNT_dec(w->cb_delete);
+ SvREFCNT_dec(w->cb_fetch);
+ SvREFCNT_dec(w->cb_store);
+ SvREFCNT_dec(w->cb_exists);
+ SvREFCNT_dec(w->cb_delete);
#endif /* VMG_UVAR */
+ }
+ /* PerlMemShared_free() and Safefree() are still fine during global
+ * destruction though. */
vmg_vtable_free(w->vtable);
Safefree(w);
/* --- Wizard SV objects --------------------------------------------------- */
STATIC int vmg_wizard_sv_free(pTHX_ SV *sv, MAGIC *mg) {
- if (PL_dirty) /* During global destruction, the context is already freed */
- return 0;
-
vmg_wizard_free((vmg_wizard *) mg->mg_ptr);
return 0;
PUSHs(args[i]);
PUTBACK;
- vmg_call_sv(ctor, G_SCALAR, 0);
+ vmg_call_sv(ctor, G_SCALAR, NULL);
SPAGAIN;
nsv = POPs;
if (mg->mg_type == PERL_MAGIC_uvar)
break;
}
- /* assert(mg); */
uf = (struct ufuncs *) mg->mg_ptr;
- /* assert(uf->uf_val == vmg_svt_val); */
if (uf[1].uf_val || uf[1].uf_set) {
/* Revert the original uvar magic. */
uf[0] = uf[1];
return &PL_sv_undef;
}
-/* ... svt callbacks ....................................................... */
+/* --- svt callbacks ------------------------------------------------------- */
#define VMG_CB_CALL_ARGS_MASK 15
#define VMG_CB_CALL_ARGS_SHIFT 4
XPUSHs(vmg_op_info(opinfo));
PUTBACK;
- vmg_call_sv(cb, G_SCALAR, 0);
+ vmg_call_sv(cb, G_SCALAR, NULL);
SPAGAIN;
svr = POPs;
return 0;
}
+/* ... get magic ........................................................... */
+
STATIC int vmg_svt_get(pTHX_ SV *sv, MAGIC *mg) {
const vmg_wizard *w = vmg_wizard_from_mg_nocheck(mg);
#define vmg_svt_get_noop vmg_svt_default_noop
+/* ... set magic ........................................................... */
+
STATIC int vmg_svt_set(pTHX_ SV *sv, MAGIC *mg) {
const vmg_wizard *w = vmg_wizard_from_mg_nocheck(mg);
#define vmg_svt_set_noop vmg_svt_default_noop
+/* ... len magic ........................................................... */
+
STATIC U32 vmg_sv_len(pTHX_ SV *sv) {
#define vmg_sv_len(S) vmg_sv_len(aTHX_ (S))
STRLEN len;
XPUSHs(vmg_op_info(opinfo));
PUTBACK;
- vmg_call_sv(w->cb_len, G_SCALAR, 0);
+ vmg_call_sv(w->cb_len, G_SCALAR, NULL);
SPAGAIN;
svr = POPs;
return len;
}
+/* ... clear magic ......................................................... */
+
STATIC int vmg_svt_clear(pTHX_ SV *sv, MAGIC *mg) {
const vmg_wizard *w = vmg_wizard_from_mg_nocheck(mg);
#define vmg_svt_clear_noop vmg_svt_default_noop
+/* ... free magic .......................................................... */
+
STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) {
const vmg_wizard *w;
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 */
+ /* During global destruction, we cannot be sure that the wizard and its free
+ * callback are still alive. */
if (PL_dirty)
return 0;
XPUSHs(vmg_op_info(w->opinfo));
PUTBACK;
- vmg_call_sv(w->cb_free, G_SCALAR, 1);
+ vmg_call_sv(w->cb_free, G_SCALAR, sv);
SPAGAIN;
svr = POPs;
# define VMG_SVT_COPY_KEYLEN_TYPE int
#endif
+/* ... copy magic .......................................................... */
+
STATIC int vmg_svt_copy(pTHX_ SV *sv, MAGIC *mg, SV *nsv, const char *key, VMG_SVT_COPY_KEYLEN_TYPE keylen) {
const vmg_wizard *w = vmg_wizard_from_mg_nocheck(mg);
SV *keysv;
return 0;
}
+/* ... dup magic ........................................................... */
+
#if 0
STATIC int vmg_svt_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) {
return 0;
#define vmg_svt_dup_noop vmg_svt_dup
#endif
+/* ... local magic ......................................................... */
+
#if MGf_LOCAL
STATIC int vmg_svt_local(pTHX_ SV *nsv, MAGIC *mg) {
#endif /* MGf_LOCAL */
+/* ... uvar magic .......................................................... */
+
#if VMG_UVAR
STATIC OP *vmg_pp_resetuvar(pTHX) {
SvRMAGICAL_on(cSVOP_sv);