# define mPUSHu(U) PUSHs(sv_2mortal(newSVuv(U)))
#endif
-#ifndef SvPV_const
-# define SvPV_const SvPV
-#endif
-
#ifndef PERL_MAGIC_ext
# define PERL_MAGIC_ext '~'
#endif
if (!w)
return;
- 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 (w->cb_data) SvREFCNT_dec(w->cb_data);
+ if (w->cb_get) SvREFCNT_dec(w->cb_get);
+ if (w->cb_set) SvREFCNT_dec(w->cb_set);
+ if (w->cb_len) SvREFCNT_dec(w->cb_len);
+ if (w->cb_clear) SvREFCNT_dec(w->cb_clear);
+ if (w->cb_free) SvREFCNT_dec(w->cb_free);
#if MGf_COPY
- if (w->cb_copy) SvREFCNT_dec(SvRV(w->cb_copy));
+ if (w->cb_copy) SvREFCNT_dec(w->cb_copy);
#endif /* MGf_COPY */
#if 0 /* MGf_DUP */
- if (w->cb_dup) SvREFCNT_dec(SvRV(w->cb_dup));
+ if (w->cb_dup) SvREFCNT_dec(w->cb_dup);
#endif /* MGf_DUP */
#if MGf_LOCAL
- if (w->cb_local) SvREFCNT_dec(SvRV(w->cb_local));
+ if (w->cb_local) SvREFCNT_dec(w->cb_local);
#endif /* MGf_LOCAL */
#if VMG_UVAR
- 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));
+ if (w->cb_fetch) SvREFCNT_dec(w->cb_fetch);
+ if (w->cb_store) SvREFCNT_dec(w->cb_store);
+ if (w->cb_exists) SvREFCNT_dec(w->cb_exists);
+ if (w->cb_delete) SvREFCNT_dec(w->cb_delete);
#endif /* VMG_UVAR */
Safefree(w->vtbl);
#if VMG_THREADSAFE
#define VMG_CLONE_CB(N) \
- z->cb_ ## N = (w->cb_ ## N) ? newRV_noinc(vmg_clone(SvRV(w->cb_ ## N), \
- w->owner)) \
+ z->cb_ ## N = (w->cb_ ## N) ? vmg_clone(w->cb_ ## N, w->owner) \
: NULL;
STATIC MGWIZ *vmg_mgwiz_clone(pTHX_ const MGWIZ *w) {
STATIC SV *vmg_wizard_new(pTHX_ const MGWIZ *w) {
#define vmg_wizard_new(W) vmg_wizard_new(aTHX_ (W))
- SV *wiz = newSVuv(PTR2UV(w));
+ SV *wiz = newSVuv(PTR2IV(w));
if (w) {
MAGIC *mg = sv_magicext(wiz, NULL, PERL_MAGIC_ext, &vmg_wizard_vtbl, NULL, 0);
return wiz;
}
-STATIC SV *vmg_wizard_validate(pTHX_ SV *wiz) {
+STATIC const SV *vmg_wizard_validate(pTHX_ const SV *wiz) {
#define vmg_wizard_validate(W) vmg_wizard_validate(aTHX_ (W))
if (SvROK(wiz)) {
wiz = SvRV(wiz);
}
croak(vmg_invalid_wiz);
+ /* Not reached */
+ return NULL;
}
-#define vmg_wizard_id(W) SvUV((SV *) (W))
+#define vmg_wizard_id(W) SvIVX((const SV *) (W))
#define vmg_wizard_main_mgwiz(W) INT2PTR(const MGWIZ *, vmg_wizard_id(W))
/* ... Wizard destructor ................................................... */
#if VMG_THREADSAFE
-STATIC const MGWIZ *vmg_wizard_mgwiz(pTHX_ SV *wiz) {
-#define vmg_wizard_mgwiz(W) vmg_wizard_mgwiz(aTHX_ ((SV *) (W)))
+STATIC const MGWIZ *vmg_wizard_mgwiz(pTHX_ const SV *wiz) {
+#define vmg_wizard_mgwiz(W) vmg_wizard_mgwiz(aTHX_ ((const SV *) (W)))
const MGWIZ *w;
w = vmg_wizard_main_mgwiz(wiz);
/* --- User-level functions implementation --------------------------------- */
-STATIC const MAGIC *vmg_find(pTHX_ const SV *sv, SV *wiz) {
-#define vmg_find(S, W) vmg_find(aTHX_ (S), (W))
+STATIC const MAGIC *vmg_find(const SV *sv, const SV *wiz) {
const MAGIC *mg, *moremagic;
- UV wid;
+ IV wid;
if (SvTYPE(sv) < SVt_PVMG)
return NULL;
for (mg = SvMAGIC(sv); mg; mg = moremagic) {
moremagic = mg->mg_moremagic;
if (mg->mg_type == PERL_MAGIC_ext && mg->mg_private == SIG_WIZ) {
- UV zid = vmg_wizard_id(mg->mg_ptr);
+ IV zid = vmg_wizard_id(mg->mg_ptr);
if (zid == wid)
return mg;
}
/* ... Construct private data .............................................. */
-STATIC SV *vmg_data_new(pTHX_ SV *ctor, SV *sv, AV *args) {
-#define vmg_data_new(C, S, A) vmg_data_new(aTHX_ (C), (S), (A))
+STATIC SV *vmg_data_new(pTHX_ SV *ctor, SV *sv, SV **args, I32 items) {
+#define vmg_data_new(C, S, A, I) vmg_data_new(aTHX_ (C), (S), (A), (I))
+ I32 i;
SV *nsv;
- I32 i, alen = (args == NULL) ? 0 : av_len(args);
dSP;
SAVETMPS;
PUSHMARK(SP);
- EXTEND(SP, alen + 1);
+ EXTEND(SP, items + 1);
PUSHs(sv_2mortal(newRV_inc(sv)));
- for (i = 0; i < alen; ++i)
- PUSHs(*av_fetch(args, i, 0));
+ for (i = 0; i < items; ++i)
+ PUSHs(args[i]);
PUTBACK;
call_sv(ctor, G_SCALAR);
return nsv;
}
-STATIC SV *vmg_data_get(pTHX_ SV *sv, SV *wiz) {
+STATIC SV *vmg_data_get(pTHX_ SV *sv, const SV *wiz) {
#define vmg_data_get(S, W) vmg_data_get(aTHX_ (S), (W))
const MAGIC *mg = vmg_find(sv, wiz);
return mg ? mg->mg_obj : NULL;
}
#endif /* VMG_UVAR */
-STATIC UV vmg_cast(pTHX_ SV *sv, SV *wiz, AV *args) {
-#define vmg_cast(S, W, A) vmg_cast(aTHX_ (S), (W), (A))
+STATIC UV vmg_cast(pTHX_ SV *sv, const SV *wiz, SV **args, I32 items) {
+#define vmg_cast(S, W, A, I) vmg_cast(aTHX_ (S), (W), (A), (I))
MAGIC *mg, *moremagic = NULL;
SV *data;
const MGWIZ *w;
w = vmg_wizard_mgwiz(wiz);
oldgmg = SvGMAGICAL(sv);
- data = (w->cb_data) ? vmg_data_new(w->cb_data, sv, args) : NULL;
+ data = (w->cb_data) ? vmg_data_new(w->cb_data, sv, args, items) : NULL;
mg = sv_magicext(sv, data, PERL_MAGIC_ext, w->vtbl, (const char *) wiz, HEf_SVKEY);
+ SvREFCNT_dec(data);
mg->mg_private = SIG_WIZ;
#if MGf_COPY
if (w->cb_copy)
return 1;
}
-STATIC UV vmg_dispell(pTHX_ SV *sv, SV *wiz) {
+STATIC UV vmg_dispell(pTHX_ SV *sv, const SV *wiz) {
#define vmg_dispell(S, W) vmg_dispell(aTHX_ (S), (W))
#if VMG_UVAR
U32 uvars = 0;
#endif /* VMG_UVAR */
MAGIC *mg, *prevmagic, *moremagic = NULL;
- UV wid = vmg_wizard_id(wiz);
+ IV wid = vmg_wizard_id(wiz);
if (SvTYPE(sv) < SVt_PVMG)
return 0;
moremagic = mg->mg_moremagic;
if (mg->mg_type == PERL_MAGIC_ext && mg->mg_private == SIG_WIZ) {
const MGWIZ *z = vmg_wizard_mgwiz(mg->mg_ptr);
- UV zid = vmg_wizard_id(mg->mg_ptr);
+ IV zid = vmg_wizard_id(mg->mg_ptr);
if (zid == wid) {
#if VMG_UVAR
/* If the current has no uvar, short-circuit uvar deletion. */
if (!MY_CXT.b__op_stashes[0]) {
opclass c;
require_pv("B.pm");
- for (c = 0; c < OPc_MAX; ++c)
+ for (c = OPc_NULL; c < OPc_MAX; ++c)
MY_CXT.b__op_stashes[c] = gv_stashpv(vmg_opclassnames[c], 1);
}
break;
/* ... 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, unsigned int flags, SV *sv, ...) {
va_list ap;
- int ret;
+ int ret = 0;
unsigned int i, args, opinfo;
+ SV *svr;
dSP;
call_sv(cb, G_SCALAR);
- VMG_CB_CALL_SET_RET(0);
+ SPAGAIN;
+ svr = POPs;
+ if (SvOK(svr))
+ ret = (int) SvIV(svr);
+ PUTBACK;
FREETMPS;
LEAVE;
const MGWIZ *w = vmg_wizard_mgwiz(mg->mg_ptr);
unsigned int opinfo = w->opinfo;
U32 len, ret;
+ SV *svr;
svtype t = SvTYPE(sv);
dSP;
PUSHs(mg->mg_obj ? mg->mg_obj : &PL_sv_undef);
if (t < SVt_PVAV) {
STRLEN l;
- U8 *s = (U8 *) SvPV_const(sv, l);
+#if VMG_HAS_PERL(5, 9, 2)
+ const U8 *s = SvPV_const(sv, l);
+#else
+ U8 *s = SvPV(sv, l);
+#endif
if (DO_UTF8(sv))
len = utf8_length(s, s + l);
else
call_sv(w->cb_len, G_SCALAR);
- VMG_CB_CALL_SET_RET(len);
+ SPAGAIN;
+ svr = POPs;
+ ret = SvOK(svr) ? (U32) SvUV(svr) : len;
+ if (t == SVt_PVAV)
+ --ret;
+ PUTBACK;
FREETMPS;
LEAVE;
- return t == SVt_PVAV ? ret - 1 : ret;
+ return ret;
}
STATIC int vmg_svt_clear(pTHX_ SV *sv, MAGIC *mg) {
PERL_CONTEXT saved_cx;
I32 cxix;
#endif
- unsigned int had_err, has_err, flags = G_SCALAR | G_EVAL;
+ I32 had_err, has_err, flags = G_SCALAR | G_EVAL;
int ret = 0;
+ SV *svr;
dSP;
if (IN_PERL_COMPILETIME && !had_err && has_err)
++PL_error_count;
- VMG_CB_CALL_SET_RET(0);
+ SPAGAIN;
+ svr = POPs;
+ if (SvOK(svr))
+ ret = (int) SvIV(svr);
+ PUTBACK;
FREETMPS;
LEAVE;
#define VMG_SET_CB(S, N) \
cb = (S); \
- w->cb_ ## N = (SvOK(cb) && SvROK(cb)) ? newRV_inc(SvRV(cb)) : NULL;
+ w->cb_ ## N = (SvOK(cb) && SvROK(cb)) ? SvREFCNT_inc(SvRV(cb)) : NULL;
#define VMG_SET_SVT_CB(S, N) \
cb = (S); \
if (SvOK(cb) && SvROK(cb)) { \
t->svt_ ## N = vmg_svt_ ## N; \
- w->cb_ ## N = newRV_inc(SvRV(cb)); \
+ w->cb_ ## N = SvREFCNT_inc(SvRV(cb)); \
} else { \
t->svt_ ## N = NULL; \
w->cb_ ## N = NULL; \
}
+#if VMG_THREADSAFE
+
+STATIC void vmg_cleanup(pTHX_ void *ud) {
+ dMY_CXT;
+
+ ptable_free(MY_CXT.wizards);
+ MY_CXT.wizards = NULL;
+}
+
+#endif /* VMG_THREADSAFE */
+
/* --- XS ------------------------------------------------------------------ */
MODULE = Variable::Magic PACKAGE = Variable::Magic
MY_CXT.b__op_stashes[0] = NULL;
#if VMG_THREADSAFE
MUTEX_INIT(&vmg_op_name_init_mutex);
+ call_atexit(vmg_cleanup, NULL);
#endif
stash = gv_stashpv(__PACKAGE__, 1);
PROTOTYPE: DISABLE
PREINIT:
ptable *t;
- int *level;
U32 had_b__op_stash = 0;
opclass c;
PPCODE:
ud.owner = MY_CXT.owner;
ptable_walk(MY_CXT.wizards, vmg_ptable_clone, &ud);
- for (c = 0; c < OPc_MAX; ++c) {
+ for (c = OPc_NULL; c < OPc_MAX; ++c) {
if (MY_CXT.b__op_stashes[c])
had_b__op_stash |= (((U32) 1) << c);
}
MY_CXT_CLONE;
MY_CXT.wizards = t;
MY_CXT.owner = aTHX;
- for (c = 0; c < OPc_MAX; ++c) {
+ for (c = OPc_NULL; c < OPc_MAX; ++c) {
MY_CXT.b__op_stashes[c] = (had_b__op_stash & (((U32) 1) << c))
? gv_stashpv(vmg_opclassnames[c], 1) : NULL;
}
PROTOTYPE: DISABLE
PREINIT:
I32 i = 0;
+ UV opinfo;
MGWIZ *w;
MGVTBL *t;
SV *cb;
Newx(w, 1, MGWIZ);
VMG_SET_CB(ST(i++), data);
+
cb = ST(i++);
- w->opinfo = SvOK(cb) ? SvUV(cb) : 0;
+ opinfo = SvOK(cb) ? SvUV(cb) : 0;
+ w->opinfo = (U8) ((opinfo < 255) ? opinfo : 255);
if (w->opinfo)
vmg_op_info_init(w->opinfo);
+
VMG_SET_SVT_CB(ST(i++), get);
VMG_SET_SVT_CB(ST(i++), set);
VMG_SET_SVT_CB(ST(i++), len);
SV *cast(SV *sv, SV *wiz, ...)
PROTOTYPE: \[$@%&*]$@
PREINIT:
- AV *args = NULL;
- SV *ret;
+ SV **args = NULL;
+ I32 i = 0;
CODE:
- wiz = vmg_wizard_validate(wiz);
if (items > 2) {
- I32 i;
- args = newAV();
- av_fill(args, items - 2);
- for (i = 2; i < items; ++i) {
- SV *arg = ST(i);
- SvREFCNT_inc(arg);
- if (av_store(args, i - 2, arg) == NULL) croak(vmg_argstorefailed);
- }
+ i = items - 2;
+ args = &ST(2);
}
- ret = newSVuv(vmg_cast(SvRV(sv), wiz, args));
- SvREFCNT_dec(args);
- RETVAL = ret;
+ RETVAL = newSVuv(vmg_cast(SvRV(sv), vmg_wizard_validate(wiz), args, i));
OUTPUT:
RETVAL
PREINIT:
SV *data;
PPCODE:
- wiz = vmg_wizard_validate(wiz);
- data = vmg_data_get(SvRV(sv), wiz);
+ data = vmg_data_get(SvRV(sv), vmg_wizard_validate(wiz));
if (!data)
XSRETURN_EMPTY;
ST(0) = data;
SV *dispell(SV *sv, SV *wiz)
PROTOTYPE: \[$@%&*]$
CODE:
- wiz = vmg_wizard_validate(wiz);
- RETVAL = newSVuv(vmg_dispell(SvRV(sv), wiz));
+ RETVAL = newSVuv(vmg_dispell(SvRV(sv), vmg_wizard_validate(wiz)));
OUTPUT:
RETVAL
projects / perl / modules / Variable-Magic.git / blobdiff