# define dNOOP
#endif
+/* Safe unless stated otherwise in Makefile.PL */
+#ifndef VMG_FORKSAFE
+# define VMG_FORKSAFE 1
+#endif
+
#ifndef VMG_MULTIPLICITY
# if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT)
# define VMG_MULTIPLICITY 1
# define Newx(v, n, c) New(0, v, n, c)
#endif
-#ifndef NewOp
-# define NewOp(m, var, c, type) Newz(m, var, c, type)
-#endif
-
#ifndef SvMAGIC_set
# define SvMAGIC_set(sv, val) (SvMAGIC(sv) = (val))
#endif
# endif
#endif
-/* uvar magic and Hash::Util::FieldHash were commited with 28419 */
-#if VMG_HAS_PERL_MAINT(5, 9, 4, 28419) || VMG_HAS_PERL(5, 10, 0)
+/* uvar magic and Hash::Util::FieldHash were commited with 28419, but only
+ * enable it on 5.10 */
+#if VMG_HAS_PERL(5, 10, 0)
# define VMG_UVAR 1
#else
# define VMG_UVAR 0
};
STATIC opclass vmg_opclass(const OP *o) {
+#if 0
if (!o)
return OPc_NULL;
+#endif
if (o->op_type == 0)
return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
START_MY_CXT
+/* --- Error messages ------------------------------------------------------ */
+
+STATIC const char vmg_invalid_wiz[] = "Invalid wizard object";
+STATIC const char vmg_invalid_sig[] = "Invalid numeric signature";
+STATIC const char vmg_wrongargnum[] = "Wrong number of arguments";
+STATIC const char vmg_toomanysigs[] = "Too many magic signatures used";
+STATIC const char vmg_argstorefailed[] = "Error while storing arguments";
+STATIC const char vmg_globstorefail[] = "Couldn't store global wizard information";
+
/* --- Signatures ---------------------------------------------------------- */
#define SIG_MIN ((U16) 0u)
char buf[8];
dMY_CXT;
+ if (HvKEYS(MY_CXT.wizards) >= SIG_NBR) croak(vmg_toomanysigs);
+
do {
sig = SIG_NBR * Drand01() + SIG_MIN;
} while (hv_exists(MY_CXT.wizards, buf, sprintf(buf, "%u", sig)));
/* One uvar magic in the chain is enough. */
for (prevmagic = NULL, mg = SvMAGIC(sv); mg; prevmagic = mg, mg = moremagic) {
moremagic = mg->mg_moremagic;
- if (mg->mg_type == PERL_MAGIC_uvar) { break; }
+ if (mg->mg_type == PERL_MAGIC_uvar)
+ break;
}
if (mg) { /* Found another uvar magic. */
#endif /* VMG_UVAR */
MAGIC *mg, *prevmagic, *moremagic = NULL;
- if (SvTYPE(sv) < SVt_PVMG) { return 0; }
+ if (SvTYPE(sv) < SVt_PVMG)
+ return 0;
for (prevmagic = NULL, mg = SvMAGIC(sv); mg; prevmagic = mg, mg = moremagic) {
moremagic = mg->mg_moremagic;
}
}
}
- if (!mg) { return 0; }
+ if (!mg)
+ return 0;
if (prevmagic) {
prevmagic->mg_moremagic = moremagic;
}
mg->mg_moremagic = NULL;
- if (mg->mg_obj != sv) { SvREFCNT_dec(mg->mg_obj); } /* Destroy private data */
- SvREFCNT_dec((SV *) mg->mg_ptr); /* Unreference the wizard */
+ /* Destroy private data */
+ if (mg->mg_obj != sv)
+ SvREFCNT_dec(mg->mg_obj);
+ /* Unreference the wizard */
+ SvREFCNT_dec((SV *) mg->mg_ptr);
Safefree(mg);
#if VMG_UVAR
struct ufuncs *uf;
for (prevmagic = NULL, mg = SvMAGIC(sv); mg; prevmagic = mg, mg = moremagic){
moremagic = mg->mg_moremagic;
- if (mg->mg_type == PERL_MAGIC_uvar) { break; }
+ if (mg->mg_type == PERL_MAGIC_uvar)
+ break;
}
/* assert(mg); */
uf = (struct ufuncs *) mg->mg_ptr;
#define VMG_OP_INFO_NAME 1
#define VMG_OP_INFO_OBJECT 2
+#if VMG_THREADSAFE
+STATIC perl_mutex vmg_op_name_init_mutex;
+#endif
+
STATIC U32 vmg_op_name_init = 0;
STATIC unsigned char vmg_op_name_len[MAXO] = { 0 };
#define vmg_op_info_init(W) vmg_op_info_init(aTHX_ (W))
switch (opinfo) {
case VMG_OP_INFO_NAME:
+#if VMG_THREADSAFE
+ MUTEX_LOCK(&vmg_op_name_init_mutex);
+#endif
if (!vmg_op_name_init) {
OPCODE t;
for (t = 0; t < OP_max; ++t)
vmg_op_name_len[t] = strlen(PL_op_name[t]);
vmg_op_name_init = 1;
}
+#if VMG_THREADSAFE
+ MUTEX_UNLOCK(&vmg_op_name_init_mutex);
+#endif
break;
case VMG_OP_INFO_OBJECT: {
dMY_CXT;
STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) {
const MGWIZ *w;
+#if VMG_HAS_PERL(5, 9, 5)
+ PERL_CONTEXT saved_cx;
+ I32 cxix;
+#endif
unsigned int had_err, has_err, flags = G_SCALAR | G_EVAL;
int ret = 0;
if (had_err)
flags |= G_KEEPERR;
+#if VMG_HAS_PERL(5, 9, 5)
+ /* This context should not be used anymore, but since we croak in places the
+ * core doesn't even dare to, some pointers to it may remain in the upper call
+ * stack. Make sure call_sv() doesn't clobber it. */
+ if (cxstack_ix < cxstack_max)
+ cxix = cxstack_ix + 1;
+ else
+ cxix = Perl_cxinc(aTHX);
+ saved_cx = cxstack[cxix];
+#endif
+
call_sv(w->cb_free, flags);
+#if VMG_HAS_PERL(5, 9, 5)
+ cxstack[cxix] = saved_cx;
+#endif
+
has_err = SvTRUE(ERRSV);
if (IN_PERL_COMPILETIME && !had_err && has_err)
++PL_error_count;
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 */
--SvREFCNT(sv);
key = umg->mg_obj;
uf = (struct ufuncs *) umg->mg_ptr;
- if (uf[1].uf_val != NULL) { uf[1].uf_val(aTHX_ action, sv); }
- if (uf[1].uf_set != NULL) { uf[1].uf_set(aTHX_ action, sv); }
+ if (uf[1].uf_val)
+ uf[1].uf_val(aTHX_ action, sv);
+ if (uf[1].uf_set)
+ uf[1].uf_set(aTHX_ action, sv);
action &= HV_FETCH_ISSTORE | HV_FETCH_ISEXISTS | HV_FETCH_LVALUE | HV_DELETE;
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
if (hv_delete(MY_CXT.wizards, buf, sprintf(buf, "%u", w->sig), 0) != wiz)
return 0;
}
- SvFLAGS(wiz) |= SVf_BREAK;
- FREETMPS;
- if (w->cb_data != NULL) { SvREFCNT_dec(SvRV(w->cb_data)); }
- if (w->cb_get != NULL) { SvREFCNT_dec(SvRV(w->cb_get)); }
- if (w->cb_set != NULL) { SvREFCNT_dec(SvRV(w->cb_set)); }
- if (w->cb_len != NULL) { SvREFCNT_dec(SvRV(w->cb_len)); }
- if (w->cb_clear != NULL) { SvREFCNT_dec(SvRV(w->cb_clear)); }
- if (w->cb_free != NULL) { SvREFCNT_dec(SvRV(w->cb_free)); }
+ /* Unmortalize the wizard to avoid it being freed in weird places. */
+ if (SvTEMP(wiz) && !SvREFCNT(wiz)) {
+ const I32 myfloor = PL_tmps_floor;
+ I32 i;
+ for (i = PL_tmps_ix; i > myfloor; --i) {
+ if (PL_tmps_stack[i] == wiz)
+ PL_tmps_stack[i] = NULL;
+ }
+ }
+
+ if (w->cb_data) SvREFCNT_dec(SvRV(w->cb_data));
+ if (w->cb_get) SvREFCNT_dec(SvRV(w->cb_get));
+ if (w->cb_set) SvREFCNT_dec(SvRV(w->cb_set));
+ if (w->cb_len) SvREFCNT_dec(SvRV(w->cb_len));
+ if (w->cb_clear) SvREFCNT_dec(SvRV(w->cb_clear));
+ if (w->cb_free) SvREFCNT_dec(SvRV(w->cb_free));
#if MGf_COPY
- if (w->cb_copy != NULL) { SvREFCNT_dec(SvRV(w->cb_copy)); }
+ if (w->cb_copy) SvREFCNT_dec(SvRV(w->cb_copy));
#endif /* MGf_COPY */
#if 0 /* MGf_DUP */
- if (w->cb_dup != NULL) { SvREFCNT_dec(SvRV(w->cb_dup)); }
+ if (w->cb_dup) SvREFCNT_dec(SvRV(w->cb_dup));
#endif /* MGf_DUP */
#if MGf_LOCAL
- if (w->cb_local != NULL) { SvREFCNT_dec(SvRV(w->cb_local)); }
+ if (w->cb_local) SvREFCNT_dec(SvRV(w->cb_local));
#endif /* MGf_LOCAL */
#if VMG_UVAR
- if (w->cb_fetch != NULL) { SvREFCNT_dec(SvRV(w->cb_fetch)); }
- if (w->cb_store != NULL) { SvREFCNT_dec(SvRV(w->cb_store)); }
- if (w->cb_exists != NULL) { SvREFCNT_dec(SvRV(w->cb_exists)); }
- if (w->cb_delete != NULL) { SvREFCNT_dec(SvRV(w->cb_delete)); }
+ if (w->cb_fetch) SvREFCNT_dec(SvRV(w->cb_fetch));
+ if (w->cb_store) SvREFCNT_dec(SvRV(w->cb_store));
+ if (w->cb_exists) SvREFCNT_dec(SvRV(w->cb_exists));
+ if (w->cb_delete) SvREFCNT_dec(SvRV(w->cb_delete));
#endif /* VMG_UVAR */
Safefree(w->vtbl);
#endif /* MGf_LOCAL */
};
-STATIC const char vmg_invalid_wiz[] = "Invalid wizard object";
-STATIC const char vmg_invalid_sig[] = "Invalid numeric signature";
-STATIC const char vmg_wrongargnum[] = "Wrong number of arguments";
-STATIC const char vmg_toomanysigs[] = "Too many magic signatures used";
-STATIC const char vmg_argstorefailed[] = "Error while storing arguments";
-STATIC const char vmg_globstorefail[] = "Couldn't store global wizard information";
-
STATIC U16 vmg_sv2sig(pTHX_ SV *sv) {
#define vmg_sv2sig(S) vmg_sv2sig(aTHX_ (S))
IV sig;
STATIC U16 vmg_wizard_sig(pTHX_ SV *wiz) {
#define vmg_wizard_sig(W) vmg_wizard_sig(aTHX_ (W))
- char buf[8];
U16 sig;
if (SvROK(wiz)) {
{
dMY_CXT;
- if (!hv_fetch(MY_CXT.wizards, buf, sprintf(buf, "%u", sig), 0))
+ char buf[8];
+ SV **old = hv_fetch(MY_CXT.wizards, buf, sprintf(buf, "%u", sig), 0);
+ if (!(old && SV2MGWIZ(*old)))
croak(vmg_invalid_wiz);
}
STATIC SV *vmg_wizard_wiz(pTHX_ SV *wiz) {
#define vmg_wizard_wiz(W) vmg_wizard_wiz(aTHX_ (W))
- char buf[8];
- SV **old;
U16 sig;
if (SvROK(wiz)) {
{
dMY_CXT;
- return (old = hv_fetch(MY_CXT.wizards, buf, sprintf(buf, "%u", sig), 0))
- ? *old : NULL;
+ char buf[8];
+ SV **old = hv_fetch(MY_CXT.wizards, buf, sprintf(buf, "%u", sig), 0);
+ if (!(old && SV2MGWIZ(*old)))
+ croak(vmg_invalid_wiz);
+
+ return *old;
}
}
MY_CXT.wizards = newHV();
hv_iterinit(MY_CXT.wizards); /* Allocate iterator */
MY_CXT.b__op_stashes[0] = NULL;
+#if VMG_THREADSAFE
+ MUTEX_INIT(&vmg_op_name_init_mutex);
+#endif
+
stash = gv_stashpv(__PACKAGE__, 1);
newCONSTSUB(stash, "SIG_MIN", newSVuv(SIG_MIN));
newCONSTSUB(stash, "SIG_MAX", newSVuv(SIG_MAX));
newSVuv(VMG_COMPAT_SCALAR_LENGTH_NOLEN));
newCONSTSUB(stash, "VMG_PERL_PATCHLEVEL", newSVuv(VMG_PERL_PATCHLEVEL));
newCONSTSUB(stash, "VMG_THREADSAFE", newSVuv(VMG_THREADSAFE));
+ newCONSTSUB(stash, "VMG_FORKSAFE", newSVuv(VMG_FORKSAFE));
newCONSTSUB(stash, "VMG_OP_INFO_NAME", newSVuv(VMG_OP_INFO_NAME));
newCONSTSUB(stash, "VMG_OP_INFO_OBJECT", newSVuv(VMG_OP_INFO_OBJECT));
}
STRLEN len;
char *sig = HePV(key, len);
SV *sv;
- const MGWIZ *w;
- MAGIC *mg;
- w = SV2MGWIZ(HeVAL(key));
- w = vmg_wizard_clone(w);
- sv = MGWIZ2SV(w);
- mg = sv_magicext(sv, NULL, PERL_MAGIC_ext, &vmg_wizard_vtbl, NULL, 0);
- mg->mg_private = SIG_WZO;
+ const MGWIZ *w = SV2MGWIZ(HeVAL(key));
+ if (w) {
+ MAGIC *mg;
+ w = vmg_wizard_clone(w);
+ sv = MGWIZ2SV(w);
+ mg = sv_magicext(sv, NULL, PERL_MAGIC_ext, &vmg_wizard_vtbl, NULL, 0);
+ mg->mg_private = SIG_WZO;
+ } else {
+ sv = MGWIZ2SV(NULL);
+ }
SvREADONLY_on(sv);
if (!hv_store(hv, sig, len, sv, HeHASH(key))) croak("%s during CLONE", vmg_globstorefail);
}
if (SvOK(svsig)) {
SV **old;
sig = vmg_sv2sig(svsig);
- if ((old = hv_fetch(MY_CXT.wizards, buf, sprintf(buf, "%u", sig), 0))) {
+ old = hv_fetch(MY_CXT.wizards, buf, sprintf(buf, "%u", sig), 0);
+ if (old && SV2MGWIZ(*old)) {
ST(0) = sv_2mortal(newRV_inc(*old));
XSRETURN(1);
}
} else {
- if (HvKEYS(MY_CXT.wizards) >= SIG_NBR) { croak(vmg_toomanysigs); }
sig = vmg_gensig();
}
SV *gensig()
PROTOTYPE:
+PREINIT:
+ U16 sig;
+ char buf[8];
CODE:
dMY_CXT;
- if (HvKEYS(MY_CXT.wizards) >= SIG_NBR) { croak(vmg_toomanysigs); }
- RETVAL = newSVuv(vmg_gensig());
+ sig = vmg_gensig();
+ if (!hv_store(MY_CXT.wizards, buf, sprintf(buf, "%u", sig), MGWIZ2SV(NULL), 0)) croak(vmg_globstorefail);
+ RETVAL = newSVuv(sig);
OUTPUT:
RETVAL
SV *getsig(SV *wiz)
PROTOTYPE: $
+PREINIT:
+ U16 sig;
CODE:
- if (!SvROK(wiz)) { croak(vmg_invalid_wiz); }
- RETVAL = newSVuv(SV2MGWIZ(SvRV(wiz))->sig);
+ sig = vmg_wizard_sig(wiz);
+ RETVAL = newSVuv(sig);
OUTPUT:
RETVAL
SV *ret;
CODE:
wiz = vmg_wizard_wiz(wiz);
- if (!wiz)
- XSRETURN_UNDEF;
if (items > 2) {
I32 i;
args = newAV();
for (i = 2; i < items; ++i) {
SV *arg = ST(i);
SvREFCNT_inc(arg);
- if (av_store(args, i - 2, arg) == NULL) { croak(vmg_argstorefailed); }
+ if (av_store(args, i - 2, arg) == NULL) croak(vmg_argstorefailed);
}
}
ret = newSVuv(vmg_cast(SvRV(sv), wiz, args));
PPCODE:
sig = vmg_wizard_sig(wiz);
data = vmg_data_get(SvRV(sv), sig);
- if (!data) { XSRETURN_UNDEF; }
+ if (!data)
+ XSRETURN_EMPTY;
ST(0) = data;
XSRETURN(1);
projects / perl / modules / Variable-Magic.git / blobdiff